diff --git a/Admin/components/components.sha1 b/Admin/components/components.sha1 --- a/Admin/components/components.sha1 +++ b/Admin/components/components.sha1 @@ -1,459 +1,460 @@ 59a71e08c34ff01f3f5c4af00db5e16369527eb7 Haskabelle-2013.tar.gz 23a96ff4951d72f4024b6e8843262eda988bc151 Haskabelle-2014.tar.gz eccff31931fb128c1dd522cfc85495c9b66e67af Haskabelle-2015.tar.gz ed740867925dcf58692c8d3e350c28e3b4d4a60f Isabelle_app-20210126.tar.gz 8ee375cfc38972f080dbc78f07b68dac03efe968 ProofGeneral-3.7.1.1.tar.gz 847b52c0676b5eb0fbf0476f64fc08c2d72afd0c ProofGeneral-4.1.tar.gz 8e0b2b432755ef11d964e20637d1bc567d1c0477 ProofGeneral-4.2-1.tar.gz 51e1e0f399e934020565b2301358452c0bcc8a5e ProofGeneral-4.2-2.tar.gz 8472221c876a430cde325841ce52893328302712 ProofGeneral-4.2.tar.gz fbe83b522cb37748ac1b3c943ad71704fdde2f82 bash_process-1.1.1.tar.gz bb9ef498cd594b4289221b96146d529c899da209 bash_process-1.1.tar.gz 81250148f8b89ac3587908fb20645081d7f53207 bash_process-1.2.1.tar.gz 97b2491382130a841b3bbaebdcf8720c4d4fb227 bash_process-1.2.2.tar.gz 5c5b7c18cc1dc2a4d22b997dac196da09eaca868 bash_process-1.2.3-1.tar.gz 48b01bd9436e243ffcb7297f08b498d0c0875ed9 bash_process-1.2.3.tar.gz 11815d5f3af0de9022e903ed8702c136591f06fe bash_process-1.2.4-1.tar.gz 729486311833e4eff0fbf2d8041dddad520ca88c bash_process-1.2.4-2.tar.gz 7ae9ec8aab2d8a811842d9dc67d8bf6c179e11ee bash_process-1.2.4.tar.gz 9e21f447bfa0431ae5097301d553dd6df3c58218 bash_process-1.2.tar.gz a65ce644b6094d41e9f991ef851cf05eff5dd0a9 bib2xhtml-20171221.tar.gz 4085dd6060a32d7e0d2e3f874c463a9964fd409b bib2xhtml-20190409.tar.gz f92cff635dfba5d4d77f469307369226c868542c cakeml-2.0.tar.gz e7ffe4238b61a3c1ee87aca4421e7a612e09b836 ci-extras-1.tar.gz e880f31f59bd403fb72fcd3b5afb413c3831a21c csdp-6.1-1.tar.gz 2659100ba8e28e7cb0ecb554178ee5315d4a87f5 csdp-6.1.1.tar.gz a2bd94f4f9281dc70dfda66cf28016c2ffef7ed7 csdp-6.1.tar.gz ec17080269737e4a97b4424a379924c09b338ca2 csdp-6.2.0.tar.gz 70105fd6fbfd1a868383fc510772b95234325d31 csdp-6.x.tar.gz 2f6417b8e96a0e4e8354fe0f1a253c18fb55d9a7 cvc3-2.4.1.tar.gz d70bfbe63590153c07709dea7084fbc39c669841 cvc4-1.5-1.tar.gz 541eac340464c5d34b70bb163ae277cc8829c40f cvc4-1.5-2.tar.gz 1a44895d2a440091a15cc92d7f77a06a2e432507 cvc4-1.5-3.tar.gz c0d8d5929b00e113752d8bf5d11241cd3bccafce cvc4-1.5-4.tar.gz ffb0d4739c10eb098eb092baef13eccf94a79bad cvc4-1.5-5.tar.gz 3682476dc5e915cf260764fa5b86f1ebdab57507 cvc4-1.5.tar.gz a5e02b5e990da4275dc5d4480c3b72fc73160c28 cvc4-1.5pre-1.tar.gz 4d9658fd2688ae8ac78da8fdfcbf85960f871b71 cvc4-1.5pre-2.tar.gz b01fdb93f2dc2b8bcfd41c6091d91b37d6e240f9 cvc4-1.5pre-3.tar.gz 76ff6103b8560f0e2778bbfbdb05f5fa18f850b7 cvc4-1.5pre-4.tar.gz 03aec2ec5757301c9df149f115d1f4f1d2cafd9e cvc4-1.5pre.tar.gz e99560d0b7cb9bafde2b0ec1a3a95af315918a25 cvc4-1.8.tar.gz 842d9526f37b928cf9e22f141884365129990d63 cygwin-20130110.tar.gz cb3b0706d208f104b800267697204f6d82f7b48a cygwin-20130114.tar.gz 3b44cca04855016d5f8cfb5101b2e0579ab80197 cygwin-20130117.tar.gz 1fde9ddf0fa4f398965113d0c0c4f0e97c78d008 cygwin-20130716.tar.gz a03735a53c2963eb0b453f6a7282d3419f28bf38 cygwin-20130916.tar.gz 7470125fc46e24ee188bdaacc6d560e01b6fa839 cygwin-20140520.tar.gz db4dedae026981c5f001be283180abc1962b79ad cygwin-20140521.tar.gz acbc4bf161ad21e96ecfe506266ccdbd288f8a6f cygwin-20140530.tar.gz 3dc680d9eb85276e8c3e9f6057dad0efe2d5aa41 cygwin-20140626.tar.gz 8e562dfe57a2f894f9461f4addedb88afa108152 cygwin-20140725.tar.gz 238d8e30e8e22495b7ea3f5ec36e852e97fe8bbf cygwin-20140813.tar.gz 629b8fbe35952d1551cd2a7ff08db697f6dff870 cygwin-20141024.tar.gz ce93d0b3b2743c4f4e5bba30c2889b3b7bc22f2c cygwin-20150410.tar.gz fa712dd5ec66ad16add1779d68aa171ff5694064 cygwin-20151210.tar.gz 056b843d5a3b69ecf8a52c06f2ce6e696dd275f9 cygwin-20151221.tar.gz 44f3a530f727e43a9413226c2423c9ca3e4c0cf5 cygwin-20161002.tar.gz dd56dd16d861fc6e1a008bf5e9da6f33ed6eb820 cygwin-20161022.tar.gz d9ad7aae99d54e3b9813151712eb88a441613f04 cygwin-20161024.tar.gz f8eb6a0f722e3cfe3775d1204c5c7063ee1f008e cygwin-20170828.tar.gz c22048912b010a5a0b4f2a3eb4d318d6953761e4 cygwin-20170930.tar.gz 5a3919e665947b820fd7f57787280c7512be3782 cygwin-20180604.tar.gz 2aa049170e8088de59bd70eed8220f552093932d cygwin-20190320.tar.gz fb898e263fcf6f847d97f564fe49ea0760bb453f cygwin-20190322.tar.gz cd01fac0ab4fdb50a2bbb6416da3f15a4d540da1 cygwin-20190524.tar.gz caa616fbab14c1fce790a87db5c4758c1322cf28 cygwin-20200116.tar.gz f053a9ab01f0be9cb456560f7eff66a8e7ba2fd2 cygwin-20200323.tar.gz 0107343cd2562618629f73b2581168f0045c3234 cygwin-20201002.tar.gz a3d481401b633c0ee6abf1da07d75da94076574c cygwin-20201130.tar.gz 5b1820b87b25d8f2d237515d9854e3ce54ee331b cygwin-20211002.tar.gz 5dff30be394d88dd83ea584fa6f8063bdcdc21fd cygwin-20211004.tar.gz fffaae24da4d274d34b8dc79a76b478b87ec31dd cygwin-20211007.tar.gz 0fe549949a025d65d52d6deca30554de8fca3b6e e-1.5.tar.gz 2e293256a134eb8e5b1a283361b15eb812fbfbf1 e-1.6-1.tar.gz e1919e72416cbd7ac8de5455caba8901acc7b44d e-1.6-2.tar.gz b98a98025d1f7e560ca6864a53296137dae736b4 e-1.6.tar.gz c11b25c919e2ec44fe2b6ac2086337b456344e97 e-1.8.tar.gz a895a96ec7e6fcc275114bb9b4c92b20fac73dba e-2.0-1.tar.gz 2ebd7e3067a2cdae3cb8b073345827013978d74b e-2.0-2.tar.gz fac44556dd16f666a2c186be30aa6d8c67228bb9 e-2.0-3.tar.gz 5d36fb62912cfcff7f3b99a6266c578aafc288b7 e-2.0-4.tar.gz 3223c51c0b16fe00ced4ae903041fff858e61742 e-2.0-5.tar.gz 6b962a6b4539b7ca4199977973c61a8c98a492e8 e-2.0.tar.gz 66449a7b68b7d85a7189e10735a81069356123b6 e-2.5-1.tar.gz 813b66ca151d7a39b5cacb39ab52acabc2a54845 e-2.5.tar.gz 6e63f9f354b8c06035952845b987080699a12d55 e-2.6-1.tar.gz a3bebab5df4294dac2dd7fd2065a94df00e0b3ff e-2.6.tar.gz 6d34b18ca0aa1e10bab6413045d079188c0e2dfb exec_process-1.0.1.tar.gz 8b9bffd10e396d965e815418295f2ee2849bea75 exec_process-1.0.2.tar.gz e6aada354da11e533af2dee3dcdd96c06479b053 exec_process-1.0.3.tar.gz ae7ee5becb26512f18c609e83b34612918bae5f0 exec_process-1.0.tar.gz 7a4b46752aa60c1ee6c53a2c128dedc8255a4568 flatlaf-0.46-1.tar.gz ed5cbc216389b655dac21a19e770a02a96867b85 flatlaf-0.46.tar.gz d37b38b9a27a6541c644e22eeebe9a339282173d flatlaf-1.0-rc1.tar.gz dac46ce81cee10fb36a9d39b414dec7b7b671545 flatlaf-1.0-rc2.tar.gz d94e6da7299004890c04a7b395a3f2d381a3281e flatlaf-1.0-rc3.tar.gz 7ca3e6a8c9bd837990e64d89e7fa07a7e7cf78ff flatlaf-1.0.tar.gz 9908e5ab721f1c0035c0ab04dc7ad0bd00a8db27 flatlaf-1.2.tar.gz 212a0f1f867511722024cc60156fd71872a16f92 flatlaf-1.6.tar.gz f339234ec18369679be0095264e0c0af7762f351 gnu-utils-20210414.tar.gz 683acd94761ef460cca1a628f650355370de5afb hol-light-bundle-0.5-126.tar.gz 989234b3799fe8750f3c24825d1f717c24fb0214 idea-icons-20210508.tar.gz 20b53cfc3ffc5b15c1eabc91846915b49b4c0367 isabelle_fonts-20151021.tar.gz 736844204b2ef83974cd9f0a215738b767958c41 isabelle_fonts-20151104.tar.gz 9502c1aea938021f154adadff254c5c55da344bd isabelle_fonts-20151106.tar.gz f5c63689a394b974ac0d365debda577c6fa31c07 isabelle_fonts-20151107.tar.gz 812101680b75f7fa9ee8e138ea6314fa4824ea2d isabelle_fonts-20151229.tar.gz 2730e1475c7d655655882e75743e0b451725a274 isabelle_fonts-20151231.tar.gz 1f004a6bf20088a7e8f1b3d4153aa85de6fc1091 isabelle_fonts-20160101.tar.gz 379d51ef3b71452dac34ba905def3daa8b590f2e isabelle_fonts-20160102.tar.gz 878536aab1eaf1a52da560c20bb41ab942971fa3 isabelle_fonts-20160227.tar.gz 8ff0eedf0191d808ecc58c6b3149a4697f29ab21 isabelle_fonts-20160812-1.tar.gz 9283e3b0b4c7239f57b18e076ec8bb21021832cb isabelle_fonts-20160812.tar.gz 620cffeb125e198b91a716da116f754d6cc8174b isabelle_fonts-20160830.tar.gz b70690c85c05d0ca5bc29287abd20142f6ddcfb0 isabelle_fonts-20171222.tar.gz c17c482e411bbaf992498041a3e1dea80336aaa6 isabelle_fonts-20171230.tar.gz 3affbb306baff37c360319b21cbaa2cc96ebb282 isabelle_fonts-20180113.tar.gz bee32019e5d7cf096ef2ea1d836c732e9a7628cc isabelle_fonts-20181124.tar.gz f249bc2c85bd2af9eee509de17187a766b74ab86 isabelle_fonts-20181129.tar.gz 928b5320073d04d93bcc5bc4347b6d01632b9d45 isabelle_fonts-20190210.tar.gz dfcdf9a757b9dc36cee87f82533b43c58ba84abe isabelle_fonts-20190309.tar.gz 95e3acf038df7fdeeacd8b4769930e6f57bf3692 isabelle_fonts-20190406.tar.gz dabcf5085d67c99159007007ff0e9bf775e423d1 isabelle_fonts-20190409.tar.gz 76827987c70051719e117138858930d42041f57d isabelle_fonts-20190717.tar.gz abc8aea3ae471f9313917008ac90e5c1c99e17da isabelle_fonts-20210317.tar.gz 3ff9195aab574fc75ca3b77af0adb33f9b6d7b74 isabelle_fonts-20210318.tar.gz b166b4bd583b6442a5d75eab06f7adbb66919d6d isabelle_fonts-20210319.tar.gz 9467ad54a9ac10a6e7e8db5458d8d2a5516eba96 isabelle_fonts-20210321.tar.gz 1f7a0b9829ecac6552b21e995ad0f0ac168634f3 isabelle_fonts-20210322.tar.gz 667000ce6dd6ea3c2d11601a41c206060468807d isabelle_fonts-20211004.tar.gz 916adccd2f40c55116b68b92ce1eccb24d4dd9a2 isabelle_setup-20210630.tar.gz c611e363287fcc9bdd93c33bef85fa4e66cd3f37 isabelle_setup-20210701.tar.gz a0e7527448ef0f7ce164a38a50dc26e98de3cad6 isabelle_setup-20210709.tar.gz e413706694b0968245ee15183af2d464814ce0a4 isabelle_setup-20210711.tar.gz d2c9fd7b73457a460111edd6eb93a133272935fb isabelle_setup-20210715.tar.gz a5f478ba1088f67c2c86dc2fa7764b6d884e5ae5 isabelle_setup-20210716-1.tar.gz 79fad009cb22aa5e7cb4aed3c810ad5f61790293 isabelle_setup-20210716.tar.gz 692a39f716998e556ec9559c9ca362fc8fc9d5b6 isabelle_setup-20210717-1.tar.gz 7322d6d84d75c486a58ed36630431db4499e3232 isabelle_setup-20210717-2.tar.gz 14f8508bcae9140815bb23e430e26d2cbc504b81 isabelle_setup-20210717.tar.gz ca801d5c380ea896ee32b309ff19ae5f34538963 isabelle_setup-20210718.tar.gz ac9739e38e4fbbfce1a71a0987a57b22f83922d3 isabelle_setup-20210724-1.tar.gz 4554679cc8ea31e539655810a14d14216b383d0e isabelle_setup-20210724-2.tar.gz 127a75ae33e97480d352087fcb9b47a632d77169 isabelle_setup-20210724.tar.gz 309909ec6d43ae460338e9af54c1b2a48adcb1ec isabelle_setup-20210726.tar.gz a14ce46c62c64c3413f3cc9239242e33570d0f3d isabelle_setup-20210922.tar.gz 0b2206f914336dec4923dd0479d8cee4b904f544 jdk-11+28.tar.gz e12574d838ed55ef2845acf1152329572ab0cc56 jdk-11.0.10+9.tar.gz 3e05213cad47dbef52804fe329395db9b4e57f39 jdk-11.0.2+9.tar.gz 06ac8993b5bebd02c70f1bd18ce13075f01115f3 jdk-11.0.3+7.tar.gz e7e3cc9b0550c1e5d71197ad8c30f92b622d7183 jdk-11.0.4+11.tar.gz 49007a84a2643a204ce4406770dfd574b97880d9 jdk-11.0.5+10.tar.gz 3c250e98eb82f98afc6744ddc9170d293f0677e1 jdk-11.0.6+10.tar.gz 76cf7a141e15db30bd975089c65c833b58092aa7 jdk-11.0.9+11.tar.gz 71d19df63816e9be1c4c5eb44aea7a44cfadb319 jdk-11.tar.gz 72455a2fdb6cced9cd563f4d5d6134f7a6c34913 jdk-15.0.1+9.tar.gz e8ae300e61b0b121018456d50010b555bc96ce10 jdk-15.0.2+7.tar.gz a426a32ad34014953c0f7d4cc6f44199572e1c38 jdk-17+35.tar.gz 8d83e433c1419e0c0cc5fd1762903d11b4a5752c jdk-6u31.tar.gz 38d2d2a91c66714c18430e136e7e5191af3996e6 jdk-7u11.tar.gz d765bc4ad2f34d494429b2a8c1563c49db224944 jdk-7u13.tar.gz 13a265e4b706ece26fdfa6fc9f4a3dd1366016d2 jdk-7u21.tar.gz 5080274f8721a18111a7f614793afe6c88726739 jdk-7u25.tar.gz dd24d63afd6d17b29ec9cb2b2464d4ff2e02de2c jdk-7u40.tar.gz ec740ee9ffd43551ddf1e5b91641405116af6291 jdk-7u6.tar.gz 71b629b2ce83dbb69967c4785530afce1bec3809 jdk-7u60.tar.gz e119f4cbfa2a39a53b9578d165d0dc44b59527b7 jdk-7u65.tar.gz d6d1c42989433839fe64f34eb77298ef6627aed4 jdk-7u67.tar.gz b66039bc6dc2bdb2992133743005e1e4fc58ae24 jdk-7u72.tar.gz d980055694ddfae430ee001c7ee877d535e97252 jdk-7u76.tar.gz baa6de37bb6f7a104ce5fe6506bca3d2572d601a jdk-7u80.tar.gz 7d5b152ac70f720bb9e783fa45ecadcf95069584 jdk-7u9.tar.gz baf275a68d3f799a841932e4e9a95a1a604058ae jdk-8u102.tar.gz 5442f1015a0657259be0590b04572cd933431df7 jdk-8u11.tar.gz 741de6a4a805a0f9fb917d1845409e99346c2747 jdk-8u112.tar.gz ae7df8bd0c18eb40237cf54cc28933f4893b9c92 jdk-8u121.tar.gz 51531a3a0c16e180ed95cb7d2bd680c2ec0aa553 jdk-8u131.tar.gz e45edcf184f608d6f4a7b966d65a5d3289462693 jdk-8u144.tar.gz 264e806b9300a4fb3b6e15ba0e2c664d4ea698c8 jdk-8u152.tar.gz 84b04d877a2ea3a4e2082297b540e14f76722bc5 jdk-8u162.tar.gz 87303a0de3fd595aa3857c8f7cececa036d6ed18 jdk-8u172.tar.gz 9ae0338a5277d8749b4b4c7e65fc627319d98b27 jdk-8u181.tar.gz cfecb1383faaf027ffbabfcd77a0b6a6521e0969 jdk-8u20.tar.gz 44ffeeae219782d40ce6822b580e608e72fd4c76 jdk-8u31.tar.gz c95ebf7777beb3e7ef10c0cf3f734cb78f9828e4 jdk-8u5.tar.gz 4132cf52d5025bf330d53b96a5c6466fef432377 jdk-8u51.tar.gz 74df343671deba03be7caa49de217d78b693f817 jdk-8u60.tar.gz dfb087bd64c3e5da79430e0ba706b9abc559c090 jdk-8u66.tar.gz 2ac389babd15aa5ddd1a424c1509e1c459e6fbb1 jdk-8u72.tar.gz caa0cf65481b6207f66437576643f41dabae3c83 jdk-8u92.tar.gz 778fd85c827ec49d2d658a832d20e63916186b0d jedit-20210715.tar.gz beb99f2cb0bd4e595c5c597d3970c46aa21616e4 jedit-20210717.tar.gz 33dd96cd83f2c6a26c035b7a0ee57624655224c5 jedit-20210724.tar.gz 0e4fd4d66388ddc760fa5fbd8d4a9a3b77cf59c7 jedit-20210802.tar.gz +258d527819583d740a3aa52dfef630eed389f8c6 jedit-20211019.tar.gz 44775a22f42a9d665696bfb49e53c79371c394b0 jedit_build-20111217.tar.gz a242a688810f2bccf24587b0062ce8027bf77fa2 jedit_build-20120304.tar.gz 4c948dee53f74361c097c08f49a1a5ff9b17bd1d jedit_build-20120307.tar.gz 9c221fe71af8a063fcffcce21672a97aea0a8d5b jedit_build-20120313.tar.gz ed72630f307729df08fdedb095f0af8725f81b9c jedit_build-20120327.tar.gz 6425f622625024c1de27f3730d6811f6370a19cd jedit_build-20120414.tar.gz 7b012f725ec1cc102dc259df178d511cc7890bba jedit_build-20120813.tar.gz 8e1d36f5071e3def2cb281f7fefe9f52352cb88f jedit_build-20120903.tar.gz 8fa0c67f59beba369ab836562eed4e56382f672a jedit_build-20121201.tar.gz 06e9be2627ebb95c45a9bcfa025d2eeef086b408 jedit_build-20130104.tar.gz c85c0829b8170f25aa65ec6852f505ce2a50639b jedit_build-20130628.tar.gz 5de3e399be2507f684b49dfd13da45228214bbe4 jedit_build-20130905.tar.gz 87136818fd5528d97288f5b06bd30c787229eb0d jedit_build-20130910.tar.gz c63189cbe39eb8104235a0928f579d9523de78a9 jedit_build-20130925.tar.gz 65cc13054be20d3a60474d406797c32a976d7db7 jedit_build-20130926.tar.gz 30ca171f745adf12b65c798c660ac77f9c0f9b4b jedit_build-20131106.tar.gz 054c1300128f8abd0f46a3e92c756ccdb96ff2af jedit_build-20140405.tar.gz 4a963665537ea66c69de4d761846541ebdbf69f2 jedit_build-20140511.tar.gz a9d637a30f6a87a3583f265da51e63e3619cff52 jedit_build-20140722.tar.gz f29391c53d85715f8454e1aaa304fbccc352928f jedit_build-20141018.tar.gz d7206d4c9d14d3f4c8115422b7391ffbcc6e80b4 jedit_build-20141026.tar.gz f15d36abc1780875a46b6dbd4568e43b776d5db6 jedit_build-20141104.tar.gz 14ce124c897abfa23713928dc034d6ef0e1c5031 jedit_build-20150228.tar.gz b5f7115384c167559211768eb5fe98138864473b jedit_build-20151023.tar.gz 8ba7b6791be788f316427cdcd805daeaa6935190 jedit_build-20151124.tar.gz c70c5a6c565d435a09a8639f8afd3de360708e1c jedit_build-20160330.tar.gz d4e1496c257659cf15458d718f4663cdd95a404e jedit_build-20161024.tar.gz d806c1c26b571b5b4ef05ea11e8b9cf936518e06 jedit_build-20170319.tar.gz 7bcb202e13358dd750e964b2f747664428b5d8b3 jedit_build-20180417.tar.gz 23c8a05687d05a6937f7d600ac3aa19e3ce59c9c jedit_build-20180504.tar.gz 9c64ee0705e5284b507ca527196081979d689519 jedit_build-20181025.tar.gz cfa65bf8720b9b798ffa0986bafbc8437f44f758 jedit_build-20181026.tar.gz 847492b75b38468268f9ea424d27d53f2d95cef4 jedit_build-20181203.tar.gz 536a38ed527115b4bf2545a2137ec57b6ffad718 jedit_build-20190120.tar.gz 58b9f03e5ec0b85f8123c31f5d8092dae5803773 jedit_build-20190130.tar.gz ec0aded5f2655e2de8bc4427106729e797584f2f jedit_build-20190224.tar.gz 1e53598a02ec8d8736b15f480cbe2c84767a7827 jedit_build-20190508.tar.gz b9c6f49d3f6ebe2e85a50595ce7412d01a4314ac jedit_build-20190717.tar.gz 1c753beb93e92e95e99e8ead23a68346bd1af44a jedit_build-20200610.tar.gz 533b1ee6459f59bcbe4f09e214ad2cb990fb6952 jedit_build-20200908.tar.gz f9966b5ed26740bb5b8bddbfe947fcefaea43d4d jedit_build-20201223.tar.gz 0bdbd36eda5992396e9c6b66aa24259d4dd7559c jedit_build-20210201.tar.gz a0744f1948abdde4bfb51dd4769b619e7444baf1 jedit_build-20210510-1.tar.gz 837d6c8f72ecb21ad59a2544c69aadc9f05684c6 jedit_build-20210510.tar.gz 7bdae3d24b10261f6cb277446cf9ecab6062bd6f jedit_build-20210708.tar.gz 0bd2bc2d9a491ba5fc8dd99df27c04f11a72e8fa jfreechart-1.0.14-1.tar.gz 8122526f1fc362ddae1a328bdbc2152853186fee jfreechart-1.0.14.tar.gz d911f63a5c9b4c7335bb73f805cb1711ce017a84 jfreechart-1.5.0.tar.gz d84b7d8ef273afec55284327fca7dd20f5ecb77a jfreechart-1.5.1.tar.gz 6fa0c221ef55919b684449f0111a8112358e94ff jfreechart-1.5.3.tar.gz c8a19a36adf6cefa779d85f22ded2f4654e68ea5 jortho-1.0-1.tar.gz 2155e0bdbd29cd3d2905454de2e7203b9661d239 jortho-1.0-2.tar.gz ffe179867cf5ffaabbb6bb096db9bdc0d7110065 jortho-1.0.tar.gz 6c737137cc597fc920943783382e928ea79e3feb kodkodi-1.2.16.tar.gz afb04f4048a87bb888fe7b05b0139cb060c7925b kodkodi-1.5.2-1.tar.gz 5f95c96bb99927f3a026050f85bd056f37a9189e kodkodi-1.5.2.tar.gz 0634a946b216f7f07f1a0f7e28cf345daa28828f kodkodi-1.5.3.tar.gz 52e95b3493d71902f9df89d0bb59d0046a5f0c63 kodkodi-1.5.4-1.tar.gz 267189c637de26cf304d699cfa95389da002b250 kodkodi-1.5.4.tar.gz 3ecdade953bb455ed2907952be287d7e5cf6533b kodkodi-1.5.5.tar.gz 8aa939f5127290eb9a99952d375be9ffbf90c43b kodkodi-1.5.6-1.tar.gz 6b12bf3f40b16fae8ff22aa39171fa018d107cb3 kodkodi-1.5.6.tar.gz c8b2e632f3ab959a4e037833a45e6360c8b72a99 kodkodi-1.5.7.tar.gz 377e36efb8608e6c828c7718d890e97fde2006a4 linux_app-20131007.tar.gz 759848095e2ad506083d92b5646947e3c32f27a0 linux_app-20191223.tar.gz 1a449ce69ac874e21804595d16aaaf5a0d0d0c10 linux_app-20200110.tar.gz 0aab4f73ff7f5e36f33276547e10897e1e56fb1d macos_app-20130716.tar.gz ad5d0e640ce3609a885cecab645389a2204e03bb macos_app-20150916.tar.gz 400af57ec5cd51f96928d9de00d077524a6fe316 macos_app-20181205.tar.gz 3bc42b8e22f0be5ec5614f1914066164c83498f8 macos_app-20181208.tar.gz ae76bfaade3bf72ff6b2d3aafcd52fa45609fcd1 minisat-2.2.1.tar.gz eda10c62da927a842c0a8881f726eac85e1cb4f7 naproche-20210122.tar.gz edcb517b7578db4eec1b6573b624f291776e11f6 naproche-20210124.tar.gz d858eb0ede6aea6b8cc40de63bd3a17f8f9f5300 naproche-20210129.tar.gz 810ee0f35adada9bf970c33fd80b986ab2255bf3 naproche-20210201.tar.gz 4a4e56fd03b7ba4edd38046f853873a90cf55d1a naproche-4ad61140062f.tar.gz 77252e0b40f89825b9b5935f9f0c4cd5d4e7012a naproche-6d0d76ce2f2a.tar.gz 9c02ecf93863c3289002c5e5ac45a83e2505984c naproche-755224402e36.tar.gz e1b34e8f54e7e5844873612635444fed434718a1 naproche-7d0947a91dd5.tar.gz 26df569cee9c2fd91b9ac06714afd43f3b37a1dd nunchaku-0.3.tar.gz e573f2cbb57eb7b813ed5908753cfe2cb41033ca nunchaku-0.5.tar.gz 3d7b7690dfd09e25ad56e64b519f61f06e3ab706 old_vampire-4.2.2.tar.gz fe57793aca175336deea4f5e9c0d949a197850ac opam-1.2.2.tar.gz eb499a18e7040ca0fe1ca824c9dcb2087c47c9ba opam-2.0.3-1.tar.gz 002f74c9e65e650de2638bf54d7b012b8de76c28 opam-2.0.3.tar.gz ddb3b438430d9565adbf5e3d913bd52af8337511 opam-2.0.6.tar.gz fc66802c169f44511d3be30435eb89a11e635742 opam-2.0.7.tar.gz 108e947d17e9aa6170872614492d8f647802f483 opam-2.1.0.tar.gz 1c8cb6a8f4cbeaedce2d6d1ba8fc7e2ab3663aeb polyml-5.4.1.tar.gz a3f9c159a0ee9a63b7a5d0c835ed9c2c908f8b56 polyml-5.5.0-1.tar.gz 7d604a99355efbfc1459d80db3279ffa7ade3e39 polyml-5.5.0-2.tar.gz b3d776e6744f0cd2773d467bc2cfe1de3d1ca2fd polyml-5.5.0-3.tar.gz 1812e9fa6d163f63edb93e37d1217640a166cf3e polyml-5.5.0.tar.gz 36f5b8224f484721749682a3655c796a55a2718d polyml-5.5.1-1.tar.gz 36f78f27291a9ceb13bf1120b62a45625afd44a6 polyml-5.5.1.tar.gz a588640dbf5da9ae15455b02ef709764a48637dc polyml-5.5.2-1.tar.gz 4b690390946f7bfb777b89eb16d6f08987cca12f polyml-5.5.2-2.tar.gz 5b31ad8556e41dfd6d5e85f407818be399aa3d2a polyml-5.5.2-3.tar.gz 532f6e8814752aeb406c62fabcfd2cc05f8a7ca8 polyml-5.5.2.tar.gz 1c53f699d35c0db6c7cf4ea51f2310adbd1d0dc5 polyml-5.5.3-20150820.tar.gz b4b624fb5f34d1dc814fb4fb469fafd7d7ea018a polyml-5.5.3-20150908.tar.gz b668e1f43a41608a8eb365c5e19db6c54c72748a polyml-5.5.3-20150911.tar.gz 1f5cd9b1390dab13861f90dfc06d4180cc107587 polyml-5.5.3-20150916.tar.gz f78896e588e8ebb4da57bf0c95210b0f0fa9e551 polyml-5.6-1.tar.gz 21fa0592b7dfd23269063f42604438165630c0f0 polyml-5.6-2.tar.gz 03ba81e595fa6d6df069532d67ad3195c37d9046 polyml-5.6-20151123.tar.gz 822f489c18e38ce5ef979ec21dccce4473e09be6 polyml-5.6-20151206.tar.gz bd6a448f0e0d5787747f4f30ca661f9c1868e4a7 polyml-5.6-20151223.tar.gz 5b70c12c95a90d858f90c1945011289944ea8e17 polyml-5.6-20160118.tar.gz 5b19dc93082803b82aa553a5cfb3e914606c0ffd polyml-5.6.tar.gz 80b923fca3533bf291ff9da991f2262a98b68cc4 polyml-5.7-20170217.tar.gz 381a70cecf0fdee47f6842e2bdb5107ed52adab6 polyml-5.7.1-1.tar.gz 39dac33b569ac66f76126b8f4edc6d9227bd8a63 polyml-5.7.1-2.tar.gz 0b896ccc35bd3f2541cd55e6f0ed14637ed9fc68 polyml-5.7.1-4.tar.gz 262450ac9966abebae2e1d4f9ae703cfe0f5d8d9 polyml-5.7.1-5.tar.gz 1aeb57877d694db7fe4d4395287cddf3bc77710b polyml-5.7.1-6.tar.gz e3e7e20b1e0e5d5d68df4cd4caa1e1a7410d46b6 polyml-5.7.1-7.tar.gz 1430533c09b17f8be73798a47a5f409d43a04cf4 polyml-5.7.1-8.tar.gz 171b5783b88522a35e4822b19ef8ba838c04f494 polyml-5.7.1.tar.gz 5fbcab1da2b5eb97f24da2590ece189d55b3a105 polyml-5.7.tar.gz 51e024225b460900da5279f0b91b217085f98cf9 polyml-5.8-20190220.tar.gz 20a83fa58d497b533150defe39bcd4540529b25f polyml-5.8-20190306.tar.gz 9f0e9cd10df4c3383b063eb076e8b698ca50c3d0 polyml-5.8.1-20191101.tar.gz f46deb909d645ac8c140968e4d32b5763beb9add polyml-5.8.1-20191113.tar.gz 36a40a981b57daae0463d14940a8edf6fa1af179 polyml-5.8.1-20191114.tar.gz 525b05536b08c11a1eae943fe6818a8622326084 polyml-5.8.1-20191124.tar.gz 9043828803483ca14df64488dff014ad050a6d34 polyml-5.8.1-20200228.tar.gz 1186607e2c43b77db86731f12fbedb531ca50a21 polyml-5.8.1-20200708.tar.gz 22ae16bf7850e73b903d2ca8eb506da05b441cf3 polyml-5.8.1.tar.gz cb8e85387315f62dcfc6b21ec378186e58068f76 polyml-5.8.2.tar.gz d1fd6eced69dc1df7226432fcb824568e0994ff2 polyml-5.8.tar.gz 49f1adfacdd6d29fa9f72035d94a31eaac411a97 polyml-test-0a6ebca445fc.tar.gz 2a8c4421e0a03c0d6ad556b3c36c34eb11568adb polyml-test-1236652ebd55.tar.gz 8e83fb5088cf265902b8da753a8eac5fe3f6a14b polyml-test-159dc81efc3b.tar.gz a0064c157a59e2706e18512a49a6dca914fa17fc polyml-test-1b2dcf8f5202.tar.gz 4e6543dbbb2b2aa402fd61428e1c045c48f18b47 polyml-test-79534495ee94.tar.gz 853ab0e9ff2b73790cc80a2d36cbff8b03e50a8e polyml-test-7a7b742897e9.tar.gz 85bfda83d138e936fdafd68ed3627b1058e5c2c3 polyml-test-7e49fce62e3d.tar.gz c629cd499a724bbe37b962f727e4ff340c50299d polyml-test-8529546198aa.tar.gz 7df4857d73dbc9edda25a6ad329e47639e70fadf polyml-test-8fda4fd22441.tar.gz 2b7c02b67feb2f44dda6938a7244f4257e7c580c polyml-test-905dae2ebfda.tar.gz 3dfdc58e5d9b28f038a725e05c9c2f2ce0bb2632 polyml-test-a3cfdf648da-1.tar.gz e2f075b0cc709f4f7f6492b725362f9010b2c6d1 polyml-test-a3cfdf648da-2.tar.gz 33568f69ce813b7405386ddbefa14ad0342bb8f0 polyml-test-a3cfdf648da.tar.gz 4bedaac4f1fb9a9199aa63695735063c47059003 polyml-test-a444f281ccec.tar.gz f3031692edcc5d8028a42861e4e40779f0f9d3e1 polyml-test-b68438d33c69.tar.gz cb2318cff6ea9293cd16a4435a4fe28ad9dbe0b8 polyml-test-cf46747fee61.tar.gz 67ffed2f98864721bdb1e87f0ef250e4c69e6160 polyml-test-d68c6736402e.tar.gz b4ceeaac47f3baae41c2491a8368b03217946166 polyml-test-e7a662f8f9c4.tar.gz 609c7d09d3ed01156ff91261e801e2403ff93729 polyml-test-e8d82343b692.tar.gz b6d87466e9b44e8ef4a2fac74c96b139080a506a polyml-test-f54aa41240d0.tar.gz d365f3fc11c2427cafc62b3c79951880a1476ebb polyml-test-f86ae3dc1686.tar.gz a619177143fea42a464f49bb864665407c07a16c polyml-test-fb4f42af00fa.tar.gz 53123dc011b2d4b4e8fe307f3c9fa355718ad01a postgresql-42.1.1.tar.gz 3a5d31377ec07a5069957f5477a4848cfc89a594 postgresql-42.1.4.tar.gz 7d6ef4320d5163ceb052eb83c1cb3968f099a422 postgresql-42.2.18.tar.gz e7cd5c7955e9eb5ce8cd07feb97230b23d2eec40 postgresql-42.2.2.tar.gz 1aaa38429dc9aa7b1095394d9a7ba3465f8d6e04 postgresql-42.2.24.tar.gz 231b33c9c3c27d47e3ba01b399103d70509e0731 postgresql-42.2.5.tar.gz 6335fbc0658e447b5b9bc48c9ad36e33a05bb72b postgresql-42.2.9.tar.gz f132329ca1045858ef456cc08b197c9eeea6881b postgresql-9.4.1212.tar.gz 0885e1f1d8feaca78d2f204b6487e6eec6dfab4b scala-2.10.0.tar.gz f7dc7a4e1aea46408fd6e44b8cfacb33af61afbc scala-2.10.1.tar.gz 207e4916336335386589c918c5e3f3dcc14698f2 scala-2.10.2.tar.gz 21c8ee274ffa471ab54d4196ecd827bf3d43e591 scala-2.10.3.tar.gz d4688ddaf83037ca43b5bf271325fc53ae70e3aa scala-2.10.4.tar.gz 44d12297a78988ffd34363535e6a8e0d94c1d8b5 scala-2.11.0.tar.gz 14f20de82b25215a5e055631fb147356400625e6 scala-2.11.1.tar.gz 4fe9590d08e55760b86755d3fab750e90ac6c380 scala-2.11.2.tar.gz 27a296495b2167148de06314ed9a942f2dbe23fe scala-2.11.4.tar.gz 4b24326541161ce65424293ca9da3e7c2c6ab452 scala-2.11.5.tar.gz e7cf20e3b27c894c6127c7a37042c1667f57385e scala-2.11.6.tar.gz 4810c1b00719115df235be1c5991aa6ea7186134 scala-2.11.7.tar.gz 3eca4b80710996fff87ed1340dcea2c5f6ebf4f7 scala-2.11.8.tar.gz 0004e53f885fb165b50c95686dec40d99ab0bdbd scala-2.12.0.tar.gz 059cbdc58d36e3ac1fffcccd9139ecd34f271882 scala-2.12.10.tar.gz 82056106aa6fd37c159ea76d16096c20a749cccd scala-2.12.11.tar.gz fe7ff585acffaad7f0dd4a1d079134d15c26ed0d scala-2.12.12.tar.gz 74a8c3dab3a25a87357996ab3e95d825dc820fd0 scala-2.12.2.tar.gz d66796a68ec3254b46b17b1f8ee5bcc56a93aacf scala-2.12.3.tar.gz 1636556167dff2c191baf502c23f12e09181ef78 scala-2.12.4.tar.gz 8171f494bba54fb0d01c887f889ab8fde7171c2a scala-2.12.5.tar.gz 54c1b06fa2c5f6c2ab3d391ef342c0532cd7f392 scala-2.12.6.tar.gz 02358f00acc138371324b6248fdb62eed791c6bd scala-2.12.7.tar.gz 201c05ae9cc382ee6c08af49430e426f6bbe0d5a scala-2.12.8.tar.gz a0622fe75c3482ba7dc3ce74d58583b648a1ff0d scala-2.13.4-1.tar.gz ec53cce3c5edda1145ec5d13924a5f9418995c15 scala-2.13.4.tar.gz f51981baf34c020ad103b262f81796c37abcaa4a scala-2.13.5.tar.gz 0a7cab09dec357dab7819273f2542ff1c3ea0968 scala-2.13.6.tar.gz b447017e81600cc5e30dd61b5d4962f6da01aa80 scala-2.8.1.final.tar.gz 5659440f6b86db29f0c9c0de7249b7e24a647126 scala-2.9.2.tar.gz abe7a3b50da529d557a478e9f631a22429418a67 smbc-0.4.1.tar.gz cbd491c0feba1d21019d05564e76dd04f592ccb4 spass-3.8ds-1.tar.gz edaa1268d82203067657aabcf0371ce7d4b579b9 spass-3.8ds-2.tar.gz 43b5afbcad575ab6817d2289756ca22fd2ef43a9 spass-3.8ds.tar.gz b016a785f1f78855c00d351ff598355c3b87450f sqlite-jdbc-3.18.0-1.tar.gz b85b5bc071a59ef2a8326ceb1617d5a9a5be41cf sqlite-jdbc-3.18.0.tar.gz e56117a67ab01fb24c7fc054ede3160cefdac5f8 sqlite-jdbc-3.20.0.tar.gz 27aeac6a91353d69f0438837798ac4ae6f9ff8c5 sqlite-jdbc-3.23.1.tar.gz 4d17611857fa3a93944c1f159c0fd2a161967aaf sqlite-jdbc-3.27.2.1.tar.gz 806be457eb79408fcc5a72aeca3f64b2d89a6b63 sqlite-jdbc-3.30.1.tar.gz cba2b194114216b226d75d49a70d1bd12b141ac8 sqlite-jdbc-3.32.3.2.tar.gz 29306acd6ce9f4c87032b2c271c6df035fe7d4d3 sqlite-jdbc-3.34.0.tar.gz 8a2ca4d02cfedbfe4dad4490f1ed3ddba33a009a sqlite-jdbc-3.36.0.3.tar.gz 8d20968603f45a2c640081df1ace6a8b0527452a sqlite-jdbc-3.8.11.2.tar.gz 2369f06e8d095f9ba26df938b1a96000e535afff ssh-java-20161009.tar.gz a2335d28b5b95d8d26500a53f1a9303fc5beaf36 ssh-java-20190323.tar.gz fdc415284e031ee3eb2f65828cbc6945736fe995 stack-1.9.1.tar.gz 6e19948ff4a821e2052fc9b3ddd9ae343f4fcdbb stack-1.9.3.tar.gz f969443705aa8619e93af5b34ea98d15cd7efaf1 stack-2.1.3.tar.gz ebd0221d038966aa8bde075f1b0189ff867b02ca stack-2.5.1.tar.gz fa2d882ec45cbc8c7d2f3838b705a8316696dc66 stack-2.7.3.tar.gz 1f4a2053cc1f34fa36c4d9d2ac906ad4ebc863fd sumatra_pdf-2.1.1.tar.gz 601e08d048d8e50b0729429c8928b667d9b6bde9 sumatra_pdf-2.3.2.tar.gz 14d46c2eb1a34821703da59d543433f581e91df3 sumatra_pdf-2.4.tar.gz 44d67b6742919ce59a42368fc60e2afa210a3e42 sumatra_pdf-2.5.2.tar.gz 89719a13bc92810730a430973684629426ed1b2a sumatra_pdf-3.0.tar.gz f5afcc82f8e734665d38867e99475d3ad0d5ed15 sumatra_pdf-3.1.1.tar.gz a45eca5c1277f42f87bb8dc12a3074ccf5488221 sumatra_pdf-3.1.2-1.tar.gz 3b3239b2e6f8062b90d819f3703e30a50f4fa1e7 sumatra_pdf-3.1.2-2.tar.gz 8486387f61557147ec06b1f637117c017c8f0528 sumatra_pdf-3.1.2.tar.gz e8648878f908e93d64a393231ab21fdac976a9c2 sumatra_pdf-3.3.3.tar.gz 869ea6d8ea35c8ba68d7fcb028f16b2b7064c5fd vampire-1.0.tar.gz 399f687b56575b93e730f68c91c989cb48aa34d8 vampire-4.2.2.tar.gz 0402978ca952f08eea73e483b694928ac402a304 vampire-4.5.1-1.tar.gz 26d9d171e169c6420a08aa99eda03ef5abb9c545 vampire-4.5.1.tar.gz 4571c042efd6fc3097e105a528826959acd888a3 vampire-4.6.tar.gz 98c5c79fef7256db9f64c8feea2edef0a789ce46 verit-2016post.tar.gz 52ba18a6c96b53c5ae9b179d5a805a0c08f1da6d verit-2020.10-rmx-1.tar.gz b6706e74e20e14038e9b38f0acdb5639a134246a verit-2020.10-rmx.tar.gz d33e1e36139e86b9e9a48d8b46a6f90d7863a51c verit-2021.06-rmx-1.tar.gz c11d1120fcefaec79f099fe2be05b03cd2aed8b9 verit-2021.06-rmx.tar.gz 81d21dfd0ea5c58f375301f5166be9dbf8921a7a windows_app-20130716.tar.gz fe15e1079cf5ad86f3cbab4553722a0d20002d11 windows_app-20130905.tar.gz e6a43b7b3b21295853bd2a63b27ea20bd6102f5f windows_app-20130906.tar.gz 8fe004aead867d4c82425afac481142bd3f01fb0 windows_app-20130908.tar.gz d273abdc7387462f77a127fa43095eed78332b5c windows_app-20130909.tar.gz c368908584e2bca38b3bcb20431d0c69399fc2f0 windows_app-20131130.tar.gz c3f5285481a95fde3c1961595b4dd0311ee7ac1f windows_app-20131201.tar.gz 14807afcf69e50d49663d5b48f4b103f30ae842b windows_app-20150821.tar.gz ed106181510e825bf959025d8e0a2fc3f78e7a3f windows_app-20180417.tar.gz e809e4ab0d33cb413a7c47dd947e7dbdfcca1c24 windows_app-20181002.tar.gz 9e96ba128a0617a9020a178781df49d48c997e19 windows_app-20181006.tar.gz 1c36a840320dfa9bac8af25fc289a4df5ea3eccb xz-java-1.2-1.tar.gz 2ae13aa17d0dc95ce254a52f1dba10929763a10d xz-java-1.2.tar.gz c22196148fcace5443a933238216cff5112948df xz-java-1.5.tar.gz 4368ee09154dff42666a8c87e072261745619e51 xz-java-1.6.tar.gz 63f5fa09e92a895cb9aea27d7142abc86c487d25 xz-java-1.8.tar.gz a06875bdadd653627a68d2083c5178c1264d8fc6 xz-java-1.9.tar.gz 4530a1aa6f4498ee3d78d6000fa71a3f63bd077f yices-1.0.28.tar.gz 3a8f77822278fe9250890e357248bc678d8fac95 z3-3.2-1.tar.gz 12ae71acde43bd7bed1e005c43034b208c0cba4c z3-3.2.tar.gz d94a716502c8503d63952bcb4d4176fac8b28704 z3-4.0.tar.gz 86e721296c400ada440e4a9ce11b9e845eec9e25 z3-4.3.0.tar.gz a8917c31b31c182edeec0aaa48870844960c8a61 z3-4.3.2pre-1.tar.gz 06b30757ff23aefbc30479785c212685ffd39f4d z3-4.3.2pre.tar.gz 93e7e4bddc6afcf87fe2b6656cfcb1b1acd0a4f8 z3-4.4.0pre-1.tar.gz b1bc411c2083fc01577070b56b94514676f53854 z3-4.4.0pre-2.tar.gz 4c366ab255d2e9343fb635d44d4d55ddd24c76d0 z3-4.4.0pre-3.tar.gz 517ba7b94c1985416c5b411c8ae84456367eb231 z3-4.4.0pre.tar.gz aa20745f0b03e606b1a4149598e0c7572b63c657 z3-4.8.3.tar.gz 9dfeb39c87393af7b6a34118507637aa53aca05e zipperposition-2.0-1.tar.gz b884c60653002a7811e3b652ae0515e825d98667 zipperposition-2.0.tar.gz b129ec4f8a4474953ec107536298ee08a01fbebc zipperposition-2.1-1.tar.gz 5f53a77efb5cbe9d0c95d74a1588cc923bd711a7 zipperposition-2.1.tar.gz diff --git a/Admin/components/main b/Admin/components/main --- a/Admin/components/main +++ b/Admin/components/main @@ -1,32 +1,32 @@ #main components for repository clones or release bundles gnu-utils-20210414 bash_process-1.2.4-2 bib2xhtml-20190409 csdp-6.1.1 cvc4-1.8 e-2.6-1 flatlaf-1.6 idea-icons-20210508 isabelle_fonts-20211004 isabelle_setup-20210922 jdk-17+35 -jedit-20210802 +jedit-20211019 jfreechart-1.5.3 jortho-1.0-2 kodkodi-1.5.7 minisat-2.2.1 nunchaku-0.5 opam-2.0.7 polyml-5.8.2 postgresql-42.2.24 scala-2.13.5 smbc-0.4.1 spass-3.8ds-2 sqlite-jdbc-3.36.0.3 ssh-java-20190323 stack-2.7.3 vampire-4.6 verit-2021.06-rmx-1 xz-java-1.9 z3-4.4.0pre-3 zipperposition-2.1-1 diff --git a/src/HOL/Analysis/Metric_Arith.thy b/src/HOL/Analysis/Metric_Arith.thy --- a/src/HOL/Analysis/Metric_Arith.thy +++ b/src/HOL/Analysis/Metric_Arith.thy @@ -1,114 +1,114 @@ -(* Title: Metric_Arith.thy - Author: Maximilian Schäffeler (port from HOL Light) +(* Title: HOL/Analysis/Metric_Arith.thy + Author: Maximilian Schäffeler (port from HOL Light) *) chapter \Functional Analysis\ section\<^marker>\tag unimportant\ \A decision procedure for metric spaces\ theory Metric_Arith imports HOL.Real_Vector_Spaces begin text\<^marker>\tag unimportant\ \ A port of the decision procedure ``Formalization of metric spaces in HOL Light'' @{cite "DBLP:journals/jar/Maggesi18"} for the type class @{class metric_space}, with the \Argo\ solver as backend. \ named_theorems metric_prenex named_theorems metric_nnf named_theorems metric_unfold named_theorems metric_pre_arith lemmas pre_arith_simps = max.bounded_iff max_less_iff_conj le_max_iff_disj less_max_iff_disj simp_thms HOL.eq_commute declare pre_arith_simps [metric_pre_arith] lemmas unfold_simps = Un_iff subset_iff disjoint_iff_not_equal Ball_def Bex_def declare unfold_simps [metric_unfold] declare HOL.nnf_simps(4) [metric_prenex] lemma imp_prenex [metric_prenex]: "\P Q. (\x. P x) \ Q \ \x. (P x \ Q)" "\P Q. P \ (\x. Q x) \ \x. (P \ Q x)" "\P Q. (\x. P x) \ Q \ \x. (P x \ Q)" "\P Q. P \ (\x. Q x) \ \x. (P \ Q x)" by simp_all lemma ex_prenex [metric_prenex]: "\P Q. (\x. P x) \ Q \ \x. (P x \ Q)" "\P Q. P \ (\x. Q x) \ \x. (P \ Q x)" "\P Q. (\x. P x) \ Q \ \x. (P x \ Q)" "\P Q. P \ (\x. Q x) \ \x. (P \ Q x)" "\P. \(\x. P x) \ \x. \P x" by simp_all lemma all_prenex [metric_prenex]: "\P Q. (\x. P x) \ Q \ \x. (P x \ Q)" "\P Q. P \ (\x. Q x) \ \x. (P \ Q x)" "\P Q. (\x. P x) \ Q \ \x. (P x \ Q)" "\P Q. P \ (\x. Q x) \ \x. (P \ Q x)" "\P. \(\x. P x) \ \x. \P x" by simp_all lemma nnf_thms [metric_nnf]: "(\ (P \ Q)) = (\ P \ \ Q)" "(\ (P \ Q)) = (\ P \ \ Q)" "(P \ Q) = (\ P \ Q)" "(P = Q) \ (P \ \ Q) \ (\ P \ Q)" "(\ (P = Q)) \ (\ P \ \ Q) \ (P \ Q)" "(\ \ P) = P" by blast+ lemmas nnf_simps = nnf_thms linorder_not_less linorder_not_le declare nnf_simps[metric_nnf] lemma ball_insert: "(\x\insert a B. P x) = (P a \ (\x\B. P x))" by blast lemma Sup_insert_insert: fixes a::real shows "Sup (insert a (insert b s)) = Sup (insert (max a b) s)" by (simp add: Sup_real_def) lemma real_abs_dist: "\dist x y\ = dist x y" by simp lemma maxdist_thm [THEN HOL.eq_reflection]: assumes "finite s" "x \ s" "y \ s" defines "\a. f a \ \dist x a - dist a y\" shows "dist x y = Sup (f ` s)" proof - have "dist x y \ Sup (f ` s)" proof - have "finite (f ` s)" by (simp add: \finite s\) moreover have "\dist x y - dist y y\ \ f ` s" by (metis \y \ s\ f_def imageI) ultimately show ?thesis using le_cSup_finite by simp qed also have "Sup (f ` s) \ dist x y" using \x \ s\ cSUP_least[of s f] abs_dist_diff_le unfolding f_def by blast finally show ?thesis . qed theorem metric_eq_thm [THEN HOL.eq_reflection]: "x \ s \ y \ s \ x = y \ (\a\s. dist x a = dist y a)" by auto ML_file "metric_arith.ML" method_setup metric = \ - Scan.succeed (SIMPLE_METHOD' o MetricArith.metric_arith_tac) + Scan.succeed (SIMPLE_METHOD' o Metric_Arith.metric_arith_tac) \ "prove simple linear statements in metric spaces (\\\<^sub>p fragment)" -end \ No newline at end of file +end diff --git a/src/HOL/Analysis/metric_arith.ML b/src/HOL/Analysis/metric_arith.ML --- a/src/HOL/Analysis/metric_arith.ML +++ b/src/HOL/Analysis/metric_arith.ML @@ -1,323 +1,329 @@ -signature METRIC_ARITH = sig +(* Title: HOL/Analysis/metric_arith.ML + Author: Maximilian Schäffeler (port from HOL Light) + +A decision procedure for metric spaces. +*) + +signature METRIC_ARITH = +sig + val trace: bool Config.T val metric_arith_tac : Proof.context -> int -> tactic - val trace: bool Config.T end -structure MetricArith : METRIC_ARITH = struct +structure Metric_Arith : METRIC_ARITH = +struct fun default d x = case x of SOME y => SOME y | NONE => d (* apply f to both cterms in ct_pair, merge results *) fun app_union_ct_pair f ct_pair = uncurry (union (op aconvc)) (apply2 f ct_pair) val trace = Attrib.setup_config_bool \<^binding>\metric_trace\ (K false) fun trace_tac ctxt msg = if Config.get ctxt trace then print_tac ctxt msg else all_tac fun argo_trace_ctxt ctxt = if Config.get ctxt trace then Config.map (Argo_Tactic.trace) (K "basic") ctxt else ctxt fun IF_UNSOLVED' tac i = IF_UNSOLVED (tac i) fun REPEAT' tac i = REPEAT (tac i) fun free_in v ct = Cterms.defined (Cterms.build (Drule.add_frees_cterm ct)) v (* build a cterm set with elements cts of type ty *) fun mk_ct_set ctxt ty = map Thm.term_of #> HOLogic.mk_set ty #> Thm.cterm_of ctxt fun prenex_tac ctxt = let val prenex_simps = Proof_Context.get_thms ctxt @{named_theorems metric_prenex} val prenex_ctxt = put_simpset HOL_basic_ss ctxt addsimps prenex_simps in simp_tac prenex_ctxt THEN' K (trace_tac ctxt "Prenex form") end fun nnf_tac ctxt = let val nnf_simps = Proof_Context.get_thms ctxt @{named_theorems metric_nnf} val nnf_ctxt = put_simpset HOL_basic_ss ctxt addsimps nnf_simps in simp_tac nnf_ctxt THEN' K (trace_tac ctxt "NNF form") end fun unfold_tac ctxt = asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps ( Proof_Context.get_thms ctxt @{named_theorems metric_unfold})) fun pre_arith_tac ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps ( Proof_Context.get_thms ctxt @{named_theorems metric_pre_arith})) THEN' K (trace_tac ctxt "Prepared for decision procedure") fun dist_refl_sym_tac ctxt = let val refl_sym_simps = @{thms dist_self dist_commute add_0_right add_0_left simp_thms} val refl_sym_ctxt = put_simpset HOL_basic_ss ctxt addsimps refl_sym_simps in simp_tac refl_sym_ctxt THEN' K (trace_tac ctxt ("Simplified using " ^ @{make_string} refl_sym_simps)) end fun is_exists ct = case Thm.term_of ct of Const (\<^const_name>\HOL.Ex\,_)$_ => true | Const (\<^const_name>\Trueprop\,_)$_ => is_exists (Thm.dest_arg ct) | _ => false fun is_forall ct = case Thm.term_of ct of Const (\<^const_name>\HOL.All\,_)$_ => true | Const (\<^const_name>\Trueprop\,_)$_ => is_forall (Thm.dest_arg ct) | _ => false fun dist_ty mty = mty --> mty --> \<^typ>\real\ (* find all free points in ct of type metric_ty *) fun find_points ctxt metric_ty ct = let fun find ct = (if Thm.typ_of_cterm ct = metric_ty then [ct] else []) @ ( case Thm.term_of ct of _ $ _ => app_union_ct_pair find (Thm.dest_comb ct) | Abs (_, _, _) => (* ensure the point doesn't contain the bound variable *) let val (var, bod) = Thm.dest_abs_global ct in filter (free_in var #> not) (find bod) end | _ => []) val points = find ct in case points of [] => (* if no point can be found, invent one *) let val free_name = Term.variant_frees (Thm.term_of ct) [("x", metric_ty)] in map (Free #> Thm.cterm_of ctxt) free_name end | _ => points end (* find all cterms "dist x y" in ct, where x and y have type metric_ty *) fun find_dist metric_ty ct = let val dty = dist_ty metric_ty fun find ct = case Thm.term_of ct of Const (\<^const_name>\dist\, ty) $ _ $ _ => if ty = dty then [ct] else [] | _ $ _ => app_union_ct_pair find (Thm.dest_comb ct) | Abs (_, _, _) => let val (var, bod) = Thm.dest_abs_global ct in filter (free_in var #> not) (find bod) end | _ => [] in find ct end (* find all "x=y", where x has type metric_ty *) fun find_eq metric_ty ct = let fun find ct = case Thm.term_of ct of Const (\<^const_name>\HOL.eq\, ty) $ _ $ _ => if fst (dest_funT ty) = metric_ty then [ct] else app_union_ct_pair find (Thm.dest_binop ct) | _ $ _ => app_union_ct_pair find (Thm.dest_comb ct) | Abs (_, _, _) => let val (var, bod) = Thm.dest_abs_global ct in filter (free_in var #> not) (find bod) end | _ => [] in find ct end (* rewrite ct of the form "dist x y" using maxdist_thm *) fun maxdist_conv ctxt fset_ct ct = let val (xct, yct) = Thm.dest_binop ct val solve_prems = rule_by_tactic ctxt (ALLGOALS (simp_tac (put_simpset HOL_ss ctxt addsimps @{thms finite.emptyI finite_insert empty_iff insert_iff}))) val image_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms image_empty image_insert}) val dist_refl_sym_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms dist_commute dist_self}) val algebra_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms diff_self diff_0_right diff_0 abs_zero abs_minus_cancel abs_minus_commute}) val insert_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms insert_absorb2 insert_commute}) val sup_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms cSup_singleton Sup_insert_insert}) val real_abs_dist_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms real_abs_dist}) val maxdist_thm = @{thm maxdist_thm} |> infer_instantiate' ctxt [SOME fset_ct, SOME xct, SOME yct] |> solve_prems in ((Conv.rewr_conv maxdist_thm) then_conv (* SUP to Sup *) image_simp then_conv dist_refl_sym_simp then_conv algebra_simp then_conv (* eliminate duplicate terms in set *) insert_simp then_conv (* Sup to max *) sup_simp then_conv real_abs_dist_simp) ct end (* rewrite ct of the form "x=y" using metric_eq_thm *) fun metric_eq_conv ctxt fset_ct ct = let val (xct, yct) = Thm.dest_binop ct val solve_prems = rule_by_tactic ctxt (ALLGOALS (simp_tac (put_simpset HOL_ss ctxt addsimps @{thms empty_iff insert_iff}))) val ball_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms Set.ball_empty ball_insert}) val dist_refl_sym_simp = Simplifier.rewrite (put_simpset HOL_ss ctxt addsimps @{thms dist_commute dist_self}) val metric_eq_thm = @{thm metric_eq_thm} |> infer_instantiate' ctxt [SOME xct, SOME fset_ct, SOME yct] |> solve_prems in ((Conv.rewr_conv metric_eq_thm) then_conv (* convert \x\{x\<^sub>1,...,x\<^sub>n}. P x to P x\<^sub>1 \ ... \ P x\<^sub>n *) ball_simp then_conv dist_refl_sym_simp) ct end (* build list of theorems "0 \ dist x y" for all dist terms in ct *) fun augment_dist_pos ctxt metric_ty ct = let fun inst dist_ct = let val (xct, yct) = Thm.dest_binop dist_ct in infer_instantiate' ctxt [SOME xct, SOME yct] @{thm zero_le_dist} end in map inst (find_dist metric_ty ct) end -fun top_sweep_rewrs_tac ctxt thms = - CONVERSION (Conv.top_sweep_conv (K (Conv.rewrs_conv thms)) ctxt) - (* apply maxdist_conv and metric_eq_conv to the goal, thereby embedding the goal in (\\<^sup>n,dist\<^sub>\) *) -fun embedding_tac ctxt metric_ty i goal = +fun embedding_tac ctxt metric_ty = CSUBGOAL (fn (goal, i) => let - val ct = (Thm.cprem_of goal 1) - val points = find_points ctxt metric_ty ct + val points = find_points ctxt metric_ty goal val fset_ct = mk_ct_set ctxt metric_ty points (* embed all subterms of the form "dist x y" in (\\<^sup>n,dist\<^sub>\) *) - val eq1 = map (maxdist_conv ctxt fset_ct) (find_dist metric_ty ct) + val eq1 = map (maxdist_conv ctxt fset_ct) (find_dist metric_ty goal) (* replace point equality by equality of components in \\<^sup>n *) - val eq2 = map (metric_eq_conv ctxt fset_ct) (find_eq metric_ty ct) + val eq2 = map (metric_eq_conv ctxt fset_ct) (find_eq metric_ty goal) in - ( K (trace_tac ctxt "Embedding into \\<^sup>n") THEN' top_sweep_rewrs_tac ctxt (eq1 @ eq2))i goal - end + (K (trace_tac ctxt "Embedding into \\<^sup>n") THEN' + CONVERSION (Conv.top_sweep_rewrs_conv (eq1 @ eq2) ctxt)) i + end) (* decision procedure for linear real arithmetic *) fun lin_real_arith_tac ctxt metric_ty i goal = let val dist_thms = augment_dist_pos ctxt metric_ty (Thm.cprem_of goal 1) val ctxt' = argo_trace_ctxt ctxt in (Argo_Tactic.argo_tac ctxt' dist_thms) i goal end fun basic_metric_arith_tac ctxt metric_ty = HEADGOAL (dist_refl_sym_tac ctxt THEN' IF_UNSOLVED' (embedding_tac ctxt metric_ty) THEN' IF_UNSOLVED' (pre_arith_tac ctxt) THEN' IF_UNSOLVED' (lin_real_arith_tac ctxt metric_ty)) (* tries to infer the metric space from ct from dist terms, if no dist terms are present, equality terms will be used *) fun guess_metric ctxt ct = let fun find_dist ct = case Thm.term_of ct of Const (\<^const_name>\dist\, ty) $ _ $ _ => SOME (fst (dest_funT ty)) | _ $ _ => let val (s, t) = Thm.dest_comb ct in default (find_dist t) (find_dist s) end | Abs (_, _, _) => find_dist (snd (Thm.dest_abs_global ct)) | _ => NONE fun find_eq ct = case Thm.term_of ct of Const (\<^const_name>\HOL.eq\, ty) $ x $ _ => let val (l, r) = Thm.dest_binop ct in if Sign.of_sort (Proof_Context.theory_of ctxt) (type_of x, \<^sort>\metric_space\) then SOME (fst (dest_funT ty)) else default (find_dist r) (find_eq l) end | _ $ _ => let val (s, t) = Thm.dest_comb ct in default (find_eq t) (find_eq s) end | Abs (_, _, _) => find_eq (snd (Thm.dest_abs_global ct)) | _ => NONE in case default (find_eq ct) (find_dist ct) of SOME ty => ty | NONE => error "No Metric Space was found" end (* eliminate \ by proving the goal for a single witness from the metric space *) fun elim_exists ctxt goal = let val ct = Thm.cprem_of goal 1 val metric_ty = guess_metric ctxt ct val points = find_points ctxt metric_ty ct fun try_point ctxt pt = let val ex_rule = infer_instantiate' ctxt [NONE, SOME pt] @{thm exI} in HEADGOAL (resolve_tac ctxt [ex_rule] ORELSE' (* variable doesn't occur in body *) resolve_tac ctxt @{thms exI}) THEN trace_tac ctxt ("Removed existential quantifier, try " ^ @{make_string} pt) THEN try_points ctxt end and try_points ctxt goal = ( if is_exists (Thm.cprem_of goal 1) then FIRST (map (try_point ctxt) points) else if is_forall (Thm.cprem_of goal 1) then HEADGOAL (resolve_tac ctxt @{thms HOL.allI} THEN' Subgoal.FOCUS (fn {context = ctxt', ...} => trace_tac ctxt "Removed universal quantifier" THEN try_points ctxt') ctxt) else basic_metric_arith_tac ctxt metric_ty) goal in try_points ctxt goal end fun metric_arith_tac ctxt = (* unfold common definitions to get rid of sets *) unfold_tac ctxt THEN' (* remove all meta-level connectives *) IF_UNSOLVED' (Object_Logic.full_atomize_tac ctxt) THEN' (* convert goal to prenex form *) IF_UNSOLVED' (prenex_tac ctxt) THEN' (* and NNF to ? *) IF_UNSOLVED' (nnf_tac ctxt) THEN' (* turn all universally quantified variables into free variables, by focusing the subgoal *) REPEAT' (resolve_tac ctxt @{thms HOL.allI}) THEN' IF_UNSOLVED' (SUBPROOF (fn {context=ctxt', ...} => trace_tac ctxt' "Focused on subgoal" THEN elim_exists ctxt') ctxt) + end diff --git a/src/HOL/Analysis/normarith.ML b/src/HOL/Analysis/normarith.ML --- a/src/HOL/Analysis/normarith.ML +++ b/src/HOL/Analysis/normarith.ML @@ -1,414 +1,414 @@ (* Title: HOL/Analysis/normarith.ML Author: Amine Chaieb, University of Cambridge Simple decision procedure for linear problems in Euclidean space. *) signature NORM_ARITH = sig val norm_arith : Proof.context -> conv val norm_arith_tac : Proof.context -> int -> tactic end structure NormArith : NORM_ARITH = struct open Conv; val bool_eq = op = : bool *bool -> bool fun dest_ratconst t = case Thm.term_of t of Const(\<^const_name>\divide\, _)$a$b => Rat.make(HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd) | Const(\<^const_name>\inverse\, _)$a => Rat.make(1, HOLogic.dest_number a |> snd) | _ => Rat.of_int (HOLogic.dest_number (Thm.term_of t) |> snd) fun is_ratconst t = can dest_ratconst t fun augment_norm b t acc = case Thm.term_of t of Const(\<^const_name>\norm\, _) $ _ => insert (eq_pair bool_eq (op aconvc)) (b,Thm.dest_arg t) acc | _ => acc fun find_normedterms t acc = case Thm.term_of t of \<^term>\(+) :: real => _\$_$_ => find_normedterms (Thm.dest_arg1 t) (find_normedterms (Thm.dest_arg t) acc) | \<^term>\(*) :: real => _\$_$_ => if not (is_ratconst (Thm.dest_arg1 t)) then acc else augment_norm (dest_ratconst (Thm.dest_arg1 t) >= @0) (Thm.dest_arg t) acc | _ => augment_norm true t acc val cterm_lincomb_neg = FuncUtil.Ctermfunc.map (K ~) fun cterm_lincomb_cmul c t = if c = @0 then FuncUtil.Ctermfunc.empty else FuncUtil.Ctermfunc.map (fn _ => fn x => x * c) t fun cterm_lincomb_add l r = FuncUtil.Ctermfunc.combine (curry op +) (fn x => x = @0) l r fun cterm_lincomb_sub l r = cterm_lincomb_add l (cterm_lincomb_neg r) fun cterm_lincomb_eq l r = FuncUtil.Ctermfunc.is_empty (cterm_lincomb_sub l r) (* val int_lincomb_neg = FuncUtil.Intfunc.map (K ~) *) fun int_lincomb_cmul c t = if c = @0 then FuncUtil.Intfunc.empty else FuncUtil.Intfunc.map (fn _ => fn x => x * c) t fun int_lincomb_add l r = FuncUtil.Intfunc.combine (curry op +) (fn x => x = @0) l r (* fun int_lincomb_sub l r = int_lincomb_add l (int_lincomb_neg r) fun int_lincomb_eq l r = FuncUtil.Intfunc.is_empty (int_lincomb_sub l r) *) fun vector_lincomb t = case Thm.term_of t of Const(\<^const_name>\plus\, _) $ _ $ _ => cterm_lincomb_add (vector_lincomb (Thm.dest_arg1 t)) (vector_lincomb (Thm.dest_arg t)) | Const(\<^const_name>\minus\, _) $ _ $ _ => cterm_lincomb_sub (vector_lincomb (Thm.dest_arg1 t)) (vector_lincomb (Thm.dest_arg t)) | Const(\<^const_name>\scaleR\, _)$_$_ => cterm_lincomb_cmul (dest_ratconst (Thm.dest_arg1 t)) (vector_lincomb (Thm.dest_arg t)) | Const(\<^const_name>\uminus\, _)$_ => cterm_lincomb_neg (vector_lincomb (Thm.dest_arg t)) (* FIXME: how should we handle numerals? | Const(@ {const_name vec},_)$_ => let val b = ((snd o HOLogic.dest_number o term_of o Thm.dest_arg) t = 0 handle TERM _=> false) in if b then FuncUtil.Ctermfunc.onefunc (t,@1) else FuncUtil.Ctermfunc.empty end *) | _ => FuncUtil.Ctermfunc.onefunc (t,@1) fun vector_lincombs ts = fold_rev (fn t => fn fns => case AList.lookup (op aconvc) fns t of NONE => let val f = vector_lincomb t in case find_first (fn (_,f') => cterm_lincomb_eq f f') fns of SOME (_,f') => (t,f') :: fns | NONE => (t,f) :: fns end | SOME _ => fns) ts [] fun replacenegnorms cv t = case Thm.term_of t of \<^term>\(+) :: real => _\$_$_ => binop_conv (replacenegnorms cv) t | \<^term>\(*) :: real => _\$_$_ => if dest_ratconst (Thm.dest_arg1 t) < @0 then arg_conv cv t else Thm.reflexive t | _ => Thm.reflexive t (* fun flip v eq = if FuncUtil.Ctermfunc.defined eq v then FuncUtil.Ctermfunc.update (v, ~ (FuncUtil.Ctermfunc.apply eq v)) eq else eq *) fun allsubsets s = case s of [] => [[]] |(a::t) => let val res = allsubsets t in map (cons a) res @ res end fun evaluate env lin = FuncUtil.Intfunc.fold (fn (x,c) => fn s => s + c * (FuncUtil.Intfunc.apply env x)) lin @0 fun solve (vs,eqs) = case (vs,eqs) of ([],[]) => SOME (FuncUtil.Intfunc.onefunc (0,@1)) |(_,eq::oeqs) => (case filter (member (op =) vs) (FuncUtil.Intfunc.dom eq) of (*FIXME use find_first here*) [] => NONE | v::_ => if FuncUtil.Intfunc.defined eq v then let val c = FuncUtil.Intfunc.apply eq v val vdef = int_lincomb_cmul (~ (Rat.inv c)) eq fun eliminate eqn = if not (FuncUtil.Intfunc.defined eqn v) then eqn else int_lincomb_add (int_lincomb_cmul (FuncUtil.Intfunc.apply eqn v) vdef) eqn in (case solve (remove (op =) v vs, map eliminate oeqs) of NONE => NONE | SOME soln => SOME (FuncUtil.Intfunc.update (v, evaluate soln (FuncUtil.Intfunc.delete_safe v vdef)) soln)) end else NONE) fun combinations k l = if k = 0 then [[]] else case l of [] => [] | h::t => map (cons h) (combinations (k - 1) t) @ combinations k t fun vertices vs eqs = let fun vertex cmb = case solve(vs,cmb) of NONE => NONE | SOME soln => SOME (map (fn v => FuncUtil.Intfunc.tryapplyd soln v @0) vs) val rawvs = map_filter vertex (combinations (length vs) eqs) val unset = filter (forall (fn c => c >= @0)) rawvs in fold_rev (insert (eq_list op =)) unset [] end val subsumes = eq_list (fn (x, y) => Rat.abs x <= Rat.abs y) fun subsume todo dun = case todo of [] => dun |v::ovs => let val dun' = if exists (fn w => subsumes (w, v)) dun then dun else v:: filter (fn w => not (subsumes (v, w))) dun in subsume ovs dun' end; fun match_mp PQ P = P RS PQ; fun cterm_of_rat x = let val (a, b) = Rat.dest x in if b = 1 then Numeral.mk_cnumber \<^ctyp>\real\ a else Thm.apply (Thm.apply \<^cterm>\(/) :: real => _\ (Numeral.mk_cnumber \<^ctyp>\real\ a)) (Numeral.mk_cnumber \<^ctyp>\real\ b) end; fun norm_cmul_rule c th = Thm.instantiate' [] [SOME (cterm_of_rat c)] (th RS @{thm norm_cmul_rule_thm}); fun norm_add_rule th1 th2 = [th1, th2] MRS @{thm norm_add_rule_thm}; (* I think here the static context should be sufficient!! *) fun inequality_canon_rule ctxt = let (* FIXME : Should be computed statically!! *) val real_poly_conv = Semiring_Normalizer.semiring_normalize_wrapper ctxt (the (Semiring_Normalizer.match ctxt \<^cterm>\(0::real) + 1\)) in fconv_rule (arg_conv ((rewr_conv @{thm ge_iff_diff_ge_0}) then_conv arg_conv (Numeral_Simprocs.field_comp_conv ctxt then_conv real_poly_conv))) end; val apply_pth1 = rewr_conv @{thm pth_1}; val apply_pth2 = rewr_conv @{thm pth_2}; val apply_pth3 = rewr_conv @{thm pth_3}; val apply_pth4 = rewrs_conv @{thms pth_4}; val apply_pth5 = rewr_conv @{thm pth_5}; val apply_pth6 = rewr_conv @{thm pth_6}; val apply_pth7 = rewrs_conv @{thms pth_7}; fun apply_pth8 ctxt = rewr_conv @{thm pth_8} then_conv arg1_conv (Numeral_Simprocs.field_comp_conv ctxt) then_conv (try_conv (rewr_conv (mk_meta_eq @{thm scaleR_zero_left}))); fun apply_pth9 ctxt = rewrs_conv @{thms pth_9} then_conv arg1_conv (arg1_conv (Numeral_Simprocs.field_comp_conv ctxt)); val apply_ptha = rewr_conv @{thm pth_a}; val apply_pthb = rewrs_conv @{thms pth_b}; val apply_pthc = rewrs_conv @{thms pth_c}; val apply_pthd = try_conv (rewr_conv @{thm pth_d}); fun headvector t = case t of Const(\<^const_name>\plus\, _)$ (Const(\<^const_name>\scaleR\, _)$_$v)$_ => v | Const(\<^const_name>\scaleR\, _)$_$v => v | _ => error "headvector: non-canonical term" fun vector_cmul_conv ctxt ct = ((apply_pth5 then_conv arg1_conv (Numeral_Simprocs.field_comp_conv ctxt)) else_conv (apply_pth6 then_conv binop_conv (vector_cmul_conv ctxt))) ct fun vector_add_conv ctxt ct = apply_pth7 ct handle CTERM _ => (apply_pth8 ctxt ct handle CTERM _ => (case Thm.term_of ct of Const(\<^const_name>\plus\,_)$lt$rt => let val l = headvector lt val r = headvector rt in (case Term_Ord.fast_term_ord (l,r) of LESS => (apply_pthb then_conv arg_conv (vector_add_conv ctxt) then_conv apply_pthd) ct | GREATER => (apply_pthc then_conv arg_conv (vector_add_conv ctxt) then_conv apply_pthd) ct | EQUAL => (apply_pth9 ctxt then_conv ((apply_ptha then_conv (vector_add_conv ctxt)) else_conv arg_conv (vector_add_conv ctxt) then_conv apply_pthd)) ct) end | _ => Thm.reflexive ct)) fun vector_canon_conv ctxt ct = case Thm.term_of ct of Const(\<^const_name>\plus\,_)$_$_ => let val ((p,l),r) = Thm.dest_comb ct |>> Thm.dest_comb val lth = vector_canon_conv ctxt l val rth = vector_canon_conv ctxt r val th = Drule.binop_cong_rule p lth rth in fconv_rule (arg_conv (vector_add_conv ctxt)) th end | Const(\<^const_name>\scaleR\, _)$_$_ => let val (p,r) = Thm.dest_comb ct val rth = Drule.arg_cong_rule p (vector_canon_conv ctxt r) in fconv_rule (arg_conv (apply_pth4 else_conv (vector_cmul_conv ctxt))) rth end | Const(\<^const_name>\minus\,_)$_$_ => (apply_pth2 then_conv (vector_canon_conv ctxt)) ct | Const(\<^const_name>\uminus\,_)$_ => (apply_pth3 then_conv (vector_canon_conv ctxt)) ct (* FIXME | Const(@{const_name vec},_)$n => let val n = Thm.dest_arg ct in if is_ratconst n andalso not (dest_ratconst n =/ @0) then Thm.reflexive ct else apply_pth1 ct end *) | _ => apply_pth1 ct fun norm_canon_conv ctxt ct = case Thm.term_of ct of Const(\<^const_name>\norm\,_)$_ => arg_conv (vector_canon_conv ctxt) ct | _ => raise CTERM ("norm_canon_conv", [ct]) fun int_flip v eq = if FuncUtil.Intfunc.defined eq v then FuncUtil.Intfunc.update (v, ~ (FuncUtil.Intfunc.apply eq v)) eq else eq; local val pth_zero = @{thm norm_zero} val tv_n = (dest_TVar o Thm.typ_of_cterm o Thm.dest_arg o Thm.dest_arg1 o Thm.dest_arg o Thm.cprop_of) pth_zero val concl = Thm.dest_arg o Thm.cprop_of fun real_vector_combo_prover ctxt translator (nubs,ges,gts) = let (* FIXME: Should be computed statically!!*) val real_poly_conv = Semiring_Normalizer.semiring_normalize_wrapper ctxt (the (Semiring_Normalizer.match ctxt \<^cterm>\(0::real) + 1\)) val sources = map (Thm.dest_arg o Thm.dest_arg1 o concl) nubs val rawdests = fold_rev (find_normedterms o Thm.dest_arg o concl) (ges @ gts) [] val _ = if not (forall fst rawdests) then error "real_vector_combo_prover: Sanity check" else () val dests = distinct (op aconvc) (map snd rawdests) val srcfuns = map vector_lincomb sources val destfuns = map vector_lincomb dests val vvs = fold_rev (union (op aconvc) o FuncUtil.Ctermfunc.dom) (srcfuns @ destfuns) [] val n = length srcfuns val nvs = 1 upto n val srccombs = srcfuns ~~ nvs fun consider d = let fun coefficients x = let val inp = if FuncUtil.Ctermfunc.defined d x then FuncUtil.Intfunc.onefunc (0, ~ (FuncUtil.Ctermfunc.apply d x)) else FuncUtil.Intfunc.empty in fold_rev (fn (f,v) => fn g => if FuncUtil.Ctermfunc.defined f x then FuncUtil.Intfunc.update (v, FuncUtil.Ctermfunc.apply f x) g else g) srccombs inp end val equations = map coefficients vvs val inequalities = map (fn n => FuncUtil.Intfunc.onefunc (n,@1)) nvs fun plausiblevertices f = let val flippedequations = map (fold_rev int_flip f) equations val constraints = flippedequations @ inequalities val rawverts = vertices nvs constraints fun check_solution v = let val f = fold_rev FuncUtil.Intfunc.update (nvs ~~ v) (FuncUtil.Intfunc.onefunc (0, @1)) in forall (fn e => evaluate f e = @0) flippedequations end val goodverts = filter check_solution rawverts val signfixups = map (fn n => if member (op =) f n then ~1 else 1) nvs in map (map2 (fn s => fn c => Rat.of_int s * c) signfixups) goodverts end val allverts = fold_rev append (map plausiblevertices (allsubsets nvs)) [] in subsume allverts [] end fun compute_ineq v = let val ths = map_filter (fn (v,t) => if v = @0 then NONE else SOME(norm_cmul_rule v t)) (v ~~ nubs) fun end_itlist f xs = split_last xs |> uncurry (fold_rev f) in inequality_canon_rule ctxt (end_itlist norm_add_rule ths) end val ges' = map_filter (try compute_ineq) (fold_rev (append o consider) destfuns []) @ map (inequality_canon_rule ctxt) nubs @ ges val zerodests = filter (fn t => null (FuncUtil.Ctermfunc.dom (vector_lincomb t))) (map snd rawdests) in fst (RealArith.real_linear_prover translator (map (fn t => Drule.instantiate_normalize (TVars.make [(tv_n, Thm.ctyp_of_cterm t)], Vars.empty) pth_zero) zerodests, - map (fconv_rule (try_conv (Conv.top_sweep_conv (K (norm_canon_conv ctxt)) ctxt) then_conv + map (fconv_rule (try_conv (Conv.top_sweep_conv norm_canon_conv ctxt) then_conv arg_conv (arg_conv real_poly_conv))) ges', - map (fconv_rule (try_conv (Conv.top_sweep_conv (K (norm_canon_conv ctxt)) ctxt) then_conv + map (fconv_rule (try_conv (Conv.top_sweep_conv norm_canon_conv ctxt) then_conv arg_conv (arg_conv real_poly_conv))) gts)) end in val real_vector_combo_prover = real_vector_combo_prover end; local val pth = @{thm norm_imp_pos_and_ge} val norm_mp = match_mp pth val concl = Thm.dest_arg o Thm.cprop_of fun conjunct1 th = th RS @{thm conjunct1} fun conjunct2 th = th RS @{thm conjunct2} fun real_vector_ineq_prover ctxt translator (ges,gts) = let (* val _ = error "real_vector_ineq_prover: pause" *) val ntms = fold_rev find_normedterms (map (Thm.dest_arg o concl) (ges @ gts)) [] val lctab = vector_lincombs (map snd (filter (not o fst) ntms)) val (fxns, ctxt') = Variable.variant_fixes (replicate (length lctab) "x") ctxt fun instantiate_cterm' ty tms = Drule.cterm_rule (Thm.instantiate' ty tms) fun mk_norm t = let val T = Thm.typ_of_cterm t in Thm.apply (Thm.cterm_of ctxt' (Const (\<^const_name>\norm\, T --> \<^typ>\real\))) t end fun mk_equals l r = let val T = Thm.typ_of_cterm l val eq = Thm.cterm_of ctxt (Const (\<^const_name>\Pure.eq\, T --> T --> propT)) in Thm.apply (Thm.apply eq l) r end val asl = map2 (fn (t,_) => fn n => Thm.assume (mk_equals (mk_norm t) (Thm.cterm_of ctxt' (Free(n,\<^typ>\real\))))) lctab fxns val replace_conv = try_conv (rewrs_conv asl) val replace_rule = fconv_rule (funpow 2 arg_conv (replacenegnorms replace_conv)) val ges' = fold_rev (fn th => fn ths => conjunct1(norm_mp th)::ths) asl (map replace_rule ges) val gts' = map replace_rule gts val nubs = map (conjunct2 o norm_mp) asl val th1 = real_vector_combo_prover ctxt' translator (nubs,ges',gts') val shs = filter (member (fn (t,th) => t aconvc Thm.cprop_of th) asl) (Thm.chyps_of th1) val th11 = hd (Variable.export ctxt' ctxt [fold Thm.implies_intr shs th1]) val cps = map (swap o Thm.dest_equals) (cprems_of th11) val th12 = Drule.instantiate_normalize (TVars.empty, Vars.make (map (apfst (dest_Var o Thm.term_of)) cps)) th11 val th13 = fold Thm.elim_implies (map (Thm.reflexive o snd) cps) th12; in hd (Variable.export ctxt' ctxt [th13]) end in val real_vector_ineq_prover = real_vector_ineq_prover end; local val rawrule = fconv_rule (arg_conv (rewr_conv @{thm real_eq_0_iff_le_ge_0})) fun conj_pair th = (th RS @{thm conjunct1}, th RS @{thm conjunct2}) (* FIXME: Lookup in the context every time!!! Fix this !!!*) fun splitequation ctxt th acc = let val real_poly_neg_conv = #neg (Semiring_Normalizer.semiring_normalizers_ord_wrapper ctxt (the (Semiring_Normalizer.match ctxt \<^cterm>\(0::real) + 1\)) Thm.term_ord) val (th1,th2) = conj_pair(rawrule th) in th1::fconv_rule (arg_conv (arg_conv (real_poly_neg_conv ctxt))) th2::acc end in fun real_vector_prover ctxt _ translator (eqs,ges,gts) = (real_vector_ineq_prover ctxt translator (fold_rev (splitequation ctxt) eqs ges,gts), RealArith.Trivial) end; fun init_conv ctxt = Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps ([(*@{thm vec_0}, @{thm vec_1},*) @{thm dist_norm}, @{thm right_minus}, @{thm diff_self}, @{thm norm_zero}] @ @{thms arithmetic_simps} @ @{thms norm_pths})) then_conv Numeral_Simprocs.field_comp_conv ctxt then_conv nnf_conv ctxt fun pure ctxt = fst o RealArith.gen_prover_real_arith ctxt (real_vector_prover ctxt); fun norm_arith ctxt ct = let val ctxt' = Variable.declare_term (Thm.term_of ct) ctxt val th = init_conv ctxt' ct in Thm.equal_elim (Drule.arg_cong_rule \<^cterm>\Trueprop\ (Thm.symmetric th)) (pure ctxt' (Thm.rhs_of th)) end fun norm_arith_tac ctxt = clarify_tac (put_claset HOL_cs ctxt) THEN' Object_Logic.full_atomize_tac ctxt THEN' CSUBGOAL ( fn (p,i) => resolve_tac ctxt [norm_arith ctxt (Thm.dest_arg p )] i); end; diff --git a/src/HOL/Library/cconv.ML b/src/HOL/Library/cconv.ML --- a/src/HOL/Library/cconv.ML +++ b/src/HOL/Library/cconv.ML @@ -1,254 +1,249 @@ (* Title: HOL/Library/cconv.ML Author: Christoph Traut, Lars Noschinski, TU Muenchen -FIXME!? +Conditional conversions. *) infix 1 then_cconv infix 0 else_cconv -type cconv = conv - signature BASIC_CCONV = sig + type cconv = conv val then_cconv: cconv * cconv -> cconv val else_cconv: cconv * cconv -> cconv val CCONVERSION: cconv -> int -> tactic end signature CCONV = sig include BASIC_CCONV val no_cconv: cconv val all_cconv: cconv val first_cconv: cconv list -> cconv val abs_cconv: (cterm * Proof.context -> cconv) -> Proof.context -> cconv val combination_cconv: cconv -> cconv -> cconv val comb_cconv: cconv -> cconv val arg_cconv: cconv -> cconv val fun_cconv: cconv -> cconv val arg1_cconv: cconv -> cconv val fun2_cconv: cconv -> cconv val rewr_cconv: thm -> cconv val rewrs_cconv: thm list -> cconv val params_cconv: int -> (Proof.context -> cconv) -> Proof.context -> cconv val prems_cconv: int -> cconv -> cconv val with_prems_cconv: int -> cconv -> cconv val concl_cconv: int -> cconv -> cconv val fconv_rule: cconv -> thm -> thm val gconv_rule: cconv -> int -> thm -> thm end structure CConv : CCONV = struct +type cconv = conv + val concl_lhs_of = Thm.cprop_of #> Drule.strip_imp_concl #> Thm.dest_equals_lhs val concl_rhs_of = Thm.cprop_of #> Drule.strip_imp_concl #> Thm.dest_equals_rhs fun transitive th1 th2 = Drule.transitive_thm OF [th1, th2] val combination_thm = let val fg = \<^cprop>\f :: 'a :: {} \ 'b :: {} \ g\ val st = \<^cprop>\s :: 'a :: {} \ t\ val thm = Thm.combination (Thm.assume fg) (Thm.assume st) |> Thm.implies_intr st |> Thm.implies_intr fg in Drule.export_without_context thm end fun abstract_rule_thm n = let val eq = \<^cprop>\\x :: 'a :: {}. (s :: 'a \ 'b :: {}) x \ t x\ val x = \<^cterm>\x :: 'a :: {}\ val thm = eq |> Thm.assume |> Thm.forall_elim x |> Thm.abstract_rule n x |> Thm.implies_intr eq in Drule.export_without_context thm end val no_cconv = Conv.no_conv val all_cconv = Conv.all_conv - -fun (cv1 else_cconv cv2) ct = - (cv1 ct - handle THM _ => cv2 ct - | CTERM _ => cv2 ct - | TERM _ => cv2 ct - | TYPE _ => cv2 ct) +val op else_cconv = Conv.else_conv fun (cv1 then_cconv cv2) ct = let val eq1 = cv1 ct val eq2 = cv2 (concl_rhs_of eq1) in if Thm.is_reflexive eq1 then eq2 else if Thm.is_reflexive eq2 then eq1 else transitive eq1 eq2 end fun first_cconv cvs = fold_rev (curry op else_cconv) cvs no_cconv fun rewr_cconv rule ct = let val rule1 = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) rule val lhs = concl_lhs_of rule1 val rule2 = Thm.rename_boundvars (Thm.term_of lhs) (Thm.term_of ct) rule1 val rule3 = Thm.instantiate (Thm.match (lhs, ct)) rule2 handle Pattern.MATCH => raise CTERM ("rewr_cconv", [lhs, ct]) val concl = rule3 |> Thm.cprop_of |> Drule.strip_imp_concl val rule4 = if Thm.dest_equals_lhs concl aconvc ct then rule3 else let val ceq = Thm.dest_fun2 concl in rule3 RS Thm.trivial (Thm.mk_binop ceq ct (Thm.dest_equals_rhs concl)) end in transitive rule4 (Thm.beta_conversion true (concl_rhs_of rule4)) end fun rewrs_cconv rules = first_cconv (map rewr_cconv rules) fun combination_cconv cv1 cv2 cterm = let val (l, r) = Thm.dest_comb cterm in combination_thm OF [cv1 l, cv2 r] end fun comb_cconv cv = combination_cconv cv cv fun fun_cconv conversion = combination_cconv conversion all_cconv fun arg_cconv conversion = combination_cconv all_cconv conversion fun abs_cconv cv ctxt ct = (case Thm.term_of ct of Abs (x, _, _) => let (* Instantiate the rule properly and apply it to the eq theorem. *) fun abstract_rule v eq = let (* Take a variable v and an equality theorem of form: P1 \ ... \ Pn \ L v \ R v And build a term of form: \v. (\x. L x) v \ (\x. R x) v *) fun mk_concl eq = let fun abs t = lambda v t $ v fun equals_cong f = Logic.dest_equals #> apply2 f #> Logic.mk_equals in Thm.concl_of eq |> equals_cong abs |> Logic.all v |> Thm.cterm_of ctxt end val rule = abstract_rule_thm x val inst = Thm.match (hd (Drule.cprems_of rule), mk_concl eq) val gen = (Names.empty, Names.make_set [#1 (dest_Free v)]) in (Drule.instantiate_normalize inst rule OF [Drule.generalize gen eq]) |> Drule.zero_var_indexes end (* Destruct the abstraction and apply the conversion. *) val ((v, ct'), ctxt') = Variable.dest_abs_cterm ct ctxt val eq = cv (v, ctxt') ct' in if Thm.is_reflexive eq then all_cconv ct else abstract_rule (Thm.term_of v) eq end | _ => raise CTERM ("abs_cconv", [ct])) val arg1_cconv = fun_cconv o arg_cconv val fun2_cconv = fun_cconv o fun_cconv (* conversions on HHF rules *) (*rewrite B in \x1 ... xn. B*) fun params_cconv n cv ctxt ct = if n <> 0 andalso Logic.is_all (Thm.term_of ct) then arg_cconv (abs_cconv (params_cconv (n - 1) cv o #2) ctxt) ct else cv ctxt ct (* FIXME: This code behaves not exactly like Conv.prems_cconv does. *) (*rewrite the A's in A1 \ ... \ An \ B*) fun prems_cconv 0 cv ct = cv ct | prems_cconv n cv ct = (case ct |> Thm.term_of of (Const (\<^const_name>\Pure.imp\, _) $ _) $ _ => ((if n = 1 then fun_cconv else I) o arg_cconv) (prems_cconv (n-1) cv) ct | _ => cv ct) fun inst_imp_cong ct = Thm.instantiate (TVars.empty, Vars.make [(\<^var>\?A::prop\, ct)]) Drule.imp_cong (*rewrite B in A1 \ ... \ An \ B*) fun concl_cconv 0 cv ct = cv ct | concl_cconv n cv ct = (case try Thm.dest_implies ct of NONE => cv ct | SOME (A,B) => (concl_cconv (n-1) cv B) RS inst_imp_cong A) (* Rewrites A in A \ A1 \ An \ B. The premises of the resulting theorem assume A1, ..., An *) fun with_prems_cconv n cv ct = let fun strip_prems 0 As B = (As, B) | strip_prems i As B = case try Thm.dest_implies B of NONE => (As, B) | SOME (A,B) => strip_prems (i - 1) (A::As) B val (prem, (prems, concl)) = ct |> Thm.dest_implies ||> strip_prems n [] val rewr_imp_concl = Thm.instantiate (TVars.empty, Vars.make [(\<^var>\?C::prop\, concl)]) @{thm rewr_imp} val th1 = cv prem RS rewr_imp_concl val nprems = Thm.nprems_of th1 fun inst_cut_rl ct = Thm.instantiate (TVars.empty, Vars.make [(\<^var>\?psi::prop\, ct)]) cut_rl fun f p th = (th RS inst_cut_rl p) |> Conv.fconv_rule (Conv.concl_conv nprems (Conv.rewr_conv @{thm imp_cong_eq})) in fold f prems th1 end (*forward conversion, cf. FCONV_RULE in LCF*) fun fconv_rule cv th = let val eq = cv (Thm.cprop_of th) in if Thm.is_reflexive eq then th else th COMP (Thm.permute_prems 0 (Thm.nprems_of eq) (eq RS Drule.equal_elim_rule1)) end (*goal conversion*) fun gconv_rule cv i th = (case try (Thm.cprem_of th) i of SOME ct => let val eq = cv ct (* Drule.with_subgoal assumes that there are no new premises generated and thus rotates the premises wrongly. *) fun with_subgoal i f thm = let val num_prems = Thm.nprems_of thm val rotate_to_front = rotate_prems (i - 1) fun rotate_back thm = rotate_prems (1 - i + num_prems - Thm.nprems_of thm) thm in thm |> rotate_to_front |> f |> rotate_back end in if Thm.is_reflexive eq then th else with_subgoal i (fconv_rule (arg1_cconv (K eq))) th end | NONE => raise THM ("gconv_rule", i, [th])) (* Conditional conversions as tactics. *) fun CCONVERSION cv i st = Seq.single (gconv_rule cv i st) handle THM _ => Seq.empty | CTERM _ => Seq.empty | TERM _ => Seq.empty | TYPE _ => Seq.empty end structure Basic_CConv: BASIC_CCONV = CConv open Basic_CConv diff --git a/src/HOL/Library/conditional_parametricity.ML b/src/HOL/Library/conditional_parametricity.ML --- a/src/HOL/Library/conditional_parametricity.ML +++ b/src/HOL/Library/conditional_parametricity.ML @@ -1,519 +1,520 @@ (* Title: HOL/Library/conditional_parametricity.ML Author: Jan Gilcher, Andreas Lochbihler, Dmitriy Traytel, ETH Zürich A conditional parametricity prover *) signature CONDITIONAL_PARAMETRICITY = sig exception WARNING of string type settings = {suppress_print_theorem: bool, suppress_warnings: bool, warnings_as_errors: bool, use_equality_heuristic: bool} val default_settings: settings val quiet_settings: settings val parametric_constant: settings -> Attrib.binding * thm -> Proof.context -> (thm * Proof.context) val get_parametricity_theorems: Proof.context -> thm list val prove_goal: settings -> Proof.context -> thm option -> term -> thm val prove_find_goal_cond: settings -> Proof.context -> thm list -> thm option -> term -> thm val mk_goal: Proof.context -> term -> term val mk_cond_goal: Proof.context -> thm -> term * thm val mk_param_goal_from_eq_def: Proof.context -> thm -> term val step_tac: settings -> Proof.context -> thm list -> int -> tactic end structure Conditional_Parametricity: CONDITIONAL_PARAMETRICITY = struct type settings = {suppress_print_theorem: bool, suppress_warnings: bool, warnings_as_errors: bool (* overrides suppress_warnings! *), use_equality_heuristic: bool}; val quiet_settings = {suppress_print_theorem = true, suppress_warnings = true, warnings_as_errors = false, use_equality_heuristic = false}; val default_settings = {suppress_print_theorem = false, suppress_warnings = false, warnings_as_errors = false, use_equality_heuristic = false}; (* helper functions *) fun strip_imp_prems_concl (Const("Pure.imp", _) $ A $ B) = A :: strip_imp_prems_concl B | strip_imp_prems_concl C = [C]; fun strip_prop_safe t = Logic.unprotect t handle TERM _ => t; fun get_class_of ctxt t = Axclass.class_of_param (Proof_Context.theory_of ctxt) (fst (dest_Const t)); fun is_class_op ctxt t = let val t' = t |> Envir.eta_contract; in Term.is_Const t' andalso is_some (get_class_of ctxt t') end; fun apply_Var_to_bounds t = let val (t, ts) = strip_comb t; in (case t of Var (xi, _) => let val (bounds, tail) = chop_prefix is_Bound ts; in list_comb (Var (xi, fastype_of (betapplys (t, bounds))), map apply_Var_to_bounds tail) end | _ => list_comb (t, map apply_Var_to_bounds ts)) end; fun theorem_format_error ctxt thm = let val msg = Pretty.string_of (Pretty.chunks [(Pretty.para "Unexpected format of definition. Must be an unconditional equation."), Thm.pretty_thm ctxt thm]); in error msg end; (* Tacticals and Tactics *) exception FINISH of thm; (* Tacticals *) fun REPEAT_TRY_ELSE_DEFER tac st = let fun COMB' tac count st = ( let val n = Thm.nprems_of st; in (if n = 0 then all_tac st else (case Seq.pull ((tac THEN COMB' tac 0) st) of NONE => if count+1 = n then raise FINISH st else (defer_tac 1 THEN (COMB' tac (count+1))) st | some => Seq.make (fn () => some))) end) in COMB' tac 0 st end; (* Tactics *) (* helper tactics for printing *) fun error_tac ctxt msg st = (error(msg ^ "\n" ^ Pretty.string_of (Pretty.chunks (Goal_Display.pretty_goals ctxt st))); Seq.single st); fun error_tac' ctxt msg = SELECT_GOAL (error_tac ctxt msg); (* finds assumption of the form "Rel ?B Bound x Bound y", rotates it in front, applies rel_app arity times and uses ams_rl *) fun rel_app_tac ctxt t x y arity = let val rel_app = [@{thm Rel_app}]; val assume = [asm_rl]; fun find_and_rotate_tac t i = let fun is_correct_rule t = (case t of Const (\<^const_name>\HOL.Trueprop\, _) $ (Const (\<^const_name>\Transfer.Rel\, _) $ _ $ Bound x' $ Bound y') => x = x' andalso y = y' | _ => false); val idx = find_index is_correct_rule (t |> Logic.strip_assums_hyp); in if idx < 0 then no_tac else rotate_tac idx i end; fun rotate_and_dresolve_tac ctxt arity i = REPEAT_DETERM_N (arity - 1) (EVERY' [rotate_tac ~1, dresolve_tac ctxt rel_app, defer_tac] i); in SELECT_GOAL (EVERY' [find_and_rotate_tac t, forward_tac ctxt rel_app, defer_tac, rotate_and_dresolve_tac ctxt arity, rotate_tac ~1, eresolve_tac ctxt assume] 1) end; exception WARNING of string; fun transform_rules 0 thms = thms | transform_rules n thms = transform_rules (n - 1) (curry (Drule.RL o swap) @{thms Rel_app Rel_match_app} thms); fun assume_equality_tac settings ctxt t arity i st = let val quiet = #suppress_warnings settings; val errors = #warnings_as_errors settings; val T = fastype_of t; val is_eq_lemma = @{thm is_equality_Rel} |> Thm.incr_indexes ((Term.maxidx_of_term t) + 1) |> Drule.infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt t)]; val msg = Pretty.string_of (Pretty.chunks [Pretty.paragraph ((Pretty.text "No rule found for constant \"") @ [Syntax.pretty_term ctxt t, Pretty.str " :: " , Syntax.pretty_typ ctxt T] @ (Pretty.text "\". Using is_eq_lemma:")), Pretty.quote (Thm.pretty_thm ctxt is_eq_lemma)]); fun msg_tac st = (if errors then raise WARNING msg else if quiet then () else warning msg; Seq.single st) val tac = resolve_tac ctxt (transform_rules arity [is_eq_lemma]) i; in (if fold_atyps (K (K true)) T false then msg_tac THEN tac else tac) st end; fun mark_class_as_match_tac ctxt const const' arity = let val rules = transform_rules arity [@{thm Rel_match_Rel} |> Thm.incr_indexes ((Int.max o apply2 Term.maxidx_of_term) (const, const') + 1) |> Drule.infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt const), SOME (Thm.cterm_of ctxt const')]]; in resolve_tac ctxt rules end; (* transforms the parametricity theorems to fit a given arity and uses them for resolution *) fun parametricity_thm_tac settings ctxt parametricity_thms const arity = let val rules = transform_rules arity parametricity_thms; in resolve_tac ctxt rules ORELSE' assume_equality_tac settings ctxt const arity end; (* variant of parametricity_thm_tac to use matching *) fun parametricity_thm_match_tac ctxt parametricity_thms arity = let val rules = transform_rules arity parametricity_thms; in match_tac ctxt rules end; fun rel_abs_tac ctxt = resolve_tac ctxt [@{thm Rel_abs}]; fun step_tac' settings ctxt parametricity_thms (tm, i) = (case tm |> Logic.strip_assums_concl of Const (\<^const_name>\HOL.Trueprop\, _) $ (Const (rel, _) $ _ $ t $ u) => let val (arity_of_t, arity_of_u) = apply2 (strip_comb #> snd #> length) (t, u); in (case rel of \<^const_name>\Transfer.Rel\ => (case (head_of t, head_of u) of (Abs _, _) => rel_abs_tac ctxt | (_, Abs _) => rel_abs_tac ctxt | (const as (Const _), const' as (Const _)) => if #use_equality_heuristic settings andalso t aconv u then assume_equality_tac quiet_settings ctxt t 0 else if arity_of_t = arity_of_u then if is_class_op ctxt const orelse is_class_op ctxt const' then mark_class_as_match_tac ctxt const const' arity_of_t else parametricity_thm_tac settings ctxt parametricity_thms const arity_of_t else error_tac' ctxt "Malformed term. Arities of t and u don't match." | (Bound x, Bound y) => if arity_of_t = arity_of_u then if arity_of_t > 0 then rel_app_tac ctxt tm x y arity_of_t else assume_tac ctxt else error_tac' ctxt "Malformed term. Arities of t and u don't match." | _ => error_tac' ctxt "Unexpected format. Expected (Abs _, _), (_, Abs _), (Const _, Const _) or (Bound _, Bound _).") | \<^const_name>\Conditional_Parametricity.Rel_match\ => parametricity_thm_match_tac ctxt parametricity_thms arity_of_t | _ => error_tac' ctxt "Unexpected format. Expected Transfer.Rel or Rel_match marker." ) i end | Const (\<^const_name>\HOL.Trueprop\, _) $ (Const (\<^const_name>\Transfer.is_equality\, _) $ _) => Transfer.eq_tac ctxt i | _ => error_tac' ctxt "Unexpected format. Not of form Const (HOL.Trueprop, _) $ _" i); fun step_tac settings = SUBGOAL oo step_tac' settings; fun apply_theorem_tac ctxt thm = HEADGOAL (resolve_tac ctxt [Local_Defs.unfold ctxt @{thms Pure.prop_def} thm] THEN_ALL_NEW assume_tac ctxt); (* Goal Generation *) fun strip_boundvars_from_rel_match t = (case t of (Tp as Const (\<^const_name>\HOL.Trueprop\, _)) $ ((Rm as Const (\<^const_name>\Conditional_Parametricity.Rel_match\, _)) $ R $ t $ t') => Tp $ (Rm $ apply_Var_to_bounds R $ t $ t') | _ => t); val extract_conditions = let val filter_bounds = filter_out Term.is_open; val prem_to_conditions = map (map strip_boundvars_from_rel_match o strip_imp_prems_concl o strip_all_body); val remove_duplicates = distinct Term.aconv; in remove_duplicates o filter_bounds o flat o prem_to_conditions end; fun mk_goal ctxt t = let val ctxt = fold (Variable.declare_typ o snd) (Term.add_frees t []) ctxt; val t = singleton (Variable.polymorphic ctxt) t; val i = maxidx_of_term t + 1; fun tvar_to_tfree ((name, _), sort) = (name, sort); val tvars = Term.add_tvars t []; val new_frees = map TFree (Term.variant_frees t (map tvar_to_tfree tvars)); val u = subst_atomic_types ((map TVar tvars) ~~ new_frees) t; val T = fastype_of t; val U = fastype_of u; val R = [T,U] ---> \<^typ>\bool\ val r = Var (("R", 2 * i), R); val transfer_rel = Const (\<^const_name>\Transfer.Rel\, [R,T,U] ---> \<^typ>\bool\); in HOLogic.mk_Trueprop (transfer_rel $ r $ t $ u) end; fun mk_abs_helper T t = let val U = fastype_of t; fun mk_abs_helper' T U = if T = U then t else let val (T2, T1) = Term.dest_funT T; in Term.absdummy T2 (mk_abs_helper' T1 U) end; in mk_abs_helper' T U end; fun compare_ixs ((name, i):indexname, (name', i'):indexname) = if name < name' then LESS else if name > name' then GREATER else if i < i' then LESS else if i > i' then GREATER else EQUAL; fun mk_cond_goal ctxt thm = let val conclusion = (hd o strip_imp_prems_concl o strip_prop_safe o Thm.concl_of) thm; val conditions = (extract_conditions o Thm.prems_of) thm; val goal = Logic.list_implies (conditions, conclusion); fun compare ((ix, _), (ix', _)) = compare_ixs (ix, ix'); val goal_vars = Term.add_vars goal [] |> Ord_List.make compare; val (ixs, Ts) = split_list goal_vars; val (_, Ts') = Term.add_vars (Thm.prop_of thm) [] |> Ord_List.make compare |> Ord_List.inter compare goal_vars |> split_list; val (As, _) = Ctr_Sugar_Util.mk_Frees "A" Ts ctxt; val goal_subst = ixs ~~ As; val thm_subst = ixs ~~ (map2 mk_abs_helper Ts' As); val thm' = thm |> Drule.infer_instantiate ctxt (map (apsnd (Thm.cterm_of ctxt)) thm_subst); in (goal |> Term.subst_Vars goal_subst, thm') end; fun mk_param_goal_from_eq_def ctxt thm = let val t = (case Thm.full_prop_of thm of (Const (\<^const_name>\Pure.eq\, _) $ t' $ _) => t' | _ => theorem_format_error ctxt thm); in mk_goal ctxt t end; (* Transformations and parametricity theorems *) fun transform_class_rule ctxt thm = (case Thm.concl_of thm of Const (\<^const_name>\HOL.Trueprop\, _) $ (Const (\<^const_name>\Transfer.Rel\, _) $ _ $ t $ u ) => (if curry Term.aconv_untyped t u andalso is_class_op ctxt t then thm RS @{thm Rel_Rel_match} else thm) | _ => thm); fun is_parametricity_theorem thm = (case Thm.concl_of thm of Const (\<^const_name>\HOL.Trueprop\, _) $ (Const (rel, _) $ _ $ t $ u ) => if rel = \<^const_name>\Transfer.Rel\ orelse rel = \<^const_name>\Conditional_Parametricity.Rel_match\ then curry Term.aconv_untyped t u else false | _ => false); (* Pre- and postprocessing of theorems *) fun mk_Domainp_assm (T, R) = HOLogic.mk_eq ((Const (\<^const_name>\Domainp\, Term.fastype_of T --> Term.fastype_of R) $ T), R); val Domainp_lemma = @{lemma "(!!R. Domainp T = R ==> PROP (P R)) == PROP (P (Domainp T))" by (rule, drule meta_spec, erule meta_mp, rule HOL.refl, simp)}; fun fold_Domainp f (t as Const (\<^const_name>\Domainp\,_) $ (Var (_,_))) = f t | fold_Domainp f (t $ u) = fold_Domainp f t #> fold_Domainp f u | fold_Domainp f (Abs (_, _, t)) = fold_Domainp f t | fold_Domainp _ _ = I; fun subst_terms tab t = let val t' = Termtab.lookup tab t in (case t' of SOME t' => t' | NONE => (case t of u $ v => (subst_terms tab u) $ (subst_terms tab v) | Abs (a, T, t) => Abs (a, T, subst_terms tab t) | t => t)) end; fun gen_abstract_domains ctxt (dest : term -> term * (term -> term)) thm = let val prop = Thm.prop_of thm val (t, mk_prop') = dest prop val Domainp_ts = rev (fold_Domainp (fn t => insert op= t) t []) val Domainp_Ts = map (snd o dest_funT o snd o dest_Const o fst o dest_comb) Domainp_ts val used = Term.add_free_names t [] val rels = map (snd o dest_comb) Domainp_ts val rel_names = map (fst o fst o dest_Var) rels val names = map (fn name => ("D" ^ name)) rel_names |> Name.variant_list used val frees = map Free (names ~~ Domainp_Ts) val prems = map (HOLogic.mk_Trueprop o mk_Domainp_assm) (rels ~~ frees); val t' = subst_terms (fold Termtab.update (Domainp_ts ~~ frees) Termtab.empty) t val prop1 = fold Logic.all frees (Logic.list_implies (prems, mk_prop' t')) val prop2 = Logic.list_rename_params (rev names) prop1 val cprop = Thm.cterm_of ctxt prop2 val equal_thm = Raw_Simplifier.rewrite ctxt false [Domainp_lemma] cprop fun forall_elim thm = Thm.forall_elim_vars (Thm.maxidx_of thm + 1) thm; in forall_elim (thm COMP (equal_thm COMP @{thm equal_elim_rule2})) end handle TERM _ => thm; fun abstract_domains_transfer ctxt thm = let fun dest prop = let val prems = Logic.strip_imp_prems prop val concl = HOLogic.dest_Trueprop (Logic.strip_imp_concl prop) val ((rel, x), y) = apfst Term.dest_comb (Term.dest_comb concl) in (x, fn x' => Logic.list_implies (prems, HOLogic.mk_Trueprop (rel $ x' $ y))) end in gen_abstract_domains ctxt dest thm end; fun transfer_rel_conv conv = Conv.concl_conv ~1 (HOLogic.Trueprop_conv (Conv.fun2_conv (Conv.arg_conv conv))); -fun fold_relator_eqs_conv ctxt ct = (Transfer.bottom_rewr_conv (Transfer.get_relator_eq ctxt)) ct; +fun fold_relator_eqs_conv ctxt = + Conv.bottom_rewrs_conv (Transfer.get_relator_eq ctxt) ctxt; fun mk_is_equality t = Const (\<^const_name>\is_equality\, Term.fastype_of t --> HOLogic.boolT) $ t; val is_equality_lemma = @{lemma "(!!R. is_equality R ==> PROP (P R)) == PROP (P (=))" by (unfold is_equality_def, rule, drule meta_spec, erule meta_mp, rule HOL.refl, simp)}; fun gen_abstract_equalities ctxt (dest : term -> term * (term -> term)) thm = let val prop = Thm.prop_of thm val (t, mk_prop') = dest prop (* Only consider "(=)" at non-base types *) fun is_eq (Const (\<^const_name>\HOL.eq\, Type ("fun", [T, _]))) = (case T of Type (_, []) => false | _ => true) | is_eq _ = false val add_eqs = Term.fold_aterms (fn t => if is_eq t then insert (op =) t else I) val eq_consts = rev (add_eqs t []) val eqTs = map (snd o dest_Const) eq_consts val used = Term.add_free_names prop [] val names = map (K "") eqTs |> Name.variant_list used val frees = map Free (names ~~ eqTs) val prems = map (HOLogic.mk_Trueprop o mk_is_equality) frees val prop1 = mk_prop' (Term.subst_atomic (eq_consts ~~ frees) t) val prop2 = fold Logic.all frees (Logic.list_implies (prems, prop1)) val cprop = Thm.cterm_of ctxt prop2 val equal_thm = Raw_Simplifier.rewrite ctxt false [is_equality_lemma] cprop fun forall_elim thm = Thm.forall_elim_vars (Thm.maxidx_of thm + 1) thm in forall_elim (thm COMP (equal_thm COMP @{thm equal_elim_rule2})) end handle TERM _ => thm; fun abstract_equalities_transfer ctxt thm = let fun dest prop = let val prems = Logic.strip_imp_prems prop val concl = HOLogic.dest_Trueprop (Logic.strip_imp_concl prop) val ((rel, x), y) = apfst Term.dest_comb (Term.dest_comb concl) in (rel, fn rel' => Logic.list_implies (prems, HOLogic.mk_Trueprop (rel' $ x $ y))) end val contracted_eq_thm = Conv.fconv_rule (transfer_rel_conv (fold_relator_eqs_conv ctxt)) thm handle CTERM _ => thm in gen_abstract_equalities ctxt dest contracted_eq_thm end; fun prep_rule ctxt = abstract_equalities_transfer ctxt #> abstract_domains_transfer ctxt; fun get_preprocess_theorems ctxt = Named_Theorems.get ctxt \<^named_theorems>\parametricity_preprocess\; fun preprocess_theorem ctxt = Local_Defs.unfold0 ctxt (get_preprocess_theorems ctxt) #> transform_class_rule ctxt; fun postprocess_theorem ctxt = Local_Defs.fold ctxt (@{thm Rel_Rel_match_eq} :: get_preprocess_theorems ctxt) #> prep_rule ctxt #> Local_Defs.unfold ctxt @{thms Rel_def}; fun get_parametricity_theorems ctxt = let val parametricity_thm_map_filter = Option.filter (is_parametricity_theorem andf (not o curry Term.could_unify (Thm.full_prop_of @{thm is_equality_Rel})) o Thm.full_prop_of) o preprocess_theorem ctxt; in map_filter (parametricity_thm_map_filter o Thm.transfer' ctxt) (Transfer.get_transfer_raw ctxt) end; (* Provers *) (* Tries to prove a parametricity theorem without conditions, returns the last goal_state as thm *) fun prove_find_goal_cond settings ctxt rules def_thm t = let fun find_conditions_tac {context = ctxt, prems = _} = unfold_tac ctxt (the_list def_thm) THEN (REPEAT_TRY_ELSE_DEFER o HEADGOAL) (step_tac settings ctxt rules); in Goal.prove ctxt [] [] t find_conditions_tac handle FINISH st => st end; (* Simplifies and proves thm *) fun prove_cond_goal ctxt thm = let val (goal, thm') = mk_cond_goal ctxt thm; val vars = Variable.add_free_names ctxt goal []; fun prove_conditions_tac {context = ctxt, prems = _} = apply_theorem_tac ctxt thm'; val vars = Variable.add_free_names ctxt (Thm.prop_of thm') vars; in Goal.prove ctxt vars [] goal prove_conditions_tac end; (* Finds necessary conditions for t and proofs conditional parametricity of t under those conditions *) fun prove_goal settings ctxt def_thm t = let val parametricity_thms = get_parametricity_theorems ctxt; val found_thm = prove_find_goal_cond settings ctxt parametricity_thms def_thm t; val thm = prove_cond_goal ctxt found_thm; in postprocess_theorem ctxt thm end; (* Commands *) fun gen_parametric_constant settings prep_att prep_thm (raw_b : Attrib.binding, raw_eq) lthy = let val b = apsnd (map (prep_att lthy)) raw_b; val def_thm = (prep_thm lthy raw_eq); val eq = Ctr_Sugar_Util.mk_abs_def def_thm handle TERM _ => theorem_format_error lthy def_thm; val goal= mk_param_goal_from_eq_def lthy eq; val thm = prove_goal settings lthy (SOME eq) goal; val (res, lthy') = Local_Theory.note (b, [thm]) lthy; val _ = if #suppress_print_theorem settings then () else Proof_Display.print_results true (Position.thread_data ()) lthy' (("theorem",""), [res]); in (the_single (snd res), lthy') end; fun parametric_constant settings = gen_parametric_constant settings (K I) (K I); val parametric_constant_cmd = snd oo gen_parametric_constant default_settings (Attrib.check_src) (singleton o Attrib.eval_thms); val _ = Outer_Syntax.local_theory \<^command_keyword>\parametric_constant\ "proves parametricity" ((Parse_Spec.opt_thm_name ":" -- Parse.thm) >> parametric_constant_cmd); end; diff --git a/src/HOL/Library/rewrite.ML b/src/HOL/Library/rewrite.ML --- a/src/HOL/Library/rewrite.ML +++ b/src/HOL/Library/rewrite.ML @@ -1,453 +1,453 @@ (* Title: HOL/Library/rewrite.ML Author: Christoph Traut, Lars Noschinski, TU Muenchen This is a rewrite method that supports subterm-selection based on patterns. The patterns accepted by rewrite are of the following form: ::= | "concl" | "asm" | "for" "(" ")" ::= (in | at ) [] ::= [] ("to" ) This syntax was clearly inspired by Gonthier's and Tassi's language of patterns but has diverged significantly during its development. We also allow introduction of identifiers for bound variables, which can then be used to match arbitrary subterms inside abstractions. *) infix 1 then_pconv; infix 0 else_pconv; signature REWRITE = sig type patconv = Proof.context -> Type.tyenv * (string * term) list -> cconv val then_pconv: patconv * patconv -> patconv val else_pconv: patconv * patconv -> patconv val abs_pconv: patconv -> string option * typ -> patconv (*XXX*) val fun_pconv: patconv -> patconv val arg_pconv: patconv -> patconv val imp_pconv: patconv -> patconv val params_pconv: patconv -> patconv val forall_pconv: patconv -> string option * typ option -> patconv val all_pconv: patconv val for_pconv: patconv -> (string option * typ option) list -> patconv val concl_pconv: patconv -> patconv val asm_pconv: patconv -> patconv val asms_pconv: patconv -> patconv val judgment_pconv: patconv -> patconv val in_pconv: patconv -> patconv val match_pconv: patconv -> term * (string option * typ) list -> patconv val rewrs_pconv: term option -> thm list -> patconv datatype ('a, 'b) pattern = At | In | Term of 'a | Concl | Asm | For of 'b list val mk_hole: int -> typ -> term val rewrite_conv: Proof.context -> (term * (string * typ) list, string * typ option) pattern list * term option -> thm list -> conv end structure Rewrite : REWRITE = struct datatype ('a, 'b) pattern = At | In | Term of 'a | Concl | Asm | For of 'b list exception NO_TO_MATCH val holeN = Name.internal "_hole" fun prep_meta_eq ctxt = Simplifier.mksimps ctxt #> map Drule.zero_var_indexes (* holes *) fun mk_hole i T = Var ((holeN, i), T) fun is_hole (Var ((name, _), _)) = (name = holeN) | is_hole _ = false fun is_hole_const (Const (\<^const_name>\rewrite_HOLE\, _)) = true | is_hole_const _ = false val hole_syntax = let (* Modified variant of Term.replace_hole *) fun replace_hole Ts (Const (\<^const_name>\rewrite_HOLE\, T)) i = (list_comb (mk_hole i (Ts ---> T), map_range Bound (length Ts)), i + 1) | replace_hole Ts (Abs (x, T, t)) i = let val (t', i') = replace_hole (T :: Ts) t i in (Abs (x, T, t'), i') end | replace_hole Ts (t $ u) i = let val (t', i') = replace_hole Ts t i val (u', i'') = replace_hole Ts u i' in (t' $ u', i'') end | replace_hole _ a i = (a, i) fun prep_holes ts = #1 (fold_map (replace_hole []) ts 1) in Context.proof_map (Syntax_Phases.term_check 101 "hole_expansion" (K prep_holes)) #> Proof_Context.set_mode Proof_Context.mode_pattern end (* pattern conversions *) type patconv = Proof.context -> Type.tyenv * (string * term) list -> cterm -> thm fun (cv1 then_pconv cv2) ctxt tytenv ct = (cv1 ctxt tytenv then_conv cv2 ctxt tytenv) ct fun (cv1 else_pconv cv2) ctxt tytenv ct = (cv1 ctxt tytenv else_conv cv2 ctxt tytenv) ct fun raw_abs_pconv cv ctxt tytenv ct = case Thm.term_of ct of Abs _ => CConv.abs_cconv (fn (x, ctxt') => cv x ctxt' tytenv) ctxt ct | t => raise TERM ("raw_abs_pconv", [t]) fun raw_fun_pconv cv ctxt tytenv ct = case Thm.term_of ct of _ $ _ => CConv.fun_cconv (cv ctxt tytenv) ct | t => raise TERM ("raw_fun_pconv", [t]) fun raw_arg_pconv cv ctxt tytenv ct = case Thm.term_of ct of _ $ _ => CConv.arg_cconv (cv ctxt tytenv) ct | t => raise TERM ("raw_arg_pconv", [t]) fun abs_pconv cv (s,T) ctxt (tyenv, ts) ct = let val u = Thm.term_of ct in case try (fastype_of #> dest_funT) u of NONE => raise TERM ("abs_pconv: no function type", [u]) | SOME (U, _) => let val tyenv' = if T = dummyT then tyenv else Sign.typ_match (Proof_Context.theory_of ctxt) (T, U) tyenv val eta_expand_cconv = case u of Abs _=> Thm.reflexive | _ => CConv.rewr_cconv @{thm eta_expand} fun add_ident NONE _ l = l | add_ident (SOME name) ct l = (name, Thm.term_of ct) :: l val abs_cv = CConv.abs_cconv (fn (ct, ctxt) => cv ctxt (tyenv', add_ident s ct ts)) ctxt in (eta_expand_cconv then_conv abs_cv) ct end handle Pattern.MATCH => raise TYPE ("abs_pconv: types don't match", [T,U], [u]) end fun fun_pconv cv ctxt tytenv ct = case Thm.term_of ct of _ $ _ => CConv.fun_cconv (cv ctxt tytenv) ct | Abs (_, T, _ $ Bound 0) => abs_pconv (fun_pconv cv) (NONE, T) ctxt tytenv ct | t => raise TERM ("fun_pconv", [t]) local fun arg_pconv_gen cv0 cv ctxt tytenv ct = case Thm.term_of ct of _ $ _ => cv0 (cv ctxt tytenv) ct | Abs (_, T, _ $ Bound 0) => abs_pconv (arg_pconv_gen cv0 cv) (NONE, T) ctxt tytenv ct | t => raise TERM ("arg_pconv_gen", [t]) in fun arg_pconv ctxt = arg_pconv_gen CConv.arg_cconv ctxt fun imp_pconv ctxt = arg_pconv_gen (CConv.concl_cconv 1) ctxt end (* Move to B in !!x_1 ... x_n. B. Do not eta-expand *) fun params_pconv cv ctxt tytenv ct = let val pconv = case Thm.term_of ct of Const (\<^const_name>\Pure.all\, _) $ Abs _ => (raw_arg_pconv o raw_abs_pconv) (fn _ => params_pconv cv) | Const (\<^const_name>\Pure.all\, _) => raw_arg_pconv (params_pconv cv) | _ => cv in pconv ctxt tytenv ct end fun forall_pconv cv ident ctxt tytenv ct = case Thm.term_of ct of Const (\<^const_name>\Pure.all\, T) $ _ => let val def_U = T |> dest_funT |> fst |> dest_funT |> fst val ident' = apsnd (the_default (def_U)) ident in arg_pconv (abs_pconv cv ident') ctxt tytenv ct end | t => raise TERM ("forall_pconv", [t]) fun all_pconv _ _ = Thm.reflexive fun for_pconv cv idents ctxt tytenv ct = let fun f rev_idents (Const (\<^const_name>\Pure.all\, _) $ t) = let val (rev_idents', cv') = f rev_idents (case t of Abs (_,_,u) => u | _ => t) in case rev_idents' of [] => ([], forall_pconv cv' (NONE, NONE)) | (x :: xs) => (xs, forall_pconv cv' x) end | f rev_idents _ = (rev_idents, cv) in case f (rev idents) (Thm.term_of ct) of ([], cv') => cv' ctxt tytenv ct | _ => raise CTERM ("for_pconv", [ct]) end fun concl_pconv cv ctxt tytenv ct = case Thm.term_of ct of (Const (\<^const_name>\Pure.imp\, _) $ _) $ _ => imp_pconv (concl_pconv cv) ctxt tytenv ct | _ => cv ctxt tytenv ct fun asm_pconv cv ctxt tytenv ct = case Thm.term_of ct of (Const (\<^const_name>\Pure.imp\, _) $ _) $ _ => CConv.with_prems_cconv ~1 (cv ctxt tytenv) ct | t => raise TERM ("asm_pconv", [t]) fun asms_pconv cv ctxt tytenv ct = case Thm.term_of ct of (Const (\<^const_name>\Pure.imp\, _) $ _) $ _ => ((CConv.with_prems_cconv ~1 oo cv) else_pconv imp_pconv (asms_pconv cv)) ctxt tytenv ct | t => raise TERM ("asms_pconv", [t]) fun judgment_pconv cv ctxt tytenv ct = if Object_Logic.is_judgment ctxt (Thm.term_of ct) then arg_pconv cv ctxt tytenv ct else cv ctxt tytenv ct fun in_pconv cv ctxt tytenv ct = (cv else_pconv raw_fun_pconv (in_pconv cv) else_pconv raw_arg_pconv (in_pconv cv) else_pconv raw_abs_pconv (fn _ => in_pconv cv)) ctxt tytenv ct fun replace_idents idents t = let fun subst ((n1, s)::ss) (t as Free (n2, _)) = if n1 = n2 then s else subst ss t | subst _ t = t in Term.map_aterms (subst idents) t end fun match_pconv cv (t,fixes) ctxt (tyenv, env_ts) ct = let val t' = replace_idents env_ts t val thy = Proof_Context.theory_of ctxt val u = Thm.term_of ct fun descend_hole fixes (Abs (_, _, t)) = (case descend_hole fixes t of NONE => NONE | SOME (fix :: fixes', pos) => SOME (fixes', abs_pconv pos fix) | SOME ([], _) => raise Match (* less fixes than abstractions on path to hole *)) | descend_hole fixes (t as l $ r) = let val (f, _) = strip_comb t in if is_hole f then SOME (fixes, cv) else (case descend_hole fixes l of SOME (fixes', pos) => SOME (fixes', fun_pconv pos) | NONE => (case descend_hole fixes r of SOME (fixes', pos) => SOME (fixes', arg_pconv pos) | NONE => NONE)) end | descend_hole fixes t = if is_hole t then SOME (fixes, cv) else NONE val to_hole = descend_hole (rev fixes) #> the_default ([], cv) #> snd in case try (Pattern.match thy (apply2 Logic.mk_term (t',u))) (tyenv, Vartab.empty) of NONE => raise TERM ("match_pconv: Does not match pattern", [t, t',u]) | SOME (tyenv', _) => to_hole t ctxt (tyenv', env_ts) ct end fun rewrs_pconv to thms ctxt (tyenv, env_ts) = let - fun instantiate_normalize_env ctxt env thm = + fun instantiate_normalize_env env thm = let val prop = Thm.prop_of thm val norm_type = Envir.norm_type o Envir.type_env val insts = Term.add_vars prop [] |> map (fn x as (s, T) => ((s, norm_type env T), Thm.cterm_of ctxt (Envir.norm_term env (Var x)))) val tyinsts = Term.add_tvars prop [] |> map (fn x => (x, Thm.ctyp_of ctxt (norm_type env (TVar x)))) in Drule.instantiate_normalize (TVars.make tyinsts, Vars.make insts) thm end - fun unify_with_rhs context to env thm = + fun unify_with_rhs to env thm = let val (_, rhs) = thm |> Thm.concl_of |> Logic.dest_equals - val env' = Pattern.unify context (Logic.mk_term to, Logic.mk_term rhs) env + val env' = Pattern.unify (Context.Proof ctxt) (Logic.mk_term to, Logic.mk_term rhs) env handle Pattern.Unif => raise NO_TO_MATCH in env' end - fun inst_thm_to _ (NONE, _) thm = thm - | inst_thm_to (ctxt : Proof.context) (SOME to, env) thm = - instantiate_normalize_env ctxt (unify_with_rhs (Context.Proof ctxt) to env thm) thm + fun inst_thm_to (NONE, _) thm = thm + | inst_thm_to (SOME to, env) thm = + instantiate_normalize_env (unify_with_rhs to env thm) thm - fun inst_thm ctxt idents (to, tyenv) thm = + fun inst_thm idents (to, tyenv) thm = let (* Replace any identifiers with their corresponding bound variables. *) val maxidx = Term.maxidx_typs (map (snd o snd) (Vartab.dest tyenv)) 0 val env = Envir.Envir {maxidx = maxidx, tenv = Vartab.empty, tyenv = tyenv} val maxidx = Envir.maxidx_of env |> fold Term.maxidx_term (the_list to) val thm' = Thm.incr_indexes (maxidx + 1) thm - in SOME (inst_thm_to ctxt (Option.map (replace_idents idents) to, env) thm') end + in SOME (inst_thm_to (Option.map (replace_idents idents) to, env) thm') end handle NO_TO_MATCH => NONE - in CConv.rewrs_cconv (map_filter (inst_thm ctxt env_ts (to, tyenv)) thms) end + in CConv.rewrs_cconv (map_filter (inst_thm env_ts (to, tyenv)) thms) end fun rewrite_conv ctxt (pattern, to) thms ct = let fun apply_pat At = judgment_pconv | apply_pat In = in_pconv | apply_pat Asm = params_pconv o asms_pconv | apply_pat Concl = params_pconv o concl_pconv | apply_pat (For idents) = (fn cv => for_pconv cv (map (apfst SOME) idents)) | apply_pat (Term x) = (fn cv => match_pconv cv (apsnd (map (apfst SOME)) x)) val cv = fold_rev apply_pat pattern fun distinct_prems th = case Seq.pull (distinct_subgoals_tac th) of NONE => th | SOME (th', _) => th' val rewrite = rewrs_pconv to (maps (prep_meta_eq ctxt) thms) in cv rewrite ctxt (Vartab.empty, []) ct |> distinct_prems end fun rewrite_export_tac ctxt (pat, pat_ctxt) thms = let val export = case pat_ctxt of NONE => I - | SOME inner => singleton (Proof_Context.export inner ctxt) + | SOME ctxt' => singleton (Proof_Context.export ctxt' ctxt) in CCONVERSION (export o rewrite_conv ctxt pat thms) end val _ = Theory.setup let fun mk_fix s = (Binding.name s, NONE, NoSyn) val raw_pattern : (string, binding * string option * mixfix) pattern list parser = let val sep = (Args.$$$ "at" >> K At) || (Args.$$$ "in" >> K In) val atom = (Args.$$$ "asm" >> K Asm) || (Args.$$$ "concl" >> K Concl) || (Args.$$$ "for" |-- Args.parens (Scan.optional Parse.vars []) >> For) || (Parse.term >> Term) val sep_atom = sep -- atom >> (fn (s,a) => [s,a]) fun append_default [] = [Concl, In] | append_default (ps as Term _ :: _) = Concl :: In :: ps | append_default [For x, In] = [For x, Concl, In] | append_default (For x :: (ps as In :: Term _:: _)) = For x :: Concl :: ps | append_default ps = ps in Scan.repeats sep_atom >> (rev #> append_default) end fun context_lift (scan : 'a parser) f = fn (context : Context.generic, toks) => let val (r, toks') = scan toks val (r', context') = Context.map_proof_result (fn ctxt => f ctxt r) context - in (r', (context', toks' : Token.T list)) end + in (r', (context', toks')) end fun read_fixes fixes ctxt = let fun read_typ (b, rawT, mx) = (b, Option.map (Syntax.read_typ ctxt) rawT, mx) in Proof_Context.add_fixes (map read_typ fixes) ctxt end fun prep_pats ctxt (ps : (string, binding * string option * mixfix) pattern list) = let fun add_constrs ctxt n (Abs (x, T, t)) = let val (x', ctxt') = yield_singleton Proof_Context.add_fixes (mk_fix x) ctxt in (case add_constrs ctxt' (n+1) t of NONE => NONE | SOME ((ctxt'', n', xs), t') => let val U = Type_Infer.mk_param n [] val u = Type.constraint (U --> dummyT) (Abs (x, T, t')) in SOME ((ctxt'', n', (x', U) :: xs), u) end) end | add_constrs ctxt n (l $ r) = (case add_constrs ctxt n l of SOME (c, l') => SOME (c, l' $ r) | NONE => (case add_constrs ctxt n r of SOME (c, r') => SOME (c, l $ r') | NONE => NONE)) | add_constrs ctxt n t = if is_hole_const t then SOME ((ctxt, n, []), t) else NONE fun prep (Term s) (n, ctxt) = let val t = Syntax.parse_term ctxt s val ((ctxt', n', bs), t') = the_default ((ctxt, n, []), t) (add_constrs ctxt (n+1) t) in (Term (t', bs), (n', ctxt')) end | prep (For ss) (n, ctxt) = let val (ns, ctxt') = read_fixes ss ctxt in (For ns, (n, ctxt')) end | prep At (n,ctxt) = (At, (n, ctxt)) | prep In (n,ctxt) = (In, (n, ctxt)) | prep Concl (n,ctxt) = (Concl, (n, ctxt)) | prep Asm (n,ctxt) = (Asm, (n, ctxt)) val (xs, (_, ctxt')) = fold_map prep ps (0, ctxt) in (xs, ctxt') end fun prep_args ctxt (((raw_pats, raw_to), raw_ths)) = let fun check_terms ctxt ps to = let fun safe_chop (0: int) xs = ([], xs) | safe_chop n (x :: xs) = chop (n - 1) xs |>> cons x | safe_chop _ _ = raise Match fun reinsert_pat _ (Term (_, cs)) (t :: ts) = let val (cs', ts') = safe_chop (length cs) ts in (Term (t, map dest_Free cs'), ts') end | reinsert_pat _ (Term _) [] = raise Match | reinsert_pat ctxt (For ss) ts = let val fixes = map (fn s => (s, Variable.default_type ctxt s)) ss in (For fixes, ts) end | reinsert_pat _ At ts = (At, ts) | reinsert_pat _ In ts = (In, ts) | reinsert_pat _ Concl ts = (Concl, ts) | reinsert_pat _ Asm ts = (Asm, ts) fun free_constr (s,T) = Type.constraint T (Free (s, dummyT)) fun mk_free_constrs (Term (t, cs)) = t :: map free_constr cs | mk_free_constrs _ = [] val ts = maps mk_free_constrs ps @ the_list to |> Syntax.check_terms (hole_syntax ctxt) val ctxt' = fold Variable.declare_term ts ctxt val (ps', (to', ts')) = fold_map (reinsert_pat ctxt') ps ts ||> (fn xs => case to of NONE => (NONE, xs) | SOME _ => (SOME (hd xs), tl xs)) val _ = case ts' of (_ :: _) => raise Match | [] => () in ((ps', to'), ctxt') end val (pats, ctxt') = prep_pats ctxt raw_pats val ths = Attrib.eval_thms ctxt' raw_ths val to = Option.map (Syntax.parse_term ctxt') raw_to val ((pats', to'), ctxt'') = check_terms ctxt' pats to in ((pats', ths, (to', ctxt)), ctxt'') end val to_parser = Scan.option ((Args.$$$ "to") |-- Parse.term) val subst_parser = let val scan = raw_pattern -- to_parser -- Parse.thms1 in context_lift scan prep_args end in Method.setup \<^binding>\rewrite\ (subst_parser >> (fn (pattern, inthms, (to, pat_ctxt)) => fn orig_ctxt => SIMPLE_METHOD' (rewrite_export_tac orig_ctxt ((pattern, to), SOME pat_ctxt) inthms))) - "single-step rewriting, allowing subterm selection via patterns." + "single-step rewriting, allowing subterm selection via patterns" end end diff --git a/src/HOL/Tools/BNF/bnf_def_tactics.ML b/src/HOL/Tools/BNF/bnf_def_tactics.ML --- a/src/HOL/Tools/BNF/bnf_def_tactics.ML +++ b/src/HOL/Tools/BNF/bnf_def_tactics.ML @@ -1,414 +1,414 @@ (* Title: HOL/Tools/BNF/bnf_def_tactics.ML Author: Dmitriy Traytel, TU Muenchen Author: Jasmin Blanchette, TU Muenchen Author: Martin Desharnais, TU Muenchen Author: Ondrej Kuncar, TU Muenchen Copyright 2012, 2013, 2014, 2015 Tactics for definition of bounded natural functors. *) signature BNF_DEF_TACTICS = sig val mk_collect_set_map_tac: Proof.context -> thm list -> tactic val mk_in_mono_tac: Proof.context -> int -> tactic val mk_inj_map_strong_tac: Proof.context -> thm -> thm list -> thm -> tactic val mk_inj_map_tac: Proof.context -> int -> thm -> thm -> thm -> thm -> tactic val mk_map_id: thm -> thm val mk_map_ident: Proof.context -> thm -> thm val mk_map_comp: thm -> thm val mk_map_cong_tac: Proof.context -> thm -> tactic val mk_set_map: thm -> thm val mk_rel_Grp_tac: Proof.context -> thm list -> thm -> thm -> thm -> thm -> thm list -> tactic val mk_rel_eq_tac: Proof.context -> int -> thm -> thm -> thm -> tactic val mk_rel_OO_le_tac: Proof.context -> thm list -> thm -> thm -> thm -> thm list -> tactic val mk_rel_conversep_tac: Proof.context -> thm -> thm -> tactic val mk_rel_conversep_le_tac: Proof.context -> thm list -> thm -> thm -> thm -> thm list -> tactic val mk_rel_map0_tac: Proof.context -> int -> thm -> thm -> thm -> thm -> tactic val mk_rel_mono_tac: Proof.context -> thm list -> thm -> tactic val mk_rel_mono_strong0_tac: Proof.context -> thm -> thm list -> tactic val mk_rel_cong_tac: Proof.context -> thm list * thm list -> thm -> tactic val mk_rel_eq_onp_tac: Proof.context -> thm -> thm -> thm -> tactic val mk_pred_mono_strong0_tac: Proof.context -> thm -> thm -> tactic val mk_pred_mono_tac: Proof.context -> thm -> thm -> tactic val mk_map_transfer_tac: Proof.context -> thm -> thm -> thm list -> thm -> thm -> tactic val mk_pred_transfer_tac: Proof.context -> int -> thm -> thm -> thm -> tactic val mk_rel_transfer_tac: Proof.context -> thm -> thm list -> thm -> tactic val mk_set_transfer_tac: Proof.context -> thm -> thm list -> tactic val mk_in_bd_tac: Proof.context -> int -> thm -> thm -> thm -> thm -> thm list -> thm list -> thm -> thm -> thm -> thm -> tactic val mk_trivial_wit_tac: Proof.context -> thm list -> thm list -> tactic end; structure BNF_Def_Tactics : BNF_DEF_TACTICS = struct open BNF_Util open BNF_Tactics val ord_eq_le_trans = @{thm ord_eq_le_trans}; val ord_le_eq_trans = @{thm ord_le_eq_trans}; val conversep_shift = @{thm conversep_le_swap} RS iffD1; fun mk_map_id id = mk_trans (fun_cong OF [id]) @{thm id_apply}; fun mk_map_ident ctxt = unfold_thms ctxt @{thms id_def}; fun mk_map_comp comp = @{thm comp_eq_dest_lhs} OF [mk_sym comp]; fun mk_map_cong_tac ctxt cong0 = (hyp_subst_tac ctxt THEN' rtac ctxt cong0 THEN' REPEAT_DETERM o (dtac ctxt meta_spec THEN' etac ctxt meta_mp THEN' assume_tac ctxt)) 1; fun mk_set_map set_map0 = set_map0 RS @{thm comp_eq_dest}; fun mk_in_mono_tac ctxt n = if n = 0 then rtac ctxt subset_UNIV 1 else (rtac ctxt @{thm subsetI} THEN' rtac ctxt @{thm CollectI}) 1 THEN REPEAT_DETERM (eresolve_tac ctxt @{thms CollectE conjE} 1) THEN REPEAT_DETERM_N (n - 1) ((rtac ctxt conjI THEN' etac ctxt @{thm subset_trans} THEN' assume_tac ctxt) 1) THEN (etac ctxt @{thm subset_trans} THEN' assume_tac ctxt) 1; fun mk_inj_map_tac ctxt n map_id map_comp map_cong0 map_cong = let val map_cong' = map_cong OF (asm_rl :: replicate n refl); val map_cong0' = map_cong0 OF (replicate n @{thm the_inv_f_o_f_id}); in HEADGOAL (rtac ctxt @{thm injI} THEN' etac ctxt (map_cong' RS box_equals) THEN' REPEAT_DETERM_N 2 o (rtac ctxt (box_equals OF [map_cong0', map_comp RS sym, map_id]) THEN' REPEAT_DETERM_N n o assume_tac ctxt)) end; fun mk_inj_map_strong_tac ctxt rel_eq rel_maps rel_mono_strong = let val rel_eq' = rel_eq RS @{thm predicate2_eqD}; val rel_maps' = map (fn thm => thm RS iffD1) rel_maps; in HEADGOAL (dtac ctxt (rel_eq' RS iffD2) THEN' rtac ctxt (rel_eq' RS iffD1)) THEN EVERY (map (HEADGOAL o dtac ctxt) rel_maps') THEN HEADGOAL (etac ctxt rel_mono_strong) THEN TRYALL (Goal.assume_rule_tac ctxt) end; fun mk_collect_set_map_tac ctxt set_map0s = (rtac ctxt (@{thm collect_comp} RS trans) THEN' rtac ctxt @{thm arg_cong[of _ _ collect]} THEN' EVERY' (map (fn set_map0 => rtac ctxt (mk_trans @{thm image_insert} @{thm arg_cong2[of _ _ _ _ insert]}) THEN' rtac ctxt set_map0) set_map0s) THEN' rtac ctxt @{thm image_empty}) 1; fun mk_rel_Grp_tac ctxt rel_OO_Grps map_id0 map_cong0 map_id map_comp set_maps = let val n = length set_maps; val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac else rtac ctxt (hd rel_OO_Grps RS trans); in if null set_maps then unfold_thms_tac ctxt ((map_id0 RS @{thm Grp_UNIV_id}) :: rel_OO_Grps) THEN resolve_tac ctxt @{thms refl Grp_UNIV_idI[OF refl]} 1 else EVERY' [rel_OO_Grps_tac, rtac ctxt @{thm antisym}, rtac ctxt @{thm predicate2I}, REPEAT_DETERM o eresolve_tac ctxt @{thms CollectE exE conjE GrpE relcomppE conversepE}, hyp_subst_tac ctxt, rtac ctxt @{thm GrpI}, rtac ctxt trans, rtac ctxt map_comp, rtac ctxt map_cong0, REPEAT_DETERM_N n o EVERY' [rtac ctxt @{thm Collect_case_prod_Grp_eqD}, etac ctxt @{thm set_mp}, assume_tac ctxt], rtac ctxt @{thm CollectI}, CONJ_WRAP' (fn thm => EVERY' [rtac ctxt (thm RS ord_eq_le_trans), rtac ctxt @{thm image_subsetI}, rtac ctxt @{thm Collect_case_prod_Grp_in}, etac ctxt @{thm set_mp}, assume_tac ctxt]) set_maps, rtac ctxt @{thm predicate2I}, REPEAT_DETERM o eresolve_tac ctxt [@{thm GrpE}, exE, conjE], hyp_subst_tac ctxt, rtac ctxt @{thm relcomppI}, rtac ctxt @{thm conversepI}, EVERY' (map2 (fn convol => fn map_id0 => EVERY' [rtac ctxt @{thm GrpI}, rtac ctxt (@{thm box_equals} OF [map_cong0, map_comp RS sym, map_id0]), REPEAT_DETERM_N n o rtac ctxt (convol RS fun_cong), REPEAT_DETERM o eresolve_tac ctxt @{thms CollectE conjE}, rtac ctxt @{thm CollectI}, CONJ_WRAP' (fn thm => EVERY' [rtac ctxt ord_eq_le_trans, rtac ctxt thm, rtac ctxt @{thm image_subsetI}, rtac ctxt @{thm convol_mem_GrpI}, etac ctxt set_mp, assume_tac ctxt]) set_maps]) @{thms fst_convol snd_convol} [map_id, refl])] 1 end; fun mk_rel_eq_tac ctxt n rel_Grp rel_cong map_id0 = (EVERY' (rtac ctxt (rel_cong RS trans) :: replicate n (rtac ctxt @{thm eq_alt})) THEN' rtac ctxt (rel_Grp RSN (2, @{thm box_equals[OF _ sym sym[OF eq_alt]]})) THEN' (if n = 0 then SELECT_GOAL (unfold_thms_tac ctxt (no_refl [map_id0])) THEN' rtac ctxt refl else EVERY' [rtac ctxt @{thm arg_cong2[of _ _ _ _ "Grp"]}, rtac ctxt @{thm equalityI}, rtac ctxt subset_UNIV, rtac ctxt @{thm subsetI}, rtac ctxt @{thm CollectI}, CONJ_WRAP' (K (rtac ctxt subset_UNIV)) (1 upto n), rtac ctxt map_id0])) 1; fun mk_rel_map0_tac ctxt live rel_compp rel_conversep rel_Grp map_id = if live = 0 then HEADGOAL (Goal.conjunction_tac) THEN unfold_thms_tac ctxt @{thms id_apply} THEN ALLGOALS (rtac ctxt refl) else let val ks = 1 upto live; in Goal.conjunction_tac 1 THEN unfold_thms_tac ctxt [rel_compp, rel_conversep, rel_Grp, @{thm vimage2p_Grp}] THEN TRYALL (EVERY' [rtac ctxt iffI, rtac ctxt @{thm relcomppI}, rtac ctxt @{thm GrpI}, resolve_tac ctxt [map_id, refl], rtac ctxt @{thm CollectI}, CONJ_WRAP' (K (rtac ctxt @{thm subset_UNIV})) ks, rtac ctxt @{thm relcomppI}, assume_tac ctxt, rtac ctxt @{thm conversepI}, rtac ctxt @{thm GrpI}, resolve_tac ctxt [map_id, refl], rtac ctxt @{thm CollectI}, CONJ_WRAP' (K (rtac ctxt @{thm subset_UNIV})) ks, REPEAT_DETERM o eresolve_tac ctxt @{thms relcomppE conversepE GrpE}, dtac ctxt (trans OF [sym, map_id]), hyp_subst_tac ctxt, assume_tac ctxt]) end; fun mk_rel_mono_tac ctxt rel_OO_Grps in_mono = let val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac else rtac ctxt (hd rel_OO_Grps RS ord_eq_le_trans) THEN' rtac ctxt (hd rel_OO_Grps RS sym RSN (2, ord_le_eq_trans)); in EVERY' [rel_OO_Grps_tac, rtac ctxt @{thm relcompp_mono}, rtac ctxt @{thm iffD2[OF conversep_mono]}, rtac ctxt @{thm Grp_mono}, rtac ctxt in_mono, REPEAT_DETERM o etac ctxt @{thm Collect_case_prod_mono}, rtac ctxt @{thm Grp_mono}, rtac ctxt in_mono, REPEAT_DETERM o etac ctxt @{thm Collect_case_prod_mono}] 1 end; fun mk_rel_conversep_le_tac ctxt rel_OO_Grps rel_eq map_cong0 map_comp set_maps = let val n = length set_maps; val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac else rtac ctxt (hd rel_OO_Grps RS ord_eq_le_trans) THEN' rtac ctxt (hd rel_OO_Grps RS sym RS @{thm arg_cong[of _ _ conversep]} RSN (2, ord_le_eq_trans)); in if null set_maps then rtac ctxt (rel_eq RS @{thm leq_conversepI}) 1 else EVERY' [rel_OO_Grps_tac, rtac ctxt @{thm predicate2I}, REPEAT_DETERM o eresolve_tac ctxt @{thms CollectE exE conjE GrpE relcomppE conversepE}, hyp_subst_tac ctxt, rtac ctxt @{thm conversepI}, rtac ctxt @{thm relcomppI}, rtac ctxt @{thm conversepI}, EVERY' (map (fn thm => EVERY' [rtac ctxt @{thm GrpI}, rtac ctxt sym, rtac ctxt trans, rtac ctxt map_cong0, REPEAT_DETERM_N n o rtac ctxt thm, rtac ctxt (map_comp RS sym), rtac ctxt @{thm CollectI}, CONJ_WRAP' (fn thm => EVERY' [rtac ctxt (thm RS ord_eq_le_trans), etac ctxt @{thm flip_pred}]) set_maps]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1 end; fun mk_rel_conversep_tac ctxt le_conversep rel_mono = EVERY' [rtac ctxt @{thm antisym}, rtac ctxt le_conversep, rtac ctxt @{thm xt1(6)}, rtac ctxt conversep_shift, rtac ctxt le_conversep, rtac ctxt @{thm iffD2[OF conversep_mono]}, rtac ctxt rel_mono, REPEAT_DETERM o rtac ctxt @{thm eq_refl[OF sym[OF conversep_conversep]]}] 1; fun mk_rel_OO_le_tac ctxt rel_OO_Grps rel_eq map_cong0 map_comp set_maps = let val n = length set_maps; fun in_tac nthO_in = rtac ctxt @{thm CollectI} THEN' CONJ_WRAP' (fn thm => EVERY' [rtac ctxt (thm RS ord_eq_le_trans), rtac ctxt @{thm image_subsetI}, rtac ctxt nthO_in, etac ctxt set_mp, assume_tac ctxt]) set_maps; val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac else rtac ctxt (hd rel_OO_Grps RS ord_eq_le_trans) THEN' rtac ctxt (@{thm arg_cong2[of _ _ _ _ "(OO)"]} OF (replicate 2 (hd rel_OO_Grps RS sym)) RSN (2, ord_le_eq_trans)); in if null set_maps then rtac ctxt (rel_eq RS @{thm leq_OOI}) 1 else EVERY' [rel_OO_Grps_tac, rtac ctxt @{thm predicate2I}, REPEAT_DETERM o eresolve_tac ctxt @{thms CollectE exE conjE GrpE relcomppE conversepE}, hyp_subst_tac ctxt, rtac ctxt @{thm relcomppI}, rtac ctxt @{thm relcomppI}, rtac ctxt @{thm conversepI}, rtac ctxt @{thm GrpI}, rtac ctxt trans, rtac ctxt map_comp, rtac ctxt sym, rtac ctxt map_cong0, REPEAT_DETERM_N n o rtac ctxt @{thm fst_fstOp}, in_tac @{thm fstOp_in}, rtac ctxt @{thm GrpI}, rtac ctxt trans, rtac ctxt map_comp, rtac ctxt map_cong0, REPEAT_DETERM_N n o EVERY' [rtac ctxt trans, rtac ctxt o_apply, rtac ctxt @{thm ballE}, rtac ctxt subst, rtac ctxt @{thm csquare_def}, rtac ctxt @{thm csquare_fstOp_sndOp}, assume_tac ctxt, etac ctxt notE, etac ctxt set_mp, assume_tac ctxt], in_tac @{thm fstOp_in}, rtac ctxt @{thm relcomppI}, rtac ctxt @{thm conversepI}, rtac ctxt @{thm GrpI}, rtac ctxt trans, rtac ctxt map_comp, rtac ctxt map_cong0, REPEAT_DETERM_N n o rtac ctxt o_apply, in_tac @{thm sndOp_in}, rtac ctxt @{thm GrpI}, rtac ctxt trans, rtac ctxt map_comp, rtac ctxt sym, rtac ctxt map_cong0, REPEAT_DETERM_N n o rtac ctxt @{thm snd_sndOp}, in_tac @{thm sndOp_in}] 1 end; fun mk_rel_mono_strong0_tac ctxt in_rel set_maps = if null set_maps then assume_tac ctxt 1 else unfold_tac ctxt [in_rel] THEN REPEAT_DETERM (eresolve_tac ctxt @{thms exE CollectE conjE} 1) THEN hyp_subst_tac ctxt 1 THEN EVERY' [rtac ctxt exI, rtac ctxt @{thm conjI[OF CollectI conjI[OF refl refl]]}, CONJ_WRAP' (fn thm => (etac ctxt (@{thm Collect_split_mono_strong} OF [thm, thm]) THEN' assume_tac ctxt)) set_maps] 1; fun mk_rel_transfer_tac ctxt in_rel rel_map rel_mono_strong = let fun last_tac iffD = HEADGOAL (etac ctxt rel_mono_strong) THEN REPEAT_DETERM (HEADGOAL (etac ctxt (@{thm predicate2_transferD} RS iffD) THEN' REPEAT_DETERM o assume_tac ctxt)); in REPEAT_DETERM (HEADGOAL (rtac ctxt rel_funI)) THEN (HEADGOAL (hyp_subst_tac ctxt THEN' rtac ctxt refl) ORELSE REPEAT_DETERM (HEADGOAL (eresolve_tac ctxt (Tactic.make_elim (in_rel RS iffD1) :: @{thms exE conjE CollectE}))) THEN HEADGOAL (hyp_subst_tac ctxt) THEN REPEAT_DETERM (HEADGOAL (resolve_tac ctxt (maps (fn thm => [thm RS trans, thm RS @{thm trans[rotated, OF sym]}]) rel_map))) THEN HEADGOAL (rtac ctxt iffI) THEN last_tac iffD1 THEN last_tac iffD2) end; fun mk_map_transfer_tac ctxt rel_mono in_rel set_maps map_cong0 map_comp = let val n = length set_maps; val in_tac = if n = 0 then rtac ctxt @{thm UNIV_I} else rtac ctxt @{thm CollectI} THEN' CONJ_WRAP' (fn thm => etac ctxt (thm RS @{thm ord_eq_le_trans[OF _ subset_trans[OF image_mono convol_image_vimage2p]]})) set_maps; in REPEAT_DETERM_N n (HEADGOAL (rtac ctxt rel_funI)) THEN unfold_thms_tac ctxt @{thms rel_fun_iff_leq_vimage2p} THEN HEADGOAL (EVERY' [rtac ctxt @{thm order_trans}, rtac ctxt rel_mono, REPEAT_DETERM_N n o assume_tac ctxt, rtac ctxt @{thm predicate2I}, dtac ctxt (in_rel RS iffD1), REPEAT_DETERM o eresolve_tac ctxt @{thms exE CollectE conjE}, hyp_subst_tac ctxt, rtac ctxt @{thm vimage2pI}, rtac ctxt (in_rel RS iffD2), rtac ctxt exI, rtac ctxt conjI, in_tac, rtac ctxt conjI, EVERY' (map (fn convol => rtac ctxt (@{thm box_equals} OF [map_cong0, map_comp RS sym, map_comp RS sym]) THEN' REPEAT_DETERM_N n o rtac ctxt (convol RS fun_cong)) @{thms fst_convol snd_convol})]) end; fun mk_in_bd_tac ctxt live surj_imp_ordLeq_inst map_comp map_id map_cong0 set_maps set_bds bd_card_order bd_Card_order bd_Cinfinite bd_Cnotzero = if live = 0 then rtac ctxt @{thm ordLeq_transitive[OF ordLeq_csum2[OF card_of_Card_order] ordLeq_cexp2[OF ordLeq_refl[OF Card_order_ctwo] Card_order_csum]]} 1 else let val bd'_Cinfinite = bd_Cinfinite RS @{thm Cinfinite_csum1}; val inserts = map (fn set_bd => iffD2 OF [@{thm card_of_ordLeq}, @{thm ordLeq_ordIso_trans} OF [set_bd, bd_Card_order RS @{thm card_of_Field_ordIso} RS @{thm ordIso_symmetric}]]) set_bds; in EVERY' [rtac ctxt (Drule.rotate_prems 1 ctrans), rtac ctxt @{thm cprod_cinfinite_bound}, rtac ctxt (ctrans OF @{thms ordLeq_csum2 ordLeq_cexp2}), rtac ctxt @{thm card_of_Card_order}, rtac ctxt @{thm ordLeq_csum2}, rtac ctxt @{thm Card_order_ctwo}, rtac ctxt @{thm Card_order_csum}, rtac ctxt @{thm ordIso_ordLeq_trans}, rtac ctxt @{thm cexp_cong1}, if live = 1 then rtac ctxt @{thm ordIso_refl[OF Card_order_csum]} else REPEAT_DETERM_N (live - 2) o rtac ctxt @{thm ordIso_transitive[OF csum_cong2]} THEN' REPEAT_DETERM_N (live - 1) o rtac ctxt @{thm csum_csum}, rtac ctxt bd_Card_order, rtac ctxt (@{thm cexp_mono2_Cnotzero} RS ctrans), rtac ctxt @{thm ordLeq_csum1}, rtac ctxt bd_Card_order, rtac ctxt @{thm Card_order_csum}, rtac ctxt bd_Cnotzero, rtac ctxt @{thm csum_Cfinite_cexp_Cinfinite}, rtac ctxt (if live = 1 then @{thm card_of_Card_order} else @{thm Card_order_csum}), CONJ_WRAP_GEN' (rtac ctxt @{thm Cfinite_csum}) (K (rtac ctxt @{thm Cfinite_cone})) set_maps, rtac ctxt bd'_Cinfinite, rtac ctxt @{thm card_of_Card_order}, rtac ctxt @{thm Card_order_cexp}, rtac ctxt @{thm Cinfinite_cexp}, rtac ctxt @{thm ordLeq_csum2}, rtac ctxt @{thm Card_order_ctwo}, rtac ctxt bd'_Cinfinite, rtac ctxt (Drule.rotate_prems 1 (@{thm cprod_mono2} RSN (2, ctrans))), REPEAT_DETERM_N (live - 1) o (rtac ctxt (bd_Cinfinite RS @{thm cprod_cexp_csum_cexp_Cinfinite} RSN (2, ctrans)) THEN' rtac ctxt @{thm ordLeq_ordIso_trans[OF cprod_mono2 ordIso_symmetric[OF cprod_cexp]]}), rtac ctxt @{thm ordLeq_refl[OF Card_order_cexp]}] 1 THEN unfold_thms_tac ctxt [bd_card_order RS @{thm card_order_csum_cone_cexp_def}] THEN unfold_thms_tac ctxt @{thms cprod_def Field_card_of} THEN EVERY' [rtac ctxt (Drule.rotate_prems 1 ctrans), rtac ctxt surj_imp_ordLeq_inst, rtac ctxt @{thm subsetI}, Method.insert_tac ctxt inserts, REPEAT_DETERM o dtac ctxt meta_spec, REPEAT_DETERM o eresolve_tac ctxt [exE, Tactic.make_elim conjunct1], etac ctxt @{thm CollectE}, if live = 1 then K all_tac else REPEAT_DETERM_N (live - 2) o (etac ctxt conjE THEN' rotate_tac ~1) THEN' etac ctxt conjE, rtac ctxt (Drule.rotate_prems 1 @{thm image_eqI}), rtac ctxt @{thm SigmaI}, rtac ctxt @{thm UNIV_I}, CONJ_WRAP_GEN' (rtac ctxt @{thm SigmaI}) (K (etac ctxt @{thm If_the_inv_into_in_Func} THEN' assume_tac ctxt)) set_maps, rtac ctxt sym, rtac ctxt (Drule.rotate_prems 1 ((@{thm box_equals} OF [map_cong0 OF replicate live @{thm If_the_inv_into_f_f}, map_comp RS sym, map_id]) RSN (2, trans))), REPEAT_DETERM_N (2 * live) o assume_tac ctxt, REPEAT_DETERM_N live o rtac ctxt (@{thm prod.case} RS trans), rtac ctxt refl, rtac ctxt @{thm surj_imp_ordLeq}, rtac ctxt @{thm subsetI}, rtac ctxt (Drule.rotate_prems 1 @{thm image_eqI}), REPEAT_DETERM o eresolve_tac ctxt @{thms CollectE conjE}, rtac ctxt @{thm CollectI}, CONJ_WRAP' (fn thm => rtac ctxt (thm RS ord_eq_le_trans) THEN' etac ctxt @{thm subset_trans[OF image_mono Un_upper1]}) set_maps, rtac ctxt sym, rtac ctxt (@{thm box_equals} OF [map_cong0 OF replicate live @{thm fun_cong[OF case_sum_o_inj(1)]}, map_comp RS sym, map_id])] 1 end; fun mk_trivial_wit_tac ctxt wit_defs set_maps = unfold_thms_tac ctxt wit_defs THEN HEADGOAL (EVERY' (map (fn thm => dtac ctxt (thm RS @{thm equalityD1} RS set_mp) THEN' etac ctxt @{thm imageE} THEN' assume_tac ctxt) set_maps)) THEN ALLGOALS (assume_tac ctxt); fun mk_set_transfer_tac ctxt in_rel set_maps = Goal.conjunction_tac 1 THEN EVERY (map (fn set_map => HEADGOAL (rtac ctxt rel_funI) THEN REPEAT_DETERM (HEADGOAL (eresolve_tac ctxt (Tactic.make_elim (in_rel RS iffD1) :: @{thms exE conjE CollectE}))) THEN HEADGOAL (hyp_subst_tac ctxt THEN' rtac ctxt (@{thm iffD2[OF arg_cong2]} OF [set_map, set_map]) THEN' rtac ctxt @{thm rel_setI}) THEN REPEAT (HEADGOAL (etac ctxt @{thm imageE} THEN' dtac ctxt @{thm set_mp} THEN' assume_tac ctxt THEN' REPEAT_DETERM o (eresolve_tac ctxt @{thms CollectE case_prodE}) THEN' hyp_subst_tac ctxt THEN' rtac ctxt @{thm bexI} THEN' etac ctxt @{thm subst_Pair[OF _ refl]} THEN' etac ctxt @{thm imageI}))) set_maps); fun mk_rel_cong_tac ctxt (eqs, prems) mono = let fun mk_tac thm = etac ctxt thm THEN_ALL_NEW assume_tac ctxt; fun mk_tacs iffD = etac ctxt mono :: map (fn thm => (unfold_thms ctxt @{thms simp_implies_def} thm RS iffD) |> Drule.rotate_prems ~1 |> mk_tac) prems; in unfold_thms_tac ctxt eqs THEN HEADGOAL (EVERY' (rtac ctxt iffI :: mk_tacs iffD1 @ mk_tacs iffD2)) end; fun subst_conv ctxt thm = - Conv.arg_conv (Conv.arg_conv - (Conv.top_sweep_conv (K (Conv.rewr_conv (safe_mk_meta_eq thm))) ctxt)); + (Conv.arg_conv o Conv.arg_conv) + (Conv.top_sweep_rewrs_conv [safe_mk_meta_eq thm] ctxt); fun mk_rel_eq_onp_tac ctxt pred_def map_id0 rel_Grp = HEADGOAL (EVERY' [SELECT_GOAL (unfold_thms_tac ctxt (pred_def :: @{thms UNIV_def eq_onp_Grp Ball_Collect})), CONVERSION (subst_conv ctxt (map_id0 RS sym)), rtac ctxt (unfold_thms ctxt @{thms UNIV_def} rel_Grp)]); fun mk_pred_mono_strong0_tac ctxt pred_rel rel_mono_strong0 = unfold_thms_tac ctxt [pred_rel] THEN HEADGOAL (etac ctxt rel_mono_strong0 THEN_ALL_NEW etac ctxt @{thm eq_onp_mono0}); fun mk_pred_mono_tac ctxt rel_eq_onp rel_mono = unfold_thms_tac ctxt (map mk_sym [@{thm eq_onp_mono_iff}, rel_eq_onp]) THEN HEADGOAL (rtac ctxt rel_mono THEN_ALL_NEW assume_tac ctxt); fun mk_pred_transfer_tac ctxt n in_rel pred_map pred_cong = HEADGOAL (EVERY' [REPEAT_DETERM_N (n + 1) o rtac ctxt rel_funI, dtac ctxt (in_rel RS iffD1), REPEAT_DETERM o eresolve_tac ctxt @{thms exE conjE CollectE}, hyp_subst_tac ctxt, rtac ctxt (box_equals OF [@{thm _}, pred_map RS sym, pred_map RS sym]), rtac ctxt (refl RS pred_cong), REPEAT_DETERM_N n o (etac ctxt @{thm rel_fun_Collect_case_prodD[where B="(=)"]} THEN_ALL_NEW assume_tac ctxt)]); end; diff --git a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML --- a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML +++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML @@ -1,2930 +1,2928 @@ (* Title: HOL/Tools/BNF/bnf_fp_def_sugar.ML Author: Jasmin Blanchette, TU Muenchen Author: Martin Desharnais, TU Muenchen Copyright 2012, 2013, 2014 Sugared datatype and codatatype constructions. *) signature BNF_FP_DEF_SUGAR = sig type fp_ctr_sugar = {ctrXs_Tss: typ list list, ctor_iff_dtor: thm, ctr_defs: thm list, ctr_sugar: Ctr_Sugar.ctr_sugar, ctr_transfers: thm list, case_transfers: thm list, disc_transfers: thm list, sel_transfers: thm list} type fp_bnf_sugar = {map_thms: thm list, map_disc_iffs: thm list, map_selss: thm list list, rel_injects: thm list, rel_distincts: thm list, rel_sels: thm list, rel_intros: thm list, rel_cases: thm list, pred_injects: thm list, set_thms: thm list, set_selssss: thm list list list list, set_introssss: thm list list list list, set_cases: thm list} type fp_co_induct_sugar = {co_rec: term, common_co_inducts: thm list, co_inducts: thm list, co_rec_def: thm, co_rec_thms: thm list, co_rec_discs: thm list, co_rec_disc_iffs: thm list, co_rec_selss: thm list list, co_rec_codes: thm list, co_rec_transfers: thm list, co_rec_o_maps: thm list, common_rel_co_inducts: thm list, rel_co_inducts: thm list, common_set_inducts: thm list, set_inducts: thm list} type fp_sugar = {T: typ, BT: typ, X: typ, fp: BNF_Util.fp_kind, fp_res_index: int, fp_res: BNF_FP_Util.fp_result, pre_bnf: BNF_Def.bnf, fp_bnf: BNF_Def.bnf, absT_info: BNF_Comp.absT_info, fp_nesting_bnfs: BNF_Def.bnf list, live_nesting_bnfs: BNF_Def.bnf list, fp_ctr_sugar: fp_ctr_sugar, fp_bnf_sugar: fp_bnf_sugar, fp_co_induct_sugar: fp_co_induct_sugar option} val co_induct_of: 'a list -> 'a val strong_co_induct_of: 'a list -> 'a val morph_fp_bnf_sugar: morphism -> fp_bnf_sugar -> fp_bnf_sugar val morph_fp_co_induct_sugar: morphism -> fp_co_induct_sugar -> fp_co_induct_sugar val morph_fp_ctr_sugar: morphism -> fp_ctr_sugar -> fp_ctr_sugar val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar val transfer_fp_sugar: theory -> fp_sugar -> fp_sugar val fp_sugar_of: Proof.context -> string -> fp_sugar option val fp_sugar_of_global: theory -> string -> fp_sugar option val fp_sugars_of: Proof.context -> fp_sugar list val fp_sugars_of_global: theory -> fp_sugar list val fp_sugars_interpretation: string -> (fp_sugar list -> local_theory -> local_theory) -> theory -> theory val interpret_fp_sugars: (string -> bool) -> fp_sugar list -> local_theory -> local_theory val register_fp_sugars_raw: fp_sugar list -> local_theory -> local_theory val register_fp_sugars: (string -> bool) -> fp_sugar list -> local_theory -> local_theory val merge_type_args: BNF_Util.fp_kind -> ''a list * ''a list -> ''a list val type_args_named_constrained_of_spec: (((('a * 'b) * 'c) * 'd) * 'e) * 'f -> 'a val type_binding_of_spec: (((('a * 'b) * 'c) * 'd) * 'e) * 'f -> 'b val mixfix_of_spec: ((('a * 'b) * 'c) * 'd) * 'e -> 'b val mixfixed_ctr_specs_of_spec: (('a * 'b) * 'c) * 'd -> 'b val map_binding_of_spec: ('a * ('b * 'c * 'd)) * 'e -> 'b val rel_binding_of_spec: ('a * ('b * 'c * 'd)) * 'e -> 'c val pred_binding_of_spec: ('a * ('b * 'c * 'd)) * 'e -> 'd val sel_default_eqs_of_spec: 'a * 'b -> 'b val mk_parametricity_goal: Proof.context -> term list -> term -> term -> term val flat_corec_preds_predsss_gettersss: 'a list -> 'a list list list -> 'a list list list -> 'a list val mk_ctor: typ list -> term -> term val mk_dtor: typ list -> term -> term val mk_bnf_sets: BNF_Def.bnf -> string * term list val liveness_of_fp_bnf: int -> BNF_Def.bnf -> bool list val nesting_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list val massage_simple_notes: string -> (bstring * 'a list * (int -> 'b)) list -> ((binding * 'c list) * ('a list * 'b) list) list val massage_multi_notes: string list -> typ list -> (string * 'a list list * (string -> 'b)) list -> ((binding * 'b) * ('a list * 'c list) list) list val define_ctrs_dtrs_for_type: string -> typ -> term -> term -> thm -> thm -> int -> int list -> term -> binding list -> mixfix list -> typ list list -> local_theory -> (term list list * term list * thm * thm list) * local_theory val wrap_ctrs: (string -> bool) -> BNF_Util.fp_kind -> bool -> string -> thm -> int -> int list -> thm -> thm -> binding list -> binding list list -> term list -> term list -> thm -> thm list -> local_theory -> Ctr_Sugar.ctr_sugar * local_theory val derive_map_set_rel_pred_thms: (string -> bool) -> BNF_Util.fp_kind -> int -> typ list -> typ list -> typ -> typ -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> string -> BNF_Def.bnf -> BNF_Def.bnf list -> typ -> term -> thm -> thm -> thm -> thm list -> thm -> thm -> thm list -> thm -> thm list -> thm list -> thm list -> typ list list -> Ctr_Sugar.ctr_sugar -> local_theory -> (thm list * thm list * thm list list * thm list * thm list * thm list * thm list * thm list * thm list * thm list * thm list list list list * thm list list list list * thm list * thm list * thm list * thm list * thm list) * local_theory type lfp_sugar_thms = (thm list * thm * Token.src list) * (thm list list * Token.src list) val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms val transfer_lfp_sugar_thms: theory -> lfp_sugar_thms -> lfp_sugar_thms type gfp_sugar_thms = ((thm list * thm) list * (Token.src list * Token.src list)) * thm list list * thm list list * (thm list list * Token.src list) * (thm list list list * Token.src list) val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms val transfer_gfp_sugar_thms: theory -> gfp_sugar_thms -> gfp_sugar_thms val mk_co_recs_prelims: Proof.context -> BNF_Util.fp_kind -> typ list list list -> typ list -> typ list -> typ list -> typ list -> int list -> int list list -> term list -> term list * (typ list list * typ list list list list * term list list * term list list list list) option * (string * term list * term list list * (((term list list * term list list * term list list list list * term list list list list) * term list list list) * typ list)) option val repair_nullary_single_ctr: typ list list -> typ list list val mk_corec_p_pred_types: typ list -> int list -> typ list list val mk_corec_fun_arg_types: typ list list list -> typ list -> typ list -> typ list -> int list -> int list list -> term -> typ list list * (typ list list list list * typ list list list * typ list list list list * typ list) val define_co_rec_as: BNF_Util.fp_kind -> typ list -> typ -> binding -> term -> local_theory -> (term * thm) * local_theory val define_rec: typ list list * typ list list list list * term list list * term list list list list -> (string -> binding) -> typ list -> typ list -> term list -> term -> Proof.context -> (term * thm) * Proof.context val define_corec: 'a * term list * term list list * (((term list list * term list list * term list list list list * term list list list list) * term list list list) * typ list) -> (string -> binding) -> 'b list -> typ list -> term list -> term -> local_theory -> (term * thm) * local_theory val mk_induct_raw_prem: (term -> term) -> Proof.context -> typ list list -> (string * term list) list -> term -> term -> typ list -> typ list -> term list * ((term * (term * term)) list * (int * term)) list * term val finish_induct_prem: Proof.context -> int -> term list -> term list * ((term * (term * term)) list * (int * term)) list * term -> term val mk_coinduct_prem: Proof.context -> typ list list -> typ list list -> term list -> term -> term -> term -> int -> term list -> term list list -> term list -> term list list -> typ list list -> term val mk_induct_attrs: term list list -> Token.src list val mk_coinduct_attrs: typ list -> term list list -> term list list -> int list list -> Token.src list * Token.src list val derive_induct_recs_thms_for_types: (string -> bool) -> BNF_Def.bnf list -> ('a * typ list list list list * term list list * 'b) option -> thm -> thm list -> BNF_Def.bnf list -> BNF_Def.bnf list -> typ list -> typ list -> typ list -> typ list list list -> thm list -> thm list -> thm list -> term list list -> thm list list -> term list -> thm list -> Proof.context -> lfp_sugar_thms val derive_coinduct_thms_for_types: Proof.context -> bool -> (term -> term) -> BNF_Def.bnf list -> thm -> thm list -> BNF_Def.bnf list -> typ list -> typ list -> typ list list list -> int list -> thm list -> thm list -> (thm -> thm) -> thm list list -> Ctr_Sugar.ctr_sugar list -> (thm list * thm) list val derive_coinduct_corecs_thms_for_types: Proof.context -> BNF_Def.bnf list -> string * term list * term list list * (((term list list * term list list * term list list list list * term list list list list) * term list list list) * typ list) -> thm -> thm list -> thm list -> thm list -> BNF_Def.bnf list -> typ list -> typ list -> typ list -> typ list list list -> int list list -> int list list -> int list -> thm list -> thm list -> (thm -> thm) -> thm list list -> Ctr_Sugar.ctr_sugar list -> term list -> thm list -> gfp_sugar_thms val co_datatypes: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list -> binding list -> binding list list -> binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * local_theory) -> Ctr_Sugar.ctr_options * ((((((binding option * (typ * sort)) list * binding) * mixfix) * ((binding, binding * typ) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * term list) list -> local_theory -> local_theory val co_datatype_cmd: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list -> binding list -> binding list list -> binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * Proof.context) -> ((Proof.context -> Plugin_Name.filter) * bool) * ((((((binding option * (string * string option)) list * binding) * mixfix) * ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * string list) list -> Proof.context -> local_theory val parse_ctr_arg: (binding * string) parser val parse_ctr_specs: ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list parser val parse_spec: ((((((binding option * (string * string option)) list * binding) * mixfix) * ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * string list) parser val parse_co_datatype: (Ctr_Sugar.ctr_options_cmd * ((((((binding option * (string * string option)) list * binding) * mixfix) * ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding * binding)) * string list) list) parser val parse_co_datatype_cmd: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list -> binding list -> binding list list -> binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * local_theory) -> (local_theory -> local_theory) parser end; structure BNF_FP_Def_Sugar : BNF_FP_DEF_SUGAR = struct open Ctr_Sugar open BNF_FP_Rec_Sugar_Util open BNF_Util open BNF_Comp open BNF_Def open BNF_FP_Util open BNF_FP_Def_Sugar_Tactics val Eq_prefix = "Eq_"; val case_transferN = "case_transfer"; val ctor_iff_dtorN = "ctor_iff_dtor"; val ctr_transferN = "ctr_transfer"; val disc_transferN = "disc_transfer"; val sel_transferN = "sel_transfer"; val corec_codeN = "corec_code"; val corec_transferN = "corec_transfer"; val map_disc_iffN = "map_disc_iff"; val map_o_corecN = "map_o_corec"; val map_selN = "map_sel"; val pred_injectN = "pred_inject"; val rec_o_mapN = "rec_o_map"; val rec_transferN = "rec_transfer"; val set0N = "set0"; val set_casesN = "set_cases"; val set_introsN = "set_intros"; val set_inductN = "set_induct"; val set_selN = "set_sel"; type fp_ctr_sugar = {ctrXs_Tss: typ list list, ctor_iff_dtor: thm, ctr_defs: thm list, ctr_sugar: Ctr_Sugar.ctr_sugar, ctr_transfers: thm list, case_transfers: thm list, disc_transfers: thm list, sel_transfers: thm list}; type fp_bnf_sugar = {map_thms: thm list, map_disc_iffs: thm list, map_selss: thm list list, rel_injects: thm list, rel_distincts: thm list, rel_sels: thm list, rel_intros: thm list, rel_cases: thm list, pred_injects: thm list, set_thms: thm list, set_selssss: thm list list list list, set_introssss: thm list list list list, set_cases: thm list}; type fp_co_induct_sugar = {co_rec: term, common_co_inducts: thm list, co_inducts: thm list, co_rec_def: thm, co_rec_thms: thm list, co_rec_discs: thm list, co_rec_disc_iffs: thm list, co_rec_selss: thm list list, co_rec_codes: thm list, co_rec_transfers: thm list, co_rec_o_maps: thm list, common_rel_co_inducts: thm list, rel_co_inducts: thm list, common_set_inducts: thm list, set_inducts: thm list}; type fp_sugar = {T: typ, BT: typ, X: typ, fp: fp_kind, fp_res_index: int, fp_res: fp_result, pre_bnf: bnf, fp_bnf: bnf, absT_info: absT_info, fp_nesting_bnfs: bnf list, live_nesting_bnfs: bnf list, fp_ctr_sugar: fp_ctr_sugar, fp_bnf_sugar: fp_bnf_sugar, fp_co_induct_sugar: fp_co_induct_sugar option}; fun co_induct_of (i :: _) = i; fun strong_co_induct_of [_, s] = s; fun morph_fp_bnf_sugar phi ({map_thms, map_disc_iffs, map_selss, rel_injects, rel_distincts, rel_sels, rel_intros, rel_cases, pred_injects, set_thms, set_selssss, set_introssss, set_cases} : fp_bnf_sugar) = {map_thms = map (Morphism.thm phi) map_thms, map_disc_iffs = map (Morphism.thm phi) map_disc_iffs, map_selss = map (map (Morphism.thm phi)) map_selss, rel_injects = map (Morphism.thm phi) rel_injects, rel_distincts = map (Morphism.thm phi) rel_distincts, rel_sels = map (Morphism.thm phi) rel_sels, rel_intros = map (Morphism.thm phi) rel_intros, rel_cases = map (Morphism.thm phi) rel_cases, pred_injects = map (Morphism.thm phi) pred_injects, set_thms = map (Morphism.thm phi) set_thms, set_selssss = map (map (map (map (Morphism.thm phi)))) set_selssss, set_introssss = map (map (map (map (Morphism.thm phi)))) set_introssss, set_cases = map (Morphism.thm phi) set_cases}; fun morph_fp_co_induct_sugar phi ({co_rec, common_co_inducts, co_inducts, co_rec_def, co_rec_thms, co_rec_discs, co_rec_disc_iffs, co_rec_selss, co_rec_codes, co_rec_transfers, co_rec_o_maps, common_rel_co_inducts, rel_co_inducts, common_set_inducts, set_inducts} : fp_co_induct_sugar) = {co_rec = Morphism.term phi co_rec, common_co_inducts = map (Morphism.thm phi) common_co_inducts, co_inducts = map (Morphism.thm phi) co_inducts, co_rec_def = Morphism.thm phi co_rec_def, co_rec_thms = map (Morphism.thm phi) co_rec_thms, co_rec_discs = map (Morphism.thm phi) co_rec_discs, co_rec_disc_iffs = map (Morphism.thm phi) co_rec_disc_iffs, co_rec_selss = map (map (Morphism.thm phi)) co_rec_selss, co_rec_codes = map (Morphism.thm phi) co_rec_codes, co_rec_transfers = map (Morphism.thm phi) co_rec_transfers, co_rec_o_maps = map (Morphism.thm phi) co_rec_o_maps, common_rel_co_inducts = map (Morphism.thm phi) common_rel_co_inducts, rel_co_inducts = map (Morphism.thm phi) rel_co_inducts, common_set_inducts = map (Morphism.thm phi) common_set_inducts, set_inducts = map (Morphism.thm phi) set_inducts}; fun morph_fp_ctr_sugar phi ({ctrXs_Tss, ctor_iff_dtor, ctr_defs, ctr_sugar, ctr_transfers, case_transfers, disc_transfers, sel_transfers} : fp_ctr_sugar) = {ctrXs_Tss = map (map (Morphism.typ phi)) ctrXs_Tss, ctor_iff_dtor = Morphism.thm phi ctor_iff_dtor, ctr_defs = map (Morphism.thm phi) ctr_defs, ctr_sugar = morph_ctr_sugar phi ctr_sugar, ctr_transfers = map (Morphism.thm phi) ctr_transfers, case_transfers = map (Morphism.thm phi) case_transfers, disc_transfers = map (Morphism.thm phi) disc_transfers, sel_transfers = map (Morphism.thm phi) sel_transfers}; fun morph_fp_sugar phi ({T, BT, X, fp, fp_res, fp_res_index, pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, fp_bnf_sugar, fp_co_induct_sugar} : fp_sugar) = {T = Morphism.typ phi T, BT = Morphism.typ phi BT, X = Morphism.typ phi X, fp = fp, fp_res = morph_fp_result phi fp_res, fp_res_index = fp_res_index, pre_bnf = morph_bnf phi pre_bnf, fp_bnf = morph_bnf phi fp_bnf, absT_info = morph_absT_info phi absT_info, fp_nesting_bnfs = map (morph_bnf phi) fp_nesting_bnfs, live_nesting_bnfs = map (morph_bnf phi) live_nesting_bnfs, fp_ctr_sugar = morph_fp_ctr_sugar phi fp_ctr_sugar, fp_bnf_sugar = morph_fp_bnf_sugar phi fp_bnf_sugar, fp_co_induct_sugar = Option.map (morph_fp_co_induct_sugar phi) fp_co_induct_sugar}; val transfer_fp_sugar = morph_fp_sugar o Morphism.transfer_morphism; structure Data = Generic_Data ( type T = fp_sugar Symtab.table; val empty = Symtab.empty; val extend = I; fun merge data : T = Symtab.merge (K true) data; ); fun fp_sugar_of_generic context = Option.map (transfer_fp_sugar (Context.theory_of context)) o Symtab.lookup (Data.get context); fun fp_sugars_of_generic context = Symtab.fold (cons o transfer_fp_sugar (Context.theory_of context) o snd) (Data.get context) []; val fp_sugar_of = fp_sugar_of_generic o Context.Proof; val fp_sugar_of_global = fp_sugar_of_generic o Context.Theory; val fp_sugars_of = fp_sugars_of_generic o Context.Proof; val fp_sugars_of_global = fp_sugars_of_generic o Context.Theory; structure FP_Sugar_Plugin = Plugin(type T = fp_sugar list); fun fp_sugars_interpretation name f = FP_Sugar_Plugin.interpretation name (fn fp_sugars => fn lthy => f (map (transfer_fp_sugar (Proof_Context.theory_of lthy)) fp_sugars) lthy); val interpret_fp_sugars = FP_Sugar_Plugin.data; val register_fp_sugars_raw = fold (fn fp_sugar as {T = Type (s, _), ...} => Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (Symtab.update (s, morph_fp_sugar phi fp_sugar)))); fun register_fp_sugars plugins fp_sugars = register_fp_sugars_raw fp_sugars #> interpret_fp_sugars plugins fp_sugars; fun interpret_bnfs_register_fp_sugars plugins Ts BTs Xs fp pre_bnfs absT_infos fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctor_iff_dtors ctr_defss ctr_sugars co_recs co_rec_defs map_thmss common_co_inducts co_inductss co_rec_thmss co_rec_discss co_rec_selsss rel_injectss rel_distinctss map_disc_iffss map_selsss rel_selss rel_intross rel_casess pred_injectss set_thmss set_selsssss set_introsssss set_casess ctr_transferss case_transferss disc_transferss sel_transferss co_rec_disc_iffss co_rec_codess co_rec_transferss common_rel_co_inducts rel_co_inductss common_set_inducts set_inductss co_rec_o_mapss noted = let val fp_sugars = map_index (fn (kk, T) => {T = T, BT = nth BTs kk, X = nth Xs kk, fp = fp, fp_res = fp_res, fp_res_index = kk, pre_bnf = nth pre_bnfs kk, absT_info = nth absT_infos kk, fp_bnf = nth (#bnfs fp_res) kk, fp_nesting_bnfs = fp_nesting_bnfs, live_nesting_bnfs = live_nesting_bnfs, fp_ctr_sugar = {ctrXs_Tss = nth ctrXs_Tsss kk, ctor_iff_dtor = nth ctor_iff_dtors kk, ctr_defs = nth ctr_defss kk, ctr_sugar = nth ctr_sugars kk, ctr_transfers = nth ctr_transferss kk, case_transfers = nth case_transferss kk, disc_transfers = nth disc_transferss kk, sel_transfers = nth sel_transferss kk}, fp_bnf_sugar = {map_thms = nth map_thmss kk, map_disc_iffs = nth map_disc_iffss kk, map_selss = nth map_selsss kk, rel_injects = nth rel_injectss kk, rel_distincts = nth rel_distinctss kk, rel_sels = nth rel_selss kk, rel_intros = nth rel_intross kk, rel_cases = nth rel_casess kk, pred_injects = nth pred_injectss kk, set_thms = nth set_thmss kk, set_selssss = nth set_selsssss kk, set_introssss = nth set_introsssss kk, set_cases = nth set_casess kk}, fp_co_induct_sugar = SOME {co_rec = nth co_recs kk, common_co_inducts = common_co_inducts, co_inducts = nth co_inductss kk, co_rec_def = nth co_rec_defs kk, co_rec_thms = nth co_rec_thmss kk, co_rec_discs = nth co_rec_discss kk, co_rec_disc_iffs = nth co_rec_disc_iffss kk, co_rec_selss = nth co_rec_selsss kk, co_rec_codes = nth co_rec_codess kk, co_rec_transfers = nth co_rec_transferss kk, co_rec_o_maps = nth co_rec_o_mapss kk, common_rel_co_inducts = common_rel_co_inducts, rel_co_inducts = nth rel_co_inductss kk, common_set_inducts = common_set_inducts, set_inducts = nth set_inductss kk}} |> morph_fp_sugar (substitute_noted_thm noted)) Ts; in register_fp_sugars_raw fp_sugars #> fold (interpret_bnf plugins) (#bnfs fp_res) #> interpret_fp_sugars plugins fp_sugars end; fun quasi_unambiguous_case_names names = let val ps = map (`Long_Name.base_name) names; val dups = Library.duplicates (op =) (map fst ps); fun underscore s = let val ss = Long_Name.explode s in space_implode "_" (drop (length ss - 2) ss) end; in map (fn (base, full) => if member (op =) dups base then underscore full else base) ps |> Name.variant_list [] end; fun zipper_map f = let fun zed _ [] = [] | zed xs (y :: ys) = f (xs, y, ys) :: zed (xs @ [y]) ys; in zed [] end; fun cannot_merge_types fp = error ("Mutually " ^ co_prefix fp ^ "recursive types must have the same type parameters"); fun merge_type_arg fp T T' = if T = T' then T else cannot_merge_types fp; fun merge_type_args fp (As, As') = if length As = length As' then map2 (merge_type_arg fp) As As' else cannot_merge_types fp; fun type_args_named_constrained_of_spec (((((ncAs, _), _), _), _), _) = ncAs; fun type_binding_of_spec (((((_, b), _), _), _), _) = b; fun mixfix_of_spec ((((_, mx), _), _), _) = mx; fun mixfixed_ctr_specs_of_spec (((_, mx_ctr_specs), _), _) = mx_ctr_specs; fun map_binding_of_spec ((_, (b, _, _)), _) = b; fun rel_binding_of_spec ((_, (_, b, _)), _) = b; fun pred_binding_of_spec ((_, (_, _, b)), _) = b; fun sel_default_eqs_of_spec (_, ts) = ts; fun ctr_sugar_kind_of_fp_kind Least_FP = Datatype | ctr_sugar_kind_of_fp_kind Greatest_FP = Codatatype; fun uncurry_thm 0 thm = thm | uncurry_thm 1 thm = thm | uncurry_thm n thm = rotate_prems ~1 (uncurry_thm (n - 1) (rotate_prems 1 (conjI RS thm))); fun choose_binary_fun fs AB = find_first (fastype_of #> binder_types #> (fn [A, B] => AB = (A, B))) fs; fun build_binary_fun_app fs t u = Option.map (rapp u o rapp t) (choose_binary_fun fs (fastype_of t, fastype_of u)); fun build_the_rel ctxt Rs Ts A B = build_rel [] ctxt Ts [] (the o choose_binary_fun Rs) (A, B); fun build_rel_app ctxt Rs Ts t u = build_the_rel ctxt Rs Ts (fastype_of t) (fastype_of u) $ t $ u; fun build_set_app ctxt A t = Term.betapply (build_set ctxt A (fastype_of t), t); fun mk_parametricity_goal ctxt Rs t u = let val prem = build_the_rel ctxt Rs [] (fastype_of t) (fastype_of u) in HOLogic.mk_Trueprop (prem $ t $ u) end; val name_of_set = name_of_const "set function" domain_type; val fundefcong_attrs = @{attributes [fundef_cong]}; val nitpicksimp_attrs = @{attributes [nitpick_simp]}; val simp_attrs = @{attributes [simp]}; val lists_bmoc = fold (fn xs => fn t => Term.list_comb (t, xs)); fun flat_corec_predss_getterss qss gss = maps (op @) (qss ~~ gss); fun flat_corec_preds_predsss_gettersss [] [qss] [gss] = flat_corec_predss_getterss qss gss | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (gss :: gsss) = p :: flat_corec_predss_getterss qss gss @ flat_corec_preds_predsss_gettersss ps qsss gsss; fun mk_flip (x, Type (_, [T1, Type (_, [T2, T3])])) = Abs ("x", T1, Abs ("y", T2, Var (x, T2 --> T1 --> T3) $ Bound 0 $ Bound 1)); fun flip_rels ctxt n thm = let val Rs = Term.add_vars (Thm.prop_of thm) []; val Rs' = rev (drop (length Rs - n) Rs); in infer_instantiate ctxt (map (fn f => (fst f, Thm.cterm_of ctxt (mk_flip f))) Rs') thm end; fun mk_ctor_or_dtor get_T Ts t = let val Type (_, Ts0) = get_T (fastype_of t) in Term.subst_atomic_types (Ts0 ~~ Ts) t end; val mk_ctor = mk_ctor_or_dtor range_type; val mk_dtor = mk_ctor_or_dtor domain_type; fun mk_bnf_sets bnf = let val Type (T_name, Us) = T_of_bnf bnf; val lives = lives_of_bnf bnf; val sets = sets_of_bnf bnf; fun mk_set U = (case find_index (curry (op =) U) lives of ~1 => Term.dummy | i => nth sets i); in (T_name, map mk_set Us) end; fun mk_xtor_co_recs thy fp fpTs Cs ts0 = let val nn = length fpTs; val (fpTs0, Cs0) = map ((fp = Greatest_FP ? swap) o dest_funT o snd o strip_typeN nn o fastype_of) ts0 |> split_list; val rho = tvar_subst thy (fpTs0 @ Cs0) (fpTs @ Cs); in map (Term.subst_TVars rho) ts0 end; fun liveness_of_fp_bnf n bnf = (case T_of_bnf bnf of Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts | _ => replicate n false); fun add_nesting_bnf_names Us = let fun add (Type (s, Ts)) ss = let val (needs, ss') = fold_map add Ts ss in if exists I needs then (true, insert (op =) s ss') else (false, ss') end | add T ss = (member (op =) Us T, ss); in snd oo add end; fun nesting_bnfs ctxt ctr_Tsss Us = map_filter (bnf_of ctxt) (fold (fold (fold (add_nesting_bnf_names Us))) ctr_Tsss []); fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p; fun massage_simple_notes base = filter_out (null o #2) #> map (fn (thmN, thms, f_attrs) => ((Binding.qualify true base (Binding.name thmN), []), map_index (fn (i, thm) => ([thm], f_attrs i)) thms)); fun massage_multi_notes b_names Ts = maps (fn (thmN, thmss, attrs) => @{map 3} (fn b_name => fn Type (T_name, _) => fn thms => ((Binding.qualify true b_name (Binding.name thmN), attrs T_name), [(thms, [])])) b_names Ts thmss) #> filter_out (null o fst o hd o snd); fun define_ctrs_dtrs_for_type fp_b_name fpT ctor dtor ctor_dtor dtor_ctor n ks abs ctr_bindings ctr_mixfixes ctr_Tss lthy = let val ctor_absT = domain_type (fastype_of ctor); val (((w, xss), u'), _) = lthy |> yield_singleton (mk_Frees "w") ctor_absT ||>> mk_Freess "x" ctr_Tss ||>> yield_singleton Variable.variant_fixes fp_b_name; val u = Free (u', fpT); val ctor_iff_dtor_thm = let val goal = fold_rev Logic.all [w, u] (mk_Trueprop_eq (HOLogic.mk_eq (u, ctor $ w), HOLogic.mk_eq (dtor $ u, w))); val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => mk_ctor_iff_dtor_tac ctxt (map (SOME o Thm.ctyp_of lthy) [ctor_absT, fpT]) (Thm.cterm_of lthy ctor) (Thm.cterm_of lthy dtor) ctor_dtor dtor_ctor) |> Thm.close_derivation \<^here> end; val ctr_rhss = map2 (fn k => fn xs => fold_rev Term.lambda xs (ctor $ mk_absumprod ctor_absT abs n k xs)) ks xss; val ((raw_ctrs, raw_ctr_defs), (lthy, lthy_old)) = lthy |> (snd o Local_Theory.begin_nested) |> apfst split_list o @{fold_map 3} (fn b => fn mx => fn rhs => Local_Theory.define ((b, mx), ((Thm.make_def_binding (Config.get lthy bnf_internals) b, []), rhs)) #>> apsnd snd) ctr_bindings ctr_mixfixes ctr_rhss ||> `Local_Theory.end_nested; val phi = Proof_Context.export_morphism lthy_old lthy; val ctr_defs = map (Morphism.thm phi) raw_ctr_defs; val ctrs0 = map (Morphism.term phi) raw_ctrs; in ((xss, ctrs0, ctor_iff_dtor_thm, ctr_defs), lthy) end; fun wrap_ctrs plugins fp discs_sels fp_b_name ctor_inject n ms abs_inject type_definition disc_bindings sel_bindingss sel_default_eqs ctrs0 ctor_iff_dtor_thm ctr_defs lthy = let val sumEN_thm' = unfold_thms lthy @{thms unit_all_eq1} (mk_absumprodE type_definition ms); fun exhaust_tac {context = ctxt, prems = _} = mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor_thm sumEN_thm'; val inject_tacss = map2 (fn ctr_def => fn 0 => [] | _ => [fn {context = ctxt, ...} => mk_inject_tac ctxt ctr_def ctor_inject abs_inject]) ctr_defs ms; val half_distinct_tacss = map (map (fn (def, def') => fn {context = ctxt, ...} => mk_half_distinct_tac ctxt ctor_inject abs_inject [def, def'])) (mk_half_pairss (`I ctr_defs)); val tacss = [exhaust_tac] :: inject_tacss @ half_distinct_tacss; fun ctr_spec_of disc_b ctr0 sel_bs = ((disc_b, ctr0), sel_bs); val ctr_specs = @{map 3} ctr_spec_of disc_bindings ctrs0 sel_bindingss; val (ctr_sugar as {case_cong, ...}, lthy) = free_constructors (ctr_sugar_kind_of_fp_kind fp) tacss ((((plugins, discs_sels), standard_binding), ctr_specs), sel_default_eqs) lthy; val anonymous_notes = [([case_cong], fundefcong_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); val notes = if Config.get lthy bnf_internals then [(ctor_iff_dtorN, [ctor_iff_dtor_thm], K [])] |> massage_simple_notes fp_b_name else []; in (ctr_sugar, lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd) end; fun derive_map_set_rel_pred_thms plugins fp live As Bs C E abs_inverses ctr_defs fp_nesting_set_maps fp_nesting_rel_eq_onps live_nesting_map_id0s live_nesting_set_maps live_nesting_rel_eqs live_nesting_rel_eq_onps fp_nested_rel_eq_onps fp_b_name fp_bnf fp_bnfs fpT ctor ctor_dtor dtor_ctor pre_map_def pre_set_defs pre_rel_def fp_map_thm fp_set_thms fp_rel_thm extra_unfolds_map extra_unfolds_set extra_unfolds_rel ctr_Tss ({casex, case_thms, discs, selss, sel_defs, ctrs, exhaust, exhaust_discs, disc_thmss, sel_thmss, injects, distincts, distinct_discsss, ...} : ctr_sugar) lthy = let val n = length ctr_Tss; val ms = map length ctr_Tss; val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val fpBT = B_ify_T fpT; val live_AsBs = filter (op <>) (As ~~ Bs); val live_As = map fst live_AsBs; val fTs = map (op -->) live_AsBs; val ((((((((xss, yss), fs), Ps), Rs), ta), tb), thesis), names_lthy) = lthy |> fold (fold Variable.declare_typ) [As, Bs] |> mk_Freess "x" ctr_Tss ||>> mk_Freess "y" (map (map B_ify_T) ctr_Tss) ||>> mk_Frees "f" fTs ||>> mk_Frees "P" (map mk_pred1T live_As) ||>> mk_Frees "R" (map (uncurry mk_pred2T) live_AsBs) ||>> yield_singleton (mk_Frees "a") fpT ||>> yield_singleton (mk_Frees "b") fpBT ||>> apfst HOLogic.mk_Trueprop o yield_singleton (mk_Frees "thesis") HOLogic.boolT; val ctrAs = map (mk_ctr As) ctrs; val ctrBs = map (mk_ctr Bs) ctrs; val ctr_defs' = map2 (fn m => fn def => mk_unabs_def m (HOLogic.mk_obj_eq def)) ms ctr_defs; val ABfs = live_AsBs ~~ fs; fun derive_rel_case relAsBs rel_inject_thms rel_distinct_thms = let val rel_Rs_a_b = list_comb (relAsBs, Rs) $ ta $ tb; fun mk_assms ctrA ctrB ctxt = let val argA_Ts = binder_types (fastype_of ctrA); val argB_Ts = binder_types (fastype_of ctrB); val ((argAs, argBs), names_ctxt) = ctxt |> mk_Frees "x" argA_Ts ||>> mk_Frees "y" argB_Ts; val ctrA_args = list_comb (ctrA, argAs); val ctrB_args = list_comb (ctrB, argBs); in (fold_rev Logic.all (argAs @ argBs) (Logic.list_implies (mk_Trueprop_eq (ta, ctrA_args) :: mk_Trueprop_eq (tb, ctrB_args) :: map2 (HOLogic.mk_Trueprop oo build_rel_app lthy Rs []) argAs argBs, thesis)), names_ctxt) end; val (assms, names_lthy) = @{fold_map 2} mk_assms ctrAs ctrBs names_lthy; val goal = Logic.list_implies (HOLogic.mk_Trueprop rel_Rs_a_b :: assms, thesis); in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_rel_case_tac ctxt (Thm.cterm_of ctxt ta) (Thm.cterm_of ctxt tb) exhaust injects rel_inject_thms distincts rel_distinct_thms live_nesting_rel_eqs) |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation \<^here> end; fun derive_case_transfer rel_case_thm = let val (S, names_lthy) = yield_singleton (mk_Frees "S") (mk_pred2T C E) names_lthy; val caseA = mk_case As C casex; val caseB = mk_case Bs E casex; val goal = mk_parametricity_goal names_lthy (S :: Rs) caseA caseB; in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_case_transfer_tac ctxt rel_case_thm case_thms) |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation \<^here> end; in if live = 0 then if plugins transfer_plugin then let val relAsBs = HOLogic.eq_const fpT; val rel_case_thm = derive_rel_case relAsBs [] []; val case_transfer_thm = derive_case_transfer rel_case_thm; val notes = [(case_transferN, [case_transfer_thm], K [])] |> massage_simple_notes fp_b_name; val (noted, lthy') = lthy |> Local_Theory.notes notes; val subst = Morphism.thm (substitute_noted_thm noted); in (([], [], [], [], [], [], [], [], [], [], [], [], [], [], [subst case_transfer_thm], [], []), lthy') end else (([], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], []), lthy) else let val mapx = mk_map live As Bs (map_of_bnf fp_bnf); val relAsBs = mk_rel live As Bs (rel_of_bnf fp_bnf); val setAs = map (mk_set As) (sets_of_bnf fp_bnf); val discAs = map (mk_disc_or_sel As) discs; val discBs = map (mk_disc_or_sel Bs) discs; val selAss = map (map (mk_disc_or_sel As)) selss; val selBss = map (map (mk_disc_or_sel Bs)) selss; val map_ctor_thm = if fp = Least_FP then fp_map_thm else let val ctorA = mk_ctor As ctor; val ctorB = mk_ctor Bs ctor; val y_T = domain_type (fastype_of ctorA); val (y as Free (y_s, _), _) = lthy |> yield_singleton (mk_Frees "y") y_T; val ctor_cong = infer_instantiate' lthy [NONE, NONE, SOME (Thm.cterm_of lthy ctorB)] arg_cong; val fp_map_thm' = fp_map_thm |> infer_instantiate' lthy (replicate live NONE @ [SOME (Thm.cterm_of lthy (ctorA $ y))]) |> unfold_thms lthy [dtor_ctor]; in (fp_map_thm' RS ctor_cong RS (ctor_dtor RS sym RS trans)) |> Drule.generalize (Names.empty, Names.make_set [y_s]) end; val map_thms = let fun mk_goal ctrA ctrB xs ys = let val fmap = list_comb (mapx, fs); fun mk_arg (x as Free (_, T)) (Free (_, U)) = if T = U then x else build_map lthy [] [] (the o AList.lookup (op =) ABfs) (T, U) $ x; val xs' = map2 mk_arg xs ys; in mk_Trueprop_eq (fmap $ list_comb (ctrA, xs), list_comb (ctrB, xs')) end; val goals = @{map 4} mk_goal ctrAs ctrBs xss yss; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_map_tac ctxt abs_inverses pre_map_def map_ctor_thm live_nesting_map_id0s ctr_defs' extra_unfolds_map) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; val set0_thms = let fun mk_goal A setA ctrA xs = let val sets = map (build_set_app lthy A) (filter (exists_subtype_in [A] o fastype_of) xs); in mk_Trueprop_eq (setA $ list_comb (ctrA, xs), (if null sets then HOLogic.mk_set A [] else Library.foldl1 mk_union sets)) end; val goals = @{map 2} (fn live_A => fn setA => map2 (mk_goal live_A setA) ctrAs xss) live_As setAs |> flat; in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_set0_tac ctxt abs_inverses pre_set_defs dtor_ctor fp_set_thms fp_nesting_set_maps live_nesting_set_maps ctr_defs' extra_unfolds_set) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val set_thms = set0_thms |> map (unfold_thms lthy @{thms insert_is_Un[THEN sym] Un_empty_left Un_insert_left}); val rel_ctor_thm = if fp = Least_FP then fp_rel_thm else let val ctorA = mk_ctor As ctor; val ctorB = mk_ctor Bs ctor; val y_T = domain_type (fastype_of ctorA); val z_T = domain_type (fastype_of ctorB); val ((y as Free (y_s, _), z as Free (z_s, _)), _) = lthy |> yield_singleton (mk_Frees "y") y_T ||>> yield_singleton (mk_Frees "z") z_T; in fp_rel_thm |> infer_instantiate' lthy (replicate live NONE @ [SOME (Thm.cterm_of lthy (ctorA $ y)), SOME (Thm.cterm_of lthy (ctorB $ z))]) |> unfold_thms lthy [dtor_ctor] |> Drule.generalize (Names.empty, Names.make_set [y_s, z_s]) end; val rel_inject_thms = let fun mk_goal ctrA ctrB xs ys = let val lhs = list_comb (relAsBs, Rs) $ list_comb (ctrA, xs) $ list_comb (ctrB, ys); val conjuncts = map2 (build_rel_app lthy Rs []) xs ys; in HOLogic.mk_Trueprop (if null conjuncts then lhs else HOLogic.mk_eq (lhs, Library.foldr1 HOLogic.mk_conj conjuncts)) end; val goals = @{map 4} mk_goal ctrAs ctrBs xss yss; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rel_tac ctxt abs_inverses pre_rel_def rel_ctor_thm live_nesting_rel_eqs ctr_defs' extra_unfolds_rel) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; val half_rel_distinct_thmss = let fun mk_goal ((ctrA, xs), (ctrB, ys)) = HOLogic.mk_Trueprop (HOLogic.mk_not (list_comb (relAsBs, Rs) $ list_comb (ctrA, xs) $ list_comb (ctrB, ys))); val rel_infos = (ctrAs ~~ xss, ctrBs ~~ yss); val goalss = map (map mk_goal) (mk_half_pairss rel_infos); val goals = flat goalss; in unflat goalss (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rel_tac ctxt abs_inverses pre_rel_def rel_ctor_thm live_nesting_rel_eqs ctr_defs' extra_unfolds_rel) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val rel_flip = rel_flip_of_bnf fp_bnf; fun mk_other_half_rel_distinct_thm thm = flip_rels lthy live thm RS (rel_flip RS sym RS @{thm arg_cong[of _ _ Not]} RS iffD2); val other_half_rel_distinct_thmss = map (map mk_other_half_rel_distinct_thm) half_rel_distinct_thmss; val (rel_distinct_thms, _) = join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss; fun mk_rel_intro_thm m thm = uncurry_thm m (thm RS iffD2) handle THM _ => thm; val rel_intro_thms = map2 mk_rel_intro_thm ms rel_inject_thms; val rel_code_thms = map (fn thm => thm RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms @ map2 (fn thm => fn 0 => thm RS @{thm eq_True[THEN iffD2]} | _ => thm) rel_inject_thms ms; val ctr_transfer_thms = let val goals = map2 (mk_parametricity_goal names_lthy Rs) ctrAs ctrBs; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_ctr_transfer_tac ctxt rel_intro_thms live_nesting_rel_eqs) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; val (set_cases_thms, set_cases_attrss) = let fun mk_prems assms elem t ctxt = (case fastype_of t of Type (type_name, xs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => apfst flat (fold_map (fn set => fn ctxt => let val T = HOLogic.dest_setT (range_type (fastype_of set)); val new_var = not (T = fastype_of elem); val (x, ctxt') = if new_var then yield_singleton (mk_Frees "x") T ctxt else (elem, ctxt); in mk_prems (mk_Trueprop_mem (x, set $ t) :: assms) elem x ctxt' |>> map (new_var ? Logic.all x) end) (map (mk_set xs) (sets_of_bnf bnf)) ctxt)) | T => rpair ctxt (if T = fastype_of elem then [fold (curry Logic.mk_implies) assms thesis] else [])); in split_list (map (fn set => let val A = HOLogic.dest_setT (range_type (fastype_of set)); val (elem, names_lthy) = yield_singleton (mk_Frees "e") A names_lthy; val premss = map (fn ctr => let val (args, names_lthy) = mk_Frees "z" (binder_types (fastype_of ctr)) names_lthy; in flat (zipper_map (fn (prev_args, arg, next_args) => let val (args_with_elem, args_without_elem) = if fastype_of arg = A then (prev_args @ [elem] @ next_args, prev_args @ next_args) else `I (prev_args @ [arg] @ next_args); in mk_prems [mk_Trueprop_eq (ta, Term.list_comb (ctr, args_with_elem))] elem arg names_lthy |> fst |> map (fold_rev Logic.all args_without_elem) end) args) end) ctrAs; val goal = Logic.mk_implies (mk_Trueprop_mem (elem, set $ ta), thesis); val vars = Variable.add_free_names lthy goal []; val thm = Goal.prove_sorry lthy vars (flat premss) goal (fn {context = ctxt, prems} => mk_set_cases_tac ctxt (Thm.cterm_of ctxt ta) prems exhaust set_thms) |> Thm.close_derivation \<^here> |> rotate_prems ~1; val cases_set_attr = Attrib.internal (K (Induct.cases_pred (name_of_set set))); val ctr_names = quasi_unambiguous_case_names (flat (map (uncurry mk_names o map_prod length name_of_ctr) (premss ~~ ctrAs))); in (* TODO: @{attributes [elim?]} *) (thm, [Attrib.consumes 1, cases_set_attr, Attrib.case_names ctr_names]) end) setAs) end; val (set_intros_thmssss, set_intros_thms) = let fun mk_goals A setA ctr_args t ctxt = (case fastype_of t of Type (type_name, innerTs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => apfst flat (fold_map (fn set => fn ctxt => let val T = HOLogic.dest_setT (range_type (fastype_of set)); val (y, ctxt') = yield_singleton (mk_Frees "y") T ctxt; val assm = mk_Trueprop_mem (y, set $ t); in apfst (map (Logic.mk_implies o pair assm)) (mk_goals A setA ctr_args y ctxt') end) (map (mk_set innerTs) (sets_of_bnf bnf)) ctxt)) | T => (if T = A then [mk_Trueprop_mem (t, setA $ ctr_args)] else [], ctxt)); val (goalssss, _) = fold_map (fn set => let val A = HOLogic.dest_setT (range_type (fastype_of set)) in @{fold_map 2} (fn ctr => fn xs => fold_map (mk_goals A set (Term.list_comb (ctr, xs))) xs) ctrAs xss end) setAs lthy; val goals = flat (flat (flat goalssss)); in `(unflattt goalssss) (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_set_intros_tac ctxt set0_thms) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val rel_sel_thms = let val n = length discAs; fun mk_conjunct n k discA selAs discB selBs = (if k = n then [] else [HOLogic.mk_eq (discA $ ta, discB $ tb)]) @ (if null selAs then [] else [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [discA $ ta, discB $ tb], Library.foldr1 HOLogic.mk_conj (map2 (build_rel_app names_lthy Rs []) (map (rapp ta) selAs) (map (rapp tb) selBs)))]); val goals = if n = 0 then [] else [mk_Trueprop_eq (build_rel_app names_lthy Rs [] ta tb, (case flat (@{map 5} (mk_conjunct n) (1 upto n) discAs selAss discBs selBss) of [] => \<^term>\True\ | conjuncts => Library.foldr1 HOLogic.mk_conj conjuncts))]; fun prove goal = Variable.add_free_names lthy goal [] |> (fn vars => Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rel_sel_tac ctxt (Thm.cterm_of ctxt ta) (Thm.cterm_of ctxt tb) exhaust (flat disc_thmss) (flat sel_thmss) rel_inject_thms distincts rel_distinct_thms live_nesting_rel_eqs)) |> Thm.close_derivation \<^here>; in map prove goals end; val (rel_case_thm, rel_case_attrs) = let val thm = derive_rel_case relAsBs rel_inject_thms rel_distinct_thms; val ctr_names = quasi_unambiguous_case_names (map name_of_ctr ctrAs); in (thm, [Attrib.case_names ctr_names, Attrib.consumes 1] @ @{attributes [cases pred]}) end; val case_transfer_thm = derive_case_transfer rel_case_thm; val sel_transfer_thms = if null selAss then [] else let val shared_sels = foldl1 (uncurry (inter (op =))) (map (op ~~) (selAss ~~ selBss)); val goals = map (uncurry (mk_parametricity_goal names_lthy Rs)) shared_sels; in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_sel_transfer_tac ctxt n sel_defs case_transfer_thm) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val disc_transfer_thms = let val goals = map2 (mk_parametricity_goal names_lthy Rs) discAs discBs in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_disc_transfer_tac ctxt (the_single rel_sel_thms) (the_single exhaust_discs) (flat (flat distinct_discsss))) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val map_disc_iff_thms = let val discsB = map (mk_disc_or_sel Bs) discs; val discsA_t = map (fn disc1 => Term.betapply (disc1, ta)) discAs; fun mk_goal (discA_t, discB) = if head_of discA_t aconv HOLogic.Not orelse is_refl_bool discA_t then NONE else SOME (mk_Trueprop_eq (betapply (discB, (Term.list_comb (mapx, fs) $ ta)), discA_t)); val goals = map_filter mk_goal (discsA_t ~~ discsB); in if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_map_disc_iff_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) map_thms) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end end; val (map_sel_thmss, map_sel_thms) = let fun mk_goal discA selA selB = let val prem = Term.betapply (discA, ta); val lhs = selB $ (Term.list_comb (mapx, fs) $ ta); val lhsT = fastype_of lhs; val map_rhsT = map_atyps (perhaps (AList.lookup (op =) (map swap live_AsBs))) lhsT; val map_rhs = build_map lthy [] [] (the o (AList.lookup (op =) (live_AsBs ~~ fs))) (map_rhsT, lhsT); val rhs = (case map_rhs of Const (\<^const_name>\id\, _) => selA $ ta | _ => map_rhs $ (selA $ ta)); val concl = mk_Trueprop_eq (lhs, rhs); in if is_refl_bool prem then concl else Logic.mk_implies (HOLogic.mk_Trueprop prem, concl) end; val goalss = @{map 3} (map2 o mk_goal) discAs selAss selBss; val goals = flat goalss; in `(unflat goalss) (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_map_sel_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) map_thms (flat sel_thmss) live_nesting_map_id0s) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val (set_sel_thmssss, set_sel_thms) = let fun mk_goal setA discA selA ctxt = let val prem = Term.betapply (discA, ta); val sel_rangeT = range_type (fastype_of selA); val A = HOLogic.dest_setT (range_type (fastype_of setA)); fun travese_nested_types t ctxt = (case fastype_of t of Type (type_name, innerTs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => let fun seq_assm a set ctxt = let val T = HOLogic.dest_setT (range_type (fastype_of set)); val (x, ctxt') = yield_singleton (mk_Frees "x") T ctxt; val assm = mk_Trueprop_mem (x, set $ a); in travese_nested_types x ctxt' |>> map (Logic.mk_implies o pair assm) end; in fold_map (seq_assm t o mk_set innerTs) (sets_of_bnf bnf) ctxt |>> flat end) | T => if T = A then ([mk_Trueprop_mem (t, setA $ ta)], ctxt) else ([], ctxt)); val (concls, ctxt') = if sel_rangeT = A then ([mk_Trueprop_mem (selA $ ta, setA $ ta)], ctxt) else travese_nested_types (selA $ ta) ctxt; in if exists_subtype_in [A] sel_rangeT then if is_refl_bool prem then (concls, ctxt') else (map (Logic.mk_implies o pair (HOLogic.mk_Trueprop prem)) concls, ctxt') else ([], ctxt) end; val (goalssss, _) = fold_map (fn set => @{fold_map 2} (fold_map o mk_goal set) discAs selAss) setAs names_lthy; val goals = flat (flat (flat goalssss)); in `(unflattt goalssss) (if null goals then [] else let val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_set_sel_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) (flat sel_thmss) set0_thms) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end) end; val pred_injects = let - fun top_sweep_rewr_conv rewrs = - Conv.top_sweep_conv (K (Conv.rewrs_conv rewrs)) \<^context>; - - val rel_eq_onp_with_tops_of = Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.arg1_conv - (top_sweep_rewr_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]}))); + val rel_eq_onp_with_tops_of = + Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.arg1_conv + (Conv.top_sweep_rewrs_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]} lthy))); val eq_onps = map rel_eq_onp_with_tops_of (map rel_eq_onp_of_bnf fp_bnfs @ fp_nesting_rel_eq_onps @ live_nesting_rel_eq_onps @ fp_nested_rel_eq_onps); val cTs = map (SOME o Thm.ctyp_of lthy) (maps (replicate 2) live_As); val cts = map (SOME o Thm.cterm_of lthy) (map mk_eq_onp Ps); val get_rhs = Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq #> snd; val pred_eq_onp_conj = List.foldr (fn (_, thm) => thm RS @{thm eq_onp_live_step}) @{thm refl[of True]}; fun predify_rel_inject rel_inject = let val conjuncts = try (get_rhs #> HOLogic.dest_conj) rel_inject |> the_default []; fun postproc thm = if null conjuncts then thm RS (@{thm eq_onp_same_args} RS iffD1) else @{thm box_equals} OF [thm, @{thm eq_onp_same_args}, pred_eq_onp_conj conjuncts |> unfold_thms lthy @{thms simp_thms(21)}]; in rel_inject |> Thm.instantiate' cTs cts |> Conv.fconv_rule (HOLogic.Trueprop_conv (Conv.arg_conv (Raw_Simplifier.rewrite lthy false @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]}))) |> unfold_thms lthy eq_onps |> postproc |> unfold_thms lthy @{thms top_conj} end; in rel_inject_thms |> map (unfold_thms lthy [@{thm conj_assoc}]) |> map predify_rel_inject |> Proof_Context.export names_lthy lthy end; val anonymous_notes = [(rel_code_thms, nitpicksimp_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); val notes = (if Config.get lthy bnf_internals then [(set0N, set0_thms, K [])] else []) @ [(case_transferN, [case_transfer_thm], K []), (ctr_transferN, ctr_transfer_thms, K []), (disc_transferN, disc_transfer_thms, K []), (sel_transferN, sel_transfer_thms, K []), (mapN, map_thms, K (nitpicksimp_attrs @ simp_attrs)), (map_disc_iffN, map_disc_iff_thms, K simp_attrs), (map_selN, map_sel_thms, K []), (pred_injectN, pred_injects, K simp_attrs), (rel_casesN, [rel_case_thm], K rel_case_attrs), (rel_distinctN, rel_distinct_thms, K simp_attrs), (rel_injectN, rel_inject_thms, K simp_attrs), (rel_introsN, rel_intro_thms, K []), (rel_selN, rel_sel_thms, K []), (setN, set_thms, K (case_fp fp nitpicksimp_attrs [] @ simp_attrs)), (set_casesN, set_cases_thms, nth set_cases_attrss), (set_introsN, set_intros_thms, K []), (set_selN, set_sel_thms, K [])] |> massage_simple_notes fp_b_name; val (noted, lthy') = lthy |> uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational) (`(single o lhs_head_of o hd) map_thms) |> fp = Least_FP ? uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational) (`(single o lhs_head_of o hd) rel_code_thms) |> uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational) (`(single o lhs_head_of o hd) set0_thms) |> plugins code_plugin ? Code.declare_default_eqns (map (rpair true) (rel_code_thms @ map_thms @ set_thms)) |> Local_Theory.notes (anonymous_notes @ notes); val subst = Morphism.thm (substitute_noted_thm noted); in ((map subst map_thms, map subst map_disc_iff_thms, map (map subst) map_sel_thmss, map subst rel_inject_thms, map subst rel_distinct_thms, map subst rel_sel_thms, map subst rel_intro_thms, [subst rel_case_thm], map subst pred_injects, map subst set_thms, map (map (map (map subst))) set_sel_thmssss, map (map (map (map subst))) set_intros_thmssss, map subst set_cases_thms, map subst ctr_transfer_thms, [subst case_transfer_thm], map subst disc_transfer_thms, map subst sel_transfer_thms), lthy') end end; type lfp_sugar_thms = (thm list * thm * Token.src list) * (thm list list * Token.src list); fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (recss, rec_attrs)) = ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs), (map (map (Morphism.thm phi)) recss, rec_attrs)) : lfp_sugar_thms; val transfer_lfp_sugar_thms = morph_lfp_sugar_thms o Morphism.transfer_morphism; type gfp_sugar_thms = ((thm list * thm) list * (Token.src list * Token.src list)) * thm list list * thm list list * (thm list list * Token.src list) * (thm list list list * Token.src list); fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs_pair), corecss, corec_discss, (corec_disc_iffss, corec_disc_iff_attrs), (corec_selsss, corec_sel_attrs)) = ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs, coinduct_attrs_pair), map (map (Morphism.thm phi)) corecss, map (map (Morphism.thm phi)) corec_discss, (map (map (Morphism.thm phi)) corec_disc_iffss, corec_disc_iff_attrs), (map (map (map (Morphism.thm phi))) corec_selsss, corec_sel_attrs)) : gfp_sugar_thms; val transfer_gfp_sugar_thms = morph_gfp_sugar_thms o Morphism.transfer_morphism; fun unzip_recT (Type (\<^type_name>\prod\, [_, TFree x])) (T as Type (\<^type_name>\prod\, Ts as [_, TFree y])) = if x = y then [T] else Ts | unzip_recT _ (Type (\<^type_name>\prod\, Ts as [_, TFree _])) = Ts | unzip_recT _ T = [T]; fun mk_recs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss ctor_rec_fun_Ts = let val Css = map2 replicate ns Cs; val x_Tssss = @{map 6} (fn absT => fn repT => fn n => fn ms => fn ctr_Tss => fn ctor_rec_fun_T => map2 (map2 unzip_recT) ctr_Tss (dest_absumprodT absT repT n ms (domain_type ctor_rec_fun_T))) absTs repTs ns mss ctr_Tsss ctor_rec_fun_Ts; val x_Tsss' = map (map flat_rec_arg_args) x_Tssss; val f_Tss = map2 (map2 (curry (op --->))) x_Tsss' Css; val ((fss, xssss), _) = ctxt |> mk_Freess "f" f_Tss ||>> mk_Freessss "x" x_Tssss; in (f_Tss, x_Tssss, fss, xssss) end; fun unzip_corecT (Type (\<^type_name>\sum\, _)) T = [T] | unzip_corecT _ (Type (\<^type_name>\sum\, Ts)) = Ts | unzip_corecT _ T = [T]; (*avoid "'a itself" arguments in corecursors*) fun repair_nullary_single_ctr [[]] = [[HOLogic.unitT]] | repair_nullary_single_ctr Tss = Tss; fun mk_corec_fun_arg_types0 ctr_Tsss Cs absTs repTs ns mss fun_Ts = let val ctr_Tsss' = map repair_nullary_single_ctr ctr_Tsss; val g_absTs = map range_type fun_Ts; val g_Tsss = map repair_nullary_single_ctr (@{map 5} dest_absumprodT absTs repTs ns mss g_absTs); val g_Tssss = @{map 3} (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT))) Cs ctr_Tsss' g_Tsss; val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) g_Tssss; in (q_Tssss, g_Tsss, g_Tssss, g_absTs) end; fun mk_corec_p_pred_types Cs ns = map2 (fn n => replicate (Int.max (0, n - 1)) o mk_pred1T) ns Cs; fun mk_corec_fun_arg_types ctr_Tsss Cs absTs repTs ns mss dtor_corec = (mk_corec_p_pred_types Cs ns, mk_corec_fun_arg_types0 ctr_Tsss Cs absTs repTs ns mss (binder_fun_types (fastype_of dtor_corec))); fun mk_corecs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss dtor_corec_fun_Ts = let val p_Tss = mk_corec_p_pred_types Cs ns; val (q_Tssss, g_Tsss, g_Tssss, corec_types) = mk_corec_fun_arg_types0 ctr_Tsss Cs absTs repTs ns mss dtor_corec_fun_Ts; val (((((Free (x, _), cs), pss), qssss), gssss), _) = ctxt |> yield_singleton (mk_Frees "x") dummyT ||>> mk_Frees "a" Cs ||>> mk_Freess "p" p_Tss ||>> mk_Freessss "q" q_Tssss ||>> mk_Freessss "g" g_Tssss; val cpss = map2 (map o rapp) cs pss; fun build_sum_inj mk_inj = build_map ctxt [] [] (uncurry mk_inj o dest_sumT o snd); fun build_dtor_corec_arg _ [] [cg] = cg | build_dtor_corec_arg T [cq] [cg, cg'] = mk_If cq (build_sum_inj Inl_const (fastype_of cg, T) $ cg) (build_sum_inj Inr_const (fastype_of cg', T) $ cg'); val pgss = @{map 3} flat_corec_preds_predsss_gettersss pss qssss gssss; val cqssss = map2 (map o map o map o rapp) cs qssss; val cgssss = map2 (map o map o map o rapp) cs gssss; val cqgsss = @{map 3} (@{map 3} (@{map 3} build_dtor_corec_arg)) g_Tsss cqssss cgssss; in (x, cs, cpss, (((pgss, pss, qssss, gssss), cqgsss), corec_types)) end; fun mk_co_recs_prelims ctxt fp ctr_Tsss fpTs Cs absTs repTs ns mss xtor_co_recs0 = let val thy = Proof_Context.theory_of ctxt; val (xtor_co_rec_fun_Ts, xtor_co_recs) = mk_xtor_co_recs thy fp fpTs Cs xtor_co_recs0 |> `(binder_fun_types o fastype_of o hd); val (recs_args_types, corecs_args_types) = if fp = Least_FP then mk_recs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss xtor_co_rec_fun_Ts |> (rpair NONE o SOME) else mk_corecs_args_types ctxt ctr_Tsss Cs absTs repTs ns mss xtor_co_rec_fun_Ts |> (pair NONE o SOME); in (xtor_co_recs, recs_args_types, corecs_args_types) end; fun mk_preds_getterss_join c cps absT abs cqgss = let val n = length cqgss; val ts = map2 (mk_absumprod absT abs n) (1 upto n) cqgss; in Term.lambda c (mk_IfN absT cps ts) end; fun define_co_rec_as fp Cs fpT b rhs lthy0 = let val thy = Proof_Context.theory_of lthy0; val ((cst, (_, def)), (lthy', lthy)) = lthy0 |> (snd o Local_Theory.begin_nested) |> Local_Theory.define ((b, NoSyn), ((Thm.make_def_binding (Config.get lthy0 bnf_internals) b, []), rhs)) ||> `Local_Theory.end_nested; val phi = Proof_Context.export_morphism lthy lthy'; val cst' = mk_co_rec thy fp Cs fpT (Morphism.term phi cst); val def' = Morphism.thm phi def; in ((cst', def'), lthy') end; fun define_rec (_, _, fss, xssss) mk_binding fpTs Cs reps ctor_rec = let val nn = length fpTs; val (ctor_rec_absTs, fpT) = strip_typeN nn (fastype_of ctor_rec) |>> map domain_type ||> domain_type; in define_co_rec_as Least_FP Cs fpT (mk_binding recN) (fold_rev (fold_rev Term.lambda) fss (Term.list_comb (ctor_rec, @{map 4} (fn ctor_rec_absT => fn rep => fn fs => fn xsss => mk_case_absumprod ctor_rec_absT rep fs (map (map HOLogic.mk_tuple) xsss) (map flat_rec_arg_args xsss)) ctor_rec_absTs reps fss xssss))) end; fun define_corec (_, cs, cpss, (((pgss, _, _, _), cqgsss), f_absTs)) mk_binding fpTs Cs abss dtor_corec = let val nn = length fpTs; val fpT = range_type (snd (strip_typeN nn (fastype_of dtor_corec))); in define_co_rec_as Greatest_FP Cs fpT (mk_binding corecN) (fold_rev (fold_rev Term.lambda) pgss (Term.list_comb (dtor_corec, @{map 5} mk_preds_getterss_join cs cpss f_absTs abss cqgsss))) end; fun mk_induct_raw_prem_prems names_ctxt Xss setss_fp_nesting (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) = (case AList.lookup (op =) setss_fp_nesting T_name of NONE => [] | SOME raw_sets0 => let val (Xs_Ts, (Ts, raw_sets)) = filter (exists_subtype_in (flat Xss) o fst) (Xs_Ts0 ~~ (Ts0 ~~ raw_sets0)) |> split_list ||> split_list; val sets = map (mk_set Ts0) raw_sets; val (ys, names_ctxt') = names_ctxt |> mk_Frees s Ts; val xysets = map (pair x) (ys ~~ sets); val ppremss = map2 (mk_induct_raw_prem_prems names_ctxt' Xss setss_fp_nesting) ys Xs_Ts; in flat (map2 (map o apfst o cons) xysets ppremss) end) | mk_induct_raw_prem_prems _ Xss _ (x as Free (_, Type _)) X = [([], (find_index (fn Xs => member (op =) Xs X) Xss + 1, x))] | mk_induct_raw_prem_prems _ _ _ _ _ = []; fun mk_induct_raw_prem alter_x names_ctxt Xss setss_fp_nesting p ctr ctr_Ts ctrXs_Ts = let val (xs, names_ctxt') = names_ctxt |> mk_Frees "x" ctr_Ts; val pprems = flat (map2 (mk_induct_raw_prem_prems names_ctxt' Xss setss_fp_nesting) xs ctrXs_Ts); val y = Term.list_comb (ctr, map alter_x xs); val p' = enforce_type names_ctxt domain_type (fastype_of y) p; in (xs, pprems, HOLogic.mk_Trueprop (p' $ y)) end; fun close_induct_prem_prem nn ps xs t = fold_rev Logic.all (map Free (drop (nn + length xs) (rev (Term.add_frees t (map dest_Free xs @ map_filter (try dest_Free) ps))))) t; fun finish_induct_prem_prem ctxt nn ps xs (xysets, (j, x)) = let val p' = enforce_type ctxt domain_type (fastype_of x) (nth ps (j - 1)) in close_induct_prem_prem nn ps xs (Logic.list_implies (map (fn (x', (y, set)) => mk_Trueprop_mem (y, set $ x')) xysets, HOLogic.mk_Trueprop (p' $ x))) end; fun finish_induct_prem ctxt nn ps (xs, raw_pprems, concl) = fold_rev Logic.all xs (Logic.list_implies (map (finish_induct_prem_prem ctxt nn ps xs) raw_pprems, concl)); fun mk_coinduct_prem_ctr_concls ctxt Xss fpTss rs' n k udisc usels vdisc vsels ctrXs_Ts = let fun build_the_rel T Xs_T = build_rel [] ctxt [] [] (fn (T, X) => nth rs' (find_index (fn Xs => member (op =) Xs X) Xss) |> enforce_type ctxt domain_type T) (T, Xs_T) |> Term.subst_atomic_types (flat Xss ~~ flat fpTss); fun build_rel_app usel vsel Xs_T = fold rapp [usel, vsel] (build_the_rel (fastype_of usel) Xs_T); in (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @ (if null usels then [] else [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc], Library.foldr1 HOLogic.mk_conj (@{map 3} build_rel_app usels vsels ctrXs_Ts))]) end; fun mk_coinduct_prem_concl ctxt Xss fpTss rs' n udiscs uselss vdiscs vselss ctrXs_Tss = @{map 6} (mk_coinduct_prem_ctr_concls ctxt Xss fpTss rs' n) (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss |> flat |> Library.foldr1 HOLogic.mk_conj handle List.Empty => \<^term>\True\; fun mk_coinduct_prem ctxt Xss fpTss rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss = fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr, HOLogic.mk_Trueprop (mk_coinduct_prem_concl ctxt Xss fpTss rs' n udiscs uselss vdiscs vselss ctrXs_Tss))); fun postproc_co_induct ctxt nn prop prop_conj = Drule.zero_var_indexes #> `(conj_dests nn) #>> map (fn thm => Thm.permute_prems 0 ~1 (thm RS prop)) ##> (fn thm => Thm.permute_prems 0 (~ nn) (if nn = 1 then thm RS prop else funpow nn (fn thm => unfold_thms ctxt @{thms conj_assoc} (thm RS prop_conj)) thm)); fun mk_induct_attrs ctrss = let val induct_cases = quasi_unambiguous_case_names (maps (map name_of_ctr) ctrss); in [Attrib.case_names induct_cases] end; fun derive_rel_induct_thms_for_types ctxt nn fpA_Ts As Bs ctrAss ctrAs_Tsss exhausts ctor_rel_induct ctor_defss ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs = let val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val B_ify = Term.map_types B_ify_T; val fpB_Ts = map B_ify_T fpA_Ts; val ctrBs_Tsss = map (map (map B_ify_T)) ctrAs_Tsss; val ctrBss = map (map B_ify) ctrAss; val ((((Rs, IRs), ctrAsss), ctrBsss), names_ctxt) = ctxt |> mk_Frees "R" (map2 mk_pred2T As Bs) ||>> mk_Frees "IR" (map2 mk_pred2T fpA_Ts fpB_Ts) ||>> mk_Freesss "a" ctrAs_Tsss ||>> mk_Freesss "b" ctrBs_Tsss; val prems = let fun mk_prem ctrA ctrB argAs argBs = fold_rev Logic.all (argAs @ argBs) (fold_rev (curry Logic.mk_implies) (map2 (HOLogic.mk_Trueprop oo build_rel_app names_ctxt (Rs @ IRs) fpA_Ts) argAs argBs) (HOLogic.mk_Trueprop (build_rel_app names_ctxt (Rs @ IRs) fpA_Ts (Term.list_comb (ctrA, argAs)) (Term.list_comb (ctrB, argBs))))); in flat (@{map 4} (@{map 4} mk_prem) ctrAss ctrBss ctrAsss ctrBsss) end; val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_leq (map2 (build_the_rel ctxt (Rs @ IRs) []) fpA_Ts fpB_Ts) IRs)); val vars = Variable.add_free_names ctxt goal []; val rel_induct0_thm = Goal.prove_sorry ctxt vars prems goal (fn {context = ctxt, prems} => mk_rel_induct0_tac ctxt ctor_rel_induct prems (map (Thm.cterm_of ctxt) IRs) exhausts ctor_defss ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs) |> Thm.close_derivation \<^here>; in (postproc_co_induct ctxt nn @{thm predicate2D} @{thm predicate2D_conj} rel_induct0_thm, mk_induct_attrs ctrAss) end; fun derive_induct_recs_thms_for_types plugins pre_bnfs rec_args_typess ctor_induct ctor_rec_thms live_nesting_bnfs fp_nesting_bnfs fpTs Cs Xs ctrXs_Tsss pre_abs_inverses pre_type_definitions abs_inverses ctrss ctr_defss recs rec_defs ctxt = let val ctr_Tsss = map (map (binder_types o fastype_of)) ctrss; val nn = length pre_bnfs; val ns = map length ctr_Tsss; val mss = map (map length) ctr_Tsss; val pre_map_defs = map map_def_of_bnf pre_bnfs; val pre_set_defss = map set_defs_of_bnf pre_bnfs; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val fp_nesting_map_ident0s = map map_ident0_of_bnf fp_nesting_bnfs; val fp_nesting_set_maps = maps set_map_of_bnf fp_nesting_bnfs; val fp_b_names = map base_name_of_typ fpTs; val (((ps, xsss), us'), names_ctxt) = ctxt |> mk_Frees "P" (map mk_pred1T fpTs) ||>> mk_Freesss "x" ctr_Tsss ||>> Variable.variant_fixes fp_b_names; val us = map2 (curry Free) us' fpTs; val setss_fp_nesting = map mk_bnf_sets fp_nesting_bnfs; val (induct_thms, induct_thm) = let val raw_premss = @{map 4} (@{map 3} o mk_induct_raw_prem I names_ctxt (map single Xs) setss_fp_nesting) ps ctrss ctr_Tsss ctrXs_Tsss; val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)); val goal = Library.foldr (Logic.list_implies o apfst (map (finish_induct_prem ctxt nn ps))) (raw_premss, concl); val vars = Variable.add_free_names ctxt goal []; val kksss = map (map (map (fst o snd) o #2)) raw_premss; val ctor_induct' = ctor_induct OF (map2 mk_absumprodE pre_type_definitions mss); val thm = Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, ...} => mk_induct_tac ctxt nn ns mss kksss (flat ctr_defss) ctor_induct' pre_abs_inverses abs_inverses fp_nesting_set_maps pre_set_defss) |> Thm.close_derivation \<^here>; in `(conj_dests nn) thm end; val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss; fun mk_rec_thmss (_, x_Tssss, fss, _) recs rec_defs ctor_rec_thms = let val frecs = map (lists_bmoc fss) recs; fun mk_goal frec xctr f xs fxs = fold_rev (fold_rev Logic.all) (xs :: fss) (mk_Trueprop_eq (frec $ xctr, Term.list_comb (f, fxs))); fun maybe_tick (T, U) u f = if try (fst o HOLogic.dest_prodT) U = SOME T then Term.lambda u (HOLogic.mk_prod (u, f $ u)) else f; fun build_rec (x as Free (_, T)) U = if T = U then x else let val build_simple = indexify (perhaps (try (snd o HOLogic.dest_prodT)) o snd) Cs (fn kk => fn TU => maybe_tick TU (nth us kk) (nth frecs kk)); in build_map ctxt [] [] build_simple (T, U) $ x end; val fxsss = map2 (map2 (flat_rec_arg_args oo map2 (map o build_rec))) xsss x_Tssss; val goalss = @{map 5} (@{map 4} o mk_goal) frecs xctrss fss xsss fxsss; val tacss = @{map 4} (map ooo mk_rec_tac pre_map_defs (fp_nesting_map_ident0s @ live_nesting_map_ident0s) rec_defs) ctor_rec_thms pre_abs_inverses abs_inverses ctr_defss; fun prove goal tac = Goal.prove_sorry ctxt [] [] goal (tac o #context) |> Thm.close_derivation \<^here>; in map2 (map2 prove) goalss tacss end; val rec_thmss = mk_rec_thmss (the rec_args_typess) recs rec_defs ctor_rec_thms; in ((induct_thms, induct_thm, mk_induct_attrs ctrss), (rec_thmss, nitpicksimp_attrs @ simp_attrs)) end; fun mk_coinduct_attrs fpTs ctrss discss mss = let val fp_b_names = map base_name_of_typ fpTs; fun mk_coinduct_concls ms discs ctrs = let fun mk_disc_concl disc = [name_of_disc disc]; fun mk_ctr_concl 0 _ = [] | mk_ctr_concl _ ctr = [name_of_ctr ctr]; val disc_concls = map mk_disc_concl (fst (split_last discs)) @ [[]]; val ctr_concls = map2 mk_ctr_concl ms ctrs; in flat (map2 append disc_concls ctr_concls) end; val coinduct_cases = quasi_unambiguous_case_names (map (prefix Eq_prefix) fp_b_names); val coinduct_conclss = @{map 3} (quasi_unambiguous_case_names ooo mk_coinduct_concls) mss discss ctrss; val coinduct_case_names_attr = Attrib.case_names coinduct_cases; val coinduct_case_concl_attrs = map2 (fn casex => fn concls => Attrib.case_conclusion (casex, concls)) coinduct_cases coinduct_conclss; val common_coinduct_attrs = coinduct_case_names_attr :: coinduct_case_concl_attrs; val coinduct_attrs = Attrib.consumes 1 :: coinduct_case_names_attr :: coinduct_case_concl_attrs; in (coinduct_attrs, common_coinduct_attrs) end; fun derive_rel_coinduct_thms_for_types ctxt nn fpA_Ts ns As Bs mss (ctr_sugars : ctr_sugar list) abs_inverses abs_injects ctor_injects dtor_ctors rel_pre_defs ctor_defss dtor_rel_coinduct live_nesting_rel_eqs = let val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val fpB_Ts = map B_ify_T fpA_Ts; val (Rs, IRs, fpAs, fpBs, _) = let val fp_names = map base_name_of_typ fpA_Ts; val ((((Rs, IRs), fpAs_names), fpBs_names), names_ctxt) = ctxt |> mk_Frees "R" (map2 mk_pred2T As Bs) ||>> mk_Frees "IR" (map2 mk_pred2T fpA_Ts fpB_Ts) ||>> Variable.variant_fixes fp_names ||>> Variable.variant_fixes (map (suffix "'") fp_names); in (Rs, IRs, map2 (curry Free) fpAs_names fpA_Ts, map2 (curry Free) fpBs_names fpB_Ts, names_ctxt) end; val ((discA_tss, selA_tsss), (discB_tss, selB_tsss)) = let val discss = map #discs ctr_sugars; val selsss = map #selss ctr_sugars; fun mk_discss ts Ts = map2 (map o rapp) ts (map (map (mk_disc_or_sel Ts)) discss); fun mk_selsss ts Ts = map2 (map o map o rapp) ts (map (map (map (mk_disc_or_sel Ts))) selsss); in ((mk_discss fpAs As, mk_selsss fpAs As), (mk_discss fpBs Bs, mk_selsss fpBs Bs)) end; val prems = let fun mk_prem_ctr_concls n k discA_t selA_ts discB_t selB_ts = (if k = n then [] else [HOLogic.mk_eq (discA_t, discB_t)]) @ (case (selA_ts, selB_ts) of ([], []) => [] | (_ :: _, _ :: _) => [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [discA_t, discB_t], Library.foldr1 HOLogic.mk_conj (map2 (build_rel_app ctxt (Rs @ IRs) fpA_Ts) selA_ts selB_ts))]); fun mk_prem_concl n discA_ts selA_tss discB_ts selB_tss = Library.foldr1 HOLogic.mk_conj (flat (@{map 5} (mk_prem_ctr_concls n) (1 upto n) discA_ts selA_tss discB_ts selB_tss)) handle List.Empty => \<^term>\True\; fun mk_prem IR tA tB n discA_ts selA_tss discB_ts selB_tss = fold_rev Logic.all [tA, tB] (Logic.mk_implies (HOLogic.mk_Trueprop (IR $ tA $ tB), HOLogic.mk_Trueprop (mk_prem_concl n discA_ts selA_tss discB_ts selB_tss))); in @{map 8} mk_prem IRs fpAs fpBs ns discA_tss selA_tsss discB_tss selB_tsss end; val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_leq IRs (map2 (build_the_rel ctxt (Rs @ IRs) []) fpA_Ts fpB_Ts))); val vars = Variable.add_free_names ctxt goal []; val rel_coinduct0_thm = Goal.prove_sorry ctxt vars prems goal (fn {context = ctxt, prems} => mk_rel_coinduct0_tac ctxt dtor_rel_coinduct (map (Thm.cterm_of ctxt) IRs) prems (map #exhaust ctr_sugars) (map (flat o #disc_thmss) ctr_sugars) (map (flat o #sel_thmss) ctr_sugars) ctor_defss dtor_ctors ctor_injects abs_injects rel_pre_defs abs_inverses live_nesting_rel_eqs) |> Thm.close_derivation \<^here>; in (postproc_co_induct ctxt nn @{thm predicate2D} @{thm predicate2D_conj} rel_coinduct0_thm, mk_coinduct_attrs fpA_Ts (map #ctrs ctr_sugars) (map #discs ctr_sugars) mss) end; fun derive_set_induct_thms_for_types ctxt nn fpTs ctrss setss dtor_set_inducts exhausts set_pre_defs ctor_defs dtor_ctors Abs_pre_inverses = let fun mk_prems A Ps ctr_args t ctxt = (case fastype_of t of Type (type_name, innerTs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => let fun seq_assm a set ctxt = let val X = HOLogic.dest_setT (range_type (fastype_of set)); val (x, ctxt') = yield_singleton (mk_Frees "x") X ctxt; val assm = mk_Trueprop_mem (x, set $ a); in (case build_binary_fun_app Ps x a of NONE => mk_prems A Ps ctr_args x ctxt' |>> map (Logic.all x o Logic.mk_implies o pair assm) | SOME f => ([Logic.all x (Logic.mk_implies (assm, Logic.mk_implies (HOLogic.mk_Trueprop f, HOLogic.mk_Trueprop (the (build_binary_fun_app Ps x ctr_args)))))], ctxt')) end; in fold_map (seq_assm t o mk_set innerTs) (sets_of_bnf bnf) ctxt |>> flat end) | T => if T = A then ([HOLogic.mk_Trueprop (the (build_binary_fun_app Ps t ctr_args))], ctxt) else ([], ctxt)); fun mk_prems_for_ctr A Ps ctr ctxt = let val (args, ctxt') = mk_Frees "z" (binder_types (fastype_of ctr)) ctxt; in fold_map (mk_prems A Ps (list_comb (ctr, args))) args ctxt' |>> map (fold_rev Logic.all args) o flat |>> (fn prems => (prems, mk_names (length prems) (name_of_ctr ctr))) end; fun mk_prems_and_concl_for_type A Ps ((fpT, ctrs), set) ctxt = let val ((x, fp), ctxt') = ctxt |> yield_singleton (mk_Frees "x") A ||>> yield_singleton (mk_Frees "a") fpT; val concl = mk_Ball (set $ fp) (Term.absfree (dest_Free x) (the (build_binary_fun_app Ps x fp))); in fold_map (mk_prems_for_ctr A Ps) ctrs ctxt' |>> split_list |>> map_prod flat flat |>> apfst (rpair concl) end; fun mk_thm ctxt fpTs ctrss sets = let val A = HOLogic.dest_setT (range_type (fastype_of (hd sets))); val (Ps, ctxt') = mk_Frees "P" (map (fn fpT => A --> fpT --> HOLogic.boolT) fpTs) ctxt; val (((prems, concl), case_names), ctxt'') = fold_map (mk_prems_and_concl_for_type A Ps) (fpTs ~~ ctrss ~~ sets) ctxt' |>> apfst split_list o split_list |>> apfst (apfst flat) |>> apfst (apsnd (Library.foldr1 HOLogic.mk_conj)) |>> apsnd flat; val vars = fold (Variable.add_free_names ctxt) (concl :: prems) []; val thm = Goal.prove_sorry ctxt vars prems (HOLogic.mk_Trueprop concl) (fn {context = ctxt, prems} => mk_set_induct0_tac ctxt (map (Thm.cterm_of ctxt'') Ps) prems dtor_set_inducts exhausts set_pre_defs ctor_defs dtor_ctors Abs_pre_inverses) |> Thm.close_derivation \<^here>; val case_names_attr = Attrib.case_names (quasi_unambiguous_case_names case_names); val induct_set_attrs = map (Attrib.internal o K o Induct.induct_pred o name_of_set) sets; in (thm, case_names_attr :: induct_set_attrs) end val consumes_attr = Attrib.consumes 1; in map (mk_thm ctxt fpTs ctrss #> nn = 1 ? map_prod (fn thm => rotate_prems ~1 (thm RS bspec)) (cons consumes_attr)) (transpose setss) end; fun mk_coinduct_strong_thm coind rel_eqs rel_monos mk_vimage2p ctxt = let val n = Thm.nprems_of coind; val m = Thm.nprems_of (hd rel_monos) - n; fun mk_inst phi = (phi, Thm.cterm_of ctxt (mk_union (Var phi, HOLogic.eq_const (fst (dest_pred2T (#2 phi)))))); val insts = Term.add_vars (Thm.prop_of coind) [] |> rev |> take n |> map mk_inst; fun mk_unfold rel_eq rel_mono = let val eq = iffD2 OF [rel_eq RS @{thm predicate2_eqD}, refl]; val mono = rel_mono OF (replicate m @{thm order_refl} @ replicate n @{thm eq_subset}); in mk_vimage2p (eq RS (mono RS @{thm predicate2D})) RS eqTrueI end; val unfolds = map2 mk_unfold rel_eqs rel_monos @ @{thms sup_fun_def sup_bool_def imp_disjL all_conj_distrib subst_eq_imp simp_thms(18,21,35)}; in Thm.instantiate (TVars.empty, Vars.make insts) coind |> unfold_thms ctxt unfolds end; fun derive_coinduct_thms_for_types ctxt strong alter_r pre_bnfs dtor_coinduct dtor_ctors live_nesting_bnfs fpTs Xs ctrXs_Tsss ns pre_abs_inverses abs_inverses mk_vimage2p ctr_defss (ctr_sugars : ctr_sugar list) = let val nn = length pre_bnfs; val pre_rel_defs = map rel_def_of_bnf pre_bnfs; val live_nesting_rel_eqs = map rel_eq_of_bnf live_nesting_bnfs; val fp_b_names = map base_name_of_typ fpTs; val discss = map #discs ctr_sugars; val selsss = map #selss ctr_sugars; val exhausts = map #exhaust ctr_sugars; val disc_thmsss = map #disc_thmss ctr_sugars; val sel_thmsss = map #sel_thmss ctr_sugars; val (((rs, us'), vs'), _) = ctxt |> mk_Frees "R" (map (fn T => mk_pred2T T T) fpTs) ||>> Variable.variant_fixes fp_b_names ||>> Variable.variant_fixes (map (suffix "'") fp_b_names); val us = map2 (curry Free) us' fpTs; val udiscss = map2 (map o rapp) us discss; val uselsss = map2 (map o map o rapp) us selsss; val vs = map2 (curry Free) vs' fpTs; val vdiscss = map2 (map o rapp) vs discss; val vselsss = map2 (map o map o rapp) vs selsss; val uvrs = @{map 3} (fn r => fn u => fn v => r $ u $ v) rs us vs; val uv_eqs = map2 (curry HOLogic.mk_eq) us vs; val strong_rs = @{map 4} (fn u => fn v => fn uvr => fn uv_eq => fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs; val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (@{map 3} (fn uvr => fn u => fn v => HOLogic.mk_imp (uvr, HOLogic.mk_eq (u, v))) uvrs us vs)) fun mk_goal rs0' = Logic.list_implies (@{map 9} (mk_coinduct_prem ctxt (map single Xs) (map single fpTs) (map alter_r rs0')) uvrs us vs ns udiscss uselsss vdiscss vselsss ctrXs_Tsss, concl); val goals = map mk_goal ([rs] @ (if strong then [strong_rs] else [])); fun prove dtor_coinduct' goal = Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, ...} => mk_coinduct_tac ctxt live_nesting_rel_eqs nn ns dtor_coinduct' pre_rel_defs pre_abs_inverses abs_inverses dtor_ctors exhausts ctr_defss disc_thmsss sel_thmsss)) |> Thm.close_derivation \<^here>; val rel_eqs = map rel_eq_of_bnf pre_bnfs; val rel_monos = map rel_mono_of_bnf pre_bnfs; val dtor_coinducts = [dtor_coinduct] @ (if strong then [mk_coinduct_strong_thm dtor_coinduct rel_eqs rel_monos mk_vimage2p ctxt] else []); in map2 (postproc_co_induct ctxt nn mp @{thm conj_commute[THEN iffD1]} oo prove) dtor_coinducts goals end; fun derive_coinduct_corecs_thms_for_types ctxt pre_bnfs (x, cs, cpss, (((pgss, _, _, _), cqgsss), _)) dtor_coinduct dtor_injects dtor_ctors dtor_corec_thms live_nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns pre_abs_inverses abs_inverses mk_vimage2p ctr_defss (ctr_sugars : ctr_sugar list) corecs corec_defs = let fun mk_ctor_dtor_corec_thm dtor_inject dtor_ctor corec = iffD1 OF [dtor_inject, trans OF [corec, dtor_ctor RS sym]]; val ctor_dtor_corec_thms = @{map 3} mk_ctor_dtor_corec_thm dtor_injects dtor_ctors dtor_corec_thms; val pre_map_defs = map map_def_of_bnf pre_bnfs; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val fp_b_names = map base_name_of_typ fpTs; val ctrss = map #ctrs ctr_sugars; val discss = map #discs ctr_sugars; val selsss = map #selss ctr_sugars; val disc_thmsss = map #disc_thmss ctr_sugars; val discIss = map #discIs ctr_sugars; val sel_thmsss = map #sel_thmss ctr_sugars; val coinduct_thms_pairs = derive_coinduct_thms_for_types ctxt true I pre_bnfs dtor_coinduct dtor_ctors live_nesting_bnfs fpTs Xs ctrXs_Tsss ns pre_abs_inverses abs_inverses mk_vimage2p ctr_defss ctr_sugars; fun mk_maybe_not pos = not pos ? HOLogic.mk_not; val gcorecs = map (lists_bmoc pgss) corecs; val corec_thmss = let val (us', _) = ctxt |> Variable.variant_fixes fp_b_names; val us = map2 (curry Free) us' fpTs; fun mk_goal c cps gcorec n k ctr m cfs' = fold_rev (fold_rev Logic.all) ([c] :: pgss) (Logic.list_implies (seq_conds (HOLogic.mk_Trueprop oo mk_maybe_not) n k cps, mk_Trueprop_eq (gcorec $ c, Term.list_comb (ctr, take m cfs')))); val mk_U = typ_subst_nonatomic (map2 (fn C => fn fpT => (mk_sumT (fpT, C), fpT)) Cs fpTs); fun tack (c, u) f = let val x' = Free (x, mk_sumT (fastype_of u, fastype_of c)) in Term.lambda x' (mk_case_sum (Term.lambda u u, Term.lambda c (f $ c)) $ x') end; fun build_corec cqg = let val T = fastype_of cqg in if exists_subtype_in Cs T then let val U = mk_U T; val build_simple = indexify fst (map2 (curry mk_sumT) fpTs Cs) (fn kk => fn _ => tack (nth cs kk, nth us kk) (nth gcorecs kk)); in build_map ctxt [] [] build_simple (T, U) $ cqg end else cqg end; val cqgsss' = map (map (map build_corec)) cqgsss; val goalss = @{map 8} (@{map 4} oooo mk_goal) cs cpss gcorecs ns kss ctrss mss cqgsss'; val tacss = @{map 4} (map ooo mk_corec_tac corec_defs live_nesting_map_ident0s) ctor_dtor_corec_thms pre_map_defs abs_inverses ctr_defss; fun prove goal tac = Goal.prove_sorry ctxt [] [] goal (tac o #context) |> Thm.close_derivation \<^here>; in map2 (map2 prove) goalss tacss |> map (map (unfold_thms ctxt @{thms case_sum_if})) end; val corec_disc_iff_thmss = let fun mk_goal c cps gcorec n k disc = mk_Trueprop_eq (disc $ (gcorec $ c), if n = 1 then \<^Const>\True\ else Library.foldr1 HOLogic.mk_conj (seq_conds mk_maybe_not n k cps)); val goalss = @{map 6} (map2 oooo mk_goal) cs cpss gcorecs ns kss discss; fun mk_case_split' cp = Thm.instantiate' [] [SOME (Thm.cterm_of ctxt cp)] @{thm case_split}; val case_splitss' = map (map mk_case_split') cpss; val tacss = @{map 3} (map oo mk_corec_disc_iff_tac) case_splitss' corec_thmss disc_thmsss; fun prove goal tac = Variable.add_free_names ctxt goal [] |> (fn vars => Goal.prove_sorry ctxt vars [] goal (tac o #context)) |> Thm.close_derivation \<^here>; fun proves [_] [_] = [] | proves goals tacs = map2 prove goals tacs; in map2 proves goalss tacss end; fun mk_corec_disc_thms corecs discIs = map (op RS) (corecs ~~ discIs); val corec_disc_thmss = map2 mk_corec_disc_thms corec_thmss discIss; fun mk_corec_sel_thm corec_thm sel sel_thm = let val (domT, ranT) = dest_funT (fastype_of sel); val arg_cong' = Thm.instantiate' (map (SOME o Thm.ctyp_of ctxt) [domT, ranT]) [NONE, NONE, SOME (Thm.cterm_of ctxt sel)] arg_cong |> Thm.varifyT_global; val sel_thm' = sel_thm RSN (2, trans); in corec_thm RS arg_cong' RS sel_thm' end; fun mk_corec_sel_thms corec_thmss = @{map 3} (@{map 3} (map2 o mk_corec_sel_thm)) corec_thmss selsss sel_thmsss; val corec_sel_thmsss = mk_corec_sel_thms corec_thmss; in ((coinduct_thms_pairs, mk_coinduct_attrs fpTs (map #ctrs ctr_sugars) (map #discs ctr_sugars) mss), corec_thmss, corec_disc_thmss, (corec_disc_iff_thmss, simp_attrs), (corec_sel_thmsss, simp_attrs)) end; fun define_co_datatypes prepare_plugins prepare_constraint prepare_typ prepare_term fp construct_fp ((raw_plugins, discs_sels0), specs) lthy = let val plugins = prepare_plugins lthy raw_plugins; val discs_sels = discs_sels0 orelse fp = Greatest_FP; val nn = length specs; val fp_bs = map type_binding_of_spec specs; val fp_b_names = map Binding.name_of fp_bs; val fp_common_name = mk_common_name fp_b_names; val map_bs = map map_binding_of_spec specs; val rel_bs = map rel_binding_of_spec specs; val pred_bs = map pred_binding_of_spec specs; fun prepare_type_arg (_, (ty, c)) = let val TFree (s, _) = prepare_typ lthy ty in TFree (s, prepare_constraint lthy c) end; val Ass0 = map (map prepare_type_arg o type_args_named_constrained_of_spec) specs; val unsorted_Ass0 = map (map (resort_tfree_or_tvar \<^sort>\type\)) Ass0; val unsorted_As = Library.foldr1 (merge_type_args fp) unsorted_Ass0; val num_As = length unsorted_As; val set_boss = map (map fst o type_args_named_constrained_of_spec) specs; val set_bss = map (map (the_default Binding.empty)) set_boss; fun add_fake_type spec = Typedecl.basic_typedecl {final = true} (type_binding_of_spec spec, num_As, Mixfix.reset_pos (mixfix_of_spec spec)); val (fake_T_names, fake_lthy) = fold_map add_fake_type specs lthy; val qsoty = quote o Syntax.string_of_typ fake_lthy; val _ = (case Library.duplicates (op =) unsorted_As of [] => () | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^ "datatype specification")); val bad_args = map (Logic.type_map (singleton (Variable.polymorphic lthy))) unsorted_As |> filter_out Term.is_TVar; val _ = null bad_args orelse error ("Locally fixed type argument " ^ qsoty (hd bad_args) ^ " in " ^ co_prefix fp ^ "datatype specification"); val mixfixes = map mixfix_of_spec specs; val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => () | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b))); val mx_ctr_specss = map mixfixed_ctr_specs_of_spec specs; val ctr_specss = map (map fst) mx_ctr_specss; val ctr_mixfixess = map (map snd) mx_ctr_specss; val disc_bindingss = map (map disc_of_ctr_spec) ctr_specss; val ctr_bindingss = map2 (fn fp_b_name => map (Binding.qualify false fp_b_name o ctr_of_ctr_spec)) fp_b_names ctr_specss; val ctr_argsss = map (map args_of_ctr_spec) ctr_specss; val sel_bindingsss = map (map (map fst)) ctr_argsss; val fake_ctr_Tsss0 = map (map (map (prepare_typ fake_lthy o snd))) ctr_argsss; val raw_sel_default_eqss = map sel_default_eqs_of_spec specs; val (As :: _) :: fake_ctr_Tsss = burrow (burrow (Syntax.check_typs fake_lthy)) (Ass0 :: fake_ctr_Tsss0); val As' = map dest_TFree As; val rhs_As' = fold (fold (fold Term.add_tfreesT)) fake_ctr_Tsss []; val _ = (case subtract (op =) As' rhs_As' of [] => () | extras => error ("Extra type variables on right-hand side: " ^ commas (map (qsoty o TFree) extras))); val fake_Ts = map (fn s => Type (s, As)) fake_T_names; val ((((Bs0, Cs), Es), Xs), _) = lthy |> fold (Variable.declare_typ o resort_tfree_or_tvar dummyS) unsorted_As |> mk_TFrees num_As ||>> mk_TFrees nn ||>> mk_TFrees nn ||>> variant_tfrees fp_b_names; fun eq_fpT_check (T as Type (s, Ts)) (T' as Type (s', Ts')) = s = s' andalso (Ts = Ts' orelse error ("Wrong type arguments in " ^ co_prefix fp ^ "recursive type " ^ qsoty T ^ " (expected " ^ qsoty T' ^ ")")) | eq_fpT_check _ _ = false; fun freeze_fp (T as Type (s, Ts)) = (case find_index (eq_fpT_check T) fake_Ts of ~1 => Type (s, map freeze_fp Ts) | kk => nth Xs kk) | freeze_fp T = T; val unfreeze_fp = Term.typ_subst_atomic (Xs ~~ fake_Ts); val ctrXs_Tsss = map (map (map freeze_fp)) fake_ctr_Tsss; val ctrXs_repTs = map mk_sumprodT_balanced ctrXs_Tsss; val _ = let fun add_deps i = fold (fn T => fold_index (fn (j, X) => (i <> j andalso exists_subtype_in [X] T) ? insert (op =) (i, j)) Xs); val add_missing_nodes = fold (AList.default (op =) o rpair []) (0 upto nn - 1); val deps = fold_index (uncurry (fold o add_deps)) ctrXs_Tsss [] |> AList.group (op =) |> add_missing_nodes; val G = Int_Graph.make (map (apfst (rpair ())) deps); val sccs = map (sort int_ord) (Int_Graph.strong_conn G); val str_of_scc = prefix (co_prefix fp ^ "datatype ") o space_implode " and " o map (suffix " = \" o Long_Name.base_name); fun warn [_] = () | warn sccs = warning ("Defined types not fully mutually " ^ co_prefix fp ^ "recursive\n\ \Alternative specification:\n" ^ cat_lines (map (prefix " " o str_of_scc o map (nth fp_b_names)) sccs)); in warn (order_strong_conn (op =) Int_Graph.make Int_Graph.topological_order deps sccs) end; val killed_As = map_filter (fn (A, set_bos) => if exists is_none set_bos then SOME A else NONE) (As ~~ transpose set_boss); val (((pre_bnfs, absT_infos), _), (fp_res as {bnfs = fp_bnfs as any_fp_bnf :: _, ctors = ctors0, dtors = dtors0, xtor_co_recs = xtor_co_recs0, xtor_co_induct, dtor_ctors, ctor_dtors, ctor_injects, dtor_injects, xtor_maps, xtor_setss, xtor_rels, xtor_co_rec_thms, xtor_rel_co_induct, dtor_set_inducts, xtor_co_rec_transfers, xtor_co_rec_o_maps, ...}, lthy)) = fixpoint_bnf false I (construct_fp mixfixes map_bs rel_bs pred_bs set_bss) fp_bs (map dest_TFree As) (map dest_TFree killed_As) (map dest_TFree Xs) ctrXs_repTs empty_comp_cache lthy handle BAD_DEAD (X, X_backdrop) => (case X_backdrop of Type (bad_tc, _) => let val fake_T = qsoty (unfreeze_fp X); val fake_T_backdrop = qsoty (unfreeze_fp X_backdrop); fun register_hint () = "\nUse the " ^ quote (#1 \<^command_keyword>\bnf\) ^ " command to register " ^ quote bad_tc ^ " as a bounded natural functor to allow nested (co)recursion through \ \it"; in if is_some (bnf_of lthy bad_tc) orelse is_some (fp_sugar_of lthy bad_tc) then error ("Inadmissible " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^ " in type expression " ^ fake_T_backdrop) else if is_some (Old_Datatype_Data.get_info (Proof_Context.theory_of lthy) bad_tc) then error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^ " via the old-style datatype " ^ quote bad_tc ^ " in type expression " ^ fake_T_backdrop ^ register_hint ()) else error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^ " via type constructor " ^ quote bad_tc ^ " in type expression " ^ fake_T_backdrop ^ register_hint ()) end); val time = time lthy; val timer = time (Timer.startRealTimer ()); val fp_nesting_bnfs = nesting_bnfs lthy ctrXs_Tsss Xs; val live_nesting_bnfs = nesting_bnfs lthy ctrXs_Tsss As; val pre_map_defs = map map_def_of_bnf pre_bnfs; val pre_set_defss = map set_defs_of_bnf pre_bnfs; val pre_rel_defs = map rel_def_of_bnf pre_bnfs; val fp_nesting_set_maps = maps set_map_of_bnf fp_nesting_bnfs; val fp_nesting_rel_eq_onps = map rel_eq_onp_of_bnf fp_nesting_bnfs; val live_nesting_map_id0s = map map_id0_of_bnf live_nesting_bnfs; val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs; val live_nesting_set_maps = maps set_map_of_bnf live_nesting_bnfs; val live_nesting_rel_eqs = map rel_eq_of_bnf live_nesting_bnfs; val live_nesting_rel_eq_onps = map rel_eq_onp_of_bnf live_nesting_bnfs; val liveness = liveness_of_fp_bnf num_As any_fp_bnf; val live = live_of_bnf any_fp_bnf; val _ = if live = 0 andalso exists (not o Binding.is_empty) (map_bs @ rel_bs @ pred_bs) then warning "Map function, relator, and predicator names ignored" else (); val Bs = @{map 3} (fn alive => fn A as TFree (_, S) => fn B => if alive then resort_tfree_or_tvar S B else A) liveness As Bs0; val B_ify_T = Term.typ_subst_atomic (As ~~ Bs); val B_ify = Term.map_types B_ify_T; val live_AsBs = filter (op <>) (As ~~ Bs); val abss = map #abs absT_infos; val reps = map #rep absT_infos; val absTs = map #absT absT_infos; val repTs = map #repT absT_infos; val abs_injects = map #abs_inject absT_infos; val abs_inverses = map #abs_inverse absT_infos; val type_definitions = map #type_definition absT_infos; val ctors = map (mk_ctor As) ctors0; val dtors = map (mk_dtor As) dtors0; val fpTs = map (domain_type o fastype_of) dtors; val fpBTs = map B_ify_T fpTs; val real_unfreeze_fp = Term.typ_subst_atomic (Xs ~~ fpTs); val ctr_Tsss = map (map (map real_unfreeze_fp)) ctrXs_Tsss; val ns = map length ctr_Tsss; val kss = map (fn n => 1 upto n) ns; val mss = map (map length) ctr_Tsss; val (xtor_co_recs, recs_args_types, corecs_args_types) = mk_co_recs_prelims lthy fp ctr_Tsss fpTs Cs absTs repTs ns mss xtor_co_recs0; fun define_ctrs_dtrs_for_type_etc fp_bnf fp_b fpT C E ctor dtor xtor_co_rec ctor_dtor dtor_ctor ctor_inject pre_map_def pre_set_defs pre_rel_def fp_map_thm fp_set_thms fp_rel_thm n ks ms abs abs_inject type_definition ctr_bindings ctr_mixfixes ctr_Tss disc_bindings sel_bindingss raw_sel_default_eqs lthy = let val fp_b_name = Binding.name_of fp_b; val ((xss, ctrs0, ctor_iff_dtor_thm, ctr_defs), lthy) = define_ctrs_dtrs_for_type fp_b_name fpT ctor dtor ctor_dtor dtor_ctor n ks abs ctr_bindings ctr_mixfixes ctr_Tss lthy; val ctrs = map (mk_ctr As) ctrs0; val sel_default_eqs = let val sel_Tss = map (map (curry (op -->) fpT)) ctr_Tss; val sel_bTs = flat sel_bindingss ~~ flat sel_Tss |> filter_out (Binding.is_empty o fst) |> distinct (Binding.eq_name o apply2 fst); val sel_default_lthy = fake_local_theory_for_sel_defaults sel_bTs lthy in map (prepare_term sel_default_lthy) raw_sel_default_eqs end; fun mk_binding pre = Binding.qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b); fun massage_res (ctr_sugar, maps_sets_rels) = (maps_sets_rels, (ctrs, xss, ctor_iff_dtor_thm, ctr_defs, ctr_sugar)); in (wrap_ctrs plugins fp discs_sels fp_b_name ctor_inject n ms abs_inject type_definition disc_bindings sel_bindingss sel_default_eqs ctrs0 ctor_iff_dtor_thm ctr_defs #> (fn (ctr_sugar, lthy) => derive_map_set_rel_pred_thms plugins fp live As Bs C E abs_inverses ctr_defs fp_nesting_set_maps fp_nesting_rel_eq_onps live_nesting_map_id0s live_nesting_set_maps live_nesting_rel_eqs live_nesting_rel_eq_onps [] fp_b_name fp_bnf fp_bnfs fpT ctor ctor_dtor dtor_ctor pre_map_def pre_set_defs pre_rel_def fp_map_thm fp_set_thms fp_rel_thm [] [] [] ctr_Tss ctr_sugar lthy |>> pair ctr_sugar) ##>> (if fp = Least_FP then define_rec (the recs_args_types) mk_binding fpTs Cs reps else define_corec (the corecs_args_types) mk_binding fpTs Cs abss) xtor_co_rec #>> apfst massage_res, lthy) end; fun wrap_ctrs_derive_map_set_rel_pred_thms_define_co_rec_for_types (wrap_one_etcs, lthy) = fold_map I wrap_one_etcs lthy |>> apsnd split_list o apfst (apsnd @{split_list 5} o apfst @{split_list 17} o split_list) o split_list; fun mk_simp_thms ({injects, distincts, case_thms, ...} : ctr_sugar) co_recs map_thms rel_injects rel_distincts set_thmss = injects @ distincts @ case_thms @ co_recs @ map_thms @ rel_injects @ rel_distincts @ set_thmss; fun mk_co_rec_transfer_goals lthy co_recs = let val BE_ify = Term.subst_atomic_types (live_AsBs @ (Cs ~~ Es)); val ((Rs, Ss), names_lthy) = lthy |> mk_Frees "R" (map (uncurry mk_pred2T) live_AsBs) ||>> mk_Frees "S" (map2 mk_pred2T Cs Es); val co_recBs = map BE_ify co_recs; in (Rs, Ss, map2 (mk_parametricity_goal lthy (Rs @ Ss)) co_recs co_recBs, names_lthy) end; fun derive_rec_transfer_thms lthy recs rec_defs (SOME (_, _, _, xsssss)) = let val (Rs, Ss, goals, _) = mk_co_rec_transfer_goals lthy recs; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_rec_transfer_tac ctxt nn ns (map (Thm.cterm_of ctxt) Ss) (map (Thm.cterm_of ctxt) Rs) xsssss rec_defs xtor_co_rec_transfers pre_rel_defs live_nesting_rel_eqs) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced nn end; fun derive_rec_o_map_thmss lthy recs rec_defs = if live = 0 then replicate nn [] else let fun variant_names n pre = fst (Variable.variant_fixes (replicate n pre) lthy); val maps0 = map map_of_bnf fp_bnfs; val f_names = variant_names num_As "f"; val fs = map2 (curry Free) f_names (map (op -->) (As ~~ Bs)); val live_gs = AList.find (op =) (fs ~~ liveness) true; val gmaps = map (fn map0 => Term.list_comb (mk_map live As Bs map0, live_gs)) maps0; val rec_arg_Ts = binder_fun_types (hd (map fastype_of recs)); val num_rec_args = length rec_arg_Ts; val g_Ts = map B_ify_T rec_arg_Ts; val g_names = variant_names num_rec_args "g"; val gs = map2 (curry Free) g_names g_Ts; val grecs = map (fn recx => Term.list_comb (Term.map_types B_ify_T recx, gs)) recs; val rec_o_map_lhss = map2 (curry HOLogic.mk_comp) grecs gmaps; val ABfs = (As ~~ Bs) ~~ fs; fun mk_rec_arg_arg (x as Free (_, T)) = let val U = B_ify_T T in if T = U then x else build_map lthy [] [] (the o AList.lookup (op =) ABfs) (T, U) $ x end; fun mk_rec_o_map_arg rec_arg_T h = let val x_Ts = binder_types rec_arg_T; val m = length x_Ts; val x_names = variant_names m "x"; val xs = map2 (curry Free) x_names x_Ts; val xs' = map mk_rec_arg_arg xs; in fold_rev Term.lambda xs (Term.list_comb (h, xs')) end; fun mk_rec_o_map_rhs recx = let val args = map2 mk_rec_o_map_arg rec_arg_Ts gs in Term.list_comb (recx, args) end; val rec_o_map_rhss = map mk_rec_o_map_rhs recs; val rec_o_map_goals = map2 (fold_rev (fold_rev Logic.all) [fs, gs] o HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) rec_o_map_lhss rec_o_map_rhss; val rec_o_map_thms = @{map 3} (fn goal => fn rec_def => fn ctor_rec_o_map => Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => mk_co_rec_o_map_tac ctxt rec_def pre_map_defs live_nesting_map_ident0s abs_inverses ctor_rec_o_map) |> Thm.close_derivation \<^here>) rec_o_map_goals rec_defs xtor_co_rec_o_maps; in map single rec_o_map_thms end; fun derive_note_induct_recs_thms_for_types ((((map_thmss, map_disc_iffss, map_selsss, rel_injectss, rel_distinctss, rel_selss, rel_intross, rel_casess, pred_injectss, set_thmss, set_selsssss, set_introsssss, set_casess, ctr_transferss, case_transferss, disc_transferss, sel_transferss), (ctrss, _, ctor_iff_dtors, ctr_defss, ctr_sugars)), (recs, rec_defs)), lthy) = let val ((induct_thms, induct_thm, induct_attrs), (rec_thmss, rec_attrs)) = derive_induct_recs_thms_for_types plugins pre_bnfs recs_args_types xtor_co_induct xtor_co_rec_thms live_nesting_bnfs fp_nesting_bnfs fpTs Cs Xs ctrXs_Tsss abs_inverses type_definitions abs_inverses ctrss ctr_defss recs rec_defs lthy; val rec_transfer_thmss = map single (derive_rec_transfer_thms lthy recs rec_defs recs_args_types); val induct_type_attr = Attrib.internal o K o Induct.induct_type; val induct_pred_attr = Attrib.internal o K o Induct.induct_pred; val ((rel_induct_thmss, common_rel_induct_thms), (rel_induct_attrs, common_rel_induct_attrs)) = if live = 0 then ((replicate nn [], []), ([], [])) else let val ((rel_induct_thms, common_rel_induct_thm), rel_induct_attrs) = derive_rel_induct_thms_for_types lthy nn fpTs As Bs ctrss ctr_Tsss (map #exhaust ctr_sugars) xtor_rel_co_induct ctr_defss ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs; in ((map single rel_induct_thms, single common_rel_induct_thm), (rel_induct_attrs, rel_induct_attrs)) end; val rec_o_map_thmss = derive_rec_o_map_thmss lthy recs rec_defs; val simp_thmss = @{map 6} mk_simp_thms ctr_sugars rec_thmss map_thmss rel_injectss rel_distinctss set_thmss; val common_notes = (if nn > 1 then [(inductN, [induct_thm], K induct_attrs), (rel_inductN, common_rel_induct_thms, K common_rel_induct_attrs)] else []) |> massage_simple_notes fp_common_name; val notes = [(inductN, map single induct_thms, fn T_name => induct_attrs @ [induct_type_attr T_name]), (recN, rec_thmss, K rec_attrs), (rec_o_mapN, rec_o_map_thmss, K []), (rec_transferN, rec_transfer_thmss, K []), (rel_inductN, rel_induct_thmss, K (rel_induct_attrs @ [induct_pred_attr ""])), (simpsN, simp_thmss, K [])] |> massage_multi_notes fp_b_names fpTs; in lthy |> Spec_Rules.add Binding.empty Spec_Rules.equational recs (flat rec_thmss) |> plugins code_plugin ? Code.declare_default_eqns (map (rpair true) (flat rec_thmss)) |> Local_Theory.notes (common_notes @ notes) (* for "datatype_realizer.ML": *) |>> name_noted_thms (fst (dest_Type (hd fpTs)) ^ implode (map (prefix "_") (tl fp_b_names))) inductN |-> interpret_bnfs_register_fp_sugars plugins fpTs fpBTs Xs Least_FP pre_bnfs absT_infos fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctor_iff_dtors ctr_defss ctr_sugars recs rec_defs map_thmss [induct_thm] (map single induct_thms) rec_thmss (replicate nn []) (replicate nn []) rel_injectss rel_distinctss map_disc_iffss map_selsss rel_selss rel_intross rel_casess pred_injectss set_thmss set_selsssss set_introsssss set_casess ctr_transferss case_transferss disc_transferss sel_transferss (replicate nn []) (replicate nn []) rec_transfer_thmss common_rel_induct_thms rel_induct_thmss [] (replicate nn []) rec_o_map_thmss end; fun derive_corec_transfer_thms lthy corecs corec_defs = let val (Rs, Ss, goals, _) = mk_co_rec_transfer_goals lthy corecs; val (_, _, _, (((pgss, pss, qssss, gssss), _), _)) = the corecs_args_types; val goal = Logic.mk_conjunction_balanced goals; val vars = Variable.add_free_names lthy goal []; in Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => mk_corec_transfer_tac ctxt (map (Thm.cterm_of ctxt) Ss) (map (Thm.cterm_of ctxt) Rs) type_definitions corec_defs xtor_co_rec_transfers pre_rel_defs live_nesting_rel_eqs (flat pgss) pss qssss gssss) |> Thm.close_derivation \<^here> |> Conjunction.elim_balanced (length goals) end; fun derive_map_o_corec_thmss lthy0 lthy2 corecs corec_defs = if live = 0 then replicate nn [] else let fun variant_names n pre = fst (Variable.variant_fixes (replicate n pre) lthy0); val maps0 = map map_of_bnf fp_bnfs; val f_names = variant_names num_As "f"; val fs = map2 (curry Free) f_names (map (op -->) (As ~~ Bs)); val live_fs = AList.find (op =) (fs ~~ liveness) true; val fmaps = map (fn map0 => Term.list_comb (mk_map live As Bs map0, live_fs)) maps0; val corec_arg_Ts = binder_fun_types (hd (map fastype_of corecs)); val num_rec_args = length corec_arg_Ts; val g_names = variant_names num_rec_args "g"; val gs = map2 (curry Free) g_names corec_arg_Ts; val gcorecs = map (fn corecx => Term.list_comb (corecx, gs)) corecs; val map_o_corec_lhss = map2 (curry HOLogic.mk_comp) fmaps gcorecs; val ABfs = (As ~~ Bs) ~~ fs; fun mk_map_o_corec_arg corec_argB_T g = let val T = range_type (fastype_of g); val U = range_type corec_argB_T; in if T = U then g else HOLogic.mk_comp (build_map lthy2 [] [] (the o AList.lookup (op =) ABfs) (T, U), g) end; fun mk_map_o_corec_rhs corecx = let val args = map2 (mk_map_o_corec_arg o B_ify_T) corec_arg_Ts gs in Term.list_comb (B_ify corecx, args) end; val map_o_corec_rhss = map mk_map_o_corec_rhs corecs; val map_o_corec_goals = map2 (fold_rev (fold_rev Logic.all) [fs, gs] o HOLogic.mk_Trueprop oo curry HOLogic.mk_eq) map_o_corec_lhss map_o_corec_rhss; val map_o_corec_thms = @{map 3} (fn goal => fn corec_def => fn dtor_map_o_corec => Goal.prove_sorry lthy2 [] [] goal (fn {context = ctxt, ...} => mk_co_rec_o_map_tac ctxt corec_def pre_map_defs live_nesting_map_ident0s abs_inverses dtor_map_o_corec) |> Thm.close_derivation \<^here>) map_o_corec_goals corec_defs xtor_co_rec_o_maps; in map single map_o_corec_thms end; fun derive_note_coinduct_corecs_thms_for_types ((((map_thmss, map_disc_iffss, map_selsss, rel_injectss, rel_distinctss, rel_selss, rel_intross, rel_casess, pred_injectss, set_thmss, set_selsssss, set_introsssss, set_casess, ctr_transferss, case_transferss, disc_transferss, sel_transferss), (_, _, ctor_iff_dtors, ctr_defss, ctr_sugars)), (corecs, corec_defs)), lthy) = let val (([(coinduct_thms, coinduct_thm), (coinduct_strong_thms, coinduct_strong_thm)], (coinduct_attrs, common_coinduct_attrs)), corec_thmss, corec_disc_thmss, (corec_disc_iff_thmss, corec_disc_iff_attrs), (corec_sel_thmsss, corec_sel_attrs)) = derive_coinduct_corecs_thms_for_types lthy pre_bnfs (the corecs_args_types) xtor_co_induct dtor_injects dtor_ctors xtor_co_rec_thms live_nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns abs_inverses abs_inverses I ctr_defss ctr_sugars corecs corec_defs; fun distinct_prems ctxt thm = Goal.prove (*no sorry*) ctxt [] [] (thm |> Thm.prop_of |> Logic.strip_horn |>> distinct (op aconv) |> Logic.list_implies) (fn _ => HEADGOAL (cut_tac thm THEN' assume_tac ctxt) THEN ALLGOALS eq_assume_tac); fun eq_ifIN _ [thm] = thm | eq_ifIN ctxt (thm :: thms) = distinct_prems ctxt (@{thm eq_ifI} OF (map (unfold_thms ctxt @{thms atomize_imp[of _ "t = u" for t u]}) [thm, eq_ifIN ctxt thms])); val corec_code_thms = map (eq_ifIN lthy) corec_thmss; val corec_sel_thmss = map flat corec_sel_thmsss; val coinduct_type_attr = Attrib.internal o K o Induct.coinduct_type; val coinduct_pred_attr = Attrib.internal o K o Induct.coinduct_pred; val flat_corec_thms = append oo append; val corec_transfer_thmss = map single (derive_corec_transfer_thms lthy corecs corec_defs); val ((rel_coinduct_thmss, common_rel_coinduct_thms), (rel_coinduct_attrs, common_rel_coinduct_attrs)) = if live = 0 then ((replicate nn [], []), ([], [])) else let val ((rel_coinduct_thms, common_rel_coinduct_thm), (rel_coinduct_attrs, common_rel_coinduct_attrs)) = derive_rel_coinduct_thms_for_types lthy nn fpTs ns As Bs mss ctr_sugars abs_inverses abs_injects ctor_injects dtor_ctors pre_rel_defs ctr_defss xtor_rel_co_induct live_nesting_rel_eqs; in ((map single rel_coinduct_thms, single common_rel_coinduct_thm), (rel_coinduct_attrs, common_rel_coinduct_attrs)) end; val map_o_corec_thmss = derive_map_o_corec_thmss lthy lthy corecs corec_defs; val (set_induct_thms, set_induct_attrss) = derive_set_induct_thms_for_types lthy nn fpTs (map #ctrs ctr_sugars) (map (map (mk_set As)) (map sets_of_bnf fp_bnfs)) dtor_set_inducts (map #exhaust ctr_sugars) (flat pre_set_defss) (flat ctr_defss) dtor_ctors abs_inverses |> split_list; val simp_thmss = @{map 6} mk_simp_thms ctr_sugars (@{map 3} flat_corec_thms corec_disc_thmss corec_disc_iff_thmss corec_sel_thmss) map_thmss rel_injectss rel_distinctss set_thmss; val common_notes = (set_inductN, set_induct_thms, nth set_induct_attrss) :: (if nn > 1 then [(coinductN, [coinduct_thm], K common_coinduct_attrs), (coinduct_strongN, [coinduct_strong_thm], K common_coinduct_attrs), (rel_coinductN, common_rel_coinduct_thms, K common_rel_coinduct_attrs)] else []) |> massage_simple_notes fp_common_name; val notes = [(coinductN, map single coinduct_thms, fn T_name => coinduct_attrs @ [coinduct_type_attr T_name]), (coinduct_strongN, map single coinduct_strong_thms, K coinduct_attrs), (corecN, corec_thmss, K []), (corec_codeN, map single corec_code_thms, K (nitpicksimp_attrs)), (corec_discN, corec_disc_thmss, K []), (corec_disc_iffN, corec_disc_iff_thmss, K corec_disc_iff_attrs), (corec_selN, corec_sel_thmss, K corec_sel_attrs), (corec_transferN, corec_transfer_thmss, K []), (map_o_corecN, map_o_corec_thmss, K []), (rel_coinductN, rel_coinduct_thmss, K (rel_coinduct_attrs @ [coinduct_pred_attr ""])), (simpsN, simp_thmss, K [])] |> massage_multi_notes fp_b_names fpTs; in lthy |> fold (Spec_Rules.add Binding.empty Spec_Rules.equational corecs) [flat corec_sel_thmss, flat corec_thmss] |> plugins code_plugin ? Code.declare_default_eqns (map (rpair true) corec_code_thms) |> Local_Theory.notes (common_notes @ notes) |-> interpret_bnfs_register_fp_sugars plugins fpTs fpBTs Xs Greatest_FP pre_bnfs absT_infos fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctor_iff_dtors ctr_defss ctr_sugars corecs corec_defs map_thmss [coinduct_thm, coinduct_strong_thm] (transpose [coinduct_thms, coinduct_strong_thms]) corec_thmss corec_disc_thmss corec_sel_thmsss rel_injectss rel_distinctss map_disc_iffss map_selsss rel_selss rel_intross rel_casess pred_injectss set_thmss set_selsssss set_introsssss set_casess ctr_transferss case_transferss disc_transferss sel_transferss corec_disc_iff_thmss (map single corec_code_thms) corec_transfer_thmss common_rel_coinduct_thms rel_coinduct_thmss set_induct_thms (replicate nn (if nn = 1 then set_induct_thms else [])) map_o_corec_thmss end; val lthy = lthy |> live > 0 ? fold2 (fn Type (s, _) => fn bnf => register_bnf_raw s bnf) fpTs fp_bnfs |> @{fold_map 29} define_ctrs_dtrs_for_type_etc fp_bnfs fp_bs fpTs Cs Es ctors dtors xtor_co_recs ctor_dtors dtor_ctors ctor_injects pre_map_defs pre_set_defss pre_rel_defs xtor_maps xtor_setss xtor_rels ns kss mss abss abs_injects type_definitions ctr_bindingss ctr_mixfixess ctr_Tsss disc_bindingss sel_bindingsss raw_sel_default_eqss |> wrap_ctrs_derive_map_set_rel_pred_thms_define_co_rec_for_types |> case_fp fp derive_note_induct_recs_thms_for_types derive_note_coinduct_corecs_thms_for_types; val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^ co_prefix fp ^ "datatype")); in lthy end; fun co_datatypes fp = define_co_datatypes (K I) (K I) (K I) (K I) fp; fun co_datatype_cmd fp construct_fp options lthy = define_co_datatypes Plugin_Name.make_filter Typedecl.read_constraint Syntax.parse_typ Syntax.parse_term fp construct_fp options lthy handle EMPTY_DATATYPE s => error ("Cannot define empty datatype " ^ quote s); val parse_ctr_arg = \<^keyword>\(\ |-- parse_binding_colon -- Parse.typ --| \<^keyword>\)\ || Parse.typ >> pair Binding.empty; val parse_ctr_specs = Parse.enum1 "|" (parse_ctr_spec Parse.binding parse_ctr_arg -- Parse.opt_mixfix); val parse_spec = parse_type_args_named_constrained -- Parse.binding -- Parse.opt_mixfix -- (\<^keyword>\=\ |-- parse_ctr_specs) -- parse_map_rel_pred_bindings -- parse_sel_default_eqs; val parse_co_datatype = parse_ctr_options -- Parse.and_list1 parse_spec; fun parse_co_datatype_cmd fp construct_fp = parse_co_datatype >> co_datatype_cmd fp construct_fp; end; diff --git a/src/HOL/Tools/BNF/bnf_fp_n2m_tactics.ML b/src/HOL/Tools/BNF/bnf_fp_n2m_tactics.ML --- a/src/HOL/Tools/BNF/bnf_fp_n2m_tactics.ML +++ b/src/HOL/Tools/BNF/bnf_fp_n2m_tactics.ML @@ -1,102 +1,102 @@ (* Title: HOL/Tools/BNF/bnf_fp_n2m_tactics.ML Author: Dmitriy Traytel, TU Muenchen Copyright 2013 Tactics for mutualization of nested (co)datatypes. *) signature BNF_FP_N2M_TACTICS = sig val mk_rel_xtor_co_induct_tac: BNF_Util.fp_kind -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> {prems: thm list, context: Proof.context} -> tactic val mk_xtor_un_fold_unique_tac: BNF_Util.fp_kind -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> {context: Proof.context, prems: thm list} -> tactic val mk_xtor_un_fold_tac: Proof.context -> int -> thm list -> thm list -> tactic val mk_xtor_un_fold_transfer_tac: Proof.context -> int -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list -> tactic end; structure BNF_FP_N2M_Tactics : BNF_FP_N2M_TACTICS = struct open BNF_Util open BNF_Tactics open BNF_FP_Util val vimage2p_unfolds = o_apply :: @{thms vimage2p_def}; fun unfold_at_most_once_tac ctxt thms = - CONVERSION (Conv.top_sweep_conv (K (Conv.rewrs_conv thms)) ctxt); + CONVERSION (Conv.top_sweep_rewrs_conv thms ctxt); val unfold_once_tac = CHANGED ooo unfold_at_most_once_tac; fun mk_rel_xtor_co_induct_tac fp abs_inverses co_inducts0 rel_defs rel_monos nesting_rel_eqs0 nesting_rel_monos0 {context = ctxt, prems = raw_C_IHs} = let val nesting_rel_eqs = @{thms prod.rel_eq sum.rel_eq} @ nesting_rel_eqs0; val nesting_rel_monos = map (fn thm => rotate_prems ~1 (thm RS @{thm predicate2D})) (@{thms prod.rel_mono sum.rel_mono} @ nesting_rel_monos0); val co_inducts = map (unfold_thms ctxt (vimage2p_unfolds @ nesting_rel_eqs)) co_inducts0; val unfolds = map (fn def => unfold_thms ctxt (id_apply :: vimage2p_unfolds @ abs_inverses @ no_reflexive [def])) rel_defs; val folded_C_IHs = map (fn thm => thm RS @{thm spec2} RS mp) raw_C_IHs; val C_IHs = map2 (curry op |>) folded_C_IHs unfolds; val C_IH_monos = @{map 3} (fn C_IH => fn mono => fn unfold => (mono RSN (2, @{thm vimage2p_mono}), C_IH) |> fp = Greatest_FP ? swap |> op RS |> unfold) folded_C_IHs rel_monos unfolds; val sym_nested_rel_eqs = map mk_sym nesting_rel_eqs; in unfold_thms_tac ctxt vimage2p_unfolds THEN HEADGOAL (CONJ_WRAP_GEN' (rtac ctxt @{thm context_conjI}) (fn thm => rtac ctxt thm THEN_ALL_NEW (rotate_tac ~1 THEN' REPEAT_ALL_NEW (FIRST' [eresolve_tac ctxt C_IHs, eresolve_tac ctxt C_IH_monos, SELECT_GOAL (unfold_thms_tac ctxt nesting_rel_eqs) THEN' rtac ctxt @{thm order_refl}, assume_tac ctxt, resolve_tac ctxt co_inducts, resolve_tac ctxt C_IH_monos THEN_ALL_NEW (TRY o FIRST' [SELECT_GOAL (unfold_thms_tac ctxt sym_nested_rel_eqs) THEN' assume_tac ctxt, rtac ctxt @{thm order_refl}, REPEAT_ALL_NEW (eresolve_tac ctxt nesting_rel_monos)])]))) co_inducts) end; fun mk_xtor_un_fold_unique_tac fp xtor_un_fold_defs map_arg_congs xtor_un_fold_o_maps Rep_o_Abss fp_un_fold_uniques simp_thms map_thms map_defs cache_defs {context = ctxt, prems} = unfold_thms_tac ctxt xtor_un_fold_defs THEN HEADGOAL (REPEAT_DETERM o FIRST' [hyp_subst_tac_thin true ctxt, rtac ctxt refl, rtac ctxt conjI, rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)", OF refl]}, rtac ctxt @{thm arg_cong2[of _ _ _ _ "(\)", OF _ refl]}, resolve_tac ctxt map_arg_congs, resolve_tac ctxt fp_un_fold_uniques THEN_ALL_NEW case_fp fp (K all_tac) (rtac ctxt sym), SELECT_GOAL (CHANGED (unfold_thms_tac ctxt (flat [simp_thms, map_thms, map_defs, xtor_un_fold_defs, xtor_un_fold_o_maps, Rep_o_Abss, prems]))), unfold_once_tac ctxt cache_defs]); fun mk_xtor_un_fold_tac ctxt n simps cache_defs = REPEAT_DETERM (CHANGED (unfold_thms_tac ctxt simps) ORELSE CHANGED (ALLGOALS (unfold_at_most_once_tac ctxt cache_defs))) THEN CONJ_WRAP (K (HEADGOAL (rtac ctxt refl))) (1 upto n); fun mk_xtor_un_fold_transfer_tac ctxt n xtor_un_fold_defs rel_defs fp_un_fold_transfers map_transfers Abs_transfers fp_or_nesting_rel_eqs cache_defs = let val unfold = SELECT_GOAL (unfold_thms_tac ctxt fp_or_nesting_rel_eqs); in unfold_thms_tac ctxt (xtor_un_fold_defs @ rel_defs) THEN HEADGOAL (CONJ_WRAP' (fn thm => EVERY' [REPEAT_DETERM_N n o rtac ctxt rel_funI, rtac ctxt thm THEN_ALL_NEW REPEAT_DETERM o (FIRST' [assume_tac ctxt, rtac ctxt @{thm id_transfer}, rtac ctxt @{thm rel_funD[OF rel_funD[OF comp_transfer]]}, resolve_tac ctxt fp_un_fold_transfers, resolve_tac ctxt map_transfers, unfold_once_tac ctxt cache_defs, resolve_tac ctxt Abs_transfers, rtac ctxt @{thm vimage2p_rel_fun}, unfold THEN' rtac ctxt @{thm vimage2p_rel_fun}])]) fp_un_fold_transfers) end; end; diff --git a/src/HOL/Tools/Lifting/lifting_def_code_dt.ML b/src/HOL/Tools/Lifting/lifting_def_code_dt.ML --- a/src/HOL/Tools/Lifting/lifting_def_code_dt.ML +++ b/src/HOL/Tools/Lifting/lifting_def_code_dt.ML @@ -1,830 +1,834 @@ (* Title: HOL/Tools/Lifting/lifting_def_code_dt.ML Author: Ondrej Kuncar Workaround that allows us to execute lifted constants that have as a return type a datatype containing a subtype; lift_definition command *) signature LIFTING_DEF_CODE_DT = sig type rep_isom_data val isom_of_rep_isom_data: rep_isom_data -> term val transfer_of_rep_isom_data: rep_isom_data -> thm val bundle_name_of_rep_isom_data: rep_isom_data -> string val pointer_of_rep_isom_data: rep_isom_data -> string type code_dt val rty_of_code_dt: code_dt -> typ val qty_of_code_dt: code_dt -> typ val wit_of_code_dt: code_dt -> term val wit_thm_of_code_dt: code_dt -> thm val rep_isom_data_of_code_dt: code_dt -> rep_isom_data option val morph_code_dt: morphism -> code_dt -> code_dt val mk_witness_of_code_dt: typ -> code_dt -> term val mk_rep_isom_of_code_dt: typ -> code_dt -> term option val code_dt_of: Proof.context -> typ * typ -> code_dt option val code_dt_of_global: theory -> typ * typ -> code_dt option val all_code_dt_of: Proof.context -> code_dt list val all_code_dt_of_global: theory -> code_dt list type config_code_dt = { code_dt: bool, lift_config: Lifting_Def.config } val default_config_code_dt: config_code_dt val add_lift_def_code_dt: config_code_dt -> binding * mixfix -> typ -> term -> thm -> thm list -> local_theory -> Lifting_Def.lift_def * local_theory val lift_def_code_dt: config_code_dt -> binding * mixfix -> typ -> term -> (Proof.context -> tactic) -> thm list -> local_theory -> Lifting_Def.lift_def * local_theory val lift_def_cmd: string list * (binding * string option * mixfix) * string * (Facts.ref * Token.src list) list -> local_theory -> Proof.state end structure Lifting_Def_Code_Dt: LIFTING_DEF_CODE_DT = struct open Ctr_Sugar_Util BNF_Util BNF_FP_Util BNF_FP_Def_Sugar Lifting_Def Lifting_Util infix 0 MRSL (** data structures **) (* all type variables in qty are in rty *) datatype rep_isom_data = REP_ISOM of { isom: term, transfer: thm, bundle_name: string, pointer: string } fun isom_of_rep_isom_data (REP_ISOM rep_isom) = #isom rep_isom; fun transfer_of_rep_isom_data (REP_ISOM rep_isom) = #transfer rep_isom; fun bundle_name_of_rep_isom_data (REP_ISOM rep_isom) = #bundle_name rep_isom; fun pointer_of_rep_isom_data (REP_ISOM rep_isom) = #pointer rep_isom; datatype code_dt = CODE_DT of { rty: typ, qty: typ, wit: term, wit_thm: thm, rep_isom_data: rep_isom_data option }; fun rty_of_code_dt (CODE_DT code_dt) = #rty code_dt; fun qty_of_code_dt (CODE_DT code_dt) = #qty code_dt; fun wit_of_code_dt (CODE_DT code_dt) = #wit code_dt; fun wit_thm_of_code_dt (CODE_DT code_dt) = #wit_thm code_dt; fun rep_isom_data_of_code_dt (CODE_DT code_dt) = #rep_isom_data code_dt; fun ty_alpha_equiv (T, U) = Type.raw_instance (T, U) andalso Type.raw_instance (U, T); fun code_dt_eq c = (ty_alpha_equiv o apply2 rty_of_code_dt) c andalso (ty_alpha_equiv o apply2 qty_of_code_dt) c; fun term_of_code_dt code_dt = code_dt |> `rty_of_code_dt ||> qty_of_code_dt |> HOLogic.mk_prodT |> Net.encode_type |> single; (* modulo renaming, typ must contain TVars *) fun is_code_dt_of_type (rty, qty) code_dt = code_dt |> `rty_of_code_dt ||> qty_of_code_dt |> HOLogic.mk_prodT |> curry ty_alpha_equiv (HOLogic.mk_prodT (rty, qty)); fun mk_rep_isom_data isom transfer bundle_name pointer = REP_ISOM { isom = isom, transfer = transfer, bundle_name = bundle_name, pointer = pointer} fun mk_code_dt rty qty wit wit_thm rep_isom_data = CODE_DT { rty = rty, qty = qty, wit = wit, wit_thm = wit_thm, rep_isom_data = rep_isom_data }; fun map_rep_isom_data f1 f2 f3 f4 (REP_ISOM { isom = isom, transfer = transfer, bundle_name = bundle_name, pointer = pointer }) = REP_ISOM { isom = f1 isom, transfer = f2 transfer, bundle_name = f3 bundle_name, pointer = f4 pointer }; fun map_code_dt f1 f2 f3 f4 f5 f6 f7 f8 (CODE_DT {rty = rty, qty = qty, wit = wit, wit_thm = wit_thm, rep_isom_data = rep_isom_data}) = CODE_DT {rty = f1 rty, qty = f2 qty, wit = f3 wit, wit_thm = f4 wit_thm, rep_isom_data = Option.map (map_rep_isom_data f5 f6 f7 f8) rep_isom_data}; fun update_rep_isom isom transfer binding pointer i = mk_code_dt (rty_of_code_dt i) (qty_of_code_dt i) (wit_of_code_dt i) (wit_thm_of_code_dt i) (SOME (mk_rep_isom_data isom transfer binding pointer)) fun morph_code_dt phi = let val mty = Morphism.typ phi val mterm = Morphism.term phi val mthm = Morphism.thm phi in map_code_dt mty mty mterm mthm mterm mthm I I end val transfer_code_dt = morph_code_dt o Morphism.transfer_morphism; structure Data = Generic_Data ( type T = code_dt Item_Net.T val empty = Item_Net.init code_dt_eq term_of_code_dt val extend = I val merge = Item_Net.merge ); fun code_dt_of_generic context (rty, qty) = let val typ = HOLogic.mk_prodT (rty, qty) val prefiltred = Item_Net.retrieve_matching (Data.get context) (Net.encode_type typ) in prefiltred |> filter (is_code_dt_of_type (rty, qty)) |> map (transfer_code_dt (Context.theory_of context)) |> find_first (fn _ => true) end; fun code_dt_of ctxt (rty, qty) = let val sch_rty = Logic.type_map (singleton (Variable.polymorphic ctxt)) rty val sch_qty = Logic.type_map (singleton (Variable.polymorphic ctxt)) qty in code_dt_of_generic (Context.Proof ctxt) (sch_rty, sch_qty) end; fun code_dt_of_global thy (rty, qty) = let val sch_rty = Logic.varifyT_global rty val sch_qty = Logic.varifyT_global qty in code_dt_of_generic (Context.Theory thy) (sch_rty, sch_qty) end; fun all_code_dt_of_generic context = Item_Net.content (Data.get context) |> map (transfer_code_dt (Context.theory_of context)); val all_code_dt_of = all_code_dt_of_generic o Context.Proof; val all_code_dt_of_global = all_code_dt_of_generic o Context.Theory; fun update_code_dt code_dt = (snd o Local_Theory.begin_nested) #> Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Data.map (Item_Net.update (morph_code_dt phi code_dt))) #> Local_Theory.end_nested fun mk_match_of_code_dt qty code_dt = Vartab.empty |> Type.raw_match (qty_of_code_dt code_dt, qty) |> Vartab.dest |> map (fn (x, (S, T)) => (TVar (x, S), T)); fun mk_witness_of_code_dt qty code_dt = Term.subst_atomic_types (mk_match_of_code_dt qty code_dt) (wit_of_code_dt code_dt) fun mk_rep_isom_of_code_dt qty code_dt = Option.map (isom_of_rep_isom_data #> Term.subst_atomic_types (mk_match_of_code_dt qty code_dt)) (rep_isom_data_of_code_dt code_dt) (** unique name for a type **) fun var_name name sort = if sort = \<^sort>\{type}\ orelse sort = [] then ["x" ^ name] else "x" ^ name :: "x_" :: sort @ ["x_"]; fun concat_Tnames (Type (name, ts)) = name :: maps concat_Tnames ts | concat_Tnames (TFree (name, sort)) = var_name name sort | concat_Tnames (TVar ((name, _), sort)) = var_name name sort; fun unique_Tname (rty, qty) = let val Tnames = map Long_Name.base_name (concat_Tnames rty @ ["x_x"] @ concat_Tnames qty); in fold (Binding.qualify false) (tl Tnames) (Binding.name (hd Tnames)) end; (** witnesses **) fun mk_undefined T = Const (\<^const_name>\undefined\, T); fun mk_witness quot_thm = let val wit_thm = quot_thm RS @{thm type_definition_Quotient_not_empty_witness} val wit = quot_thm_rep quot_thm $ mk_undefined (quot_thm_rty_qty quot_thm |> snd) in (wit, wit_thm) end (** config **) type config_code_dt = { code_dt: bool, lift_config: config } val default_config_code_dt = { code_dt = false, lift_config = default_config } (** Main code **) val ld_no_notes = { notes = false } fun comp_lift_error _ _ = error "Composition of abstract types has not been implemented yet." fun lift qty (quot_thm, (lthy, rel_eq_onps)) = let val quot_thm = Lifting_Term.force_qty_type lthy qty quot_thm val (rty, qty) = quot_thm_rty_qty quot_thm; in if is_none (code_dt_of lthy (rty, qty)) then let val (wit, wit_thm) = (mk_witness quot_thm handle THM _ => error ("code_dt: " ^ quote (Tname qty) ^ " was not defined as a subtype.")) val code_dt = mk_code_dt rty qty wit wit_thm NONE in (quot_thm, (update_code_dt code_dt lthy, rel_eq_onps)) end else (quot_thm, (lthy, rel_eq_onps)) end; fun case_tac rule = Subgoal.FOCUS_PARAMS (fn {context = ctxt, params, ...} => HEADGOAL (rtac ctxt (infer_instantiate' ctxt [SOME (snd (hd params))] rule))); fun bundle_name_of_bundle_binding binding phi context = Name_Space.full_name (Name_Space.naming_of context) (Morphism.binding phi binding); fun prove_schematic_quot_thm actions ctxt = Lifting_Term.prove_schematic_quot_thm actions (Lifting_Info.get_quotients ctxt) ctxt fun prove_code_dt (rty, qty) lthy = let val (fold_quot_thm: (local_theory * thm list) Lifting_Term.fold_quot_thm) = { constr = constr, lift = lift, comp_lift = comp_lift_error }; in prove_schematic_quot_thm fold_quot_thm lthy (rty, qty) (lthy, []) |> snd end and add_lift_def_code_dt config var qty rhs rsp_thm par_thms lthy = let fun binop_conv2 cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2 fun ret_rel_conv conv ctm = case (Thm.term_of ctm) of Const (\<^const_name>\rel_fun\, _) $ _ $ _ => binop_conv2 Conv.all_conv conv ctm | _ => conv ctm - fun R_conv rel_eq_onps = Transfer.top_sweep_rewr_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]} - then_conv Transfer.bottom_rewr_conv rel_eq_onps + fun R_conv rel_eq_onps ctxt = + Conv.top_sweep_rewrs_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]} ctxt + then_conv Conv.bottom_rewrs_conv rel_eq_onps ctxt val (ret_lift_def, lthy1) = add_lift_def (#lift_config config) var qty rhs rsp_thm par_thms lthy in if (not (#code_dt config) orelse (code_eq_of_lift_def ret_lift_def <> NONE_EQ) andalso (code_eq_of_lift_def ret_lift_def <> UNKNOWN_EQ)) (* Let us try even in case of UNKNOWN_EQ. If this leads to problems, the user can always say that they do not want this workaround. *) then (ret_lift_def, lthy1) else let val lift_def = inst_of_lift_def lthy1 qty ret_lift_def val rty = rty_of_lift_def lift_def val rty_ret = body_type rty val qty_ret = body_type qty val (lthy2, rel_eq_onps) = prove_code_dt (rty_ret, qty_ret) lthy1 val code_dt = code_dt_of lthy2 (rty_ret, qty_ret) in if is_none code_dt orelse is_none (rep_isom_data_of_code_dt (the code_dt)) then (ret_lift_def, lthy2) else let val code_dt = the code_dt val rhs = dest_comb (rhs_of_lift_def lift_def) |> snd val rep_isom_data = code_dt |> rep_isom_data_of_code_dt |> the val pointer = pointer_of_rep_isom_data rep_isom_data val quot_active = Lifting_Info.lookup_restore_data lthy2 pointer |> the |> #quotient |> #quot_thm |> Lifting_Info.lookup_quot_thm_quotients lthy2 |> is_some val qty_code_dt_bundle_name = bundle_name_of_rep_isom_data rep_isom_data val rep_isom = mk_rep_isom_of_code_dt qty_ret code_dt |> the val lthy3 = if quot_active then lthy2 else Bundle.includes [qty_code_dt_bundle_name] lthy2 fun qty_isom_of_rep_isom rep = rep |> dest_Const |> snd |> domain_type val qty_isom = qty_isom_of_rep_isom rep_isom val f'_var = (Binding.suffix_name "_aux" (fst var), NoSyn); val f'_qty = strip_type qty |> fst |> rpair qty_isom |> op ---> val f'_rsp_rel = Lifting_Term.equiv_relation lthy3 (rty, f'_qty); val rsp = rsp_thm_of_lift_def lift_def - val rel_eq_onps_conv = HOLogic.Trueprop_conv (Conv.fun2_conv (ret_rel_conv (R_conv rel_eq_onps))) + val rel_eq_onps_conv = + HOLogic.Trueprop_conv (Conv.fun2_conv (ret_rel_conv (R_conv rel_eq_onps lthy3))) val rsp_norm = Conv.fconv_rule rel_eq_onps_conv rsp val f'_rsp_goal = HOLogic.mk_Trueprop (f'_rsp_rel $ rhs $ rhs); val f'_rsp = Goal.prove_sorry lthy3 [] [] f'_rsp_goal (fn {context = ctxt, prems = _} => HEADGOAL (CONVERSION (rel_eq_onps_conv) THEN' rtac ctxt rsp_norm)) |> Thm.close_derivation \<^here> val (f'_lift_def, lthy4) = add_lift_def ld_no_notes f'_var f'_qty rhs f'_rsp [] lthy3 val f'_lift_def = inst_of_lift_def lthy4 f'_qty f'_lift_def val f'_lift_const = mk_lift_const_of_lift_def f'_qty f'_lift_def val (args, args_ctxt) = mk_Frees "x" (binder_types qty) lthy4 val f_alt_def_goal_lhs = list_comb (lift_const_of_lift_def lift_def, args); val f_alt_def_goal_rhs = rep_isom $ list_comb (f'_lift_const, args); val f_alt_def_goal = HOLogic.mk_Trueprop (HOLogic.mk_eq (f_alt_def_goal_lhs, f_alt_def_goal_rhs)); fun f_alt_def_tac ctxt i = EVERY' [Transfer.gen_frees_tac [] ctxt, DETERM o Transfer.transfer_tac true ctxt, SELECT_GOAL (Local_Defs.unfold0_tac ctxt [id_apply]), rtac ctxt refl] i; val rep_isom_transfer = transfer_of_rep_isom_data rep_isom_data val (_, transfer_ctxt) = args_ctxt |> Proof_Context.note_thms "" (Binding.empty_atts, [([rep_isom_transfer], [Transfer.transfer_add])]) val f_alt_def = Goal.prove_sorry transfer_ctxt [] [] f_alt_def_goal (fn {context = goal_ctxt, ...} => HEADGOAL (f_alt_def_tac goal_ctxt)) |> Thm.close_derivation \<^here> |> singleton (Variable.export transfer_ctxt lthy4) val lthy5 = lthy4 |> Local_Theory.note ((Binding.empty, @{attributes [code]}), [f_alt_def]) |> snd (* if processing a mutual datatype (there is a cycle!) the corresponding quotient will be needed later and will be forgotten later *) |> (if quot_active then I else Lifting_Setup.lifting_forget pointer) in (ret_lift_def, lthy5) end end end and mk_rep_isom qty_isom_bundle (rty, qty, qty_isom) lthy0 = let (* logical definition of qty qty_isom isomorphism *) val uTname = unique_Tname (rty, qty) fun eq_onp_to_top_tac ctxt = SELECT_GOAL (Local_Defs.unfold0_tac ctxt (@{thm eq_onp_top_eq_eq[symmetric]} :: Lifting_Info.get_relator_eq_onp_rules ctxt)) fun lift_isom_tac ctxt = HEADGOAL (eq_onp_to_top_tac ctxt THEN' (rtac ctxt @{thm id_transfer})); val (rep_isom_lift_def, lthy1) = lthy0 |> (snd o Local_Theory.begin_nested) |> lift_def ld_no_notes (Binding.qualify_name true uTname "Rep_isom", NoSyn) (qty_isom --> qty) (HOLogic.id_const rty) lift_isom_tac [] |>> inst_of_lift_def lthy0 (qty_isom --> qty); val (abs_isom, lthy2) = lthy1 |> lift_def ld_no_notes (Binding.qualify_name true uTname "Abs_isom", NoSyn) (qty --> qty_isom) (HOLogic.id_const rty) lift_isom_tac [] |>> mk_lift_const_of_lift_def (qty --> qty_isom); val rep_isom = lift_const_of_lift_def rep_isom_lift_def val pointer = Lifting_Setup.pointer_of_bundle_binding lthy2 qty_isom_bundle fun code_dt phi context = code_dt_of lthy2 (rty, qty) |> the |> update_rep_isom rep_isom (transfer_rules_of_lift_def rep_isom_lift_def |> hd) (bundle_name_of_bundle_binding qty_isom_bundle phi context) pointer; val lthy3 = lthy2 |> Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => fn context => Data.map (Item_Net.update (morph_code_dt phi (code_dt phi context))) context) |> Local_Theory.end_nested (* in order to make the qty qty_isom isomorphism executable we have to define discriminators and selectors for qty_isom *) val (rty_name, typs) = dest_Type rty val (_, qty_typs) = dest_Type qty val fp = BNF_FP_Def_Sugar.fp_sugar_of lthy3 rty_name val fp = if is_some fp then the fp else error ("code_dt: " ^ quote rty_name ^ " is not a datatype.") val ctr_sugar = fp |> #fp_ctr_sugar |> #ctr_sugar val ctrs = map (Ctr_Sugar.mk_ctr typs) (#ctrs ctr_sugar); val qty_ctrs = map (Ctr_Sugar.mk_ctr qty_typs) (#ctrs ctr_sugar); val ctr_Tss = map (dest_Const #> snd #> binder_types) ctrs; val qty_ctr_Tss = map (dest_Const #> snd #> binder_types) qty_ctrs; val n = length ctrs; val ks = 1 upto n; val (xss, _) = mk_Freess "x" ctr_Tss lthy3; fun sel_retT (rty' as Type (s, rtys'), qty' as Type (s', qtys')) = if (rty', qty') = (rty, qty) then qty_isom else (if s = s' then Type (s, map sel_retT (rtys' ~~ qtys')) else qty') | sel_retT (_, qty') = qty'; val sel_retTs = map2 (map2 (sel_retT oo pair)) ctr_Tss qty_ctr_Tss fun lazy_prove_code_dt (rty, qty) lthy = if is_none (code_dt_of lthy (rty, qty)) then prove_code_dt (rty, qty) lthy |> fst else lthy; val lthy4 = fold2 (fold2 (lazy_prove_code_dt oo pair)) ctr_Tss sel_retTs lthy3 val sel_argss = @{map 4} (fn k => fn xs => @{map 2} (fn x => fn qty_ret => (k, qty_ret, (xs, x)))) ks xss xss sel_retTs; fun mk_sel_casex (_, _, (_, x)) = Ctr_Sugar.mk_case typs (x |> dest_Free |> snd) (#casex ctr_sugar); val dis_casex = Ctr_Sugar.mk_case typs HOLogic.boolT (#casex ctr_sugar); fun mk_sel_case_args lthy ctr_Tss ks (k, qty_ret, (xs, x)) = let val T = x |> dest_Free |> snd; fun gen_undef_wit Ts wits = case code_dt_of lthy (T, qty_ret) of SOME code_dt => (fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_witness_of_code_dt qty_ret code_dt), wit_thm_of_code_dt code_dt :: wits) | NONE => (fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T), wits) in @{fold_map 2} (fn Ts => fn k' => fn wits => (if k = k' then (fold_rev Term.lambda xs x, wits) else gen_undef_wit Ts wits)) ctr_Tss ks [] end; fun mk_sel_rhs arg = let val (sel_rhs, wits) = mk_sel_case_args lthy4 ctr_Tss ks arg in (arg |> #2, wits, list_comb (mk_sel_casex arg, sel_rhs)) end; fun mk_dis_case_args args k = map (fn (k', arg) => (if k = k' then fold_rev Term.lambda arg \<^Const>\True\ else fold_rev Term.lambda arg \<^Const>\False\)) args; val sel_rhs = map (map mk_sel_rhs) sel_argss val dis_rhs = map (fn k => list_comb (dis_casex, mk_dis_case_args (ks ~~ xss) k)) ks val dis_qty = qty_isom --> HOLogic.boolT; val dis_names = map (fn k => Binding.qualify_name true uTname ("dis" ^ string_of_int k)) ks; val (diss, lthy5) = @{fold_map 2} (fn b => fn rhs => fn lthy => lift_def ld_no_notes (b, NoSyn) dis_qty rhs (K all_tac) [] lthy |>> mk_lift_const_of_lift_def dis_qty) dis_names dis_rhs lthy4 val unfold_lift_sel_rsp = @{lemma "(\x. P1 x \ P2 (f x)) \ (rel_fun (eq_onp P1) (eq_onp P2)) f f" by (simp add: eq_onp_same_args rel_fun_eq_onp_rel)} fun lift_sel_tac exhaust_rule dt_rules wits ctxt i = (Method.insert_tac ctxt wits THEN' eq_onp_to_top_tac ctxt THEN' (* normalize *) rtac ctxt unfold_lift_sel_rsp THEN' case_tac exhaust_rule ctxt THEN_ALL_NEW ( EVERY' [hyp_subst_tac ctxt, (* does not kill wits because = was rewritten to eq_onp top *) Raw_Simplifier.rewrite_goal_tac ctxt (map safe_mk_meta_eq dt_rules), REPEAT_DETERM o etac ctxt conjE, assume_tac ctxt])) i val pred_simps = Transfer.lookup_pred_data lthy5 (Tname rty) |> the |> Transfer.pred_simps val sel_tac = lift_sel_tac (#exhaust ctr_sugar) (#case_thms ctr_sugar @ pred_simps) val sel_names = map (fn (k, xs) => map (fn k' => Binding.qualify_name true uTname ("sel" ^ string_of_int k ^ string_of_int k')) (1 upto length xs)) (ks ~~ ctr_Tss); val (selss, lthy6) = @{fold_map 2} (@{fold_map 2} (fn b => fn (qty_ret, wits, rhs) => fn lthy => lift_def_code_dt { code_dt = true, lift_config = ld_no_notes } (b, NoSyn) (qty_isom --> qty_ret) rhs (HEADGOAL o sel_tac wits) [] lthy |>> mk_lift_const_of_lift_def (qty_isom --> qty_ret))) sel_names sel_rhs lthy5 (* now we can execute the qty qty_isom isomorphism *) fun mk_type_definition newT oldT RepC AbsC A = let val typedefC = Const (\<^const_name>\type_definition\, (newT --> oldT) --> (oldT --> newT) --> HOLogic.mk_setT oldT --> HOLogic.boolT); in typedefC $ RepC $ AbsC $ A end; val typedef_goal = mk_type_definition qty_isom qty rep_isom abs_isom (HOLogic.mk_UNIV qty) |> HOLogic.mk_Trueprop; fun typ_isom_tac ctxt i = EVERY' [ SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms type_definition_def}), DETERM o Transfer.transfer_tac true ctxt, SELECT_GOAL (Local_Defs.unfold0_tac ctxt @{thms eq_onp_top_eq_eq}) (* normalize *), Raw_Simplifier.rewrite_goal_tac ctxt (map safe_mk_meta_eq @{thms id_apply simp_thms Ball_def}), rtac ctxt TrueI] i; val (_, transfer_ctxt) = Proof_Context.note_thms "" (Binding.empty_atts, [(@{thms right_total_UNIV_transfer}, [Transfer.transfer_add]), (@{thms Domain_eq_top}, [Transfer.transfer_domain_add])]) lthy6; val quot_thm_isom = Goal.prove_sorry transfer_ctxt [] [] typedef_goal (fn {context = goal_ctxt, ...} => typ_isom_tac goal_ctxt 1) |> Thm.close_derivation \<^here> |> singleton (Variable.export transfer_ctxt lthy6) |> (fn thm => @{thm UNIV_typedef_to_Quotient} OF [thm, @{thm reflexive}]) val qty_isom_name = Tname qty_isom; val quot_isom_rep = let val (quotients : Lifting_Term.quotients) = Symtab.insert (Lifting_Info.quotient_eq) (qty_isom_name, {quot_thm = quot_thm_isom, pcr_info = NONE}) Symtab.empty val id_actions = { constr = K I, lift = K I, comp_lift = K I } in fn ctxt => fn (rty, qty) => Lifting_Term.prove_schematic_quot_thm id_actions quotients ctxt (rty, qty) () |> fst |> Lifting_Term.force_qty_type ctxt qty |> quot_thm_rep end; val (x, x_ctxt) = yield_singleton (mk_Frees "x") qty_isom lthy6; fun mk_ctr ctr ctr_Ts sels = let val sel_ret_Ts = map (dest_Const #> snd #> body_type) sels; fun rep_isom lthy t (rty, qty) = let val rep = quot_isom_rep lthy (rty, qty) in if is_Const rep andalso (rep |> dest_Const |> fst) = \<^const_name>\id\ then t else rep $ t end; in @{fold 3} (fn sel => fn ctr_T => fn sel_ret_T => fn ctr => ctr $ rep_isom x_ctxt (sel $ x) (ctr_T, sel_ret_T)) sels ctr_Ts sel_ret_Ts ctr end; (* stolen from Metis *) exception BREAK_LIST fun break_list (x :: xs) = (x, xs) | break_list _ = raise BREAK_LIST val (ctr, ctrs) = qty_ctrs |> rev |> break_list; val (ctr_Ts, ctr_Tss) = qty_ctr_Tss |> rev |> break_list; val (sel, rselss) = selss |> rev |> break_list; val rdiss = rev diss |> tl; val first_ctr = mk_ctr ctr ctr_Ts sel; fun mk_If_ctr dis ctr ctr_Ts sel elsex = mk_If (dis$x) (mk_ctr ctr ctr_Ts sel) elsex; val rhs = @{fold 4} mk_If_ctr rdiss ctrs ctr_Tss rselss first_ctr; val rep_isom_code_goal = HOLogic.mk_Trueprop (HOLogic.mk_eq (rep_isom$x, rhs)); local val rep_isom_code_tac_rules = map safe_mk_meta_eq @{thms refl id_apply if_splits simp_thms} in fun rep_isom_code_tac (ctr_sugar:Ctr_Sugar.ctr_sugar) ctxt i = let val exhaust = ctr_sugar |> #exhaust val cases = ctr_sugar |> #case_thms val map_ids = fp |> #fp_nesting_bnfs |> map BNF_Def.map_id0_of_bnf val simp_rules = map safe_mk_meta_eq (cases @ map_ids) @ rep_isom_code_tac_rules in EVERY' [Transfer.gen_frees_tac [] ctxt, DETERM o (Transfer.transfer_tac true ctxt), case_tac exhaust ctxt THEN_ALL_NEW EVERY' [hyp_subst_tac ctxt, Raw_Simplifier.rewrite_goal_tac ctxt simp_rules, rtac ctxt TrueI ]] i end end (* stolen from bnf_fp_n2m.ML *) fun force_typ ctxt T = Term.map_types Type_Infer.paramify_vars #> Type.constraint T #> singleton (Type_Infer_Context.infer_types ctxt); (* The following tests that types in rty have corresponding arities imposed by constraints of the datatype fp. Otherwise rep_isom_code_tac could fail (especially transfer in it) is such a way that it is not easy to infer the problem with sorts. *) val _ = yield_singleton (mk_Frees "x") (#T fp) x_ctxt |> fst |> force_typ x_ctxt qty val rep_isom_code = Goal.prove_sorry x_ctxt [] [] rep_isom_code_goal (fn {context = goal_ctxt, ...} => rep_isom_code_tac ctr_sugar goal_ctxt 1) |> Thm.close_derivation \<^here> |> singleton(Variable.export x_ctxt lthy6) in lthy6 |> snd o Local_Theory.note ((Binding.empty, @{attributes [code]}), [rep_isom_code]) |> Lifting_Setup.lifting_forget pointer |> pair (selss, diss, rep_isom_code) end and constr qty (quot_thm, (lthy0, rel_eq_onps)) = let val quot_thm = Lifting_Term.force_qty_type lthy0 qty quot_thm val (rty, qty) = quot_thm_rty_qty quot_thm val rty_name = Tname rty; val pred_data = Transfer.lookup_pred_data lthy0 rty_name val pred_data = if is_some pred_data then the pred_data else error ("code_dt: " ^ quote rty_name ^ " is not a datatype.") val rel_eq_onp = safe_mk_meta_eq (Transfer.rel_eq_onp pred_data); val rel_eq_onps = insert Thm.eq_thm rel_eq_onp rel_eq_onps - val R_conv = Transfer.top_sweep_rewr_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]} + fun R_conv ctxt = + Conv.top_sweep_rewrs_conv @{thms eq_onp_top_eq_eq[symmetric, THEN eq_reflection]} ctxt then_conv Conv.rewr_conv rel_eq_onp - val quot_thm = Conv.fconv_rule(HOLogic.Trueprop_conv (Quotient_R_conv R_conv)) quot_thm; + val quot_thm = + Conv.fconv_rule (HOLogic.Trueprop_conv (Quotient_R_conv (R_conv lthy0))) quot_thm; in if is_none (code_dt_of lthy0 (rty, qty)) then let val non_empty_pred = quot_thm RS @{thm type_definition_Quotient_not_empty} val pred = quot_thm_rel quot_thm |> dest_comb |> snd; val (pred, lthy1) = lthy0 |> (snd o Local_Theory.begin_nested) |> yield_singleton (Variable.import_terms true) pred; val TFrees = Term.add_tfreesT qty [] fun non_empty_typedef_tac non_empty_pred ctxt i = (Method.insert_tac ctxt [non_empty_pred] THEN' SELECT_GOAL (Local_Defs.unfold0_tac ctxt [mem_Collect_eq]) THEN' assume_tac ctxt) i val uTname = unique_Tname (rty, qty) val Tdef_set = HOLogic.mk_Collect ("x", rty, pred $ Free("x", rty)); val ((_, tcode_dt), lthy2) = lthy1 |> conceal_naming_result (typedef (Binding.concealed uTname, TFrees, NoSyn) Tdef_set NONE (fn lthy => HEADGOAL (non_empty_typedef_tac non_empty_pred lthy))); val type_definition_thm = tcode_dt |> snd |> #type_definition; val qty_isom = tcode_dt |> fst |> #abs_type; val (binding, lthy3) = lthy2 |> conceal_naming_result (Lifting_Setup.setup_by_typedef_thm {notes = false} type_definition_thm) ||> Local_Theory.end_nested val (wit, wit_thm) = mk_witness quot_thm; val code_dt = mk_code_dt rty qty wit wit_thm NONE; val lthy4 = lthy3 |> update_code_dt code_dt |> mk_rep_isom binding (rty, qty, qty_isom) |> snd in (quot_thm, (lthy4, rel_eq_onps)) end else (quot_thm, (lthy0, rel_eq_onps)) end and lift_def_code_dt config = gen_lift_def (add_lift_def_code_dt config) (** from parsed parameters to the config record **) fun map_config_code_dt f1 f2 ({code_dt = code_dt, lift_config = lift_config}: config_code_dt) = {code_dt = f1 code_dt, lift_config = f2 lift_config} fun update_config_code_dt nval = map_config_code_dt (K nval) I val config_flags = [("code_dt", update_config_code_dt true)] fun evaluate_params params = let fun eval_param param config = case AList.lookup (op =) config_flags param of SOME update => update config | NONE => error ("Unknown parameter: " ^ (quote param)) in fold eval_param params default_config_code_dt end (** lift_definition command. It opens a proof of a corresponding respectfulness theorem in a user-friendly, readable form. Then add_lift_def_code_dt is called internally. **) local val eq_onp_assms_tac_fixed_rules = map (Transfer.prep_transfer_domain_thm \<^context>) [@{thm pcr_Domainp_total}, @{thm pcr_Domainp_par_left_total}, @{thm pcr_Domainp_par}, @{thm pcr_Domainp}] in fun mk_readable_rsp_thm_eq tm ctxt = let val ctm = Thm.cterm_of ctxt tm fun assms_rewr_conv tactic rule ct = let fun prove_extra_assms thm = let val assms = cprems_of thm fun finish thm = if Thm.no_prems thm then SOME (Goal.conclude thm) else NONE fun prove ctm = Option.mapPartial finish (SINGLE tactic (Goal.init ctm)) in map_interrupt prove assms end fun cconl_of thm = Drule.strip_imp_concl (Thm.cprop_of thm) fun lhs_of thm = fst (Thm.dest_equals (cconl_of thm)) fun rhs_of thm = snd (Thm.dest_equals (cconl_of thm)) val rule1 = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) rule; val lhs = lhs_of rule1; val rule2 = Thm.rename_boundvars (Thm.term_of lhs) (Thm.term_of ct) rule1; val rule3 = Thm.instantiate (Thm.match (lhs, ct)) rule2 handle Pattern.MATCH => raise CTERM ("assms_rewr_conv", [lhs, ct]); val proved_assms = prove_extra_assms rule3 in case proved_assms of SOME proved_assms => let val rule3 = proved_assms MRSL rule3 val rule4 = if lhs_of rule3 aconvc ct then rule3 else let val ceq = Thm.dest_fun2 (Thm.cprop_of rule3) in rule3 COMP Thm.trivial (Thm.mk_binop ceq ct (rhs_of rule3)) end in Thm.transitive rule4 (Thm.beta_conversion true (rhs_of rule4)) end | NONE => Conv.no_conv ct end fun assms_rewrs_conv tactic rules = Conv.first_conv (map (assms_rewr_conv tactic) rules) fun simp_arrows_conv ctm = let val unfold_conv = Conv.rewrs_conv [@{thm rel_fun_eq_eq_onp[THEN eq_reflection]}, @{thm rel_fun_eq_onp_rel[THEN eq_reflection]}, @{thm rel_fun_eq[THEN eq_reflection]}, @{thm rel_fun_eq_rel[THEN eq_reflection]}, @{thm rel_fun_def[THEN eq_reflection]}] fun binop_conv2 cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2 val eq_onp_assms_tac_rules = @{thm left_unique_OO} :: eq_onp_assms_tac_fixed_rules @ (Transfer.get_transfer_raw ctxt) val intro_top_rule = @{thm eq_onp_top_eq_eq[symmetric, THEN eq_reflection]} - val kill_tops = Transfer.top_sweep_rewr_conv [@{thm eq_onp_top_eq_eq[THEN eq_reflection]}] + val kill_tops = Conv.top_sweep_rewrs_conv @{thms eq_onp_top_eq_eq[THEN eq_reflection]} ctxt val eq_onp_assms_tac = (CONVERSION kill_tops THEN' TRY o REPEAT_ALL_NEW (resolve_tac ctxt eq_onp_assms_tac_rules) THEN_ALL_NEW (DETERM o Transfer.eq_tac ctxt)) 1 val relator_eq_onp_conv = Conv.bottom_conv (K (Conv.try_conv (assms_rewrs_conv eq_onp_assms_tac (intro_top_rule :: Lifting_Info.get_relator_eq_onp_rules ctxt)))) ctxt then_conv kill_tops val relator_eq_conv = Conv.bottom_conv (K (Conv.try_conv (Conv.rewrs_conv (Transfer.get_relator_eq ctxt)))) ctxt in case (Thm.term_of ctm) of Const (\<^const_name>\rel_fun\, _) $ _ $ _ => (binop_conv2 simp_arrows_conv simp_arrows_conv then_conv unfold_conv) ctm | _ => (relator_eq_onp_conv then_conv relator_eq_conv) ctm end val unfold_ret_val_invs = Conv.bottom_conv (K (Conv.try_conv (Conv.rewr_conv @{thm eq_onp_same_args[THEN eq_reflection]}))) ctxt val unfold_inv_conv = - Conv.top_sweep_conv (K (Conv.rewr_conv @{thm eq_onp_def[THEN eq_reflection]})) ctxt + Conv.top_sweep_rewrs_conv @{thms eq_onp_def[THEN eq_reflection]} ctxt val simp_conv = HOLogic.Trueprop_conv (Conv.fun2_conv simp_arrows_conv) val univq_conv = Conv.rewr_conv @{thm HOL.all_simps(6)[symmetric, THEN eq_reflection]} val univq_prenex_conv = Conv.top_conv (K (Conv.try_conv univq_conv)) ctxt val beta_conv = Thm.beta_conversion true val eq_thm = (simp_conv then_conv univq_prenex_conv then_conv beta_conv then_conv unfold_ret_val_invs then_conv unfold_inv_conv) ctm in Object_Logic.rulify ctxt (eq_thm RS Drule.equal_elim_rule2) end end fun rename_to_tnames ctxt term = let fun all_typs (Const (\<^const_name>\Pure.all\, _) $ Abs (_, T, t)) = T :: all_typs t | all_typs _ = [] fun rename (Const (\<^const_name>\Pure.all\, T1) $ Abs (_, T2, t)) (new_name :: names) = (Const (\<^const_name>\Pure.all\, T1) $ Abs (new_name, T2, rename t names)) | rename t _ = t val (fixed_def_t, _) = yield_singleton (Variable.importT_terms) term ctxt val new_names = Old_Datatype_Prop.make_tnames (all_typs fixed_def_t) in rename term new_names end fun quot_thm_err ctxt (rty, qty) pretty_msg = let val error_msg = cat_lines ["Lifting failed for the following types:", Pretty.string_of (Pretty.block [Pretty.str "Raw type:", Pretty.brk 2, Syntax.pretty_typ ctxt rty]), Pretty.string_of (Pretty.block [Pretty.str "Abstract type:", Pretty.brk 2, Syntax.pretty_typ ctxt qty]), "", (Pretty.string_of (Pretty.block [Pretty.str "Reason:", Pretty.brk 2, pretty_msg]))] in error error_msg end fun check_rty_err ctxt (rty_schematic, rty_forced) (raw_var, rhs_raw) = let val (_, ctxt') = Proof_Context.read_var raw_var ctxt val rhs = Syntax.read_term ctxt' rhs_raw val error_msg = cat_lines ["Lifting failed for the following term:", Pretty.string_of (Pretty.block [Pretty.str "Term:", Pretty.brk 2, Syntax.pretty_term ctxt rhs]), Pretty.string_of (Pretty.block [Pretty.str "Type:", Pretty.brk 2, Syntax.pretty_typ ctxt rty_schematic]), "", (Pretty.string_of (Pretty.block [Pretty.str "Reason:", Pretty.brk 2, Pretty.str "The type of the term cannot be instantiated to", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt rty_forced), Pretty.str "."]))] in error error_msg end fun lift_def_cmd (params, raw_var, rhs_raw, par_xthms) lthy0 = let val config = evaluate_params params val ((binding, SOME qty, mx), lthy1) = Proof_Context.read_var raw_var lthy0 val var = (binding, mx) val rhs = Syntax.read_term lthy1 rhs_raw val par_thms = Attrib.eval_thms lthy1 par_xthms val (goal, after_qed) = lthy1 |> prepare_lift_def (add_lift_def_code_dt config) var qty rhs par_thms val (goal, after_qed) = case goal of NONE => (goal, K (after_qed Drule.dummy_thm)) | SOME prsp_tm => let val readable_rsp_thm_eq = mk_readable_rsp_thm_eq prsp_tm lthy1 val (readable_rsp_tm, _) = Logic.dest_implies (Thm.prop_of readable_rsp_thm_eq) val readable_rsp_tm_tnames = rename_to_tnames lthy1 readable_rsp_tm fun after_qed' [[thm]] lthy = let val internal_rsp_thm = Goal.prove lthy [] [] prsp_tm (fn {context = goal_ctxt, ...} => rtac goal_ctxt readable_rsp_thm_eq 1 THEN Proof_Context.fact_tac goal_ctxt [thm] 1) in after_qed internal_rsp_thm lthy end in (SOME readable_rsp_tm_tnames, after_qed') end fun after_qed_with_err_handling thmss ctxt = (after_qed thmss ctxt handle Lifting_Term.QUOT_THM (rty, qty, msg) => quot_thm_err lthy1 (rty, qty) msg) handle Lifting_Term.CHECK_RTY (rty_schematic, rty_forced) => check_rty_err lthy1 (rty_schematic, rty_forced) (raw_var, rhs_raw); in lthy1 |> Proof.theorem NONE (snd oo after_qed_with_err_handling) [map (rpair []) (the_list goal)] end fun lift_def_cmd_with_err_handling (params, (raw_var, rhs_raw, par_xthms)) lthy = (lift_def_cmd (params, raw_var, rhs_raw, par_xthms) lthy handle Lifting_Term.QUOT_THM (rty, qty, msg) => quot_thm_err lthy (rty, qty) msg) handle Lifting_Term.CHECK_RTY (rty_schematic, rty_forced) => check_rty_err lthy (rty_schematic, rty_forced) (raw_var, rhs_raw); val parse_param = Parse.name val parse_params = Scan.optional (Args.parens (Parse.list parse_param)) []; (* command syntax *) val _ = Outer_Syntax.local_theory_to_proof \<^command_keyword>\lift_definition\ "definition for constants over the quotient type" (parse_params -- (((Parse.binding -- (\<^keyword>\::\ |-- (Parse.typ >> SOME) -- Parse.opt_mixfix') >> Scan.triple2) -- (\<^keyword>\is\ |-- Parse.term) -- Scan.optional (\<^keyword>\parametric\ |-- Parse.!!! Parse.thms1) []) >> Scan.triple1) >> lift_def_cmd_with_err_handling); end diff --git a/src/HOL/Tools/Lifting/lifting_setup.ML b/src/HOL/Tools/Lifting/lifting_setup.ML --- a/src/HOL/Tools/Lifting/lifting_setup.ML +++ b/src/HOL/Tools/Lifting/lifting_setup.ML @@ -1,1048 +1,1048 @@ (* Title: HOL/Tools/Lifting/lifting_setup.ML Author: Ondrej Kuncar Setting up the lifting infrastructure. *) signature LIFTING_SETUP = sig exception SETUP_LIFTING_INFR of string type config = { notes: bool }; val default_config: config; val setup_by_quotient: config -> thm -> thm option -> thm option -> local_theory -> binding * local_theory val setup_by_typedef_thm: config -> thm -> local_theory -> binding * local_theory val lifting_restore: Lifting_Info.quotient -> Context.generic -> Context.generic val lifting_forget: string -> local_theory -> local_theory val update_transfer_rules: string -> local_theory -> local_theory val pointer_of_bundle_binding: Proof.context -> binding -> string end structure Lifting_Setup: LIFTING_SETUP = struct open Lifting_Util infix 0 MRSL exception SETUP_LIFTING_INFR of string (* Config *) type config = { notes: bool }; val default_config = { notes = true }; fun define_crel (config: config) rep_fun lthy = let val (qty, rty) = (dest_funT o fastype_of) rep_fun val rep_fun_graph = (HOLogic.eq_const rty) $ Bound 1 $ (rep_fun $ Bound 0) val def_term = Abs ("x", rty, Abs ("y", qty, rep_fun_graph)) val qty_name = (Binding.name o Long_Name.base_name o fst o dest_Type) qty val crel_name = Binding.prefix_name "cr_" qty_name val (fixed_def_term, lthy1) = lthy |> yield_singleton (Variable.importT_terms) def_term val ((_, (_ , def_thm)), lthy2) = if #notes config then Local_Theory.define ((crel_name, NoSyn), ((Thm.def_binding crel_name, []), fixed_def_term)) lthy1 else Local_Theory.define ((Binding.concealed crel_name, NoSyn), (Binding.empty_atts, fixed_def_term)) lthy1 in (def_thm, lthy2) end fun print_define_pcrel_warning msg = let val warning_msg = cat_lines ["Generation of a parametrized correspondence relation failed.", (Pretty.string_of (Pretty.block [Pretty.str "Reason:", Pretty.brk 2, msg]))] in warning warning_msg end fun define_pcrel (config: config) crel lthy0 = let val (fixed_crel, lthy1) = yield_singleton Variable.importT_terms crel lthy0 val [rty', qty] = (binder_types o fastype_of) fixed_crel val (param_rel, args) = Lifting_Term.generate_parametrized_relator lthy1 rty' val rty_raw = (domain_type o range_type o fastype_of) param_rel val tyenv_match = Sign.typ_match (Proof_Context.theory_of lthy1) (rty_raw, rty') Vartab.empty val param_rel_subst = Envir.subst_term (tyenv_match,Vartab.empty) param_rel val args_subst = map (Envir.subst_term (tyenv_match,Vartab.empty)) args val (instT, lthy2) = lthy1 |> Variable.declare_names fixed_crel |> Variable.importT_inst (param_rel_subst :: args_subst) val args_fixed = (map (Term_Subst.instantiate (instT, Vars.empty))) args_subst val param_rel_fixed = Term_Subst.instantiate (instT, Vars.empty) param_rel_subst val rty = (domain_type o fastype_of) param_rel_fixed val relcomp_op = Const (\<^const_name>\relcompp\, (rty --> rty' --> HOLogic.boolT) --> (rty' --> qty --> HOLogic.boolT) --> rty --> qty --> HOLogic.boolT) val qty_name = (fst o dest_Type) qty val pcrel_name = Binding.prefix_name "pcr_" ((Binding.name o Long_Name.base_name) qty_name) val relator_type = foldr1 (op -->) ((map type_of args_fixed) @ [rty, qty, HOLogic.boolT]) val lhs = Library.foldl (op $) ((Free (Binding.name_of pcrel_name, relator_type)), args_fixed) val rhs = relcomp_op $ param_rel_fixed $ fixed_crel val definition_term = Logic.mk_equals (lhs, rhs) fun note_def lthy = Specification.definition (SOME (pcrel_name, SOME relator_type, NoSyn)) [] [] (Binding.empty_atts, definition_term) lthy |>> (snd #> snd); fun raw_def lthy = let val ((_, rhs), prove) = Local_Defs.derived_def lthy (K []) {conditional = true} definition_term; val ((_, (_, raw_th)), lthy') = Local_Theory.define ((Binding.concealed pcrel_name, NoSyn), (Binding.empty_atts, rhs)) lthy; val th = prove lthy' raw_th; in (th, lthy') end val (def_thm, lthy3) = if #notes config then note_def lthy2 else raw_def lthy2 in (SOME def_thm, lthy3) end handle Lifting_Term.PARAM_QUOT_THM (_, msg) => (print_define_pcrel_warning msg; (NONE, lthy0)) local val eq_OO_meta = mk_meta_eq @{thm eq_OO} fun print_generate_pcr_cr_eq_error ctxt term = let val goal = Const (\<^const_name>\HOL.eq\, dummyT) $ term $ Const (\<^const_name>\HOL.eq\, dummyT) val error_msg = cat_lines ["Generation of a pcr_cr_eq failed.", (Pretty.string_of (Pretty.block [Pretty.str "Reason: Cannot prove this: ", Pretty.brk 2, Syntax.pretty_term ctxt goal])), "Most probably a relator_eq rule for one of the involved types is missing."] in error error_msg end in fun define_pcr_cr_eq (config: config) lthy pcr_rel_def = let val lhs = (Thm.term_of o Thm.lhs_of) pcr_rel_def val qty_name = (Binding.name o Long_Name.base_name o fst o dest_Type o List.last o binder_types o fastype_of) lhs val args = (snd o strip_comb) lhs fun make_inst var ctxt = let val typ = snd (relation_types (#2 (dest_Var var))) val sort = Type.sort_of_atyp typ val (fresh_var, ctxt') = yield_singleton Variable.invent_types sort ctxt val inst = (#1 (dest_Var var), Thm.cterm_of ctxt' (HOLogic.eq_const (TFree fresh_var))) in (inst, ctxt') end val (args_inst, args_ctxt) = fold_map make_inst args lthy val pcr_cr_eq = pcr_rel_def |> infer_instantiate args_ctxt args_inst |> Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv - (Transfer.bottom_rewr_conv (Transfer.get_relator_eq args_ctxt)))) + (Conv.bottom_rewrs_conv (Transfer.get_relator_eq args_ctxt) args_ctxt))) in case (Thm.term_of o Thm.rhs_of) pcr_cr_eq of Const (\<^const_name>\relcompp\, _) $ Const (\<^const_name>\HOL.eq\, _) $ _ => let val thm = pcr_cr_eq |> Conv.fconv_rule (Conv.arg_conv (Conv.rewr_conv eq_OO_meta)) |> HOLogic.mk_obj_eq |> singleton (Variable.export args_ctxt lthy) val lthy' = lthy |> #notes config ? (Local_Theory.note ((Binding.qualify_name true qty_name "pcr_cr_eq", []), [thm]) #> #2) in (thm, lthy') end | Const (\<^const_name>\relcompp\, _) $ t $ _ => print_generate_pcr_cr_eq_error args_ctxt t | _ => error "generate_pcr_cr_eq: implementation error" end end fun define_code_constr quot_thm lthy = let val abs = quot_thm_abs quot_thm in if is_Const abs then let val (fixed_abs, lthy') = yield_singleton Variable.importT_terms abs lthy in Local_Theory.background_theory (Code.declare_datatype_global [dest_Const fixed_abs]) lthy' end else lthy end fun define_abs_type quot_thm = Lifting_Def.can_generate_code_cert quot_thm ? Code.declare_abstype (quot_thm RS @{thm Quotient_abs_rep}); local exception QUOT_ERROR of Pretty.T list in fun quot_thm_sanity_check ctxt quot_thm = let val _ = if (Thm.nprems_of quot_thm > 0) then raise QUOT_ERROR [Pretty.block [Pretty.str "The Quotient theorem has extra assumptions:", Pretty.brk 1, Thm.pretty_thm ctxt quot_thm]] else () val _ = quot_thm |> Thm.concl_of |> HOLogic.dest_Trueprop |> dest_Quotient handle TERM _ => raise QUOT_ERROR [Pretty.block [Pretty.str "The Quotient theorem is not of the right form:", Pretty.brk 1, Thm.pretty_thm ctxt quot_thm]] val ((_, [quot_thm_fixed]), ctxt') = Variable.importT [quot_thm] ctxt val (rty, qty) = quot_thm_rty_qty quot_thm_fixed val rty_tfreesT = Term.add_tfree_namesT rty [] val qty_tfreesT = Term.add_tfree_namesT qty [] val extra_rty_tfrees = case subtract (op =) qty_tfreesT rty_tfreesT of [] => [] | extras => [Pretty.block ([Pretty.str "Extra variables in the raw type:", Pretty.brk 1] @ ((Pretty.commas o map (Pretty.str o quote)) extras) @ [Pretty.str "."])] val not_type_constr = case qty of Type _ => [] | _ => [Pretty.block [Pretty.str "The quotient type ", Pretty.quote (Syntax.pretty_typ ctxt' qty), Pretty.brk 1, Pretty.str "is not a type constructor."]] val errs = extra_rty_tfrees @ not_type_constr in if null errs then () else raise QUOT_ERROR errs end handle QUOT_ERROR errs => error (cat_lines (["Sanity check of the quotient theorem failed:"] @ (map (Pretty.string_of o Pretty.item o single) errs))) end fun lifting_bundle qty_full_name qinfo lthy = let val thy = Proof_Context.theory_of lthy val binding = Binding.qualify_name true (qty_full_name |> Long_Name.base_name |> Binding.name) "lifting" val morphed_binding = Morphism.binding (Local_Theory.target_morphism lthy) binding val bundle_name = Name_Space.full_name (Name_Space.naming_of (Context.Theory thy)) morphed_binding fun phi_qinfo phi = Lifting_Info.transform_quotient phi qinfo val dummy_thm = Thm.transfer thy Drule.dummy_thm val restore_lifting_att = ([dummy_thm], [map (Token.make_string o rpair Position.none) ["Lifting.lifting_restore_internal", bundle_name]]) in lthy |> Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Lifting_Info.init_restore_data bundle_name (phi_qinfo phi)) |> Bundle.bundle ((binding, [restore_lifting_att])) [] |> pair binding end fun setup_lifting_infr config quot_thm opt_reflp_thm lthy = let val _ = quot_thm_sanity_check lthy quot_thm val (_, qty) = quot_thm_rty_qty quot_thm val (pcrel_def, lthy1) = define_pcrel config (quot_thm_crel quot_thm) lthy (**) val pcrel_def = Option.map (Morphism.thm (Local_Theory.target_morphism lthy1)) pcrel_def (**) val (pcr_cr_eq, lthy2) = case pcrel_def of SOME pcrel_def => apfst SOME (define_pcr_cr_eq config lthy1 pcrel_def) | NONE => (NONE, lthy1) val pcr_info = case pcrel_def of SOME pcrel_def => SOME { pcrel_def = pcrel_def, pcr_cr_eq = the pcr_cr_eq } | NONE => NONE val quotients = { quot_thm = quot_thm, pcr_info = pcr_info } val qty_full_name = (fst o dest_Type) qty fun quot_info phi = Lifting_Info.transform_quotient phi quotients val reflexivity_rule_attr = Attrib.internal (K Lifting_Info.add_reflexivity_rule_attribute) val lthy3 = case opt_reflp_thm of SOME reflp_thm => lthy2 |> (#2 oo Local_Theory.note) ((Binding.empty, [reflexivity_rule_attr]), [reflp_thm RS @{thm reflp_ge_eq}]) |> define_code_constr quot_thm | NONE => lthy2 |> define_abs_type quot_thm in lthy3 |> Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Lifting_Info.update_quotients qty_full_name (quot_info phi)) |> lifting_bundle qty_full_name quotients end local fun importT_inst_exclude exclude ts ctxt = let val tvars = rev (subtract op= exclude (fold Term.add_tvars ts [])) val (tfrees, ctxt') = Variable.invent_types (map #2 tvars) ctxt in (TVars.make (tvars ~~ map TFree tfrees), ctxt') end fun import_inst_exclude exclude ts ctxt = let val excludeT = fold (Term.add_tvarsT o snd) exclude [] val (instT, ctxt') = importT_inst_exclude excludeT ts ctxt val vars = map (apsnd (Term_Subst.instantiateT instT)) (rev (subtract op= exclude (fold Term.add_vars ts []))) val (xs, ctxt'') = Variable.variant_fixes (map (#1 o #1) vars) ctxt' val inst = Vars.make (vars ~~ map Free (xs ~~ map #2 vars)) in ((instT, inst), ctxt'') end fun import_terms_exclude exclude ts ctxt = let val (inst, ctxt') = import_inst_exclude exclude ts ctxt in (map (Term_Subst.instantiate inst) ts, ctxt') end in fun reduce_goal not_fix goal tac ctxt = let val (fixed_goal, ctxt') = yield_singleton (import_terms_exclude not_fix) goal ctxt val init_goal = Goal.init (Thm.cterm_of ctxt' fixed_goal) in (singleton (Variable.export ctxt' ctxt) o Goal.conclude) (the (SINGLE tac init_goal)) end end local val OO_rules = @{thms left_total_OO left_unique_OO right_total_OO right_unique_OO bi_total_OO bi_unique_OO} in fun parametrize_class_constraint ctxt0 pcr_def constraint = let fun generate_transfer_rule pcr_def constraint goal ctxt = let val (fixed_goal, ctxt') = yield_singleton (Variable.import_terms true) goal ctxt val init_goal = Goal.init (Thm.cterm_of ctxt' fixed_goal) val rules = Transfer.get_transfer_raw ctxt' val rules = constraint :: OO_rules @ rules val tac = K (Local_Defs.unfold0_tac ctxt' [pcr_def]) THEN' REPEAT_ALL_NEW (resolve_tac ctxt' rules) in (singleton (Variable.export ctxt' ctxt) o Goal.conclude) (the (SINGLE (tac 1) init_goal)) end fun make_goal pcr_def constr = let val pred_name = (fst o dest_Const o strip_args 1 o HOLogic.dest_Trueprop o Thm.prop_of) constr val arg = (fst o Logic.dest_equals o Thm.prop_of) pcr_def in HOLogic.mk_Trueprop ((Const (pred_name, (fastype_of arg) --> HOLogic.boolT)) $ arg) end val check_assms = let val right_names = ["right_total", "right_unique", "left_total", "left_unique", "bi_total", "bi_unique"] fun is_right_name name = member op= right_names (Long_Name.base_name name) fun is_trivial_assm (Const (name, _) $ Var (_, _)) = is_right_name name | is_trivial_assm (Const (name, _) $ Free (_, _)) = is_right_name name | is_trivial_assm _ = false in fn thm => let val prems = map HOLogic.dest_Trueprop (Thm.prems_of thm) val thm_name = (Long_Name.base_name o fst o dest_Const o strip_args 1 o HOLogic.dest_Trueprop o Thm.concl_of) thm val non_trivial_assms = filter_out is_trivial_assm prems in if null non_trivial_assms then () else Pretty.block ([Pretty.str "Non-trivial assumptions in ", Pretty.str thm_name, Pretty.str " transfer rule found:", Pretty.brk 1] @ Pretty.commas (map (Syntax.pretty_term ctxt0) non_trivial_assms)) |> Pretty.string_of |> warning end end val goal = make_goal pcr_def constraint val thm = generate_transfer_rule pcr_def constraint goal ctxt0 val _ = check_assms thm in thm end end local val id_unfold = (Conv.rewr_conv (mk_meta_eq @{thm id_def})) in fun generate_parametric_id lthy rty id_transfer_rule = let (* it doesn't raise an exception because it would have already raised it in define_pcrel *) val (quot_thm, _, ctxt') = Lifting_Term.prove_param_quot_thm lthy rty val parametrized_relator = singleton (Variable.export_terms ctxt' lthy) (quot_thm_crel quot_thm) val id_transfer = @{thm id_transfer} |> Thm.incr_indexes (Term.maxidx_of_term parametrized_relator + 1) |> Conv.fconv_rule(HOLogic.Trueprop_conv (Conv.arg_conv id_unfold then_conv Conv.arg1_conv id_unfold)) val var = hd (Term.add_vars (Thm.prop_of id_transfer) []) val inst = [(#1 var, Thm.cterm_of lthy parametrized_relator)] val id_par_thm = infer_instantiate lthy inst id_transfer in Lifting_Def.generate_parametric_transfer_rule lthy id_transfer_rule id_par_thm end handle Lifting_Term.MERGE_TRANSFER_REL msg => let val error_msg = cat_lines ["Generation of a parametric transfer rule for the abs. or the rep. function failed.", "A non-parametric version will be used.", (Pretty.string_of (Pretty.block [Pretty.str "Reason:", Pretty.brk 2, msg]))] in (warning error_msg; id_transfer_rule) end end local fun rewrite_first_Domainp_arg rewr_thm thm = Conv.fconv_rule (Conv.concl_conv ~1 (HOLogic.Trueprop_conv (Conv.arg1_conv (Conv.arg_conv (Conv.rewr_conv rewr_thm))))) thm fun fold_Domainp_pcrel pcrel_def thm = let val ct = thm |> Thm.cprop_of |> Drule.strip_imp_concl |> Thm.dest_arg |> Thm.dest_arg1 |> Thm.dest_arg val pcrel_def = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) pcrel_def val thm' = Thm.instantiate (Thm.match (ct, Thm.rhs_of pcrel_def)) thm handle Pattern.MATCH => raise CTERM ("fold_Domainp_pcrel", [ct, Thm.rhs_of pcrel_def]) in rewrite_first_Domainp_arg (Thm.symmetric pcrel_def) thm' end fun reduce_Domainp ctxt rules thm = let val goal = thm |> Thm.prems_of |> hd val var = goal |> HOLogic.dest_Trueprop |> dest_comb |> snd |> dest_Var val reduced_assm = reduce_goal [var] goal (TRY (REPEAT_ALL_NEW (resolve_tac ctxt rules) 1)) ctxt in reduced_assm RS thm end in fun parametrize_domain dom_thm (pcr_info : Lifting_Info.pcr) ctxt0 = let fun reduce_first_assm ctxt rules thm = let val goal = thm |> Thm.prems_of |> hd val reduced_assm = reduce_goal [] goal (TRY (REPEAT_ALL_NEW (resolve_tac ctxt rules) 1)) ctxt in reduced_assm RS thm end val pcr_cr_met_eq = #pcr_cr_eq pcr_info RS @{thm eq_reflection} val pcr_Domainp_eq = rewrite_first_Domainp_arg (Thm.symmetric pcr_cr_met_eq) dom_thm val pcrel_def = #pcrel_def pcr_info val pcr_Domainp_par_left_total = (dom_thm RS @{thm pcr_Domainp_par_left_total}) |> fold_Domainp_pcrel pcrel_def |> reduce_first_assm ctxt0 (Lifting_Info.get_reflexivity_rules ctxt0) val pcr_Domainp_par = (dom_thm RS @{thm pcr_Domainp_par}) |> fold_Domainp_pcrel pcrel_def |> reduce_Domainp ctxt0 (Transfer.get_relator_domain ctxt0) val pcr_Domainp = (dom_thm RS @{thm pcr_Domainp}) |> fold_Domainp_pcrel pcrel_def val thms = [("domain", [pcr_Domainp], @{attributes [transfer_domain_rule]}), ("domain_par", [pcr_Domainp_par], @{attributes [transfer_domain_rule]}), ("domain_par_left_total", [pcr_Domainp_par_left_total], @{attributes [transfer_domain_rule]}), ("domain_eq", [pcr_Domainp_eq], @{attributes [transfer_domain_rule]})] in thms end fun parametrize_total_domain left_total pcrel_def ctxt = let val thm = (left_total RS @{thm pcr_Domainp_total}) |> fold_Domainp_pcrel pcrel_def |> reduce_Domainp ctxt (Transfer.get_relator_domain ctxt) in [("domain", [thm], @{attributes [transfer_domain_rule]})] end end fun get_pcrel_info ctxt qty_full_name = #pcr_info (the (Lifting_Info.lookup_quotients ctxt qty_full_name)) fun get_Domainp_thm quot_thm = the (get_first (try(curry op RS quot_thm)) [@{thm eq_onp_to_Domainp}, @{thm Quotient_to_Domainp}]) fun notes names thms = let val notes = if names then map (fn (name, thms, attrs) => ((name, []), [(thms, attrs)])) thms else map_filter (fn (_, thms, attrs) => if null attrs then NONE else SOME (Binding.empty_atts, [(thms, attrs)])) thms in Local_Theory.notes notes #> snd end fun map_thms map_name map_thm thms = map (fn (name, thms, attr) => (map_name name, map map_thm thms, attr)) thms (* Sets up the Lifting package by a quotient theorem. quot_thm - a quotient theorem (Quotient R Abs Rep T) opt_reflp_thm - a theorem saying that a relation from quot_thm is reflexive (in the form "reflp R") opt_par_thm - a parametricity theorem for R *) fun setup_by_quotient (config: config) quot_thm opt_reflp_thm opt_par_thm lthy0 = let (**) val quot_thm = Morphism.thm (Local_Theory.target_morphism lthy0) quot_thm (**) val (rty, qty) = quot_thm_rty_qty quot_thm val induct_attr = Attrib.internal (K (Induct.induct_type (fst (dest_Type qty)))) val qty_full_name = (fst o dest_Type) qty val qty_name = (Binding.name o Long_Name.base_name) qty_full_name val qualify = Binding.qualify_name true qty_name val notes1 = case opt_reflp_thm of SOME reflp_thm => let val thms = [("abs_induct", @{thms Quotient_total_abs_induct}, [induct_attr]), ("abs_eq_iff", @{thms Quotient_total_abs_eq_iff}, [])] in map_thms qualify (fn thm => [quot_thm, reflp_thm] MRSL thm) thms end | NONE => let val thms = [("abs_induct", @{thms Quotient_abs_induct}, [induct_attr])] in map_thms qualify (fn thm => quot_thm RS thm) thms end val dom_thm = get_Domainp_thm quot_thm fun setup_transfer_rules_nonpar notes = let val notes1 = case opt_reflp_thm of SOME reflp_thm => let val thms = [("id_abs_transfer",@{thms Quotient_id_abs_transfer}, @{attributes [transfer_rule]}), ("left_total", @{thms Quotient_left_total}, @{attributes [transfer_rule]}), ("bi_total", @{thms Quotient_bi_total}, @{attributes [transfer_rule]})] in map_thms qualify (fn thm => [quot_thm, reflp_thm] MRSL thm) thms end | NONE => map_thms qualify I [("domain", [dom_thm], @{attributes [transfer_domain_rule]})] val notes2 = map_thms qualify (fn thm => quot_thm RS thm) [("rel_eq_transfer", @{thms Quotient_rel_eq_transfer}, @{attributes [transfer_rule]}), ("right_unique", @{thms Quotient_right_unique}, @{attributes [transfer_rule]}), ("right_total", @{thms Quotient_right_total}, @{attributes [transfer_rule]})] in notes2 @ notes1 @ notes end fun generate_parametric_rel_eq ctxt transfer_rule opt_param_thm = (case opt_param_thm of NONE => transfer_rule | SOME param_thm => (Lifting_Def.generate_parametric_transfer_rule ctxt transfer_rule param_thm handle Lifting_Term.MERGE_TRANSFER_REL msg => error ("Generation of a parametric transfer rule for the quotient relation failed:\n" ^ Pretty.string_of msg))) fun setup_transfer_rules_par ctxt notes = let val pcrel_info = the (get_pcrel_info ctxt qty_full_name) val pcrel_def = #pcrel_def pcrel_info val notes1 = case opt_reflp_thm of SOME reflp_thm => let val left_total = ([quot_thm, reflp_thm] MRSL @{thm Quotient_left_total}) val bi_total = ([quot_thm, reflp_thm] MRSL @{thm Quotient_bi_total}) val domain_thms = parametrize_total_domain left_total pcrel_def ctxt val id_abs_transfer = generate_parametric_id ctxt rty (Lifting_Term.parametrize_transfer_rule ctxt ([quot_thm, reflp_thm] MRSL @{thm Quotient_id_abs_transfer})) val left_total = parametrize_class_constraint ctxt pcrel_def left_total val bi_total = parametrize_class_constraint ctxt pcrel_def bi_total val thms = [("id_abs_transfer", [id_abs_transfer], @{attributes [transfer_rule]}), ("left_total", [left_total], @{attributes [transfer_rule]}), ("bi_total", [bi_total], @{attributes [transfer_rule]})] in map_thms qualify I thms @ map_thms qualify I domain_thms end | NONE => let val thms = parametrize_domain dom_thm pcrel_info ctxt in map_thms qualify I thms end val rel_eq_transfer = generate_parametric_rel_eq ctxt (Lifting_Term.parametrize_transfer_rule ctxt (quot_thm RS @{thm Quotient_rel_eq_transfer})) opt_par_thm val right_unique = parametrize_class_constraint ctxt pcrel_def (quot_thm RS @{thm Quotient_right_unique}) val right_total = parametrize_class_constraint ctxt pcrel_def (quot_thm RS @{thm Quotient_right_total}) val notes2 = map_thms qualify I [("rel_eq_transfer", [rel_eq_transfer], @{attributes [transfer_rule]}), ("right_unique", [right_unique], @{attributes [transfer_rule]}), ("right_total", [right_total], @{attributes [transfer_rule]})] in notes2 @ notes1 @ notes end fun setup_rules lthy = let val thms = if is_some (get_pcrel_info lthy qty_full_name) then setup_transfer_rules_par lthy notes1 else setup_transfer_rules_nonpar notes1 in notes (#notes config) thms lthy end in lthy0 |> setup_lifting_infr config quot_thm opt_reflp_thm ||> setup_rules end (* Sets up the Lifting package by a typedef theorem. gen_code - flag if an abstract type given by typedef_thm should be registred as an abstract type in the code generator typedef_thm - a typedef theorem (type_definition Rep Abs S) *) fun setup_by_typedef_thm config typedef_thm lthy0 = let val (_ $ rep_fun $ _ $ typedef_set) = (HOLogic.dest_Trueprop o Thm.prop_of) typedef_thm val (T_def, lthy1) = define_crel config rep_fun lthy0 (**) val T_def = Morphism.thm (Local_Theory.target_morphism lthy1) T_def (**) val quot_thm = case typedef_set of Const (\<^const_name>\top\, _) => [typedef_thm, T_def] MRSL @{thm UNIV_typedef_to_Quotient} | Const (\<^const_name>\Collect\, _) $ Abs (_, _, _) => [typedef_thm, T_def] MRSL @{thm open_typedef_to_Quotient} | _ => [typedef_thm, T_def] MRSL @{thm typedef_to_Quotient} val (rty, qty) = quot_thm_rty_qty quot_thm val qty_full_name = (fst o dest_Type) qty val qty_name = (Binding.name o Long_Name.base_name) qty_full_name val qualify = Binding.qualify_name true qty_name val opt_reflp_thm = case typedef_set of Const (\<^const_name>\top\, _) => SOME ((typedef_thm RS @{thm UNIV_typedef_to_equivp}) RS @{thm equivp_reflp2}) | _ => NONE val dom_thm = get_Domainp_thm quot_thm fun setup_transfer_rules_nonpar notes = let val notes1 = case opt_reflp_thm of SOME reflp_thm => let val thms = [("id_abs_transfer",@{thms Quotient_id_abs_transfer}, @{attributes [transfer_rule]}), ("left_total", @{thms Quotient_left_total}, @{attributes [transfer_rule]}), ("bi_total", @{thms Quotient_bi_total}, @{attributes [transfer_rule]})] in map_thms qualify (fn thm => [quot_thm, reflp_thm] MRSL thm) thms end | NONE => map_thms qualify I [("domain", [dom_thm], @{attributes [transfer_domain_rule]})] val thms = [("rep_transfer", @{thms typedef_rep_transfer}, @{attributes [transfer_rule]}), ("left_unique", @{thms typedef_left_unique}, @{attributes [transfer_rule]}), ("right_unique", @{thms typedef_right_unique}, @{attributes [transfer_rule]}), ("right_total", @{thms typedef_right_total}, @{attributes [transfer_rule]}), ("bi_unique", @{thms typedef_bi_unique}, @{attributes [transfer_rule]})] in map_thms qualify (fn thm => [typedef_thm, T_def] MRSL thm) thms @ notes1 @ notes end fun setup_transfer_rules_par ctxt notes = let val pcrel_info = (the (get_pcrel_info ctxt qty_full_name)) val pcrel_def = #pcrel_def pcrel_info val notes1 = case opt_reflp_thm of SOME reflp_thm => let val left_total = ([quot_thm, reflp_thm] MRSL @{thm Quotient_left_total}) val bi_total = ([quot_thm, reflp_thm] MRSL @{thm Quotient_bi_total}) val domain_thms = parametrize_total_domain left_total pcrel_def ctxt val left_total = parametrize_class_constraint ctxt pcrel_def left_total val bi_total = parametrize_class_constraint ctxt pcrel_def bi_total val id_abs_transfer = generate_parametric_id ctxt rty (Lifting_Term.parametrize_transfer_rule ctxt ([quot_thm, reflp_thm] MRSL @{thm Quotient_id_abs_transfer})) val thms = [("left_total", [left_total], @{attributes [transfer_rule]}), ("bi_total", [bi_total], @{attributes [transfer_rule]}), ("id_abs_transfer",[id_abs_transfer], @{attributes [transfer_rule]})] in map_thms qualify I thms @ map_thms qualify I domain_thms end | NONE => let val thms = parametrize_domain dom_thm pcrel_info ctxt in map_thms qualify I thms end val notes2 = map_thms qualify (fn thm => generate_parametric_id ctxt rty (Lifting_Term.parametrize_transfer_rule ctxt ([typedef_thm, T_def] MRSL thm))) [("rep_transfer", @{thms typedef_rep_transfer}, @{attributes [transfer_rule]})]; val notes3 = map_thms qualify (fn thm => parametrize_class_constraint ctxt pcrel_def ([typedef_thm, T_def] MRSL thm)) [("left_unique", @{thms typedef_left_unique}, @{attributes [transfer_rule]}), ("right_unique", @{thms typedef_right_unique},@{attributes [transfer_rule]}), ("bi_unique", @{thms typedef_bi_unique}, @{attributes [transfer_rule]}), ("right_total", @{thms typedef_right_total}, @{attributes [transfer_rule]})] in notes3 @ notes2 @ notes1 @ notes end val notes1 = [(Binding.prefix_name "Quotient_" qty_name, [quot_thm], [])] fun setup_rules lthy = let val thms = if is_some (get_pcrel_info lthy qty_full_name) then setup_transfer_rules_par lthy notes1 else setup_transfer_rules_nonpar notes1 in notes (#notes config) thms lthy end in lthy1 |> setup_lifting_infr config quot_thm opt_reflp_thm ||> setup_rules end fun setup_lifting_cmd xthm opt_reflp_xthm opt_par_xthm lthy = let val input_thm = singleton (Attrib.eval_thms lthy) xthm val input_term = (HOLogic.dest_Trueprop o Thm.prop_of) input_thm handle TERM _ => error "Unsupported type of a theorem. Only Quotient or type_definition are supported." fun sanity_check_reflp_thm reflp_thm = let val reflp_tm = (HOLogic.dest_Trueprop o Thm.prop_of) reflp_thm handle TERM _ => error "Invalid form of the reflexivity theorem. Use \"reflp R\"." in case reflp_tm of Const (\<^const_name>\reflp\, _) $ _ => () | _ => error "Invalid form of the reflexivity theorem. Use \"reflp R\"." end fun check_qty qty = if not (is_Type qty) then error "The abstract type must be a type constructor." else () fun setup_quotient () = let val opt_reflp_thm = Option.map (singleton (Attrib.eval_thms lthy)) opt_reflp_xthm val _ = if is_some opt_reflp_thm then sanity_check_reflp_thm (the opt_reflp_thm) else () val opt_par_thm = Option.map (singleton (Attrib.eval_thms lthy)) opt_par_xthm val _ = check_qty (snd (quot_thm_rty_qty input_thm)) in setup_by_quotient default_config input_thm opt_reflp_thm opt_par_thm lthy |> snd end fun setup_typedef () = let val qty = (range_type o fastype_of o hd o get_args 2) input_term val _ = check_qty qty in case opt_reflp_xthm of SOME _ => error "The reflexivity theorem cannot be specified if the type_definition theorem is used." | NONE => ( case opt_par_xthm of SOME _ => error "The parametricity theorem cannot be specified if the type_definition theorem is used." | NONE => setup_by_typedef_thm default_config input_thm lthy |> snd ) end in case input_term of (Const (\<^const_name>\Quotient\, _) $ _ $ _ $ _ $ _) => setup_quotient () | (Const (\<^const_name>\type_definition\, _) $ _ $ _ $ _) => setup_typedef () | _ => error "Unsupported type of a theorem. Only Quotient or type_definition are supported." end val _ = Outer_Syntax.local_theory \<^command_keyword>\setup_lifting\ "setup lifting infrastructure" (Parse.thm -- Scan.option Parse.thm -- Scan.option (\<^keyword>\parametric\ |-- Parse.!!! Parse.thm) >> (fn ((xthm, opt_reflp_xthm), opt_par_xthm) => setup_lifting_cmd xthm opt_reflp_xthm opt_par_xthm)) (* restoring lifting infrastructure *) local exception PCR_ERROR of Pretty.T list in fun lifting_restore_sanity_check ctxt (qinfo:Lifting_Info.quotient) = let val quot_thm = (#quot_thm qinfo) val _ = quot_thm_sanity_check ctxt quot_thm val pcr_info_err = (case #pcr_info qinfo of SOME pcr => let val pcrel_def = #pcrel_def pcr val pcr_cr_eq = #pcr_cr_eq pcr val (def_lhs, _) = Logic.dest_equals (Thm.prop_of pcrel_def) handle TERM _ => raise PCR_ERROR [Pretty.block [Pretty.str "The pcr definiton theorem is not a plain meta equation:", Pretty.brk 1, Thm.pretty_thm ctxt pcrel_def]] val pcr_const_def = head_of def_lhs val (eq_lhs, eq_rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of pcr_cr_eq)) handle TERM _ => raise PCR_ERROR [Pretty.block [Pretty.str "The pcr_cr equation theorem is not a plain equation:", Pretty.brk 1, Thm.pretty_thm ctxt pcr_cr_eq]] val (pcr_const_eq, eqs) = strip_comb eq_lhs fun is_eq (Const (\<^const_name>\HOL.eq\, _)) = true | is_eq _ = false fun eq_Const (Const (name1, _)) (Const (name2, _)) = (name1 = name2) | eq_Const _ _ = false val all_eqs = if not (forall is_eq eqs) then [Pretty.block [Pretty.str "Arguments of the lhs of the pcr_cr equation theorem are not only equalities:", Pretty.brk 1, Thm.pretty_thm ctxt pcr_cr_eq]] else [] val pcr_consts_not_equal = if not (eq_Const pcr_const_def pcr_const_eq) then [Pretty.block [Pretty.str "Parametrized correspondence relation constants in pcr_def and pcr_cr_eq are not equal:", Pretty.brk 1, Syntax.pretty_term ctxt pcr_const_def, Pretty.brk 1, Pretty.str "vs.", Pretty.brk 1, Syntax.pretty_term ctxt pcr_const_eq]] else [] val crel = quot_thm_crel quot_thm val cr_consts_not_equal = if not (eq_Const crel eq_rhs) then [Pretty.block [Pretty.str "Correspondence relation constants in the Quotient theorem and pcr_cr_eq are not equal:", Pretty.brk 1, Syntax.pretty_term ctxt crel, Pretty.brk 1, Pretty.str "vs.", Pretty.brk 1, Syntax.pretty_term ctxt eq_rhs]] else [] in all_eqs @ pcr_consts_not_equal @ cr_consts_not_equal end | NONE => []) val errs = pcr_info_err in if null errs then () else raise PCR_ERROR errs end handle PCR_ERROR errs => error (cat_lines (["Sanity check failed:"] @ (map (Pretty.string_of o Pretty.item o single) errs))) end (* Registers the data in qinfo in the Lifting infrastructure. *) fun lifting_restore qinfo ctxt = let val _ = lifting_restore_sanity_check (Context.proof_of ctxt) qinfo val (_, qty) = quot_thm_rty_qty (#quot_thm qinfo) val qty_full_name = (fst o dest_Type) qty val stored_qinfo = Lifting_Info.lookup_quotients (Context.proof_of ctxt) qty_full_name in if is_some (stored_qinfo) andalso not (Lifting_Info.quotient_eq (qinfo, (the stored_qinfo))) then error (Pretty.string_of (Pretty.block [Pretty.str "Lifting is already setup for the type", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ (Context.proof_of ctxt) qty)])) else Lifting_Info.update_quotients qty_full_name qinfo ctxt end val parse_opt_pcr = Scan.optional (Attrib.thm -- Attrib.thm >> (fn (pcrel_def, pcr_cr_eq) => SOME {pcrel_def = pcrel_def, pcr_cr_eq = pcr_cr_eq})) NONE val lifting_restore_attribute_setup = Attrib.setup \<^binding>\lifting_restore\ ((Attrib.thm -- parse_opt_pcr) >> (fn (quot_thm, opt_pcr) => let val qinfo = { quot_thm = quot_thm, pcr_info = opt_pcr} in Thm.declaration_attribute (K (lifting_restore qinfo)) end)) "restoring lifting infrastructure" val _ = Theory.setup lifting_restore_attribute_setup fun lifting_restore_internal bundle_name ctxt = let val restore_info = Lifting_Info.lookup_restore_data (Context.proof_of ctxt) bundle_name in case restore_info of SOME restore_info => ctxt |> lifting_restore (#quotient restore_info) |> fold_rev Transfer.transfer_raw_add (Item_Net.content (#transfer_rules restore_info)) | NONE => ctxt end val lifting_restore_internal_attribute_setup = Attrib.setup \<^binding>\lifting_restore_internal\ (Scan.lift Parse.string >> (fn name => Thm.declaration_attribute (K (lifting_restore_internal name)))) "restoring lifting infrastructure; internal attribute; not meant to be used directly by regular users" val _ = Theory.setup lifting_restore_internal_attribute_setup (* lifting_forget *) val monotonicity_names = [\<^const_name>\right_unique\, \<^const_name>\left_unique\, \<^const_name>\right_total\, \<^const_name>\left_total\, \<^const_name>\bi_unique\, \<^const_name>\bi_total\] fun fold_transfer_rel f (Const (\<^const_name>\Transfer.Rel\, _) $ rel $ _ $ _) = f rel | fold_transfer_rel f (Const (\<^const_name>\HOL.eq\, _) $ (Const (\<^const_name>\Domainp\, _) $ rel) $ _) = f rel | fold_transfer_rel f (Const (name, _) $ rel) = if member op= monotonicity_names name then f rel else f \<^term>\undefined\ | fold_transfer_rel f _ = f \<^term>\undefined\ fun filter_transfer_rules_by_rel transfer_rel transfer_rules = let val transfer_rel_name = transfer_rel |> dest_Const |> fst; fun has_transfer_rel thm = let val concl = thm |> Thm.concl_of |> HOLogic.dest_Trueprop in member op= (fold_transfer_rel (fn tm => Term.add_const_names tm []) concl) transfer_rel_name end handle TERM _ => false in filter has_transfer_rel transfer_rules end type restore_data = {quotient : Lifting_Info.quotient, transfer_rules: thm Item_Net.T} fun get_transfer_rel (qinfo : Lifting_Info.quotient) = let fun get_pcrel pcr_def = pcr_def |> Thm.concl_of |> Logic.dest_equals |> fst |> head_of in if is_some (#pcr_info qinfo) then get_pcrel (#pcrel_def (the (#pcr_info qinfo))) else quot_thm_crel (#quot_thm qinfo) end fun pointer_of_bundle_name bundle_name ctxt = let val bundle = Bundle.read ctxt bundle_name fun err () = error "The provided bundle is not a lifting bundle" in (case bundle of [(_, [arg_src])] => let val (name, _) = Token.syntax (Scan.lift Parse.string) arg_src ctxt handle ERROR _ => err () in name end | _ => err ()) end fun pointer_of_bundle_binding ctxt binding = Name_Space.full_name (Name_Space.naming_of (Context.Theory (Proof_Context.theory_of ctxt))) binding fun lifting_forget pointer lthy = let fun get_transfer_rules_to_delete qinfo ctxt = let val transfer_rel = get_transfer_rel qinfo in filter_transfer_rules_by_rel transfer_rel (Transfer.get_transfer_raw ctxt) end in case Lifting_Info.lookup_restore_data lthy pointer of SOME restore_info => let val qinfo = #quotient restore_info val quot_thm = #quot_thm qinfo val transfer_rules = get_transfer_rules_to_delete qinfo lthy in Local_Theory.declaration {syntax = false, pervasive = true} (K (fold (Transfer.transfer_raw_del) transfer_rules #> Lifting_Info.delete_quotients quot_thm)) lthy end | NONE => error "The lifting bundle refers to non-existent restore data." end fun lifting_forget_cmd bundle_name lthy = lifting_forget (pointer_of_bundle_name bundle_name lthy) lthy val _ = Outer_Syntax.local_theory \<^command_keyword>\lifting_forget\ "unsetup Lifting and Transfer for the given lifting bundle" (Parse.name_position >> lifting_forget_cmd) (* lifting_update *) fun update_transfer_rules pointer lthy = let fun new_transfer_rules ({ quotient = qinfo, ... }:Lifting_Info.restore_data) lthy = let val transfer_rel = get_transfer_rel qinfo val transfer_rules = filter_transfer_rules_by_rel transfer_rel (Transfer.get_transfer_raw lthy) in fn phi => fold_rev (Item_Net.update o Morphism.thm phi) transfer_rules Thm.item_net end in case Lifting_Info.lookup_restore_data lthy pointer of SOME refresh_data => Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => Lifting_Info.add_transfer_rules_in_restore_data pointer (new_transfer_rules refresh_data lthy phi)) lthy | NONE => error "The lifting bundle refers to non-existent restore data." end fun lifting_update_cmd bundle_name lthy = update_transfer_rules (pointer_of_bundle_name bundle_name lthy) lthy val _ = Outer_Syntax.local_theory \<^command_keyword>\lifting_update\ "add newly introduced transfer rules to a bundle storing the state of Lifting and Transfer" (Parse.name_position >> lifting_update_cmd) end diff --git a/src/HOL/Tools/Transfer/transfer.ML b/src/HOL/Tools/Transfer/transfer.ML --- a/src/HOL/Tools/Transfer/transfer.ML +++ b/src/HOL/Tools/Transfer/transfer.ML @@ -1,932 +1,924 @@ (* Title: HOL/Tools/Transfer/transfer.ML Author: Brian Huffman, TU Muenchen Author: Ondrej Kuncar, TU Muenchen Generic theorem transfer method. *) signature TRANSFER = sig type pred_data val mk_pred_data: thm -> thm -> thm list -> pred_data val rel_eq_onp: pred_data -> thm val pred_def: pred_data -> thm val pred_simps: pred_data -> thm list val update_pred_simps: thm list -> pred_data -> pred_data - - val bottom_rewr_conv: thm list -> conv - val top_rewr_conv: thm list -> conv - val top_sweep_rewr_conv: thm list -> conv - val prep_conv: conv val fold_relator_eqs_conv: Proof.context -> conv val unfold_relator_eqs_conv: Proof.context -> conv val get_transfer_raw: Proof.context -> thm list val get_relator_eq: Proof.context -> thm list val retrieve_relator_eq: Proof.context -> term -> thm list val get_sym_relator_eq: Proof.context -> thm list val get_relator_eq_raw: Proof.context -> thm list val get_relator_domain: Proof.context -> thm list val morph_pred_data: morphism -> pred_data -> pred_data val lookup_pred_data: Proof.context -> string -> pred_data option val update_pred_data: string -> pred_data -> Context.generic -> Context.generic val is_compound_lhs: Proof.context -> term -> bool val is_compound_rhs: Proof.context -> term -> bool val transfer_add: attribute val transfer_del: attribute val transfer_raw_add: thm -> Context.generic -> Context.generic val transfer_raw_del: thm -> Context.generic -> Context.generic val transferred_attribute: thm list -> attribute val untransferred_attribute: thm list -> attribute val prep_transfer_domain_thm: Proof.context -> thm -> thm val transfer_domain_add: attribute val transfer_domain_del: attribute val transfer_rule_of_term: Proof.context -> bool -> term -> thm val transfer_rule_of_lhs: Proof.context -> term -> thm val eq_tac: Proof.context -> int -> tactic val transfer_start_tac: bool -> Proof.context -> int -> tactic val transfer_prover_start_tac: Proof.context -> int -> tactic val transfer_step_tac: Proof.context -> int -> tactic val transfer_end_tac: Proof.context -> int -> tactic val transfer_prover_end_tac: Proof.context -> int -> tactic val transfer_tac: bool -> Proof.context -> int -> tactic val transfer_prover_tac: Proof.context -> int -> tactic val gen_frees_tac: (string * typ) list -> Proof.context -> int -> tactic end structure Transfer : TRANSFER = struct -fun bottom_rewr_conv rewrs = Conv.bottom_conv (K (Conv.try_conv (Conv.rewrs_conv rewrs))) \<^context> -fun top_rewr_conv rewrs = Conv.top_conv (K (Conv.try_conv (Conv.rewrs_conv rewrs))) \<^context> -fun top_sweep_rewr_conv rewrs = Conv.top_sweep_conv (K (Conv.rewrs_conv rewrs)) \<^context> (** Theory Data **) val compound_xhs_empty_net = Item_Net.init (Thm.eq_thm_prop o apply2 snd) (single o fst); val rewr_rules = Item_Net.init Thm.eq_thm_prop (single o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.concl_of); datatype pred_data = PRED_DATA of {pred_def: thm, rel_eq_onp: thm, pred_simps: thm list} fun mk_pred_data pred_def rel_eq_onp pred_simps = PRED_DATA {pred_def = pred_def, rel_eq_onp = rel_eq_onp, pred_simps = pred_simps} fun map_pred_data' f1 f2 f3 (PRED_DATA {pred_def, rel_eq_onp, pred_simps}) = PRED_DATA {pred_def = f1 pred_def, rel_eq_onp = f2 rel_eq_onp, pred_simps = f3 pred_simps} fun rep_pred_data (PRED_DATA p) = p val rel_eq_onp = #rel_eq_onp o rep_pred_data val pred_def = #pred_def o rep_pred_data val pred_simps = #pred_simps o rep_pred_data fun update_pred_simps new_pred_data = map_pred_data' I I (K new_pred_data) structure Data = Generic_Data ( type T = { transfer_raw : thm Item_Net.T, known_frees : (string * typ) list, compound_lhs : (term * thm) Item_Net.T, compound_rhs : (term * thm) Item_Net.T, relator_eq : thm Item_Net.T, relator_eq_raw : thm Item_Net.T, relator_domain : thm Item_Net.T, pred_data : pred_data Symtab.table } val empty = { transfer_raw = Thm.item_net_intro, known_frees = [], compound_lhs = compound_xhs_empty_net, compound_rhs = compound_xhs_empty_net, relator_eq = rewr_rules, relator_eq_raw = Thm.item_net, relator_domain = Thm.item_net, pred_data = Symtab.empty } val extend = I fun merge ( { transfer_raw = t1, known_frees = k1, compound_lhs = l1, compound_rhs = c1, relator_eq = r1, relator_eq_raw = rw1, relator_domain = rd1, pred_data = pd1 }, { transfer_raw = t2, known_frees = k2, compound_lhs = l2, compound_rhs = c2, relator_eq = r2, relator_eq_raw = rw2, relator_domain = rd2, pred_data = pd2 } ) = { transfer_raw = Item_Net.merge (t1, t2), known_frees = Library.merge (op =) (k1, k2), compound_lhs = Item_Net.merge (l1, l2), compound_rhs = Item_Net.merge (c1, c2), relator_eq = Item_Net.merge (r1, r2), relator_eq_raw = Item_Net.merge (rw1, rw2), relator_domain = Item_Net.merge (rd1, rd2), pred_data = Symtab.merge (K true) (pd1, pd2) } ) fun get_net_content f ctxt = Item_Net.content (f (Data.get (Context.Proof ctxt))) |> map (Thm.transfer' ctxt) val get_transfer_raw = get_net_content #transfer_raw val get_known_frees = #known_frees o Data.get o Context.Proof fun is_compound f ctxt t = Item_Net.retrieve (f (Data.get (Context.Proof ctxt))) t |> exists (fn (pat, _) => Pattern.matches (Proof_Context.theory_of ctxt) (pat, t)); val is_compound_lhs = is_compound #compound_lhs val is_compound_rhs = is_compound #compound_rhs val get_relator_eq = get_net_content #relator_eq #> map safe_mk_meta_eq fun retrieve_relator_eq ctxt t = Item_Net.retrieve (#relator_eq (Data.get (Context.Proof ctxt))) t |> map (Thm.transfer' ctxt) val get_sym_relator_eq = get_net_content #relator_eq #> map (safe_mk_meta_eq #> Thm.symmetric) val get_relator_eq_raw = get_net_content #relator_eq_raw val get_relator_domain = get_net_content #relator_domain val get_pred_data = #pred_data o Data.get o Context.Proof fun map_data f1 f2 f3 f4 f5 f6 f7 f8 { transfer_raw, known_frees, compound_lhs, compound_rhs, relator_eq, relator_eq_raw, relator_domain, pred_data } = { transfer_raw = f1 transfer_raw, known_frees = f2 known_frees, compound_lhs = f3 compound_lhs, compound_rhs = f4 compound_rhs, relator_eq = f5 relator_eq, relator_eq_raw = f6 relator_eq_raw, relator_domain = f7 relator_domain, pred_data = f8 pred_data } fun map_transfer_raw f = map_data f I I I I I I I fun map_known_frees f = map_data I f I I I I I I fun map_compound_lhs f = map_data I I f I I I I I fun map_compound_rhs f = map_data I I I f I I I I fun map_relator_eq f = map_data I I I I f I I I fun map_relator_eq_raw f = map_data I I I I I f I I fun map_relator_domain f = map_data I I I I I I f I fun map_pred_data f = map_data I I I I I I I f val add_transfer_thm = Thm.trim_context #> (fn thm => Data.map (map_transfer_raw (Item_Net.update thm) o map_compound_lhs (case HOLogic.dest_Trueprop (Thm.concl_of thm) of Const (\<^const_name>\Rel\, _) $ _ $ (lhs as (_ $ _)) $ _ => Item_Net.update (lhs, thm) | _ => I) o map_compound_rhs (case HOLogic.dest_Trueprop (Thm.concl_of thm) of Const (\<^const_name>\Rel\, _) $ _ $ _ $ (rhs as (_ $ _)) => Item_Net.update (rhs, thm) | _ => I) o map_known_frees (Term.add_frees (Thm.concl_of thm)))) fun del_transfer_thm thm = Data.map (map_transfer_raw (Item_Net.remove thm) o map_compound_lhs (case HOLogic.dest_Trueprop (Thm.concl_of thm) of Const (\<^const_name>\Rel\, _) $ _ $ (lhs as (_ $ _)) $ _ => Item_Net.remove (lhs, thm) | _ => I) o map_compound_rhs (case HOLogic.dest_Trueprop (Thm.concl_of thm) of Const (\<^const_name>\Rel\, _) $ _ $ _ $ (rhs as (_ $ _)) => Item_Net.remove (rhs, thm) | _ => I)) fun transfer_raw_add thm ctxt = add_transfer_thm thm ctxt fun transfer_raw_del thm ctxt = del_transfer_thm thm ctxt (** Conversions **) fun transfer_rel_conv conv = Conv.concl_conv ~1 (HOLogic.Trueprop_conv (Conv.fun2_conv (Conv.arg_conv conv))) val Rel_rule = Thm.symmetric @{thm Rel_def} fun Rel_conv ct = let val (cT, cT') = Thm.dest_funT (Thm.ctyp_of_cterm ct) val (cU, _) = Thm.dest_funT cT' in Thm.instantiate' [SOME cT, SOME cU] [SOME ct] Rel_rule end (* Conversion to preprocess a transfer rule *) fun safe_Rel_conv ct = Conv.try_conv (HOLogic.Trueprop_conv (Conv.fun_conv (Conv.fun_conv Rel_conv))) ct fun prep_conv ct = ( Conv.implies_conv safe_Rel_conv prep_conv else_conv safe_Rel_conv else_conv Conv.all_conv) ct -fun fold_relator_eqs_conv ctxt ct = (bottom_rewr_conv (get_relator_eq ctxt)) ct; -fun unfold_relator_eqs_conv ctxt ct = (top_rewr_conv (get_sym_relator_eq ctxt)) ct; +fun fold_relator_eqs_conv ctxt = Conv.bottom_rewrs_conv (get_relator_eq ctxt) ctxt +fun unfold_relator_eqs_conv ctxt = Conv.top_rewrs_conv (get_sym_relator_eq ctxt) ctxt (** Replacing explicit equalities with is_equality premises **) fun mk_is_equality t = Const (\<^const_name>\is_equality\, Term.fastype_of t --> HOLogic.boolT) $ t fun gen_abstract_equalities ctxt (dest : term -> term * (term -> term)) thm = let val prop = Thm.prop_of thm val (t, mk_prop') = dest prop (* Only consider "(=)" at non-base types *) fun is_eq (Const (\<^const_name>\HOL.eq\, Type ("fun", [T, _]))) = (case T of Type (_, []) => false | _ => true) | is_eq _ = false val add_eqs = Term.fold_aterms (fn t => if is_eq t then insert (op =) t else I) val eq_consts = rev (add_eqs t []) val eqTs = map (snd o dest_Const) eq_consts val used = Term.add_free_names prop [] val names = map (K "") eqTs |> Name.variant_list used val frees = map Free (names ~~ eqTs) val prems = map (HOLogic.mk_Trueprop o mk_is_equality) frees val prop1 = mk_prop' (Term.subst_atomic (eq_consts ~~ frees) t) val prop2 = fold Logic.all frees (Logic.list_implies (prems, prop1)) val cprop = Thm.cterm_of ctxt prop2 val equal_thm = Raw_Simplifier.rewrite ctxt false @{thms is_equality_lemma} cprop fun forall_elim thm = Thm.forall_elim_vars (Thm.maxidx_of thm + 1) thm in forall_elim (thm COMP (equal_thm COMP @{thm equal_elim_rule2})) end handle TERM _ => thm fun abstract_equalities_transfer ctxt thm = let fun dest prop = let val prems = Logic.strip_imp_prems prop val concl = HOLogic.dest_Trueprop (Logic.strip_imp_concl prop) val ((rel, x), y) = apfst Term.dest_comb (Term.dest_comb concl) in (rel, fn rel' => Logic.list_implies (prems, HOLogic.mk_Trueprop (rel' $ x $ y))) end val contracted_eq_thm = Conv.fconv_rule (transfer_rel_conv (fold_relator_eqs_conv ctxt)) thm handle CTERM _ => thm in gen_abstract_equalities ctxt dest contracted_eq_thm end fun abstract_equalities_relator_eq ctxt rel_eq_thm = gen_abstract_equalities ctxt (fn x => (x, I)) (rel_eq_thm RS @{thm is_equality_def [THEN iffD2]}) fun abstract_equalities_domain ctxt thm = let fun dest prop = let val prems = Logic.strip_imp_prems prop val concl = HOLogic.dest_Trueprop (Logic.strip_imp_concl prop) val ((eq, dom), y) = apfst Term.dest_comb (Term.dest_comb concl) in (dom, fn dom' => Logic.list_implies (prems, HOLogic.mk_Trueprop (eq $ dom' $ y))) end fun transfer_rel_conv conv = Conv.concl_conv ~1 (HOLogic.Trueprop_conv (Conv.arg1_conv (Conv.arg_conv conv))) val contracted_eq_thm = Conv.fconv_rule (transfer_rel_conv (fold_relator_eqs_conv ctxt)) thm in gen_abstract_equalities ctxt dest contracted_eq_thm end (** Replacing explicit Domainp predicates with Domainp assumptions **) fun mk_Domainp_assm (T, R) = HOLogic.mk_eq ((Const (\<^const_name>\Domainp\, Term.fastype_of T --> Term.fastype_of R) $ T), R) fun fold_Domainp f (t as Const (\<^const_name>\Domainp\,_) $ (Var (_,_))) = f t | fold_Domainp f (t $ u) = fold_Domainp f t #> fold_Domainp f u | fold_Domainp f (Abs (_, _, t)) = fold_Domainp f t | fold_Domainp _ _ = I fun subst_terms tab t = let val t' = Termtab.lookup tab t in case t' of SOME t' => t' | NONE => (case t of u $ v => (subst_terms tab u) $ (subst_terms tab v) | Abs (a, T, t) => Abs (a, T, subst_terms tab t) | t => t) end fun gen_abstract_domains ctxt (dest : term -> term * (term -> term)) thm = let val prop = Thm.prop_of thm val (t, mk_prop') = dest prop val Domainp_tms = rev (fold_Domainp (fn t => insert op= t) t []) val Domainp_Ts = map (snd o dest_funT o snd o dest_Const o fst o dest_comb) Domainp_tms val used = Term.add_free_names t [] val rels = map (snd o dest_comb) Domainp_tms val rel_names = map (fst o fst o dest_Var) rels val names = map (fn name => ("D" ^ name)) rel_names |> Name.variant_list used val frees = map Free (names ~~ Domainp_Ts) val prems = map (HOLogic.mk_Trueprop o mk_Domainp_assm) (rels ~~ frees); val t' = subst_terms (fold Termtab.update (Domainp_tms ~~ frees) Termtab.empty) t val prop1 = fold Logic.all frees (Logic.list_implies (prems, mk_prop' t')) val prop2 = Logic.list_rename_params (rev names) prop1 val cprop = Thm.cterm_of ctxt prop2 val equal_thm = Raw_Simplifier.rewrite ctxt false @{thms Domainp_lemma} cprop fun forall_elim thm = Thm.forall_elim_vars (Thm.maxidx_of thm + 1) thm; in forall_elim (thm COMP (equal_thm COMP @{thm equal_elim_rule2})) end handle TERM _ => thm fun abstract_domains_transfer ctxt thm = let fun dest prop = let val prems = Logic.strip_imp_prems prop val concl = HOLogic.dest_Trueprop (Logic.strip_imp_concl prop) val ((rel, x), y) = apfst Term.dest_comb (Term.dest_comb concl) in (x, fn x' => Logic.list_implies (prems, HOLogic.mk_Trueprop (rel $ x' $ y))) end in gen_abstract_domains ctxt dest thm end fun abstract_domains_relator_domain ctxt thm = let fun dest prop = let val prems = Logic.strip_imp_prems prop val concl = HOLogic.dest_Trueprop (Logic.strip_imp_concl prop) val ((rel, x), y) = apfst Term.dest_comb (Term.dest_comb concl) in (y, fn y' => Logic.list_implies (prems, HOLogic.mk_Trueprop (rel $ x $ y'))) end in gen_abstract_domains ctxt dest thm end fun detect_transfer_rules thm = let fun is_transfer_rule tm = case (HOLogic.dest_Trueprop tm) of (Const (\<^const_name>\HOL.eq\, _)) $ ((Const (\<^const_name>\Domainp\, _)) $ _) $ _ => false | _ $ _ $ _ => true | _ => false fun safe_transfer_rule_conv ctm = if is_transfer_rule (Thm.term_of ctm) then safe_Rel_conv ctm else Conv.all_conv ctm in Conv.fconv_rule (Conv.prems_conv ~1 safe_transfer_rule_conv) thm end (** Adding transfer domain rules **) fun prep_transfer_domain_thm ctxt = abstract_equalities_domain ctxt o detect_transfer_rules fun add_transfer_domain_thm thm ctxt = (add_transfer_thm o prep_transfer_domain_thm (Context.proof_of ctxt)) thm ctxt fun del_transfer_domain_thm thm ctxt = (del_transfer_thm o prep_transfer_domain_thm (Context.proof_of ctxt)) thm ctxt (** Transfer proof method **) val post_simps = @{thms transfer_forall_eq [symmetric] transfer_implies_eq [symmetric] transfer_bforall_unfold} fun gen_frees_tac keepers ctxt = SUBGOAL (fn (t, i) => let val keepers = keepers @ get_known_frees ctxt val vs = rev (Term.add_frees t []) val vs' = filter_out (member (op =) keepers) vs in Induct.arbitrary_tac ctxt 0 vs' i end) fun mk_relT (T, U) = T --> U --> HOLogic.boolT fun mk_Rel t = let val T = fastype_of t in Const (\<^const_name>\Transfer.Rel\, T --> T) $ t end fun transfer_rule_of_terms (prj : typ * typ -> typ) ctxt tab t u = let (* precondition: prj(T,U) must consist of only TFrees and type "fun" *) fun rel (T as Type ("fun", [T1, T2])) (U as Type ("fun", [U1, U2])) = let val r1 = rel T1 U1 val r2 = rel T2 U2 val rT = fastype_of r1 --> fastype_of r2 --> mk_relT (T, U) in Const (\<^const_name>\rel_fun\, rT) $ r1 $ r2 end | rel T U = let val (a, _) = dest_TFree (prj (T, U)) in Free (the (AList.lookup (op =) tab a), mk_relT (T, U)) end fun zip _ thms (Bound i) (Bound _) = (nth thms i, []) | zip ctxt thms (Abs (x, T, t)) (Abs (y, U, u)) = let val ([x', y'], ctxt') = Variable.variant_fixes [x, y] ctxt val prop = mk_Rel (rel T U) $ Free (x', T) $ Free (y', U) val cprop = Thm.cterm_of ctxt' (HOLogic.mk_Trueprop prop) val thm0 = Thm.assume cprop val (thm1, hyps) = zip ctxt' (thm0 :: thms) t u val ((r1, x), y) = apfst Thm.dest_comb (Thm.dest_comb (Thm.dest_arg cprop)) val r2 = Thm.dest_fun2 (Thm.dest_arg (Thm.cprop_of thm1)) val (a1, (b1, _)) = apsnd Thm.dest_funT (Thm.dest_funT (Thm.ctyp_of_cterm r1)) val (a2, (b2, _)) = apsnd Thm.dest_funT (Thm.dest_funT (Thm.ctyp_of_cterm r2)) val tinsts = [SOME a1, SOME b1, SOME a2, SOME b2] val insts = [SOME (Thm.dest_arg r1), SOME (Thm.dest_arg r2)] val rule = Thm.instantiate' tinsts insts @{thm Rel_abs} val thm2 = Thm.forall_intr x (Thm.forall_intr y (Thm.implies_intr cprop thm1)) in (thm2 COMP rule, hyps) end | zip ctxt thms (f $ t) (g $ u) = let val (thm1, hyps1) = zip ctxt thms f g val (thm2, hyps2) = zip ctxt thms t u in (thm2 RS (thm1 RS @{thm Rel_app}), hyps1 @ hyps2) end | zip _ _ t u = let val T = fastype_of t val U = fastype_of u val prop = mk_Rel (rel T U) $ t $ u val cprop = Thm.cterm_of ctxt (HOLogic.mk_Trueprop prop) in (Thm.assume cprop, [cprop]) end val r = mk_Rel (rel (fastype_of t) (fastype_of u)) val goal = HOLogic.mk_Trueprop (r $ t $ u) val rename = Thm.trivial (Thm.cterm_of ctxt goal) val (thm, hyps) = zip ctxt [] t u in Drule.implies_intr_list hyps (thm RS rename) end (* create a lambda term of the same shape as the given term *) fun skeleton is_atom = let fun dummy ctxt = let val (c, ctxt') = yield_singleton Variable.variant_fixes "a" ctxt in (Free (c, dummyT), ctxt') end fun skel (Bound i) ctxt = (Bound i, ctxt) | skel (Abs (x, _, t)) ctxt = let val (t', ctxt) = skel t ctxt in (Abs (x, dummyT, t'), ctxt) end | skel (tu as t $ u) ctxt = if is_atom tu andalso not (Term.is_open tu) then dummy ctxt else let val (t', ctxt) = skel t ctxt val (u', ctxt) = skel u ctxt in (t' $ u', ctxt) end | skel _ ctxt = dummy ctxt in fn ctxt => fn t => fst (skel t ctxt) |> Syntax.check_term ctxt (* FIXME avoid syntax operation!? *) end (** Monotonicity analysis **) (* TODO: Put extensible table in theory data *) val monotab = Symtab.make [(\<^const_name>\transfer_implies\, [~1, 1]), (\<^const_name>\transfer_forall\, [1])(*, (@{const_name implies}, [~1, 1]), (@{const_name All}, [1])*)] (* Function bool_insts determines the set of boolean-relation variables that can be instantiated to implies, rev_implies, or iff. Invariants: bool_insts p (t, u) requires that u :: _ => _ => ... => bool, and t is a skeleton of u *) fun bool_insts p (t, u) = let fun strip2 (t1 $ t2, u1 $ u2, tus) = strip2 (t1, u1, (t2, u2) :: tus) | strip2 x = x fun or3 ((a, b, c), (x, y, z)) = (a orelse x, b orelse y, c orelse z) fun go Ts p (Abs (_, T, t), Abs (_, _, u)) tab = go (T :: Ts) p (t, u) tab | go Ts p (t, u) tab = let val (a, _) = dest_TFree (Term.body_type (Term.fastype_of1 (Ts, t))) val (_, tf, tus) = strip2 (t, u, []) val ps_opt = case tf of Const (c, _) => Symtab.lookup monotab c | _ => NONE val tab1 = case ps_opt of SOME ps => let val ps' = map (fn x => p * x) (take (length tus) ps) in fold I (map2 (go Ts) ps' tus) tab end | NONE => tab val tab2 = Symtab.make [(a, (p >= 0, p <= 0, is_none ps_opt))] in Symtab.join (K or3) (tab1, tab2) end val tab = go [] p (t, u) Symtab.empty fun f (a, (true, false, false)) = SOME (a, \<^Const>\implies\) | f (a, (false, true, false)) = SOME (a, \<^Const>\rev_implies\) | f (a, (true, true, _)) = SOME (a, HOLogic.eq_const HOLogic.boolT) | f _ = NONE in map_filter f (Symtab.dest tab) end fun transfer_rule_of_term ctxt equiv t = let val s = skeleton (is_compound_rhs ctxt) ctxt t val frees = map fst (Term.add_frees s []) val tfrees = map fst (Term.add_tfrees s []) fun prep a = "R" ^ Library.unprefix "'" a val (rnames, ctxt') = Variable.variant_fixes (map prep tfrees) ctxt val tab = tfrees ~~ rnames fun prep a = the (AList.lookup (op =) tab a) val thm = transfer_rule_of_terms fst ctxt' tab s t val binsts = bool_insts (if equiv then 0 else 1) (s, t) val idx = Thm.maxidx_of thm + 1 fun tinst (a, _) = (((a, idx), \<^sort>\type\), \<^ctyp>\bool\) fun inst (a, t) = ((Name.clean_index (prep a, idx), \<^typ>\bool \ bool \ bool\), Thm.cterm_of ctxt' t) in thm |> Thm.generalize (Names.make_set tfrees, Names.make_set (rnames @ frees)) idx |> Thm.instantiate (TVars.make (map tinst binsts), Vars.make (map inst binsts)) end fun transfer_rule_of_lhs ctxt t = let val s = skeleton (is_compound_lhs ctxt) ctxt t val frees = map fst (Term.add_frees s []) val tfrees = map fst (Term.add_tfrees s []) fun prep a = "R" ^ Library.unprefix "'" a val (rnames, ctxt') = Variable.variant_fixes (map prep tfrees) ctxt val tab = tfrees ~~ rnames fun prep a = the (AList.lookup (op =) tab a) val thm = transfer_rule_of_terms snd ctxt' tab t s val binsts = bool_insts 1 (s, t) val idx = Thm.maxidx_of thm + 1 fun tinst (a, _) = (((a, idx), \<^sort>\type\), \<^ctyp>\bool\) fun inst (a, t) = ((Name.clean_index (prep a, idx), \<^typ>\bool \ bool \ bool\), Thm.cterm_of ctxt' t) in thm |> Thm.generalize (Names.make_set tfrees, Names.make_set (rnames @ frees)) idx |> Thm.instantiate (TVars.make (map tinst binsts), Vars.make (map inst binsts)) end fun eq_rules_tac ctxt eq_rules = TRY o REPEAT_ALL_NEW (resolve_tac ctxt eq_rules) THEN_ALL_NEW resolve_tac ctxt @{thms is_equality_eq} fun eq_tac ctxt = eq_rules_tac ctxt (get_relator_eq_raw ctxt) fun transfer_step_tac ctxt = REPEAT_ALL_NEW (resolve_tac ctxt (get_transfer_raw ctxt)) THEN_ALL_NEW (DETERM o eq_rules_tac ctxt (get_relator_eq_raw ctxt)) fun transfer_start_tac equiv ctxt i = let val pre_simps = @{thms transfer_forall_eq transfer_implies_eq} val start_rule = if equiv then @{thm transfer_start} else @{thm transfer_start'} val err_msg = "Transfer failed to convert goal to an object-logic formula" fun main_tac (t, i) = resolve_tac ctxt [start_rule] i THEN (resolve_tac ctxt [transfer_rule_of_term ctxt equiv (HOLogic.dest_Trueprop t)]) (i + 1) handle TERM (_, ts) => raise TERM (err_msg, ts) in EVERY [rewrite_goal_tac ctxt pre_simps i THEN SUBGOAL main_tac i] end; fun transfer_prover_start_tac ctxt = SUBGOAL (fn (t, i) => let val rhs = (snd o Term.dest_comb o HOLogic.dest_Trueprop) t val rule1 = transfer_rule_of_term ctxt false rhs val expand_eqs_in_rel_conv = transfer_rel_conv (unfold_relator_eqs_conv ctxt) in EVERY [CONVERSION prep_conv i, CONVERSION expand_eqs_in_rel_conv i, resolve_tac ctxt @{thms transfer_prover_start} i, resolve_tac ctxt [rule1] (i + 1)] end); fun transfer_end_tac ctxt i = let val post_simps = @{thms transfer_forall_eq [symmetric] transfer_implies_eq [symmetric] transfer_bforall_unfold} in EVERY [rewrite_goal_tac ctxt post_simps i, Goal.norm_hhf_tac ctxt i] end; fun transfer_prover_end_tac ctxt i = resolve_tac ctxt @{thms refl} i local infix 1 THEN_ALL_BUT_FIRST_NEW fun (tac1 THEN_ALL_BUT_FIRST_NEW tac2) i st = st |> (tac1 i THEN (fn st' => Seq.INTERVAL tac2 (i + 1) (i + Thm.nprems_of st' - Thm.nprems_of st) st')); in fun transfer_tac equiv ctxt i = let val rules = get_transfer_raw ctxt val eq_rules = get_relator_eq_raw ctxt (* allow unsolved subgoals only for standard transfer method, not for transfer' *) val end_tac = if equiv then K all_tac else K no_tac fun transfer_search_tac i = (SOLVED' (REPEAT_ALL_NEW (resolve_tac ctxt rules) THEN_ALL_NEW (DETERM o eq_rules_tac ctxt eq_rules)) ORELSE' end_tac) i in (transfer_start_tac equiv ctxt THEN_ALL_BUT_FIRST_NEW transfer_search_tac THEN' transfer_end_tac ctxt) i end fun transfer_prover_tac ctxt i = let val rules = get_transfer_raw ctxt val eq_rules = get_relator_eq_raw ctxt fun transfer_prover_search_tac i = (REPEAT_ALL_NEW (resolve_tac ctxt rules) THEN_ALL_NEW (DETERM o eq_rules_tac ctxt eq_rules)) i in (transfer_prover_start_tac ctxt THEN_ALL_BUT_FIRST_NEW transfer_prover_search_tac THEN' transfer_prover_end_tac ctxt) i end end; (** Transfer attribute **) fun transferred ctxt extra_rules thm = let val rules = extra_rules @ get_transfer_raw ctxt val eq_rules = get_relator_eq_raw ctxt val pre_simps = @{thms transfer_forall_eq transfer_implies_eq} val thm1 = Thm.forall_intr_vars thm val instT = rev (Term.add_tvars (Thm.full_prop_of thm1) []) |> map (fn v as ((a, _), S) => (v, Thm.ctyp_of ctxt (TFree (a, S)))) val thm2 = thm1 |> Thm.instantiate (TVars.make instT, Vars.empty) |> Raw_Simplifier.rewrite_rule ctxt pre_simps val ctxt' = Variable.declare_names (Thm.full_prop_of thm2) ctxt val rule = transfer_rule_of_lhs ctxt' (HOLogic.dest_Trueprop (Thm.concl_of thm2)) in Goal.prove_internal ctxt' [] (Thm.cterm_of ctxt' (HOLogic.mk_Trueprop (Var (("P", 0), \<^typ>\bool\)))) (fn _ => resolve_tac ctxt' [thm2 RS @{thm transfer_start'}, thm2 RS @{thm transfer_start}] 1 THEN (resolve_tac ctxt' [rule] THEN_ALL_NEW (SOLVED' (REPEAT_ALL_NEW (resolve_tac ctxt' rules) THEN_ALL_NEW (DETERM o eq_rules_tac ctxt' eq_rules)))) 1 handle TERM (_, ts) => raise TERM ("Transfer failed to convert goal to an object-logic formula", ts)) |> Raw_Simplifier.rewrite_rule ctxt' post_simps |> Simplifier.norm_hhf ctxt' |> Drule.generalize (Names.make_set (map (fst o dest_TFree o Thm.typ_of o snd) instT), Names.empty) |> Drule.zero_var_indexes end (* handle THM _ => thm *) fun untransferred ctxt extra_rules thm = let val rules = extra_rules @ get_transfer_raw ctxt val eq_rules = get_relator_eq_raw ctxt val pre_simps = @{thms transfer_forall_eq transfer_implies_eq} val thm1 = Thm.forall_intr_vars thm val instT = rev (Term.add_tvars (Thm.full_prop_of thm1) []) |> map (fn v as ((a, _), S) => (v, Thm.ctyp_of ctxt (TFree (a, S)))) val thm2 = thm1 |> Thm.instantiate (TVars.make instT, Vars.empty) |> Raw_Simplifier.rewrite_rule ctxt pre_simps val ctxt' = Variable.declare_names (Thm.full_prop_of thm2) ctxt val t = HOLogic.dest_Trueprop (Thm.concl_of thm2) val rule = transfer_rule_of_term ctxt' true t in Goal.prove_internal ctxt' [] (Thm.cterm_of ctxt' (HOLogic.mk_Trueprop (Var (("P", 0), \<^typ>\bool\)))) (fn _ => resolve_tac ctxt' [thm2 RS @{thm untransfer_start}] 1 THEN (resolve_tac ctxt' [rule] THEN_ALL_NEW (SOLVED' (REPEAT_ALL_NEW (resolve_tac ctxt' rules) THEN_ALL_NEW (DETERM o eq_rules_tac ctxt' eq_rules)))) 1 handle TERM (_, ts) => raise TERM ("Transfer failed to convert goal to an object-logic formula", ts)) |> Raw_Simplifier.rewrite_rule ctxt' post_simps |> Simplifier.norm_hhf ctxt' |> Drule.generalize (Names.make_set (map (fst o dest_TFree o Thm.typ_of o snd) instT), Names.empty) |> Drule.zero_var_indexes end (** Methods and attributes **) val free = Args.context -- Args.term >> (fn (_, Free v) => v | (ctxt, t) => error ("Bad free variable: " ^ Syntax.string_of_term ctxt t)) val fixing = Scan.optional (Scan.lift (Args.$$$ "fixing" -- Args.colon) |-- Scan.repeat free) [] val reverse_prems = fn _ => PRIMITIVE (fn thm => fold_rev (fn i => Thm.permute_prems i 1) (0 upto Thm.nprems_of thm - 1) thm); fun transfer_start_method equiv : (Proof.context -> Proof.method) context_parser = fixing >> (fn vs => fn ctxt => SIMPLE_METHOD' (gen_frees_tac vs ctxt THEN' transfer_start_tac equiv ctxt THEN' reverse_prems)); fun transfer_method equiv : (Proof.context -> Proof.method) context_parser = fixing >> (fn vs => fn ctxt => SIMPLE_METHOD' (gen_frees_tac vs ctxt THEN' transfer_tac equiv ctxt)) val transfer_prover_start_method : (Proof.context -> Proof.method) context_parser = Scan.succeed (fn ctxt => SIMPLE_METHOD' (transfer_prover_start_tac ctxt THEN' reverse_prems)) val transfer_prover_method : (Proof.context -> Proof.method) context_parser = Scan.succeed (fn ctxt => SIMPLE_METHOD' (transfer_prover_tac ctxt)) (* Attribute for transfer rules *) fun prep_rule ctxt = abstract_domains_transfer ctxt o abstract_equalities_transfer ctxt o Conv.fconv_rule prep_conv val transfer_add = Thm.declaration_attribute (fn thm => fn ctxt => (add_transfer_thm o prep_rule (Context.proof_of ctxt)) thm ctxt) val transfer_del = Thm.declaration_attribute (fn thm => fn ctxt => (del_transfer_thm o prep_rule (Context.proof_of ctxt)) thm ctxt) val transfer_attribute = Attrib.add_del transfer_add transfer_del (* Attributes for transfer domain rules *) val transfer_domain_add = Thm.declaration_attribute add_transfer_domain_thm val transfer_domain_del = Thm.declaration_attribute del_transfer_domain_thm val transfer_domain_attribute = Attrib.add_del transfer_domain_add transfer_domain_del (* Attributes for transferred rules *) fun transferred_attribute thms = Thm.rule_attribute thms (fn context => transferred (Context.proof_of context) thms) fun untransferred_attribute thms = Thm.rule_attribute thms (fn context => untransferred (Context.proof_of context) thms) val transferred_attribute_parser = Attrib.thms >> transferred_attribute val untransferred_attribute_parser = Attrib.thms >> untransferred_attribute fun morph_pred_data phi = let val morph_thm = Morphism.thm phi in map_pred_data' morph_thm morph_thm (map morph_thm) end fun lookup_pred_data ctxt type_name = Symtab.lookup (get_pred_data ctxt) type_name |> Option.map (morph_pred_data (Morphism.transfer_morphism' ctxt)) fun update_pred_data type_name qinfo ctxt = Data.map (map_pred_data (Symtab.update (type_name, qinfo))) ctxt (* Theory setup *) val _ = Theory.setup let val name = \<^binding>\relator_eq\ fun add_thm thm context = context |> Data.map (map_relator_eq (Item_Net.update (Thm.trim_context thm))) |> Data.map (map_relator_eq_raw (Item_Net.update (Thm.trim_context (abstract_equalities_relator_eq (Context.proof_of context) thm)))) fun del_thm thm context = context |> Data.map (map_relator_eq (Item_Net.remove thm)) |> Data.map (map_relator_eq_raw (Item_Net.remove (abstract_equalities_relator_eq (Context.proof_of context) thm))) val add = Thm.declaration_attribute add_thm val del = Thm.declaration_attribute del_thm val text = "declaration of relator equality rule (used by transfer method)" val content = Item_Net.content o #relator_eq o Data.get in Attrib.setup name (Attrib.add_del add del) text #> Global_Theory.add_thms_dynamic (name, content) end val _ = Theory.setup let val name = \<^binding>\relator_domain\ fun add_thm thm context = let val thm' = thm |> abstract_domains_relator_domain (Context.proof_of context) |> Thm.trim_context in context |> Data.map (map_relator_domain (Item_Net.update thm')) |> add_transfer_domain_thm thm' end fun del_thm thm context = let val thm' = abstract_domains_relator_domain (Context.proof_of context) thm in context |> Data.map (map_relator_domain (Item_Net.remove thm')) |> del_transfer_domain_thm thm' end val add = Thm.declaration_attribute add_thm val del = Thm.declaration_attribute del_thm val text = "declaration of relator domain rule (used by transfer method)" val content = Item_Net.content o #relator_domain o Data.get in Attrib.setup name (Attrib.add_del add del) text #> Global_Theory.add_thms_dynamic (name, content) end val _ = Theory.setup (Attrib.setup \<^binding>\transfer_rule\ transfer_attribute "transfer rule for transfer method" #> Global_Theory.add_thms_dynamic (\<^binding>\transfer_raw\, Item_Net.content o #transfer_raw o Data.get) #> Attrib.setup \<^binding>\transfer_domain_rule\ transfer_domain_attribute "transfer domain rule for transfer method" #> Attrib.setup \<^binding>\transferred\ transferred_attribute_parser "raw theorem transferred to abstract theorem using transfer rules" #> Attrib.setup \<^binding>\untransferred\ untransferred_attribute_parser "abstract theorem transferred to raw theorem using transfer rules" #> Global_Theory.add_thms_dynamic (\<^binding>\relator_eq_raw\, Item_Net.content o #relator_eq_raw o Data.get) #> Method.setup \<^binding>\transfer_start\ (transfer_start_method true) "firtst step in the transfer algorithm (for debugging transfer)" #> Method.setup \<^binding>\transfer_start'\ (transfer_start_method false) "firtst step in the transfer algorithm (for debugging transfer)" #> Method.setup \<^binding>\transfer_prover_start\ transfer_prover_start_method "firtst step in the transfer_prover algorithm (for debugging transfer_prover)" #> Method.setup \<^binding>\transfer_step\ (Scan.succeed (fn ctxt => SIMPLE_METHOD' (transfer_step_tac ctxt))) "step in the search for transfer rules (for debugging transfer and transfer_prover)" #> Method.setup \<^binding>\transfer_end\ (Scan.succeed (fn ctxt => SIMPLE_METHOD' (transfer_end_tac ctxt))) "last step in the transfer algorithm (for debugging transfer)" #> Method.setup \<^binding>\transfer_prover_end\ (Scan.succeed (fn ctxt => SIMPLE_METHOD' (transfer_prover_end_tac ctxt))) "last step in the transfer_prover algorithm (for debugging transfer_prover)" #> Method.setup \<^binding>\transfer\ (transfer_method true) "generic theorem transfer method" #> Method.setup \<^binding>\transfer'\ (transfer_method false) "generic theorem transfer method" #> Method.setup \<^binding>\transfer_prover\ transfer_prover_method "for proving transfer rules") end diff --git a/src/Pure/Admin/build_jedit.scala b/src/Pure/Admin/build_jedit.scala --- a/src/Pure/Admin/build_jedit.scala +++ b/src/Pure/Admin/build_jedit.scala @@ -1,555 +1,555 @@ /* Title: Pure/Admin/build_jedit.scala Author: Makarius Build component for jEdit text-editor. */ package isabelle import java.nio.charset.Charset import scala.jdk.CollectionConverters._ object Build_JEdit { /* modes */ object Mode { val empty: Mode = new Mode("", "", Nil) val init: Mode = empty + ("noWordSep" -> """_'?⇩\^<>""") + ("unalignedOpenBrackets" -> "{[(«‹⟨⌈⌊⦇⟦⦃⦉") + ("unalignedCloseBrackets" -> "⦊⦄⟧⦈⌋⌉⟩›»)]}") + ("tabSize" -> "2") + ("indentSize" -> "2") val list: List[Mode] = { val isabelle_news: Mode = init.define("isabelle-news", "Isabelle NEWS") val isabelle: Mode = init.define("isabelle", "Isabelle theory") + ("commentStart" -> "(*") + ("commentEnd" -> "*)") val isabelle_ml: Mode = isabelle.define("isabelle-ml", "Isabelle/ML") val isabelle_root: Mode = isabelle.define("isabelle-root", "Isabelle session root") val isabelle_options: Mode = isabelle.define("isabelle-options", "Isabelle options") val sml: Mode = init.define("sml", "Standard ML") + ("commentStart" -> "(*") + ("commentEnd" -> "*)") + ("noWordSep" -> "_'") List(isabelle_news, isabelle, isabelle_ml, isabelle_root, isabelle_options, sml) } } final case class Mode private(name: String, description: String, rev_props: Properties.T) { override def toString: String = name def define(a: String, b: String): Mode = new Mode(a, b, rev_props) def + (entry: Properties.Entry): Mode = new Mode(name, description, Properties.put(rev_props, entry)) def write(dir: Path): Unit = { require(name.nonEmpty && description.nonEmpty, "Bad Isabelle/jEdit mode content") val properties = rev_props.reverse.map(p => Symbol.spaces(4) + XML.string_of_tree(XML.elem(Markup("PROPERTY", List("NAME" -> p._1, "VALUE" -> p._2))))) File.write(dir + Path.basic(name).xml, """ """ + properties.mkString("\n", "\n", "") + """ """) } } /* build jEdit component */ private val download_jars: List[(String, String)] = List( "https://repo1.maven.org/maven2/com/google/code/findbugs/jsr305/3.0.2/jsr305-3.0.2.jar" -> "jsr305-3.0.2.jar") private val download_plugins: List[(String, String)] = List( "Code2HTML" -> "0.7", "CommonControls" -> "1.7.4", "Console" -> "5.1.4", "ErrorList" -> "2.4.0", - "Highlight" -> "2.2", + "Highlight" -> "2.5", "Navigator" -> "2.7", "SideKick" -> "1.8") private def exclude_package(name: String): Boolean = name.startsWith("de.masters_of_disaster.ant") || name == "doclet" || name == "installer" def build_jedit( component_dir: Path, version: String, original: Boolean = false, java_home: Path = default_java_home, progress: Progress = new Progress): Unit = { Isabelle_System.require_command("ant", test = "-version") Isabelle_System.require_command("patch") Isabelle_System.require_command("unzip", test = "-h") Isabelle_System.new_directory(component_dir) val etc_dir = Isabelle_System.make_directory(component_dir + Path.explode("etc")) /* jEdit directory */ val jedit = "jedit" + version val jedit_patched = jedit + "-patched" val jedit_dir = Isabelle_System.make_directory(component_dir + Path.basic(jedit)) val jedit_patched_dir = component_dir + Path.basic(jedit_patched) def download_jedit(dir: Path, name: String, target_name: String = ""): Path = { val jedit_name = jedit + name val url = "https://sourceforge.net/projects/jedit/files/jedit/" + version + "/" + jedit_name + "/download" val path = dir + Path.basic(proper_string(target_name) getOrElse jedit_name) Isabelle_System.download_file(url, path, progress = progress) path } Isabelle_System.with_tmp_dir("tmp")(tmp_dir => { /* original version */ val install_path = download_jedit(tmp_dir, "install.jar") Isabelle_System.bash("""export CLASSPATH="" isabelle_java java -Duser.home=""" + File.bash_platform_path(tmp_dir) + " -jar " + File.bash_platform_path(install_path) + " auto " + File.bash_platform_path(jedit_dir) + " unix-script=off unix-man=off").check val source_path = download_jedit(tmp_dir, "source.tar.bz2") Isabelle_System.gnutar("-xjf " + File.bash_path(source_path), dir = jedit_dir).check /* patched version */ Isabelle_System.copy_dir(jedit_dir, jedit_patched_dir) val source_dir = jedit_patched_dir + Path.basic("jEdit") val tmp_source_dir = tmp_dir + Path.basic("jEdit") progress.echo("Patching jEdit sources ...") for { file <- File.find_files(Path.explode("~~/src/Tools/jEdit/patches").file).iterator name = file.getName if !name.endsWith("~") && !name.endsWith(".orig") } { progress.bash("patch -p2 < " + File.bash_path(File.path(file)), cwd = source_dir.file, echo = true).check } for { theme <- List("classic", "tango") } { val path = Path.explode("org/gjt/sp/jedit/icons/themes/" + theme + "/32x32/apps/isabelle.gif") Isabelle_System.copy_file(Path.explode("~~/lib/logo/isabelle_transparent-32.gif"), source_dir + path) } progress.echo("Building jEdit ...") Isabelle_System.copy_dir(source_dir, tmp_source_dir) progress.bash("env JAVA_HOME=" + File.bash_platform_path(java_home) + " ant", cwd = tmp_source_dir.file, echo = true).check Isabelle_System.copy_file(tmp_source_dir + Path.explode("build/jedit.jar"), jedit_patched_dir) val java_sources = for { file <- File.find_files(source_dir.file, file => file.getName.endsWith(".java")) package_name <- Scala_Project.package_name(File.path(file)) if !exclude_package(package_name) } yield File.path(component_dir.java_path.relativize(file.toPath).toFile) File.write(etc_dir + Path.explode("build.props"), "module = " + jedit_patched + "/jedit.jar\n" + "no_build = true\n" + "requirements = env:JEDIT_JARS\n" + ("sources =" :: java_sources.map(p => " " + p.implode)).mkString("", " \\\n", "\n")) }) /* jars */ val jars_dir = Isabelle_System.make_directory(jedit_patched_dir + Path.basic("jars")) for { (url, name) <- download_jars } { Isabelle_System.download_file(url, jars_dir + Path.basic(name), progress = progress) } for { (name, vers) <- download_plugins } { Isabelle_System.with_tmp_file("tmp", ext = "zip")(zip_path => { val url = "https://sourceforge.net/projects/jedit-plugins/files/" + name + "/" + vers + "/" + name + "-" + vers + "-bin.zip/download" Isabelle_System.download_file(url, zip_path, progress = progress) Isabelle_System.bash("unzip -x " + File.bash_path(zip_path), cwd = jars_dir.file).check }) } /* resources */ val keep_encodings = List("ISO-8859-1", "ISO-8859-15", "US-ASCII", "UTF-8", "windows-1252") val drop_encodings = Charset.availableCharsets().keySet().asScala.toList.sorted.filterNot(keep_encodings.contains) File.write(jedit_patched_dir + Path.explode("properties/jEdit.props"), """#jEdit properties autoReloadDialog=false buffer.deepIndent=false buffer.encoding=UTF-8-Isabelle buffer.indentSize=2 buffer.lineSeparator=\n buffer.maxLineLen=100 buffer.noTabs=true buffer.sidekick.keystroke-parse=false buffer.tabSize=2 buffer.undoCount=1000 close-docking-area.shortcut2=C+e C+CIRCUMFLEX complete-word.shortcut= console.dock-position=floating console.encoding=UTF-8 console.font=Isabelle DejaVu Sans Mono console.fontsize=14 delete-line.shortcut=A+d delete.shortcut2=C+d """ + drop_encodings.map(a => "encoding.opt-out." + a + "=true").mkString("\n") + """ encodingDetectors=BOM XML-PI buffer-local-property end.shortcut= expand-abbrev.shortcut2=CA+SPACE expand-folds.shortcut= fallbackEncodings=UTF-8 ISO-8859-15 US-ASCII firstTime=false focus-buffer-switcher.shortcut2=A+CIRCUMFLEX foldPainter=Circle gatchan.highlight.overview=false helpviewer.font=Isabelle DejaVu Serif helpviewer.fontsize=12 home.shortcut= hypersearch-results.dock-position=right insert-newline-indent.shortcut= insert-newline.shortcut= isabelle-debugger.dock-position=floating isabelle-documentation.dock-position=left isabelle-export-browser.label=Browse theory exports isabelle-output.dock-position=bottom isabelle-output.height=174 isabelle-output.width=412 isabelle-query.dock-position=bottom isabelle-session-browser.label=Browse session information isabelle-simplifier-trace.dock-position=floating isabelle-sledgehammer.dock-position=bottom isabelle-state.dock-position=right isabelle-symbols.dock-position=bottom isabelle-theories.dock-position=right isabelle.antiquoted_cartouche.label=Make antiquoted cartouche isabelle.complete-word.label=Complete word isabelle.complete.label=Complete Isabelle text isabelle.complete.shortcut2=C+b isabelle.control-bold.label=Control bold isabelle.control-bold.shortcut=C+e RIGHT isabelle.control-emph.label=Control emphasized isabelle.control-emph.shortcut=C+e LEFT isabelle.control-reset.label=Control reset isabelle.control-reset.shortcut=C+e BACK_SPACE isabelle.control-sub.label=Control subscript isabelle.control-sub.shortcut=C+e DOWN isabelle.control-sup.label=Control superscript isabelle.control-sup.shortcut=C+e UP isabelle.decrease-font-size.label=Decrease font size isabelle.decrease-font-size.shortcut2=C+SUBTRACT isabelle.decrease-font-size.shortcut=C+MINUS isabelle.decrease-font-size2.label=Decrease font size (clone) isabelle.draft.label=Show draft in browser isabelle.exclude-word-permanently.label=Exclude word permanently isabelle.exclude-word.label=Exclude word isabelle.first-error.label=Go to first error isabelle.first-error.shortcut=CS+a isabelle.goto-entity.label=Go to definition of formal entity at caret isabelle.goto-entity.shortcut=CS+d isabelle.include-word-permanently.label=Include word permanently isabelle.include-word.label=Include word isabelle.increase-font-size.label=Increase font size isabelle.increase-font-size.shortcut2=C+ADD isabelle.increase-font-size.shortcut=C+PLUS isabelle.increase-font-size2.label=Increase font size (clone) isabelle.increase-font-size2.shortcut=C+EQUALS isabelle.java-monitor.label=Java/VM monitor isabelle.last-error.label=Go to last error isabelle.last-error.shortcut=CS+z isabelle.message.label=Show message isabelle.message.shortcut=CS+m isabelle.newline.label=Newline with indentation of Isabelle keywords isabelle.newline.shortcut=ENTER isabelle.next-error.label=Go to next error isabelle.next-error.shortcut=CS+n isabelle.options.label=Isabelle options isabelle.prev-error.label=Go to previous error isabelle.prev-error.shortcut=CS+p isabelle.preview.label=Show preview in browser isabelle.reset-continuous-checking.label=Reset continuous checking isabelle.reset-font-size.label=Reset font size isabelle.reset-node-required.label=Reset node required isabelle.reset-words.label=Reset non-permanent words isabelle.select-entity.label=Select all occurences of formal entity at caret isabelle.select-entity.shortcut=CS+ENTER isabelle.set-continuous-checking.label=Set continuous checking isabelle.set-node-required.label=Set node required isabelle.toggle-breakpoint.label=Toggle Breakpoint isabelle.toggle-continuous-checking.label=Toggle continuous checking isabelle.toggle-continuous-checking.shortcut=C+e ENTER isabelle.toggle-node-required.label=Toggle node required isabelle.toggle-node-required.shortcut=C+e SPACE isabelle.tooltip.label=Show tooltip isabelle.tooltip.shortcut=CS+b isabelle.update-state.label=Update state output isabelle.update-state.shortcut=S+ENTER lang.usedefaultlocale=false largefilemode=full line-end.shortcut=END line-home.shortcut=HOME logo.icon.medium=32x32/apps/isabelle.gif lookAndFeel=com.formdev.flatlaf.FlatLightLaf match-bracket.shortcut2=C+9 metal.primary.font=Isabelle DejaVu Sans metal.primary.fontsize=12 metal.secondary.font=Isabelle DejaVu Sans metal.secondary.fontsize=12 navigator.showOnToolbar=true new-file-in-mode.shortcut= next-bracket.shortcut2=C+e C+9 options.shortcuts.deletekeymap.label=Delete options.shortcuts.duplicatekeymap.dialog.title=Keymap name options.shortcuts.duplicatekeymap.label=Duplicate options.shortcuts.resetkeymap.dialog.title=Reset keymap options.shortcuts.resetkeymap.label=Reset options.textarea.lineSpacing=1 plugin-blacklist.MacOSX.jar=true plugin.MacOSXPlugin.altDispatcher=false plugin.MacOSXPlugin.disableOption=true prev-bracket.shortcut2=C+e C+8 print.font=Isabelle DejaVu Sans Mono print.glyphVector=true recent-buffer.shortcut2=C+CIRCUMFLEX restore.remote=false restore=false search.subdirs.toggle=true select-block.shortcut2=C+8 sidekick-tree.dock-position=right sidekick.auto-complete-popup-get-focus=true sidekick.buffer-save-parse=true sidekick.complete-delay=0 sidekick.complete-instant.toggle=false sidekick.complete-popup.accept-characters=\\t sidekick.complete-popup.insert-characters= sidekick.persistentFilter=true sidekick.showFilter=true sidekick.splitter.location=721 systrayicon=false tip.show=false toggle-full-screen.shortcut2=S+F11 toggle-multi-select.shortcut2=C+NUMBER_SIGN toggle-rect-select.shortcut2=A+NUMBER_SIGN twoStageSave=false vfs.browser.dock-position=left vfs.favorite.0.type=1 vfs.favorite.0=$ISABELLE_HOME vfs.favorite.1.type=1 vfs.favorite.1=$ISABELLE_HOME_USER vfs.favorite.2.type=1 vfs.favorite.2=$JEDIT_HOME vfs.favorite.3.type=1 vfs.favorite.3=$JEDIT_SETTINGS vfs.favorite.4.type=1 vfs.favorite.4=isabelle-export: vfs.favorite.5.type=1 vfs.favorite.5=isabelle-session: view.antiAlias=subpixel HRGB view.blockCaret=true view.caretBlink=false view.docking.framework=PIDE view.eolMarkers=false view.extendedState=0 view.font=Isabelle DejaVu Sans Mono view.fontsize=18 view.fracFontMetrics=false view.gutter.font=Isabelle DejaVu Sans Mono view.gutter.fontsize=12 view.gutter.lineNumbers=false view.gutter.selectionAreaWidth=18 view.height=850 view.middleMousePaste=true view.showToolbar=true view.status.memory.background=#666699 view.status=( mode , fold , encoding ) locked wrap multiSelect rectSelect overwrite lineSep buffersets task-monitor java-status ml-status errors clock view.thickCaret=true view.width=1200 xml-insert-closing-tag.shortcut= """) val modes_dir = jedit_patched_dir + Path.basic("modes") Mode.list.foreach(_.write(modes_dir)) File.change_lines(modes_dir + Path.basic("catalog"), _.flatMap(line => if (line.containsSlice("FILE=\"ml.xml\"") || line.containsSlice("FILE_NAME_GLOB=\"*.{sml,ml}\"") || line.containsSlice("FILE_NAME_GLOB=\"*.ftl\"")) Nil else if (line.containsSlice("NAME=\"jamon\"")) { List( """""", "", """""", "", """""", "", """""", "", """""", "", line) } else if (line.containsSlice("NAME=\"sqr\"")) { List( """""", "", line) } else List(line))) /* doc */ val doc_dir = jedit_patched_dir + Path.basic("doc") download_jedit(doc_dir, "manual-a4.pdf", target_name = "jedit-manual.pdf") Isabelle_System.copy_file( doc_dir + Path.basic("CHANGES.txt"), doc_dir + Path.basic("jedit-changes")) File.write(doc_dir + Path.basic("Contents"), """Original jEdit Documentation jedit-manual jEdit User's Guide jedit-changes jEdit Version History """) /* diff */ Isabelle_System.bash( "diff -ru " + Bash.string(jedit) + " " + Bash.string(jedit_patched) + " > " + Bash.string(jedit + ".patch"), cwd = component_dir.file).check_rc(_ <= 1) if (!original) Isabelle_System.rm_tree(jedit_dir) /* settings */ File.write(etc_dir + Path.explode("settings"), """# -*- shell-script -*- :mode=shellscript: JEDIT_HOME="$COMPONENT/""" + jedit_patched + """" JEDIT_JARS=""" + quote(File.read_dir(jars_dir).map("$JEDIT_HOME/jars/" + _).mkString(":")) + """ JEDIT_JAR="$JEDIT_HOME/jedit.jar" classpath "$JEDIT_JAR" JEDIT_SETTINGS="$ISABELLE_HOME_USER/jedit" JEDIT_OPTIONS="-reuseview -nobackground -nosplash -log=9" JEDIT_JAVA_OPTIONS="-Xms512m -Xmx4g -Xss16m" JEDIT_JAVA_SYSTEM_OPTIONS="-Duser.language=en -Dawt.useSystemAAFontSettings=on -Dswing.aatext=true -Dapple.laf.useScreenMenuBar=true -Dapple.awt.application.name=Isabelle" ISABELLE_DOCS="$ISABELLE_DOCS:$JEDIT_HOME/doc" """) /* README */ File.write(component_dir + Path.basic("README"), """This is a slightly patched version of jEdit """ + version + """ from https://sourceforge.net/projects/jedit/files/jedit with some additional plugins jars from https://sourceforge.net/projects/jedit-plugins/files Makarius """ + Date.Format.date(Date.now()) + "\n") } /** Isabelle tool wrappers **/ val default_version = "5.6.0" def default_java_home: Path = Path.explode("$JAVA_HOME").expand val isabelle_tool = Isabelle_Tool("build_jedit", "build Isabelle component from the jEdit text-editor", Scala_Project.here, args => { var target_dir = Path.current var java_home = default_java_home var original = false var version = default_version val getopts = Getopts(""" Usage: isabelle build_jedit [OPTIONS] Options are: -D DIR target directory (default ".") -J JAVA_HOME Java version for building jedit.jar (e.g. version 11) -O retain copy of original jEdit directory -V VERSION jEdit version (default: """ + quote(default_version) + """) Build auxiliary jEdit component from original sources, with some patches. """, "D:" -> (arg => target_dir = Path.explode(arg)), "J:" -> (arg => java_home = Path.explode(arg)), "O" -> (_ => original = true), "V:" -> (arg => version = arg)) val more_args = getopts(args) if (more_args.nonEmpty) getopts.usage() val component_dir = target_dir + Path.basic("jedit-" + Date.Format.alt_date(Date.now())) val progress = new Console_Progress() build_jedit(component_dir, version, original = original, java_home = java_home, progress = progress) }) } diff --git a/src/Pure/conv.ML b/src/Pure/conv.ML --- a/src/Pure/conv.ML +++ b/src/Pure/conv.ML @@ -1,221 +1,229 @@ (* Title: Pure/conv.ML Author: Amine Chaieb, TU Muenchen Author: Sascha Boehme, TU Muenchen Author: Makarius Conversions: primitive equality reasoning. *) infix 1 then_conv; infix 0 else_conv; signature BASIC_CONV = sig val then_conv: conv * conv -> conv val else_conv: conv * conv -> conv end; signature CONV = sig include BASIC_CONV val no_conv: conv val all_conv: conv val first_conv: conv list -> conv val every_conv: conv list -> conv val try_conv: conv -> conv val repeat_conv: conv -> conv val cache_conv: conv -> conv val abs_conv: (cterm * Proof.context -> conv) -> Proof.context -> conv val combination_conv: conv -> conv -> conv val comb_conv: conv -> conv val arg_conv: conv -> conv val fun_conv: conv -> conv val arg1_conv: conv -> conv val fun2_conv: conv -> conv val binop_conv: conv -> conv val binder_conv: (cterm * Proof.context -> conv) -> Proof.context -> conv val forall_conv: (cterm * Proof.context -> conv) -> Proof.context -> conv val implies_conv: conv -> conv -> conv val implies_concl_conv: conv -> conv val rewr_conv: thm -> conv val rewrs_conv: thm list -> conv + val bottom_rewrs_conv: thm list -> Proof.context -> conv + val top_rewrs_conv: thm list -> Proof.context -> conv + val top_sweep_rewrs_conv: thm list -> Proof.context -> conv val sub_conv: (Proof.context -> conv) -> Proof.context -> conv val bottom_conv: (Proof.context -> conv) -> Proof.context -> conv val top_conv: (Proof.context -> conv) -> Proof.context -> conv val top_sweep_conv: (Proof.context -> conv) -> Proof.context -> conv val params_conv: int -> (Proof.context -> conv) -> Proof.context -> conv val prems_conv: int -> conv -> conv val concl_conv: int -> conv -> conv val fconv_rule: conv -> thm -> thm val gconv_rule: conv -> int -> thm -> thm end; structure Conv: CONV = struct (* basic conversionals *) fun no_conv _ = raise CTERM ("no conversion", []); val all_conv = Thm.reflexive; fun (cv1 then_conv cv2) ct = let val eq1 = cv1 ct; val eq2 = cv2 (Thm.rhs_of eq1); in if Thm.is_reflexive eq1 then eq2 else if Thm.is_reflexive eq2 then eq1 else Thm.transitive eq1 eq2 end; fun (cv1 else_conv cv2) ct = (cv1 ct handle THM _ => cv2 ct | CTERM _ => cv2 ct | TERM _ => cv2 ct | TYPE _ => cv2 ct); fun first_conv cvs = fold_rev (curry op else_conv) cvs no_conv; fun every_conv cvs = fold_rev (curry op then_conv) cvs all_conv; fun try_conv cv = cv else_conv all_conv; fun repeat_conv cv ct = try_conv (cv then_conv repeat_conv cv) ct; fun cache_conv (cv: conv) = Ctermtab.cterm_cache cv; (** Pure conversions **) (* lambda terms *) fun abs_conv cv ctxt ct = (case Thm.term_of ct of Abs (a, _, _) => let val ((v, ct'), ctxt') = Variable.dest_abs_cterm ct ctxt; val eq = cv (v, ctxt') ct'; in if Thm.is_reflexive eq then all_conv ct else Thm.abstract_rule a v eq end | _ => raise CTERM ("abs_conv", [ct])); fun combination_conv cv1 cv2 ct = let val (ct1, ct2) = Thm.dest_comb ct in Thm.combination (cv1 ct1) (cv2 ct2) end; fun comb_conv cv = combination_conv cv cv; fun arg_conv cv = combination_conv all_conv cv; fun fun_conv cv = combination_conv cv all_conv; val arg1_conv = fun_conv o arg_conv; val fun2_conv = fun_conv o fun_conv; fun binop_conv cv = combination_conv (arg_conv cv) cv; fun binder_conv cv ctxt = arg_conv (abs_conv cv ctxt); (* subterm structure *) (*cf. SUB_CONV in HOL*) fun sub_conv conv ctxt = comb_conv (conv ctxt) else_conv abs_conv (conv o snd) ctxt else_conv all_conv; (*cf. BOTTOM_CONV in HOL*) fun bottom_conv conv ctxt ct = (sub_conv (bottom_conv conv) ctxt then_conv conv ctxt) ct; (*cf. TOP_CONV in HOL*) fun top_conv conv ctxt ct = (conv ctxt then_conv sub_conv (top_conv conv) ctxt) ct; (*cf. TOP_SWEEP_CONV in HOL*) fun top_sweep_conv conv ctxt ct = (conv ctxt else_conv sub_conv (top_sweep_conv conv) ctxt) ct; (* primitive logic *) fun forall_conv cv ctxt ct = (case Thm.term_of ct of Const ("Pure.all", _) $ Abs _ => arg_conv (abs_conv cv ctxt) ct | _ => raise CTERM ("forall_conv", [ct])); fun implies_conv cv1 cv2 ct = (case Thm.term_of ct of Const ("Pure.imp", _) $ _ $ _ => combination_conv (arg_conv cv1) cv2 ct | _ => raise CTERM ("implies_conv", [ct])); fun implies_concl_conv cv ct = (case Thm.term_of ct of Const ("Pure.imp", _) $ _ $ _ => arg_conv cv ct | _ => raise CTERM ("implies_concl_conv", [ct])); -(* single rewrite step, cf. REWR_CONV in HOL *) +(* rewrite steps *) +(*cf. REWR_CONV in HOL*) fun rewr_conv rule ct = let val rule1 = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) rule; val lhs = Thm.lhs_of rule1; val rule2 = Thm.rename_boundvars (Thm.term_of lhs) (Thm.term_of ct) rule1; val rule3 = Thm.instantiate (Thm.match (lhs, ct)) rule2 handle Pattern.MATCH => raise CTERM ("rewr_conv", [lhs, ct]); val rule4 = if Thm.lhs_of rule3 aconvc ct then rule3 else let val ceq = Thm.dest_fun2 (Thm.cprop_of rule3) in rule3 COMP Thm.trivial (Thm.mk_binop ceq ct (Thm.rhs_of rule3)) end; in Thm.transitive rule4 (Thm.beta_conversion true (Thm.rhs_of rule4)) end; fun rewrs_conv rules = first_conv (map rewr_conv rules); +fun bottom_rewrs_conv rewrs = bottom_conv (K (try_conv (rewrs_conv rewrs))); +fun top_rewrs_conv rewrs = top_conv (K (try_conv (rewrs_conv rewrs))); +fun top_sweep_rewrs_conv rewrs = top_sweep_conv (K (rewrs_conv rewrs)); + (* conversions on HHF rules *) (*rewrite B in \x1 ... xn. B*) fun params_conv n cv ctxt ct = if n <> 0 andalso Logic.is_all (Thm.term_of ct) then arg_conv (abs_conv (params_conv (n - 1) cv o #2) ctxt) ct else cv ctxt ct; (*rewrite the A's in A1 \ ... \ An \ B*) fun prems_conv 0 _ ct = all_conv ct | prems_conv n cv ct = (case try Thm.dest_implies ct of NONE => all_conv ct | SOME (A, B) => Drule.imp_cong_rule (cv A) (prems_conv (n - 1) cv B)); (*rewrite B in A1 \ ... \ An \ B*) fun concl_conv 0 cv ct = cv ct | concl_conv n cv ct = (case try Thm.dest_implies ct of NONE => cv ct | SOME (A, B) => Drule.imp_cong_rule (all_conv A) (concl_conv (n - 1) cv B)); (* conversions as inference rules *) (*forward conversion, cf. FCONV_RULE in LCF*) fun fconv_rule cv th = let val eq = cv (Thm.cprop_of th) in if Thm.is_reflexive eq then th else Thm.equal_elim eq th end; (*goal conversion*) fun gconv_rule cv i th = (case try (Thm.cprem_of th) i of SOME ct => let val eq = cv ct in if Thm.is_reflexive eq then th else Drule.with_subgoal i (fconv_rule (arg1_conv (K eq))) th end | NONE => raise THM ("gconv_rule", i, [th])); end; structure Basic_Conv: BASIC_CONV = Conv; open Basic_Conv;