diff options
Diffstat (limited to 'snapshots/isabelle/lib')
48 files changed, 13914 insertions, 0 deletions
diff --git a/snapshots/isabelle/lib/lem/LICENSE b/snapshots/isabelle/lib/lem/LICENSE new file mode 100644 index 00000000..06f7abfe --- /dev/null +++ b/snapshots/isabelle/lib/lem/LICENSE @@ -0,0 +1,524 @@ + Lem + +All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli} +are distributed under the following license: + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. +3. The names of the authors may not be used to endorse or promote +products derived from this software without specific prior written +permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + + + +The following files are modified versions of map and set from the +Objective Caml library and are distributed under the GNU LIBRARY GENERAL +PUBLIC LICENSE Version 2 as below. + +ocaml-lib/pmap.mli +ocaml-lib/pmap.ml +ocaml-lib/pset.mli +ocaml-lib/pset.ml + + + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, + MA 02111-1307, USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/snapshots/isabelle/lib/lem/Lem.thy b/snapshots/isabelle/lib/lem/Lem.thy new file mode 100644 index 00000000..c6a2a883 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem.thy @@ -0,0 +1,108 @@ +(*========================================================================*) +(* Lem *) +(* *) +(* Dominic Mulligan, University of Cambridge *) +(* Francesco Zappa Nardelli, INRIA Paris-Rocquencourt *) +(* Gabriel Kerneis, University of Cambridge *) +(* Kathy Gray, University of Cambridge *) +(* Peter Boehm, University of Cambridge (while working on Lem) *) +(* Peter Sewell, University of Cambridge *) +(* Scott Owens, University of Kent *) +(* Thomas Tuerk, University of Cambridge *) +(* Brian Campbell, University of Edinburgh *) +(* Shaked Flur, University of Cambridge *) +(* Thomas Bauereiss, University of Cambridge *) +(* Stephen Kell, University of Cambridge *) +(* Thomas Williams *) +(* Lars Hupel *) +(* Basile Clement *) +(* *) +(* The Lem sources are copyright 2010-2018 *) +(* by the authors above and Institut National de Recherche en *) +(* Informatique et en Automatique (INRIA). *) +(* *) +(* All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli} *) +(* are distributed under the license below. The former are distributed *) +(* under the LGPLv2, as in the LICENSE file. *) +(* *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in the *) +(* documentation and/or other materials provided with the distribution. *) +(* 3. The names of the authors may not be used to endorse or promote *) +(* products derived from this software without specific prior written *) +(* permission. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS *) +(* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED *) +(* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE *) +(* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY *) +(* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL *) +(* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE *) +(* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS *) +(* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER *) +(* IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR *) +(* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN *) +(* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) +(*========================================================================*) + +chapter\<open>Mappings of Syntax needed by Lem\<close> + +theory "Lem" + +imports + LemExtraDefs + "~~/src/HOL/Word/Word" +begin + +type_synonym numeral = nat + +subsection \<open>Finite Maps\<close> + +abbreviation (input) "map_find k m \<equiv> the (m k)" +abbreviation (input) "map_update k v m \<equiv> m (k \<mapsto> v)" +abbreviation (input) "map_remove k m \<equiv> m |` (- {k})" +abbreviation (input) "map_any P m \<equiv> \<exists> (k, v) \<in> map_to_set m. P k v" +abbreviation (input) "map_all P m \<equiv> \<forall> (k, v) \<in> map_to_set m. P k v" + +subsection \<open>Lists\<close> + +abbreviation (input) "list_mem e l \<equiv> (e \<in> set l)" +abbreviation (input) "list_forall P l \<equiv> (\<forall>e\<in>set l. P e)" +abbreviation (input) "list_exists P l \<equiv> (\<exists>e\<in>set l. P e)" +abbreviation (input) "list_unzip l \<equiv> (map fst l, map snd l)" + +subsection \<open>Sets\<close> + +abbreviation (input) "set_filter P (s::'a set) \<equiv> {x \<in> s. P x}" +abbreviation (input) "set_bigunion S \<equiv> \<Union> S" +abbreviation (input) "set_biginter S \<equiv> \<Inter> S" + +subsection \<open>Natural numbers\<close> + +subsection \<open>Integers\<close> + + +subsection \<open>Dummy\<close> + +consts + bitwise_xor :: "nat \<Rightarrow> nat \<Rightarrow> nat" + num_asr :: "nat \<Rightarrow> nat \<Rightarrow> nat" + num_lsl :: "nat \<Rightarrow> nat \<Rightarrow> nat" + bitwise_or :: "nat \<Rightarrow> nat \<Rightarrow> nat" + bitwise_not :: "nat \<Rightarrow> nat" + bitwise_and :: "nat \<Rightarrow> nat \<Rightarrow> nat" + +subsection \<open>Machine words\<close> + +definition word_update :: "'a::len word \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'b::len word \<Rightarrow> 'a word" where + "word_update v lo hi w = + (let sz = size v in + of_bl (take (sz-hi-1) (to_bl v) @ to_bl w @ drop (sz-lo) (to_bl v)))" + +end diff --git a/snapshots/isabelle/lib/lem/LemExtraDefs.thy b/snapshots/isabelle/lib/lem/LemExtraDefs.thy new file mode 100644 index 00000000..c14a669f --- /dev/null +++ b/snapshots/isabelle/lib/lem/LemExtraDefs.thy @@ -0,0 +1,1259 @@ +(*========================================================================*) +(* Lem *) +(* *) +(* Dominic Mulligan, University of Cambridge *) +(* Francesco Zappa Nardelli, INRIA Paris-Rocquencourt *) +(* Gabriel Kerneis, University of Cambridge *) +(* Kathy Gray, University of Cambridge *) +(* Peter Boehm, University of Cambridge (while working on Lem) *) +(* Peter Sewell, University of Cambridge *) +(* Scott Owens, University of Kent *) +(* Thomas Tuerk, University of Cambridge *) +(* Brian Campbell, University of Edinburgh *) +(* Shaked Flur, University of Cambridge *) +(* Thomas Bauereiss, University of Cambridge *) +(* Stephen Kell, University of Cambridge *) +(* Thomas Williams *) +(* Lars Hupel *) +(* Basile Clement *) +(* *) +(* The Lem sources are copyright 2010-2018 *) +(* by the authors above and Institut National de Recherche en *) +(* Informatique et en Automatique (INRIA). *) +(* *) +(* All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli} *) +(* are distributed under the license below. The former are distributed *) +(* under the LGPLv2, as in the LICENSE file. *) +(* *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in the *) +(* documentation and/or other materials provided with the distribution. *) +(* 3. The names of the authors may not be used to endorse or promote *) +(* products derived from this software without specific prior written *) +(* permission. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS *) +(* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED *) +(* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE *) +(* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY *) +(* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL *) +(* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE *) +(* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS *) +(* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER *) +(* IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR *) +(* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN *) +(* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) +(*========================================================================*) + +chapter \<open>Auxiliary Definitions needed by Lem\<close> + +theory "LemExtraDefs" + +imports + Main + "~~/src/HOL/Library/Permutation" + "~~/src/HOL/Library/While_Combinator" +begin + +subsection \<open>General\<close> + +consts failwith :: " 'a \<Rightarrow> 'b" + +subsection \<open>Lists\<close> + +fun index :: " 'a list \<Rightarrow> nat \<Rightarrow> 'a option " where + "index [] n = None" + | "index (x # xs) 0 = Some x" + | "index (x # xs) (Suc n) = index xs n" + +lemma index_eq_some [simp]: + "index l n = Some x \<longleftrightarrow> (n < length l \<and> (x = l ! n))" +proof (induct l arbitrary: n x) + case Nil thus ?case by simp +next + case (Cons e es n x) + note ind_hyp = this + + show ?case + proof (cases n) + case 0 thus ?thesis by auto + next + case (Suc n') + with ind_hyp show ?thesis by simp + qed +qed + +lemma index_eq_none [simp]: + "index l n = None \<longleftrightarrow> length l \<le> n" +by (rule iffD1[OF Not_eq_iff]) auto + + +lemma index_simps [simp]: + "length l \<le> n \<Longrightarrow> index l n = None" + "n < length l \<Longrightarrow> index l n = Some (l ! n)" +by (simp_all) + +fun find_indices :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat list" where + "find_indices P [] = []" + | "find_indices P (x # xs) = (if P x then 0 # (map Suc (find_indices P xs)) else (map Suc (find_indices P xs)))" + +lemma length_find_indices : + "length (find_indices P l) \<le> length l" +by (induct l) auto + +lemma sorted_map_suc : + "sorted l \<Longrightarrow> sorted (map Suc l)" +by (induct l) (simp_all add: sorted_Cons) + +lemma sorted_find_indices : + "sorted (find_indices P xs)" +proof (induct xs) + case Nil thus ?case by simp +next + case (Cons x xs) + from sorted_map_suc[OF this] + show ?case + by (simp add: sorted_Cons) +qed + +lemma find_indices_set [simp] : + "set (find_indices P l) = {i. i < length l \<and> P (l ! i)}" +proof (intro set_eqI) + fix i + show "i \<in> set (find_indices P l) \<longleftrightarrow> (i \<in> {i. i < length l \<and> P (l ! i)})" + proof (induct l arbitrary: i) + case Nil thus ?case by simp + next + case (Cons x l' i) + note ind_hyp = this + show ?case + proof (cases i) + case 0 thus ?thesis by auto + next + case (Suc i') with ind_hyp[of i'] show ?thesis by auto + qed + qed +qed + +definition find_index where + "find_index P xs = (case find_indices P xs of + [] \<Rightarrow> None + | i # _ \<Rightarrow> Some i)" + +lemma find_index_eq_some [simp] : + "(find_index P xs = Some ii) \<longleftrightarrow> (ii < length xs \<and> P (xs ! ii) \<and> (\<forall>i' < ii. \<not>(P (xs ! i'))))" + (is "?lhs = ?rhs") +proof (cases "find_indices P xs") + case Nil + with find_indices_set[of P xs] + show ?thesis + unfolding find_index_def by auto +next + case (Cons i il) note find_indices_eq = this + + from sorted_find_indices[of P xs] find_indices_eq + have "sorted (i # il)" by simp + hence i_leq: "\<And>i'. i' \<in> set (i # il) \<Longrightarrow> i \<le> i'" unfolding sorted_Cons by auto + + from find_indices_set[of P xs, unfolded find_indices_eq] + have set_i_il_eq:"\<And>i'. i' \<in> set (i # il) = (i' < length xs \<and> P (xs ! i'))" + by simp + + have lhs_eq: "find_index P xs = Some i" + unfolding find_index_def find_indices_eq by simp + + show ?thesis + proof (intro iffI) + assume ?lhs + with lhs_eq have ii_eq[simp]: "ii = i" by simp + + from set_i_il_eq[of i] i_leq[unfolded set_i_il_eq] + show ?rhs by auto (metis leD less_trans) + next + assume ?rhs + with set_i_il_eq[of ii] + have "ii \<in> set (i # il) \<and> (ii \<le> i)" + by (metis leI length_pos_if_in_set nth_Cons_0 nth_mem set_i_il_eq) + + with i_leq [of ii] have "i = ii" by simp + thus ?lhs unfolding lhs_eq by simp + qed +qed + +lemma find_index_eq_none [simp] : + "(find_index P xs = None) \<longleftrightarrow> (\<forall>x \<in> set xs. \<not>(P x))" (is "?lhs = ?rhs") +proof (rule iffD1[OF Not_eq_iff], intro iffI) + assume "\<not> ?lhs" + then obtain i where "find_index P xs = Some i" by auto + hence "i < length xs \<and> P (xs ! i)" by simp + thus "\<not> ?rhs" by auto +next + let ?p = "(\<lambda>i. i < length xs \<and> P(xs ! i))" + + assume "\<not> ?rhs" + then obtain i where "?p i" + by (metis in_set_conv_nth) + + from LeastI [of ?p, OF \<open>?p i\<close>] + have "?p (Least ?p)" . + + hence "find_index P xs = Some (Least ?p)" + by (subst find_index_eq_some) (metis (mono_tags) less_trans not_less_Least) + + thus "\<not> ?lhs" by blast +qed + +definition genlist where + "genlist f n = map f (upt 0 n)" + +lemma genlist_length [simp] : + "length (genlist f n) = n" +unfolding genlist_def by simp + +lemma genlist_simps [simp]: + "genlist f 0 = []" + "genlist f (Suc n) = genlist f n @ [f n]" +unfolding genlist_def by auto + +definition split_at where + "split_at n l = (take n l, drop n l)" + +fun delete_first :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list) option " where + "delete_first P [] = None" + | "delete_first P (x # xs) = + (if (P x) then Some xs else + map_option (\<lambda>xs'. x # xs') (delete_first P xs))" +declare delete_first.simps [simp del] + +lemma delete_first_simps [simp] : + "delete_first P [] = None" + "P x \<Longrightarrow> delete_first P (x # xs) = Some xs" + "\<not>(P x) \<Longrightarrow> delete_first P (x # xs) = map_option (\<lambda>xs'. x # xs') (delete_first P xs)" +unfolding delete_first.simps by auto + +lemmas delete_first_unroll = delete_first.simps(2) + + +lemma delete_first_eq_none [simp] : + "delete_first P l = None \<longleftrightarrow> (\<forall>x \<in> set l. \<not> (P x))" +by (induct l) (auto simp add: delete_first_unroll) + +lemma delete_first_eq_some : + "delete_first P l = (Some l') \<longleftrightarrow> (\<exists>l1 x l2. P x \<and> (\<forall>x \<in> set l1. \<not>(P x)) \<and> (l = l1 @ (x # l2)) \<and> (l' = l1 @ l2))" + (is "?lhs l l' = (\<exists>l1 x l2. ?rhs_body l1 x l2 l l')") +proof (induct l arbitrary: l') + case Nil thus ?case by simp +next + case (Cons e l l') + note ind_hyp = this + + show ?case + proof (cases "P e") + case True + show ?thesis + proof (rule iffI) + assume "?lhs (e # l) l'" + with \<open>P e\<close> have "l = l'" by simp + with \<open>P e\<close> have "?rhs_body [] e l' (e # l) l'" by simp + thus "\<exists>l1 x l2. ?rhs_body l1 x l2 (e # l) l'" by blast + next + assume "\<exists>l1 x l2. ?rhs_body l1 x l2 (e # l) l'" + then obtain l1 x l2 where body_ok: "?rhs_body l1 x l2 (e # l) l'" by blast + + from body_ok \<open>P e\<close> have l1_eq[simp]: "l = l'" + by (cases l1) (simp_all) + with \<open>P e\<close> show "?lhs (e # l) l'" by simp + qed + next + case False + define rhs_pred where "rhs_pred \<equiv> \<lambda>l1 x l2 l l'. ?rhs_body l1 x l2 l l'" + have rhs_fold: "\<And>l1 x l2 l l'. ?rhs_body l1 x l2 l l' = rhs_pred l1 x l2 l l'" + unfolding rhs_pred_def by simp + + have "(\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l') = (\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l')" + proof (intro iffI) + assume "\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l'" + then obtain z l1 x l2 where "rhs_pred l1 x l2 l z" and l'_eq: "l' = e # z" by auto + with \<open>\<not>(P e)\<close> have "rhs_pred (e # l1) x l2 (e # l) l'" + unfolding rhs_pred_def by simp + thus "\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l'" by blast + next + assume "\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l'" + then obtain l1 x l2 where "rhs_pred l1 x l2 (e # l) l'" by blast + with \<open>\<not> (P e)\<close> obtain l1' where l1_eq[simp]: "l1 = e # l1'" + unfolding rhs_pred_def by (cases l1) (auto) + + with \<open>rhs_pred l1 x l2 (e # l) l'\<close> + have "rhs_pred l1' x l2 l (l1' @ l2) \<and> e # (l1' @ l2) = l'" + unfolding rhs_pred_def by (simp) + thus "\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l'" by blast + qed + with \<open>\<not> P e\<close> show ?thesis + unfolding rhs_fold + by (simp add: ind_hyp[unfolded rhs_fold]) + qed +qed + + +lemma perm_eval [code] : + "perm [] l \<longleftrightarrow> l = []" (is ?g1) + "perm (x # xs) l \<longleftrightarrow> (case delete_first (\<lambda>e. e = x) l of + None => False + | Some l' => perm xs l')" (is ?g2) +proof - + show ?g1 by auto +next + show ?g2 + proof (cases "delete_first (\<lambda>e. e = x) l") + case None note del_eq = this + hence "x \<notin> set l" by auto + with perm_set_eq [of "x # xs" l] + have "\<not> perm (x # xs) l" by auto + thus ?thesis unfolding del_eq by simp + next + case (Some l') note del_eq = this + + from del_eq[unfolded delete_first_eq_some] + obtain l1 l2 where l_eq: "l = l1 @ [x] @ l2" and l'_eq: "l' = l1 @ l2" by auto + + have "(x # xs <~~> l1 @ x # l2) = (xs <~~> l1 @ l2)" + proof - + from perm_append_swap [of l1 "[x]"] + perm_append2 [of "l1 @ [x]" "x # l1" l2] + have "l1 @ x # l2 <~~> x # (l1 @ l2)" by simp + hence "x # xs <~~> l1 @ x # l2 \<longleftrightarrow> x # xs <~~> x # (l1 @ l2)" + by (metis perm.trans perm_sym) + thus ?thesis by simp + qed + with del_eq l_eq l'_eq show ?thesis by simp + qed +qed + + +fun sorted_by :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> bool " where + "sorted_by cmp [] = True" + | "sorted_by cmp [_] = True" + | "sorted_by cmp (x1 # x2 # xs) = ((cmp x1 x2) \<and> sorted_by cmp (x2 # xs))" + +lemma sorted_by_lesseq [simp] : + "sorted_by ((op \<le>) :: ('a::{linorder}) => 'a => bool) = sorted" +proof (rule ext) + fix l :: "'a list" + show "sorted_by (op \<le>) l = sorted l" + proof (induct l) + case Nil thus ?case by simp + next + case (Cons x xs) + thus ?case by (cases xs) (simp_all) + qed +qed + +lemma sorted_by_cons_imp : + "sorted_by cmp (x # xs) \<Longrightarrow> sorted_by cmp xs" +by (cases xs) simp_all + +lemma sorted_by_cons_trans : + assumes trans_cmp: "transp cmp" + shows "sorted_by cmp (x # xs) = ((\<forall>x' \<in> set xs . cmp x x') \<and> sorted_by cmp xs)" +proof (induct xs arbitrary: x) + case Nil thus ?case by simp +next + case (Cons x2 xs x1) + note ind_hyp = this + + from trans_cmp + show ?case + by (auto simp add: ind_hyp transp_def) +qed + + +fun insert_sort_insert_by :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list " where + "insert_sort_insert_by cmp e ([]) = ( [e])" +| "insert_sort_insert_by cmp e (x # xs) = ( if cmp e x then (e # (x # xs)) else x # (insert_sort_insert_by cmp e xs))" + + +lemma insert_sort_insert_by_length [simp] : + "length (insert_sort_insert_by cmp e l) = Suc (length l)" +by (induct l) auto + +lemma insert_sort_insert_by_set [simp] : + "set (insert_sort_insert_by cmp e l) = insert e (set l)" +by (induct l) auto + +lemma insert_sort_insert_by_perm : + "(insert_sort_insert_by cmp e l) <~~> (e # l)" +proof (induct l) + case Nil thus ?case by simp +next + case (Cons e2 l') + note ind_hyp = this + + have "e2 # e # l' <~~> e # e2 # l'" by (rule perm.swap) + hence "e2 # insert_sort_insert_by cmp e l' <~~> e # e2 # l'" + using ind_hyp by (metis cons_perm_eq perm.trans) + thus ?case by simp +qed + + +lemma insert_sort_insert_by_sorted_by : +assumes cmp_cases: "\<And>y. y \<in> set l \<Longrightarrow> \<not> (cmp e y) \<Longrightarrow> cmp y e" +assumes cmp_trans: "transp cmp" +shows "sorted_by cmp l \<Longrightarrow> sorted_by cmp (insert_sort_insert_by cmp e l)" +using cmp_cases +proof (induct l) + case Nil thus ?case by simp +next + case (Cons x1 l') + note ind_hyp = Cons(1) + note sorted_x1_l' = Cons(2) + note cmp_cases = Cons(3) + + show ?case + proof (cases l') + case Nil with cmp_cases show ?thesis by simp + next + case (Cons x2 l'') note l'_eq = this + + from l'_eq sorted_x1_l' have "cmp x1 x2" "sorted_by cmp l'" by simp_all + + show ?thesis + proof (cases "cmp e x1") + case True + with \<open>cmp x1 x2\<close> \<open>sorted_by cmp l'\<close> + have "sorted_by cmp (x1 # l')" + unfolding l'_eq by (simp) + with \<open>cmp e x1\<close> + show ?thesis by simp + next + case False + + with cmp_cases have "cmp x1 e" by simp + have "\<And>x'. x' \<in> set l' \<Longrightarrow> cmp x1 x'" + proof - + fix x' + assume "x' \<in> set l'" + hence "x' = x2 \<or> cmp x2 x'" + using \<open>sorted_by cmp l'\<close> l'_eq sorted_by_cons_trans [OF cmp_trans, of x2 l''] + by auto + with transpD[OF cmp_trans, of x1 x2 x'] \<open>cmp x1 x2\<close> + show "cmp x1 x'" by blast + qed + hence "sorted_by cmp (x1 # insert_sort_insert_by cmp e l')" + using ind_hyp [OF \<open>sorted_by cmp l'\<close>] \<open>cmp x1 e\<close> cmp_cases + unfolding sorted_by_cons_trans[OF cmp_trans] + by simp + with \<open>\<not>(cmp e x1)\<close> + show ?thesis by simp + qed + qed +qed + + + +fun insert_sort_by :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list " where + "insert_sort_by cmp [] = []" + | "insert_sort_by cmp (x # xs) = insert_sort_insert_by cmp x (insert_sort_by cmp xs)" + + +lemma insert_sort_by_perm : + "(insert_sort_by cmp l) <~~> l" +proof (induct l) + case Nil thus ?case by simp +next + case (Cons x l) + thus ?case + by simp (metis cons_perm_eq insert_sort_insert_by_perm perm.trans) +qed + +lemma insert_sort_by_length [simp]: + "length (insert_sort_by cmp l) = length l" +by (induct l) auto + +lemma insert_sort_by_set [simp]: + "set (insert_sort_by cmp l) = set l" +by (induct l) auto + +definition sort_by where + "sort_by = insert_sort_by" + +lemma sort_by_simps [simp]: + "length (sort_by cmp l) = length l" + "set (sort_by cmp l) = set l" +unfolding sort_by_def by simp_all + +lemma sort_by_perm : + "sort_by cmp l <~~> l" +unfolding sort_by_def +by (simp add: insert_sort_by_perm) + +subsection \<open>Maps\<close> + +definition map_image :: "('v \<Rightarrow> 'w) \<Rightarrow> ('k, 'v) map \<Rightarrow> ('k, 'w) map" where + "map_image f m = (\<lambda>k. map_option f (m k))" + +definition map_domain_image :: "('k \<Rightarrow> 'v \<Rightarrow> 'w) \<Rightarrow> ('k, 'v) map \<Rightarrow> ('k, 'w) map" where + "map_domain_image f m = (\<lambda>k. map_option (f k) (m k))" + + +lemma map_image_simps [simp]: + "(map_image f m) k = None \<longleftrightarrow> m k = None" + "(map_image f m) k = Some x \<longleftrightarrow> (\<exists>x'. (m k = Some x') \<and> (x = f x'))" + "(map_image f Map.empty) = Map.empty" + "(map_image f (m (k \<mapsto> v)) = (map_image f m) (k \<mapsto> f v))" +unfolding map_image_def by auto + +lemma map_image_dom_ran [simp]: + "dom (map_image f m) = dom m" + "ran (map_image f m) = f ` (ran m)" +unfolding dom_def ran_def by auto + +definition map_to_set :: "('k, 'v) map \<Rightarrow> ('k * 'v) set" where + "map_to_set m = { (k, v) . m k = Some v }" + +lemma map_to_set_simps [simp] : + "map_to_set Map.empty = {}" (is ?g1) + "map_to_set (m ((k::'k) \<mapsto> (v::'v))) = (insert (k, v) (map_to_set (m |` (- {k}))))" (is ?g2) +proof - + show ?g1 unfolding map_to_set_def by simp +next + show ?g2 + proof (rule set_eqI) + fix kv :: "('k * 'v)" + obtain k' v' where kv_eq[simp]: "kv = (k', v')" by (rule prod.exhaust) + + show "(kv \<in> map_to_set (m(k \<mapsto> v))) = (kv \<in> insert (k, v) (map_to_set (m |` (- {k}))))" + by (auto simp add: map_to_set_def) + qed +qed + + +subsection \<open>Sets\<close> + +definition "set_choose s \<equiv> (SOME x. (x \<in> s))" + +definition without_trans_edges :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where + "without_trans_edges S \<equiv> + let ts = trancl S in + { (x, y) \<in> S. \<forall>z \<in> snd ` S. x \<noteq> z \<and> y \<noteq> z \<longrightarrow> \<not> ((x, z) \<in> ts \<and> (z, y) \<in> ts)}" + +definition unbounded_lfp :: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where + "unbounded_lfp S f \<equiv> + while (\<lambda>x. x \<subset> S) f S" + +definition unbounded_gfp :: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where + "unbounded_gfp S f \<equiv> + while (\<lambda>x. S \<subset> x) f S" + +lemma set_choose_thm[simp]: + "s \<noteq> {} \<Longrightarrow> (set_choose s) \<in> s" +unfolding set_choose_def +by (rule someI_ex) auto + +lemma set_choose_sing [simp]: + "set_choose {x} = x" + unfolding set_choose_def + by auto + +lemma set_choose_code [code]: + "set_choose (set [x]) = x" +by auto + +lemma set_choose_in [intro] : + assumes "s \<noteq> {}" + shows "set_choose s \<in> s" +proof - + from \<open>s \<noteq> {}\<close> + obtain x where "x \<in> s" by auto + thus ?thesis + unfolding set_choose_def + by (rule someI) +qed + + +definition set_case where + "set_case s c_empty c_sing c_else = + (if (s = {}) then c_empty else + (if (card s = 1) then c_sing (set_choose s) else + c_else))" + +lemma set_case_simps [simp] : + "set_case {} c_empty c_sing c_else = c_empty" + "set_case {x} c_empty c_sing c_else = c_sing x" + "card s > 1 \<Longrightarrow> set_case s c_empty c_sing c_else = c_else" + "\<not>(finite s) \<Longrightarrow> set_case s c_empty c_sing c_else = c_else" +unfolding set_case_def by auto + +lemma set_case_simp_insert2 [simp] : +assumes x12_neq: "x1 \<noteq> x2" +shows "set_case (insert x1 (insert x2 xs)) c_empty c_sing c_else = c_else" +proof (cases "finite xs") + case False thus ?thesis by (simp) +next + case True note fin_xs = this + + have "card {x1,x2} \<le> card (insert x1 (insert x2 xs))" + by (rule card_mono) (auto simp add: fin_xs) + with x12_neq have "1 < card (insert x1 (insert x2 xs))" by simp + thus ?thesis by auto +qed + +lemma set_case_code [code] : + "set_case (set []) c_empty c_sing c_else = c_empty" + "set_case (set [x]) c_empty c_sing c_else = c_sing x" + "set_case (set (x1 # x2 # xs)) c_empty c_sing c_else = + (if (x1 = x2) then + set_case (set (x2 # xs)) c_empty c_sing c_else + else + c_else)" +by auto + +definition set_lfp:: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where + "set_lfp s f = lfp (\<lambda>s'. f s' \<union> s)" + +lemma set_lfp_tail_rec_def : +assumes mono_f: "mono f" +shows "set_lfp s f = (if (f s) \<subseteq> s then s else (set_lfp (s \<union> f s) f))" (is "?ls = ?rs") +proof (cases "f s \<subseteq> s") + case True note fs_sub_s = this + + from fs_sub_s have "\<Inter>{u. f u \<union> s \<subseteq> u} = s" by auto + hence "?ls = s" unfolding set_lfp_def lfp_def . + with fs_sub_s show "?ls = ?rs" by simp +next + case False note not_fs_sub_s = this + + from mono_f have mono_f': "mono (\<lambda>s'. f s' \<union> s)" + unfolding mono_def by auto + + have "\<Inter>{u. f u \<union> s \<subseteq> u} = \<Inter>{u. f u \<union> (s \<union> f s) \<subseteq> u}" (is "\<Inter>?S1 = \<Inter>?S2") + proof + have "?S2 \<subseteq> ?S1" by auto + thus "\<Inter>?S1 \<subseteq> \<Inter>?S2" by (rule Inf_superset_mono) + next + { fix e + assume "e \<in> \<Inter>?S2" + hence S2_prop: "\<And>s'. f s' \<subseteq> s' \<Longrightarrow> s \<subseteq> s' \<Longrightarrow> f s \<subseteq> s' \<Longrightarrow> e \<in> s'" by simp + + { fix s' + assume "f s' \<subseteq> s'" "s \<subseteq> s'" + + from mono_f \<open>s \<subseteq> s'\<close> + have "f s \<subseteq> f s'" unfolding mono_def by simp + with \<open>f s' \<subseteq> s'\<close> have "f s \<subseteq> s'" by simp + with \<open>f s' \<subseteq> s'\<close> \<open>s \<subseteq> s'\<close> S2_prop + have "e \<in> s'" by simp + } + hence "e \<in> \<Inter>?S1" by simp + } + thus "\<Inter>?S2 \<subseteq> \<Inter>?S1" by auto + qed + hence "?ls = (set_lfp (s \<union> f s) f)" + unfolding set_lfp_def lfp_def . + with not_fs_sub_s show "?ls = ?rs" by simp +qed + +lemma set_lfp_simps [simp] : +"mono f \<Longrightarrow> f s \<subseteq> s \<Longrightarrow> set_lfp s f = s" +"mono f \<Longrightarrow> \<not>(f s \<subseteq> s) \<Longrightarrow> set_lfp s f = (set_lfp (s \<union> f s) f)" +by (metis set_lfp_tail_rec_def)+ + + +fun insert_in_list_at_arbitrary_pos where + "insert_in_list_at_arbitrary_pos x [] = {[x]}" + | "insert_in_list_at_arbitrary_pos x (y # ys) = + insert (x # y # ys) ((\<lambda>l. y # l) ` (insert_in_list_at_arbitrary_pos x ys))" + +lemma insert_in_list_at_arbitrary_pos_thm : + "xl \<in> insert_in_list_at_arbitrary_pos x l \<longleftrightarrow> + (\<exists>l1 l2. l = l1 @ l2 \<and> xl = l1 @ [x] @ l2)" +proof (induct l arbitrary: xl) + case Nil thus ?case by simp +next + case (Cons y l xyl) + note ind_hyp = this + + show ?case + proof (rule iffI) + assume xyl_in: "xyl \<in> insert_in_list_at_arbitrary_pos x (y # l)" + show "\<exists>l1 l2. y # l = l1 @ l2 \<and> xyl = l1 @ [x] @ l2" + proof (cases "xyl = x # y # l") + case True + hence "y # l = [] @ (y # l) \<and> xyl = [] @ [x] @ (y # l)" by simp + thus ?thesis by blast + next + case False + with xyl_in have "xyl \<in> op # y ` insert_in_list_at_arbitrary_pos x l" by simp + with ind_hyp obtain l1 l2 where "l = l1 @ l2 \<and> xyl = y # l1 @ x # l2" + by (auto simp add: image_def Bex_def) + hence "y # l = (y # l1) @ l2 \<and> xyl = (y # l1) @ [x] @ l2" by simp + thus ?thesis by blast + qed + next + assume "\<exists>l1 l2. y # l = l1 @ l2 \<and> xyl = l1 @ [x] @ l2" + then obtain l1 l2 where yl_eq: "y # l = l1 @ l2" and xyl_eq: "xyl = l1 @ [x] @ l2" by blast + show "xyl \<in> insert_in_list_at_arbitrary_pos x (y # l)" + proof (cases l1) + case Nil + with yl_eq xyl_eq + have "xyl = x # y # l" by simp + thus ?thesis by simp + next + case (Cons y' l1') + with yl_eq have l1_eq: "l1 = y # l1'" and l_eq: "l = l1' @ l2" by simp_all + + have "\<exists>l1'' l2''. l = l1'' @ l2'' \<and> l1' @ [x] @ l2 = l1'' @ [x] @ l2''" + apply (rule_tac exI[where x = l1']) + apply (rule_tac exI [where x = l2]) + apply (simp add: l_eq) + done + hence "(l1' @ [x] @ l2) \<in> insert_in_list_at_arbitrary_pos x l" + unfolding ind_hyp by blast + hence "\<exists>l'. l' \<in> insert_in_list_at_arbitrary_pos x l \<and> l1 @ x # l2 = y # l'" + by (rule_tac exI [where x = "l1' @ [x] @ l2"]) (simp add: l1_eq) + thus ?thesis + by (simp add: image_def Bex_def xyl_eq) + qed + qed +qed + +definition list_of_set_set :: "'a set \<Rightarrow> ('a list) set" where +"list_of_set_set s = { l . (set l = s) \<and> distinct l }" + +lemma list_of_set_set_empty [simp]: + "list_of_set_set {} = {[]}" +unfolding list_of_set_set_def by auto + +lemma list_of_set_set_insert [simp] : + "list_of_set_set (insert x s) = + \<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set (s - {x})))" + (is "?lhs = ?rhs") +proof (intro set_eqI) + fix l + + have "(set l = insert x s \<and> distinct l) \<longleftrightarrow> (\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2)" + proof (intro iffI) + assume "set l = insert x s \<and> distinct l" + hence set_l_eq: "set l = insert x s" and "distinct l" by simp_all + + from \<open>set l = insert x s\<close> + have "x \<in> set l" by simp + then obtain l1 l2 where l_eq: "l = l1 @ x # l2" + unfolding in_set_conv_decomp by blast + + from \<open>distinct l\<close> l_eq + have "distinct (l1 @ l2)" and x_nin: "x \<notin> set (l1 @ l2)" + by auto + + from x_nin set_l_eq[unfolded l_eq] + have set_l12_eq: "set (l1 @ l2) = s - {x}" + by auto + + from \<open>distinct (l1 @ l2)\<close> l_eq set_l12_eq + show "\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2" + by blast + next + assume "\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2" + then obtain l1 l2 where "set (l1 @ l2) = s - {x}" "distinct (l1 @ l2)" "l = l1 @ x # l2" + by blast + thus "set l = insert x s \<and> distinct l" + by auto + qed + + thus "l \<in> list_of_set_set (insert x s) \<longleftrightarrow> l \<in> (\<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set (s - {x}))))" + unfolding list_of_set_set_def + by (simp add: insert_in_list_at_arbitrary_pos_thm ex_simps[symmetric] del: ex_simps) +qed + +lemma list_of_set_set_code [code]: + "list_of_set_set (set []) = {[]}" + "list_of_set_set (set (x # xs)) = + \<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set ((set xs) - {x})))" +by simp_all + +lemma list_of_set_set_is_empty : + "list_of_set_set s = {} \<longleftrightarrow> \<not> (finite s)" +proof - + have "finite s \<longleftrightarrow> (\<exists>l. set l = s \<and> distinct l)" + proof (rule iffI) + assume "\<exists>l. set l = s \<and> distinct l" then + obtain l where "s = set l" by blast + thus "finite s" by simp + next + assume "finite s" + thus "\<exists>l. set l = s \<and> distinct l" + proof (induct s) + case empty + show ?case by auto + next + case (insert e s) + note e_nin_s = insert(2) + from insert(3) obtain l where set_l: "set l = s" and dist_l: "distinct l" by blast + + from set_l have set_el: "set (e # l) = insert e s" by auto + from dist_l set_l e_nin_s have dist_el: "distinct (e # l)" by simp + + from set_el dist_el show ?case by blast + qed + qed + thus ?thesis + unfolding list_of_set_set_def by simp +qed + +definition list_of_set :: "'a set \<Rightarrow> 'a list" where + "list_of_set s = set_choose (list_of_set_set s)" + +lemma list_of_set [simp] : + assumes fin_s: "finite s" + shows "set (list_of_set s) = s" + "distinct (list_of_set s)" +proof - + from fin_s list_of_set_set_is_empty[of s] + have "\<not> (list_of_set_set s = {})" by simp + hence "list_of_set s \<in> list_of_set_set s" + unfolding list_of_set_def + by (rule set_choose_thm) + thus "set (list_of_set s) = s" + "distinct (list_of_set s)" unfolding list_of_set_set_def + by simp_all +qed + +lemma list_of_set_in: + "finite s \<Longrightarrow> list_of_set s \<in> list_of_set_set s" +unfolding list_of_set_def +by (metis list_of_set_set_is_empty set_choose_thm) + +definition ordered_list_of_set where + "ordered_list_of_set cmp s = set_choose (sort_by cmp ` list_of_set_set s)" + +subsection \<open>sum\<close> + +find_consts "'a list => ('a list * _)" + +fun sum_partition :: "('a + 'b) list \<Rightarrow> 'a list * 'b list" where + "sum_partition [] = ([], [])" +| "sum_partition ((Inl l) # lrs) = + (let (ll, rl) = sum_partition lrs in + (l # ll, rl))" +| "sum_partition ((Inr r) # lrs) = + (let (ll, rl) = sum_partition lrs in + (ll, r # rl))" + +lemma sum_partition_length : + "List.length lrs = List.length (fst (sum_partition lrs)) + List.length (snd (sum_partition lrs))" +proof (induct lrs) + case Nil thus ?case by simp +next + case (Cons lr lrs) thus ?case + by (cases lr) (auto split: prod.split) +qed + +subsection \<open>sorting\<close> + +subsection \<open>Strings\<close> + +lemma explode_str_simp [simp] : + "String.explode (STR l) = l" +by (metis STR_inverse UNIV_I) + +declare String.literal.explode_inverse [simp] + +subsection \<open>num to string conversions\<close> + +definition nat_list_to_string :: "nat list \<Rightarrow> string" where + "nat_list_to_string nl = map char_of_nat nl" + +definition is_digit where + "is_digit (n::nat) = (n < 10)" + +lemma is_digit_simps[simp] : + "n < 10 \<Longrightarrow> is_digit n" + "\<not>(n < 10) \<Longrightarrow> \<not>(is_digit n)" +unfolding is_digit_def by simp_all + +lemma is_digit_expand : + "is_digit n \<longleftrightarrow> + (n = 0) \<or> (n = 1) \<or> (n = 2) \<or> (n = 3) \<or> (n = 4) \<or> + (n = 5) \<or> (n = 6) \<or> (n = 7) \<or> (n = 8) \<or> (n = 9)" +unfolding is_digit_def by auto + +lemmas is_digitE = is_digit_expand[THEN iffD1,elim_format] +lemmas is_digitI = is_digit_expand[THEN iffD2,rule_format] + +definition is_digit_char where + "is_digit_char c \<longleftrightarrow> + (c = CHR ''0'') \<or> (c = CHR ''5'') \<or> + (c = CHR ''1'') \<or> (c = CHR ''6'') \<or> + (c = CHR ''2'') \<or> (c = CHR ''7'') \<or> + (c = CHR ''3'') \<or> (c = CHR ''8'') \<or> + (c = CHR ''4'') \<or> (c = CHR ''9'')" + +lemma is_digit_char_simps[simp] : + "is_digit_char (CHR ''0'')" + "is_digit_char (CHR ''1'')" + "is_digit_char (CHR ''2'')" + "is_digit_char (CHR ''3'')" + "is_digit_char (CHR ''4'')" + "is_digit_char (CHR ''5'')" + "is_digit_char (CHR ''6'')" + "is_digit_char (CHR ''7'')" + "is_digit_char (CHR ''8'')" + "is_digit_char (CHR ''9'')" +unfolding is_digit_char_def by simp_all + +lemmas is_digit_charE = is_digit_char_def[THEN iffD1,elim_format] +lemmas is_digit_charI = is_digit_char_def[THEN iffD2,rule_format] + +definition digit_to_char :: "nat \<Rightarrow> char" where + "digit_to_char n = ( + if n = 0 then CHR ''0'' + else if n = 1 then CHR ''1'' + else if n = 2 then CHR ''2'' + else if n = 3 then CHR ''3'' + else if n = 4 then CHR ''4'' + else if n = 5 then CHR ''5'' + else if n = 6 then CHR ''6'' + else if n = 7 then CHR ''7'' + else if n = 8 then CHR ''8'' + else if n = 9 then CHR ''9'' + else CHR ''X'')" + +lemma digit_to_char_simps [simp]: + "digit_to_char 0 = CHR ''0''" + "digit_to_char (Suc 0) = CHR ''1''" + "digit_to_char 2 = CHR ''2''" + "digit_to_char 3 = CHR ''3''" + "digit_to_char 4 = CHR ''4''" + "digit_to_char 5 = CHR ''5''" + "digit_to_char 6 = CHR ''6''" + "digit_to_char 7 = CHR ''7''" + "digit_to_char 8 = CHR ''8''" + "digit_to_char 9 = CHR ''9''" + "n > 9 \<Longrightarrow> digit_to_char n = CHR ''X''" +unfolding digit_to_char_def +by simp_all + +definition char_to_digit :: "char \<Rightarrow> nat" where + "char_to_digit c = ( + if c = CHR ''0'' then 0 + else if c = CHR ''1'' then 1 + else if c = CHR ''2'' then 2 + else if c = CHR ''3'' then 3 + else if c = CHR ''4'' then 4 + else if c = CHR ''5'' then 5 + else if c = CHR ''6'' then 6 + else if c = CHR ''7'' then 7 + else if c = CHR ''8'' then 8 + else if c = CHR ''9'' then 9 + else 10)" + +lemma char_to_digit_simps [simp]: + "char_to_digit (CHR ''0'') = 0" + "char_to_digit (CHR ''1'') = 1" + "char_to_digit (CHR ''2'') = 2" + "char_to_digit (CHR ''3'') = 3" + "char_to_digit (CHR ''4'') = 4" + "char_to_digit (CHR ''5'') = 5" + "char_to_digit (CHR ''6'') = 6" + "char_to_digit (CHR ''7'') = 7" + "char_to_digit (CHR ''8'') = 8" + "char_to_digit (CHR ''9'') = 9" +unfolding char_to_digit_def by simp_all + + +lemma diget_to_char_inv[simp]: +assumes is_digit: "is_digit n" +shows "char_to_digit (digit_to_char n) = n" +using is_digit unfolding is_digit_expand by auto + +lemma char_to_diget_inv[simp]: +assumes is_digit: "is_digit_char c" +shows "digit_to_char (char_to_digit c) = c" +using is_digit +unfolding char_to_digit_def is_digit_char_def +by auto + +lemma char_to_digit_div_mod [simp]: +assumes is_digit: "is_digit_char c" +shows "char_to_digit c < 10" +using is_digit +unfolding char_to_digit_def is_digit_char_def +by auto + + +lemma is_digit_char_intro[simp]: + "is_digit (char_to_digit c) = is_digit_char c" +unfolding char_to_digit_def is_digit_char_def is_digit_expand +by auto + +lemma is_digit_intro[simp]: + "is_digit_char (digit_to_char n) = is_digit n" +unfolding digit_to_char_def is_digit_char_def is_digit_expand +by auto + +lemma digit_to_char_11: +"digit_to_char n1 = digit_to_char n2 \<Longrightarrow> + (is_digit n1 = is_digit n2) \<and> (is_digit n1 \<longrightarrow> (n1 = n2))" +by (metis diget_to_char_inv is_digit_intro) + +lemma char_to_digit_11: +"char_to_digit c1 = char_to_digit c2 \<Longrightarrow> + (is_digit_char c1 = is_digit_char c2) \<and> (is_digit_char c1 \<longrightarrow> (c1 = c2))" +by (metis char_to_diget_inv is_digit_char_intro) + +function nat_to_string :: "nat \<Rightarrow> string" where + "nat_to_string n = + (if (is_digit n) then [digit_to_char n] else + nat_to_string (n div 10) @ [digit_to_char (n mod 10)])" +by auto +termination + by (relation "measure id") (auto simp add: is_digit_def) + +definition int_to_string :: "int \<Rightarrow> string" where + "int_to_string i \<equiv> + if i < 0 then + ''-'' @ nat_to_string (nat (abs i)) + else + nat_to_string (nat i)" + +lemma nat_to_string_simps[simp]: + "is_digit n \<Longrightarrow> nat_to_string n = [digit_to_char n]" + "\<not>(is_digit n) \<Longrightarrow> nat_to_string n = nat_to_string (n div 10) @ [digit_to_char (n mod 10)]" +by simp_all +declare nat_to_string.simps[simp del] + +lemma nat_to_string_neq_nil[simp]: + "nat_to_string n \<noteq> []" + by (cases "is_digit n") simp_all + +lemmas nat_to_string_neq_nil2[simp] = nat_to_string_neq_nil[symmetric] + +lemma nat_to_string_char_to_digit [simp]: + "is_digit_char c \<Longrightarrow> nat_to_string (char_to_digit c) = [c]" +by auto + +lemma nat_to_string_11[simp] : + "(nat_to_string n1 = nat_to_string n2) \<longleftrightarrow> n1 = n2" +proof (rule iffI) + assume "n1 = n2" + thus "nat_to_string n1 = nat_to_string n2" by simp +next + assume "nat_to_string n1 = nat_to_string n2" + thus "n1 = n2" + proof (induct n2 arbitrary: n1 rule: less_induct) + case (less n2') + note ind_hyp = this(1) + note n2s_eq = less(2) + + have is_dig_eq: "is_digit n2' = is_digit n1" using n2s_eq + apply (cases "is_digit n2'") + apply (case_tac [!] "is_digit n1") + apply (simp_all) + done + + show ?case + proof (cases "is_digit n2'") + case True with n2s_eq is_dig_eq show ?thesis by simp (metis digit_to_char_11) + next + case False + with is_dig_eq have not_digs : "\<not> (is_digit n1)" "\<not> (is_digit n2')" by simp_all + + from not_digs(2) have "n2' div 10 < n2'" unfolding is_digit_def by auto + note ind_hyp' = ind_hyp [OF this, of "n1 div 10"] + + from not_digs n2s_eq ind_hyp' digit_to_char_11[of "n1 mod 10" "n2' mod 10"] + have "(n1 mod 10) = (n2' mod 10)" "n1 div 10 = n2' div 10" by simp_all + thus "n1 = n2'" by (metis div_mult_mod_eq) + qed + qed +qed + +definition "is_nat_string s \<equiv> (\<forall>c\<in>set s. is_digit_char c)" +definition "is_strong_nat_string s \<equiv> is_nat_string s \<and> (s \<noteq> []) \<and> (hd s = CHR ''0'' \<longrightarrow> length s = 1)" + +lemma is_nat_string_simps[simp]: + "is_nat_string []" + "is_nat_string (c # s) \<longleftrightarrow> is_digit_char c \<and> is_nat_string s" +unfolding is_nat_string_def by simp_all + +lemma is_strong_nat_string_simps[simp]: + "\<not>(is_strong_nat_string [])" + "is_strong_nat_string (c # s) \<longleftrightarrow> is_digit_char c \<and> is_nat_string s \<and> + (c = CHR ''0'' \<longrightarrow> s = [])" +unfolding is_strong_nat_string_def by simp_all + +fun string_to_nat_aux :: "nat \<Rightarrow> string \<Rightarrow> nat" where + "string_to_nat_aux n [] = n" + | "string_to_nat_aux n (d#ds) = + string_to_nat_aux (n*10 + char_to_digit d) ds" + +definition string_to_nat :: "string \<Rightarrow> nat option" where + "string_to_nat s \<equiv> + (if is_nat_string s then Some (string_to_nat_aux 0 s) else None)" + +definition string_to_nat' :: "string \<Rightarrow> nat" where + "string_to_nat' s \<equiv> the (string_to_nat s)" + +lemma string_to_nat_aux_inv : +assumes "is_nat_string s" +assumes "n > 0 \<or> is_strong_nat_string s" +shows "nat_to_string (string_to_nat_aux n s) = +(if n = 0 then '''' else nat_to_string n) @ s" +using assms +proof (induct s arbitrary: n) + case Nil + thus ?case + by (simp add: is_strong_nat_string_def) +next + case (Cons c s n) + from Cons(2) have "is_digit_char c" "is_nat_string s" by simp_all + note cs_ok = Cons(3) + let ?m = "n*10 + char_to_digit c" + note ind_hyp = Cons(1)[OF \<open>is_nat_string s\<close>, of ?m] + + from \<open>is_digit_char c\<close> have m_div: "?m div 10 = n" and + m_mod: "?m mod 10 = char_to_digit c" + unfolding is_digit_char_def + by auto + + show ?case + proof (cases "?m = 0") + case True + with \<open>is_digit_char c\<close> + have "n = 0" "c = CHR ''0''" unfolding is_digit_char_def by auto + moreover with cs_ok have "s = []" by simp + ultimately show ?thesis by simp + next + case False note m_neq_0 = this + with ind_hyp have ind_hyp': + "nat_to_string (string_to_nat_aux ?m s) = (nat_to_string ?m) @ s" by auto + + hence "nat_to_string (string_to_nat_aux n (c # s)) = (nat_to_string ?m) @ s" + by simp + + with \<open>is_digit_char c\<close> m_div show ?thesis by simp + qed +qed + +lemma string_to_nat_inv : +assumes strong_nat_s: "is_strong_nat_string s" +assumes s2n_s: "string_to_nat s = Some n" +shows "nat_to_string n = s" +proof - + from strong_nat_s have nat_s: "is_nat_string s" unfolding is_strong_nat_string_def by simp + with s2n_s have n_eq: "n = string_to_nat_aux 0 s" unfolding string_to_nat_def by simp + + from string_to_nat_aux_inv[of s 0, folded n_eq] nat_s strong_nat_s + show ?thesis by simp +qed + +lemma nat_to_string_induct [case_names "digit" "non_digit"]: +assumes digit: "\<And>d. is_digit d \<Longrightarrow> P d" +assumes not_digit: "\<And>n. \<not>(is_digit n) \<Longrightarrow> P (n div 10) \<Longrightarrow> P (n mod 10) \<Longrightarrow> P n" +shows "P n" +proof (induct n rule: less_induct) + case (less n) + note ind_hyp = this + + show ?case + proof (cases "is_digit n") + case True with digit show ?thesis by simp + next + case False note not_dig = this + hence "n div 10 < n" "n mod 10 < n" unfolding is_digit_def by auto + with not_dig ind_hyp not_digit show ?thesis by simp + qed +qed + +lemma nat_to_string___is_nat_string [simp]: + "is_nat_string (nat_to_string n)" +unfolding is_nat_string_def +proof (induct n rule: nat_to_string_induct) + case (digit d) + thus ?case by simp +next + case (non_digit n) + thus ?case by simp +qed + +lemma nat_to_string___eq_0 [simp]: + "(nat_to_string n = (CHR ''0'')#s) \<longleftrightarrow> (n = 0 \<and> s = [])" +unfolding is_nat_string_def +proof (induct n arbitrary: s rule: nat_to_string_induct) + case (digit d) thus ?case unfolding is_digit_expand by auto +next + case (non_digit n) + + obtain c s' where ns_eq: "nat_to_string (n div 10) = c # s'" + by (cases "nat_to_string (n div 10)") auto + + from non_digit(1) have "n div 10 \<noteq> 0" unfolding is_digit_def by auto + with non_digit(2) ns_eq have c_neq: "c \<noteq> CHR ''0''" by auto + + from \<open>\<not> (is_digit n)\<close> c_neq ns_eq + show ?case by auto +qed + +lemma nat_to_string___is_strong_nat_string: + "is_strong_nat_string (nat_to_string n)" +proof (cases "is_digit n") + case True thus ?thesis by simp +next + case False note not_digit = this + + obtain c s' where ns_eq: "nat_to_string n = c # s'" + by (cases "nat_to_string n") auto + + from not_digit have "0 < n" unfolding is_digit_def by simp + with ns_eq have c_neq: "c \<noteq> CHR ''0''" by auto + hence "hd (nat_to_string n) \<noteq> CHR ''0''" unfolding ns_eq by simp + + thus ?thesis unfolding is_strong_nat_string_def + by simp +qed + +lemma nat_to_string_inv : + "string_to_nat (nat_to_string n) = Some n" +by (metis nat_to_string_11 + nat_to_string___is_nat_string + nat_to_string___is_strong_nat_string + string_to_nat_def + string_to_nat_inv) + +definition The_opt where + "The_opt p = (if (\<exists>!x. p x) then Some (The p) else None)" + +lemma The_opt_eq_some [simp] : +"((The_opt p) = (Some x)) \<longleftrightarrow> ((p x) \<and> ((\<forall> y. p y \<longrightarrow> (x = y))))" + (is "?lhs = ?rhs") +proof (cases "\<exists>!x. p x") + case True + note exists_unique = this + then obtain x where p_x: "p x" by auto + + from the1_equality[of p x] exists_unique p_x + have the_opt_eq: "The_opt p = Some x" + unfolding The_opt_def by simp + + from exists_unique the_opt_eq p_x show ?thesis + by auto +next + case False + note not_unique = this + + hence "The_opt p = None" + unfolding The_opt_def by simp + with not_unique show ?thesis by auto +qed + +lemma The_opt_eq_none [simp] : +"((The_opt p) = None) \<longleftrightarrow> \<not>(\<exists>!x. p x)" +unfolding The_opt_def by auto + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_assert_extra.thy b/snapshots/isabelle/lib/lem/Lem_assert_extra.thy new file mode 100644 index 00000000..b56e5a19 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_assert_extra.thy @@ -0,0 +1,45 @@ +chapter \<open>Generated by Lem from assert_extra.lem.\<close> + +theory "Lem_assert_extra" + +imports + Main + "Lem" + +begin + + +(*open import {ocaml} `Xstring`*) +(*open import {hol} `stringTheory` `lemTheory`*) +(*open import {coq} `Coq.Strings.Ascii` `Coq.Strings.String`*) +(*open import {isabelle} `$LIB_DIR/Lem`*) + +(* ------------------------------------ *) +(* failing with a proper error message *) +(* ------------------------------------ *) + +(*val failwith: forall 'a. string -> 'a*) + +(* ------------------------------------ *) +(* failing without an error message *) +(* ------------------------------------ *) + +(*val fail : forall 'a. 'a*) +definition fail :: " 'a " where + " fail = ( failwith (''fail''))" + + +(* ------------------------------------- *) +(* assertions *) +(* ------------------------------------- *) + +(*val ensure : bool -> string -> unit*) +definition ensure :: " bool \<Rightarrow> string \<Rightarrow> unit " where + " ensure test msg = ( + if test then + () + else + failwith msg )" + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_basic_classes.thy b/snapshots/isabelle/lib/lem/Lem_basic_classes.thy new file mode 100644 index 00000000..c2032dc1 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_basic_classes.thy @@ -0,0 +1,500 @@ +chapter \<open>Generated by Lem from basic_classes.lem.\<close> + +theory "Lem_basic_classes" + +imports + Main + "Lem_bool" + +begin + +(******************************************************************************) +(* Basic Type Classes *) +(******************************************************************************) + +(*open import Bool*) + +(*open import {coq} `Coq.Strings.Ascii`*) + +(* ========================================================================== *) +(* Equality *) +(* ========================================================================== *) + +(* Lem`s default equality (=) is defined by the following type-class Eq. + This typeclass should define equality on an abstract datatype 'a. It should + always coincide with the default equality of Coq, HOL and Isabelle. + For OCaml, it might be different, since abstract datatypes like sets + might have fancy equalities. *) + +(*class ( Eq 'a ) + val = [isEqual] : 'a -> 'a -> bool + val <> [isInequal] : 'a -> 'a -> bool +end*) + + +(* (=) should for all instances be an equivalence relation + The isEquivalence predicate of relations could be used here. + However, this would lead to a cyclic dependency. *) + +(* TODO: add later, once lemmata can be assigned to classes +lemma eq_equiv: ((forall x. (x = x)) && + (forall x y. (x = y) <-> (y = x)) && + (forall x y z. ((x = y) && (y = z)) --> (x = z))) +*) + +(* Structural equality *) + +(* Sometimes, it is also handy to be able to use structural equality. + This equality is mapped to the build-in equality of backends. This equality + differs significantly for each backend. For example, OCaml can`t check equality + of function types, whereas HOL can. When using structural equality, one should + know what one is doing. The only guarentee is that is behaves like + the native backend equality. + + A lengthy name for structural equality is used to discourage its direct use. + It also ensures that users realise it is unsafe (e.g. OCaml can`t check two functions + for equality *) +(*val unsafe_structural_equality : forall 'a. 'a -> 'a -> bool*) + +(*val unsafe_structural_inequality : forall 'a. 'a -> 'a -> bool*) +(*let unsafe_structural_inequality x y= not (unsafe_structural_equality x y)*) + + +(* ========================================================================== *) +(* Orderings *) +(* ========================================================================== *) + +(* The type-class Ord represents total orders (also called linear orders) *) +datatype ordering = LT | EQ | GT + +fun orderingIsLess :: " ordering \<Rightarrow> bool " where + " orderingIsLess LT = ( True )" +|" orderingIsLess _ = ( False )" + +fun orderingIsGreater :: " ordering \<Rightarrow> bool " where + " orderingIsGreater GT = ( True )" +|" orderingIsGreater _ = ( False )" + +fun orderingIsEqual :: " ordering \<Rightarrow> bool " where + " orderingIsEqual EQ = ( True )" +|" orderingIsEqual _ = ( False )" + + +definition ordering_cases :: " ordering \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a " where + " ordering_cases r lt eq gt = ( + if orderingIsLess r then lt else + if orderingIsEqual r then eq else gt )" + + + +(*val orderingEqual : ordering -> ordering -> bool*) + +record 'a Ord_class= + + compare_method ::" 'a \<Rightarrow> 'a \<Rightarrow> ordering " + + isLess_method ::" 'a \<Rightarrow> 'a \<Rightarrow> bool " + + isLessEqual_method ::" 'a \<Rightarrow> 'a \<Rightarrow> bool " + + isGreater_method ::" 'a \<Rightarrow> 'a \<Rightarrow> bool " + + isGreaterEqual_method ::" 'a \<Rightarrow> 'a \<Rightarrow> bool " + + + + +(* Ocaml provides default, polymorphic compare functions. Let's use them + as the default. However, because used perhaps in a typeclass they must be + defined for all targets. So, explicitly declare them as undefined for + all other targets. If explictly declare undefined, the type-checker won't complain and + an error will only be raised when trying to actually output the function for a certain + target. *) +(*val defaultCompare : forall 'a. 'a -> 'a -> ordering*) +(*val defaultLess : forall 'a. 'a -> 'a -> bool*) +(*val defaultLessEq : forall 'a. 'a -> 'a -> bool*) +(*val defaultGreater : forall 'a. 'a -> 'a -> bool*) +(*val defaultGreaterEq : forall 'a. 'a -> 'a -> bool*) + + +definition genericCompare :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ordering " where + " genericCompare (less1:: 'a \<Rightarrow> 'a \<Rightarrow> bool) (equal:: 'a \<Rightarrow> 'a \<Rightarrow> bool) (x :: 'a) (y :: 'a) = ( + if less1 x y then + LT + else if equal x y then + EQ + else + GT )" + + + +(* +(* compare should really be a total order *) +lemma ord_OK_1: ( + (forall x y. (compare x y = EQ) <-> (compare y x = EQ)) && + (forall x y. (compare x y = LT) <-> (compare y x = GT))) + +lemma ord_OK_2: ( + (forall x y z. (x <= y) && (y <= z) --> (x <= z)) && + (forall x y. (x <= y) || (y <= x)) +) +*) + +(* let's derive a compare function from the Ord type-class *) +(*val ordCompare : forall 'a. Eq 'a, Ord 'a => 'a -> 'a -> ordering*) +definition ordCompare :: " 'a Ord_class \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ordering " where + " ordCompare dict_Basic_classes_Ord_a x y = ( + if ((isLess_method dict_Basic_classes_Ord_a) x y) then LT else + if (x = y) then EQ else GT )" + + +record 'a OrdMaxMin_class= + + max_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + min_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +(*val minByLessEqual : forall 'a. ('a -> 'a -> bool) -> 'a -> 'a -> 'a*) + +(*val maxByLessEqual : forall 'a. ('a -> 'a -> bool) -> 'a -> 'a -> 'a*) + +(*val defaultMax : forall 'a. Ord 'a => 'a -> 'a -> 'a*) + +(*val defaultMin : forall 'a. Ord 'a => 'a -> 'a -> 'a*) + +definition instance_Basic_classes_OrdMaxMin_var_dict :: " 'a Ord_class \<Rightarrow> 'a OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_var_dict dict_Basic_classes_Ord_a = ((| + + max_method = ((\<lambda> x y. if ( + (isLessEqual_method dict_Basic_classes_Ord_a) y x) then x else y)), + + min_method = ((\<lambda> x y. if ( + (isLessEqual_method dict_Basic_classes_Ord_a) x y) then x else y))|) )" + + + +(* ========================================================================== *) +(* SetTypes *) +(* ========================================================================== *) + +(* Set implementations use often an order on the elements. This allows the OCaml implementation + to use trees for implementing them. At least, one needs to be able to check equality on sets. + One could use the Ord type-class for sets. However, defining a special typeclass is cleaner + and allows more flexibility. One can make e.g. sure, that this type-class is ignored for + backends like HOL or Isabelle, which don't need it. Moreover, one is not forced to also instantiate + the functions <, <= ... *) + +(*class ( SetType 'a ) + val {ocaml;coq} setElemCompare : 'a -> 'a -> ordering +end*) + +fun boolCompare :: " bool \<Rightarrow> bool \<Rightarrow> ordering " where + " boolCompare True True = ( EQ )" +|" boolCompare True False = ( GT )" +|" boolCompare False True = ( LT )" +|" boolCompare False False = ( EQ )" + + +(* strings *) + +(*val charEqual : char -> char -> bool*) + +(*val stringEquality : string -> string -> bool*) + +(* pairs *) + +(*val pairEqual : forall 'a 'b. Eq 'a, Eq 'b => ('a * 'b) -> ('a * 'b) -> bool*) +(*let pairEqual (a1, b1) (a2, b2)= (a1 = a2) && (b1 = b2)*) + +(*val pairEqualBy : forall 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) -> bool*) + +(*val pairCompare : forall 'a 'b. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('a * 'b) -> ('a * 'b) -> ordering*) +fun pairCompare :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow> 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> ordering " where + " pairCompare cmpa cmpb (a1, b1) (a2, b2) = ( + (case cmpa a1 a2 of + LT => LT + | GT => GT + | EQ => cmpb b1 b2 + ))" + + +fun pairLess :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'b*'a \<Rightarrow> 'b*'a \<Rightarrow> bool " where + " pairLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b (x1, x2) (y1, y2) = ( ( + (isLess_method dict_Basic_classes_Ord_b) x1 y1) \<or> (((isLessEqual_method dict_Basic_classes_Ord_b) x1 y1) \<and> ((isLess_method dict_Basic_classes_Ord_a) x2 y2)))" + +fun pairLessEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'b*'a \<Rightarrow> 'b*'a \<Rightarrow> bool " where + " pairLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b (x1, x2) (y1, y2) = ( ( + (isLess_method dict_Basic_classes_Ord_b) x1 y1) \<or> (((isLessEqual_method dict_Basic_classes_Ord_b) x1 y1) \<and> ((isLessEqual_method dict_Basic_classes_Ord_a) x2 y2)))" + + +definition pairGreater :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> bool " where + " pairGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b x12 y12 = ( pairLess + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12 x12 )" + +definition pairGreaterEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> bool " where + " pairGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b x12 y12 = ( pairLessEq + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12 x12 )" + + +definition instance_Basic_classes_Ord_tup2_dict :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow>('a*'b)Ord_class " where + " instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b = ((| + + compare_method = (pairCompare + (compare_method dict_Basic_classes_Ord_a) (compare_method dict_Basic_classes_Ord_b)), + + isLess_method = + (pairLess dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a), + + isLessEqual_method = + (pairLessEq dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a), + + isGreater_method = + (pairGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b), + + isGreaterEqual_method = + (pairGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b) |) )" + + + +(* triples *) + +(*val tripleEqual : forall 'a 'b 'c. Eq 'a, Eq 'b, Eq 'c => ('a * 'b * 'c) -> ('a * 'b * 'c) -> bool*) +(*let tripleEqual (x1, x2, x3) (y1, y2, y3)= ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, x3)) (y1, (y2, y3)))*) + +(*val tripleCompare : forall 'a 'b 'c. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) -> ('a * 'b * 'c) -> ('a * 'b * 'c) -> ordering*) +fun tripleCompare :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c \<Rightarrow> 'a*'b*'c \<Rightarrow> ordering " where + " tripleCompare cmpa cmpb cmpc (a1, b1, c1) (a2, b2, c2) = ( + pairCompare cmpa (pairCompare cmpb cmpc) (a1, (b1, c1)) (a2, (b2, c2)))" + + +fun tripleLess :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'a*'b*'c \<Rightarrow> 'a*'b*'c \<Rightarrow> bool " where + " tripleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c (x1, x2, x3) (y1, y2, y3) = ( pairLess + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c) dict_Basic_classes_Ord_a (x1, (x2, x3)) (y1, (y2, y3)))" + +fun tripleLessEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'a*'b*'c \<Rightarrow> 'a*'b*'c \<Rightarrow> bool " where + " tripleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c (x1, x2, x3) (y1, y2, y3) = ( pairLessEq + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c) dict_Basic_classes_Ord_a (x1, (x2, x3)) (y1, (y2, y3)))" + + +definition tripleGreater :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'c*'b*'a \<Rightarrow> 'c*'b*'a \<Rightarrow> bool " where + " tripleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c x123 y123 = ( tripleLess + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123 x123 )" + +definition tripleGreaterEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'c*'b*'a \<Rightarrow> 'c*'b*'a \<Rightarrow> bool " where + " tripleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c x123 y123 = ( tripleLessEq + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123 x123 )" + + +definition instance_Basic_classes_Ord_tup3_dict :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow>('a*'b*'c)Ord_class " where + " instance_Basic_classes_Ord_tup3_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c = ((| + + compare_method = (tripleCompare + (compare_method dict_Basic_classes_Ord_a) (compare_method dict_Basic_classes_Ord_b) (compare_method dict_Basic_classes_Ord_c)), + + isLess_method = + (tripleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c), + + isLessEqual_method = + (tripleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c), + + isGreater_method = + (tripleGreater dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_a), + + isGreaterEqual_method = + (tripleGreaterEq dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_a) |) )" + + +(* quadruples *) + +(*val quadrupleEqual : forall 'a 'b 'c 'd. Eq 'a, Eq 'b, Eq 'c, Eq 'd => ('a * 'b * 'c * 'd) -> ('a * 'b * 'c * 'd) -> bool*) +(*let quadrupleEqual (x1, x2, x3, x4) (y1, y2, y3, y4)= ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))))*) + +(*val quadrupleCompare : forall 'a 'b 'c 'd. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) -> + ('d -> 'd -> ordering) -> ('a * 'b * 'c * 'd) -> ('a * 'b * 'c * 'd) -> ordering*) +fun quadrupleCompare :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow>('d \<Rightarrow> 'd \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c*'d \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> ordering " where + " quadrupleCompare cmpa cmpb cmpc cmpd (a1, b1, c1, d1) (a2, b2, c2, d2) = ( + pairCompare cmpa (pairCompare cmpb (pairCompare cmpc cmpd)) (a1, (b1, (c1, d1))) (a2, (b2, (c2, d2))))" + + +fun quadrupleLess :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> bool " where + " quadrupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d (x1, x2, x3, x4) (y1, y2, y3, y4) = ( pairLess + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c + dict_Basic_classes_Ord_d)) dict_Basic_classes_Ord_a (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))))" + +fun quadrupleLessEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> bool " where + " quadrupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d (x1, x2, x3, x4) (y1, y2, y3, y4) = ( pairLessEq + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c + dict_Basic_classes_Ord_d)) dict_Basic_classes_Ord_a (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))))" + + +definition quadrupleGreater :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> bool " where + " quadrupleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d x1234 y1234 = ( quadrupleLess + dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y1234 x1234 )" + +definition quadrupleGreaterEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> bool " where + " quadrupleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d x1234 y1234 = ( quadrupleLessEq + dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y1234 x1234 )" + + +definition instance_Basic_classes_Ord_tup4_dict :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow>('a*'b*'c*'d)Ord_class " where + " instance_Basic_classes_Ord_tup4_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d = ((| + + compare_method = (quadrupleCompare + (compare_method dict_Basic_classes_Ord_a) (compare_method dict_Basic_classes_Ord_b) (compare_method dict_Basic_classes_Ord_c) (compare_method dict_Basic_classes_Ord_d)), + + isLess_method = + (quadrupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d), + + isLessEqual_method = + (quadrupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d), + + isGreater_method = + (quadrupleGreater dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a), + + isGreaterEqual_method = + (quadrupleGreaterEq dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a) |) )" + + +(* quintuples *) + +(*val quintupleEqual : forall 'a 'b 'c 'd 'e. Eq 'a, Eq 'b, Eq 'c, Eq 'd, Eq 'e => ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'd * 'e) -> bool*) +(*let quintupleEqual (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5)= ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))))*) + +(*val quintupleCompare : forall 'a 'b 'c 'd 'e. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) -> + ('d -> 'd -> ordering) -> ('e -> 'e -> ordering) -> ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'd * 'e) -> ordering*) +fun quintupleCompare :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow>('d \<Rightarrow> 'd \<Rightarrow> ordering)\<Rightarrow>('e \<Rightarrow> 'e \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> ordering " where + " quintupleCompare cmpa cmpb cmpc cmpd cmpe (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) = ( + pairCompare cmpa (pairCompare cmpb (pairCompare cmpc (pairCompare cmpd cmpe))) (a1, (b1, (c1, (d1, e1)))) (a2, (b2, (c2, (d2, e2)))))" + + +fun quintupleLess :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> bool " where + " quintupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) = ( pairLess + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_e))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))))" + +fun quintupleLessEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> bool " where + " quintupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) = ( pairLessEq + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_e))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))))" + + +definition quintupleGreater :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> bool " where + " quintupleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e x12345 y12345 = ( quintupleLess + dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12345 x12345 )" + +definition quintupleGreaterEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> bool " where + " quintupleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e x12345 y12345 = ( quintupleLessEq + dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12345 x12345 )" + + +definition instance_Basic_classes_Ord_tup5_dict :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow>('a*'b*'c*'d*'e)Ord_class " where + " instance_Basic_classes_Ord_tup5_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e = ((| + + compare_method = (quintupleCompare + (compare_method dict_Basic_classes_Ord_a) (compare_method dict_Basic_classes_Ord_b) (compare_method dict_Basic_classes_Ord_c) (compare_method dict_Basic_classes_Ord_d) (compare_method dict_Basic_classes_Ord_e)), + + isLess_method = + (quintupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_e), + + isLessEqual_method = + (quintupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_e), + + isGreater_method = + (quintupleGreater dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_a), + + isGreaterEqual_method = + (quintupleGreaterEq dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_a) |) )" + + +(* sextuples *) + +(*val sextupleEqual : forall 'a 'b 'c 'd 'e 'f. Eq 'a, Eq 'b, Eq 'c, Eq 'd, Eq 'e, Eq 'f => ('a * 'b * 'c * 'd * 'e * 'f) -> ('a * 'b * 'c * 'd * 'e * 'f) -> bool*) +(*let sextupleEqual (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6)= ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))))*) + +(*val sextupleCompare : forall 'a 'b 'c 'd 'e 'f. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) -> + ('d -> 'd -> ordering) -> ('e -> 'e -> ordering) -> ('f -> 'f -> ordering) -> + ('a * 'b * 'c * 'd * 'e * 'f) -> ('a * 'b * 'c * 'd * 'e * 'f) -> ordering*) +fun sextupleCompare :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow>('d \<Rightarrow> 'd \<Rightarrow> ordering)\<Rightarrow>('e \<Rightarrow> 'e \<Rightarrow> ordering)\<Rightarrow>('f \<Rightarrow> 'f \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> ordering " where + " sextupleCompare cmpa cmpb cmpc cmpd cmpe cmpf (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) = ( + pairCompare cmpa (pairCompare cmpb (pairCompare cmpc (pairCompare cmpd (pairCompare cmpe cmpf)))) (a1, (b1, (c1, (d1, (e1, f1))))) (a2, (b2, (c2, (d2, (e2, f2))))))" + + +fun sextupleLess :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> bool " where + " sextupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) = ( pairLess + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_e + dict_Basic_classes_Ord_f)))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))))" + +fun sextupleLessEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> bool " where + " sextupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) = ( pairLessEq + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_e + dict_Basic_classes_Ord_f)))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))))" + + +definition sextupleGreater :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> bool " where + " sextupleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f x123456 y123456 = ( sextupleLess + dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123456 x123456 )" + +definition sextupleGreaterEq :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> bool " where + " sextupleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f x123456 y123456 = ( sextupleLessEq + dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123456 x123456 )" + + +definition instance_Basic_classes_Ord_tup6_dict :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow>('a*'b*'c*'d*'e*'f)Ord_class " where + " instance_Basic_classes_Ord_tup6_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f = ((| + + compare_method = (sextupleCompare + (compare_method dict_Basic_classes_Ord_a) (compare_method dict_Basic_classes_Ord_b) (compare_method dict_Basic_classes_Ord_c) (compare_method dict_Basic_classes_Ord_d) (compare_method dict_Basic_classes_Ord_e) (compare_method dict_Basic_classes_Ord_f)), + + isLess_method = + (sextupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f), + + isLessEqual_method = + (sextupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d + dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f), + + isGreater_method = + (sextupleGreater dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e + dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a), + + isGreaterEqual_method = + (sextupleGreaterEq dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e + dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a) |) )" + +end diff --git a/snapshots/isabelle/lib/lem/Lem_bool.thy b/snapshots/isabelle/lib/lem/Lem_bool.thy new file mode 100644 index 00000000..75142160 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_bool.thy @@ -0,0 +1,75 @@ +chapter \<open>Generated by Lem from bool.lem.\<close> + +theory "Lem_bool" + +imports + Main + +begin + + + +(* The type bool is hard-coded, so are true and false *) + +(* ----------------------- *) +(* not *) +(* ----------------------- *) + +(*val not : bool -> bool*) +(*let not b= match b with + | true -> false + | false -> true +end*) + +(* ----------------------- *) +(* and *) +(* ----------------------- *) + +(*val && [and] : bool -> bool -> bool*) +(*let && b1 b2= match (b1, b2) with + | (true, true) -> true + | _ -> false +end*) + + +(* ----------------------- *) +(* or *) +(* ----------------------- *) + +(*val || [or] : bool -> bool -> bool*) +(*let || b1 b2= match (b1, b2) with + | (false, false) -> false + | _ -> true +end*) + + +(* ----------------------- *) +(* implication *) +(* ----------------------- *) + +(*val --> [imp] : bool -> bool -> bool*) +(*let --> b1 b2= match (b1, b2) with + | (true, false) -> false + | _ -> true +end*) + + +(* ----------------------- *) +(* equivalence *) +(* ----------------------- *) + +(*val <-> [equiv] : bool -> bool -> bool*) +(*let <-> b1 b2= match (b1, b2) with + | (true, true) -> true + | (false, false) -> true + | _ -> false +end*) + + +(* ----------------------- *) +(* xor *) +(* ----------------------- *) + +(*val xor : bool -> bool -> bool*) + +end diff --git a/snapshots/isabelle/lib/lem/Lem_either.thy b/snapshots/isabelle/lib/lem/Lem_either.thy new file mode 100644 index 00000000..e181f823 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_either.thy @@ -0,0 +1,85 @@ +chapter \<open>Generated by Lem from either.lem.\<close> + +theory "Lem_either" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_list" + "Lem_tuple" + +begin + + + +(*open import Bool Basic_classes List Tuple*) +(*open import {hol} `sumTheory`*) +(*open import {ocaml} `Either`*) + +(*type either 'a 'b + = Left of 'a + | Right of 'b*) + + +(* -------------------------------------------------------------------------- *) +(* Equality. *) +(* -------------------------------------------------------------------------- *) + +(*val eitherEqual : forall 'a 'b. Eq 'a, Eq 'b => (either 'a 'b) -> (either 'a 'b) -> bool*) +(*val eitherEqualBy : forall 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> (either 'a 'b) -> (either 'a 'b) -> bool*) + +definition eitherEqualBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> bool)\<Rightarrow>('a,'b)sum \<Rightarrow>('a,'b)sum \<Rightarrow> bool " where + " eitherEqualBy eql eqr (left:: ('a, 'b) sum) (right:: ('a, 'b) sum) = ( + (case (left, right) of + (Inl l, Inl l') => eql l l' + | (Inr r, Inr r') => eqr r r' + | _ => False + ))" + +(*let eitherEqual= eitherEqualBy (=) (=)*) + +fun either_setElemCompare :: "('d \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('d,'c)sum \<Rightarrow>('b,'a)sum \<Rightarrow> ordering " where + " either_setElemCompare cmpa cmpb (Inl x') (Inl y') = ( cmpa x' y' )" +|" either_setElemCompare cmpa cmpb (Inr x') (Inr y') = ( cmpb x' y' )" +|" either_setElemCompare cmpa cmpb (Inl _) (Inr _) = ( LT )" +|" either_setElemCompare cmpa cmpb (Inr _) (Inl _) = ( GT )" + + + +(* -------------------------------------------------------------------------- *) +(* Utility functions. *) +(* -------------------------------------------------------------------------- *) + +(*val isLeft : forall 'a 'b. either 'a 'b -> bool*) + +(*val isRight : forall 'a 'b. either 'a 'b -> bool*) + + +(*val either : forall 'a 'b 'c. ('a -> 'c) -> ('b -> 'c) -> either 'a 'b -> 'c*) +(*let either fa fb x= match x with + | Left a -> fa a + | Right b -> fb b +end*) + + +(*val partitionEither : forall 'a 'b. list (either 'a 'b) -> (list 'a * list 'b)*) +(*let rec partitionEither l= match l with + | [] -> ([], []) + | x :: xs -> begin + let (ll, rl) = partitionEither xs in + match x with + | Left l -> (l::ll, rl) + | Right r -> (ll, r::rl) + end + end +end*) + + +(*val lefts : forall 'a 'b. list (either 'a 'b) -> list 'a*) + + +(*val rights : forall 'a 'b. list (either 'a 'b) -> list 'b*) + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_function.thy b/snapshots/isabelle/lib/lem/Lem_function.thy new file mode 100644 index 00000000..29c1fb04 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_function.thy @@ -0,0 +1,72 @@ +chapter \<open>Generated by Lem from function.lem.\<close> + +theory "Lem_function" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + +begin + +(******************************************************************************) +(* A library for common operations on functions *) +(******************************************************************************) + +(*open import Bool Basic_classes*) + +(*open import {coq} `Program.Basics`*) + +(* ----------------------- *) +(* identity function *) +(* ----------------------- *) + +(*val id : forall 'a. 'a -> 'a*) +(*let id x= x*) + + +(* ----------------------- *) +(* constant function *) +(* ----------------------- *) + +(*val const : forall 'a 'b. 'a -> 'b -> 'a*) + + +(* ----------------------- *) +(* function composition *) +(* ----------------------- *) + +(*val comb : forall 'a 'b 'c. ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c)*) +(*let comb f g= (fun x -> f (g x))*) + + +(* ----------------------- *) +(* function application *) +(* ----------------------- *) + +(*val $ [apply] : forall 'a 'b. ('a -> 'b) -> ('a -> 'b)*) +(*let $ f= (fun x -> f x)*) + +(*val $> [rev_apply] : forall 'a 'b. 'a -> ('a -> 'b) -> 'b*) +(*let $> x f= f x*) + +(* ----------------------- *) +(* flipping argument order *) +(* ----------------------- *) + +(*val flip : forall 'a 'b 'c. ('a -> 'b -> 'c) -> ('b -> 'a -> 'c)*) +(*let flip f= (fun x y -> f y x)*) + + +(* currying / uncurrying *) + +(*val curry : forall 'a 'b 'c. (('a * 'b) -> 'c) -> 'a -> 'b -> 'c*) +definition curry :: "('a*'b \<Rightarrow> 'c)\<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c " where + " curry f = ( (\<lambda> a b . f (a, b)))" + + +(*val uncurry : forall 'a 'b 'c. ('a -> 'b -> 'c) -> ('a * 'b -> 'c)*) +fun uncurry :: "('a \<Rightarrow> 'b \<Rightarrow> 'c)\<Rightarrow> 'a*'b \<Rightarrow> 'c " where + " uncurry f (a,b) = ( f a b )" + +end diff --git a/snapshots/isabelle/lib/lem/Lem_function_extra.thy b/snapshots/isabelle/lib/lem/Lem_function_extra.thy new file mode 100644 index 00000000..f742e1e6 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_function_extra.thy @@ -0,0 +1,29 @@ +chapter \<open>Generated by Lem from function_extra.lem.\<close> + +theory "Lem_function_extra" + +imports + Main + "Lem_maybe" + "Lem_bool" + "Lem_basic_classes" + "Lem_num" + "Lem_function" + "Lem" + +begin + + + +(*open import Maybe Bool Basic_classes Num Function*) + +(*open import {hol} `lemTheory`*) +(*open import {isabelle} `$LIB_DIR/Lem`*) + +(* ----------------------- *) +(* getting a unique value *) +(* ----------------------- *) + +(*val THE : forall 'a. ('a -> bool) -> maybe 'a*) + +end diff --git a/snapshots/isabelle/lib/lem/Lem_list.thy b/snapshots/isabelle/lib/lem/Lem_list.thy new file mode 100644 index 00000000..3bdef057 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_list.thy @@ -0,0 +1,776 @@ +chapter \<open>Generated by Lem from list.lem.\<close> + +theory "Lem_list" + +imports + Main + "Lem_bool" + "Lem_maybe" + "Lem_basic_classes" + "Lem_function" + "Lem_tuple" + "Lem_num" + "Lem" + +begin + + + +(*open import Bool Maybe Basic_classes Function Tuple Num*) + +(*open import {coq} `Coq.Lists.List`*) +(*open import {isabelle} `$LIB_DIR/Lem`*) +(*open import {hol} `lemTheory` `listTheory` `rich_listTheory` `sortingTheory`*) + +(* ========================================================================== *) +(* Basic list functions *) +(* ========================================================================== *) + +(* The type of lists as well as list literals like [], [1;2], ... are hardcoded. + Thus, we can directly dive into derived definitions. *) + + +(* ----------------------- *) +(* cons *) +(* ----------------------- *) + +(*val :: : forall 'a. 'a -> list 'a -> list 'a*) + + +(* ----------------------- *) +(* Emptyness check *) +(* ----------------------- *) + +(*val null : forall 'a. list 'a -> bool*) +(*let null l= match l with [] -> true | _ -> false end*) + +(* ----------------------- *) +(* Length *) +(* ----------------------- *) + +(*val length : forall 'a. list 'a -> nat*) +(*let rec length l= + match l with + | [] -> 0 + | x :: xs -> (Instance_Num_NumAdd_nat.+) (length xs) 1 + end*) + +(* ----------------------- *) +(* Equality *) +(* ----------------------- *) + +(*val listEqual : forall 'a. Eq 'a => list 'a -> list 'a -> bool*) +(*val listEqualBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) + +fun listEqualBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool " where + " listEqualBy eq ([]) ([]) = ( True )" +|" listEqualBy eq ([]) (_ # _) = ( False )" +|" listEqualBy eq (_ # _) ([]) = ( False )" +|" listEqualBy eq (x # xs) (y # ys) = ( (eq x y \<and> listEqualBy eq xs ys))" + + + +(* ----------------------- *) +(* compare *) +(* ----------------------- *) + +(*val lexicographicCompare : forall 'a. Ord 'a => list 'a -> list 'a -> ordering*) +(*val lexicographicCompareBy : forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a -> ordering*) + +fun lexicographicCompareBy :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> ordering " where + " lexicographicCompareBy cmp ([]) ([]) = ( EQ )" +|" lexicographicCompareBy cmp ([]) (_ # _) = ( LT )" +|" lexicographicCompareBy cmp (_ # _) ([]) = ( GT )" +|" lexicographicCompareBy cmp (x # xs) (y # ys) = ( ( + (case cmp x y of + LT => LT + | GT => GT + | EQ => lexicographicCompareBy cmp xs ys + ) + ))" + + +(*val lexicographicLess : forall 'a. Ord 'a => list 'a -> list 'a -> bool*) +(*val lexicographicLessBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) +fun lexicographicLessBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool " where + " lexicographicLessBy less1 less_eq1 ([]) ([]) = ( False )" +|" lexicographicLessBy less1 less_eq1 ([]) (_ # _) = ( True )" +|" lexicographicLessBy less1 less_eq1 (_ # _) ([]) = ( False )" +|" lexicographicLessBy less1 less_eq1 (x # xs) (y # ys) = ( ((less1 x y) \<or> ((less_eq1 x y) \<and> (lexicographicLessBy less1 less_eq1 xs ys))))" + + +(*val lexicographicLessEq : forall 'a. Ord 'a => list 'a -> list 'a -> bool*) +(*val lexicographicLessEqBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) +fun lexicographicLessEqBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool " where + " lexicographicLessEqBy less1 less_eq1 ([]) ([]) = ( True )" +|" lexicographicLessEqBy less1 less_eq1 ([]) (_ # _) = ( True )" +|" lexicographicLessEqBy less1 less_eq1 (_ # _) ([]) = ( False )" +|" lexicographicLessEqBy less1 less_eq1 (x # xs) (y # ys) = ( (less1 x y \<or> (less_eq1 x y \<and> lexicographicLessEqBy less1 less_eq1 xs ys)))" + + + +definition instance_Basic_classes_Ord_list_dict :: " 'a Ord_class \<Rightarrow>('a list)Ord_class " where + " instance_Basic_classes_Ord_list_dict dict_Basic_classes_Ord_a = ((| + + compare_method = (lexicographicCompareBy + (compare_method dict_Basic_classes_Ord_a)), + + isLess_method = (lexicographicLessBy + (isLess_method dict_Basic_classes_Ord_a) (isLessEqual_method dict_Basic_classes_Ord_a)), + + isLessEqual_method = (lexicographicLessEqBy + (isLess_method dict_Basic_classes_Ord_a) (isLessEqual_method dict_Basic_classes_Ord_a)), + + isGreater_method = (\<lambda> x y. (lexicographicLessBy + (isLess_method dict_Basic_classes_Ord_a) (isLessEqual_method dict_Basic_classes_Ord_a) y x)), + + isGreaterEqual_method = (\<lambda> x y. (lexicographicLessEqBy + (isLess_method dict_Basic_classes_Ord_a) (isLessEqual_method dict_Basic_classes_Ord_a) y x))|) )" + + + +(* ----------------------- *) +(* Append *) +(* ----------------------- *) + +(*val ++ : forall 'a. list 'a -> list 'a -> list 'a*) (* originally append *) +(*let rec ++ xs ys= match xs with + | [] -> ys + | x :: xs' -> x :: (xs' ++ ys) + end*) + +(* ----------------------- *) +(* snoc *) +(* ----------------------- *) + +(*val snoc : forall 'a. 'a -> list 'a -> list 'a*) +(*let snoc e l= l ++ [e]*) + + +(* ----------------------- *) +(* Reverse *) +(* ----------------------- *) + +(* First lets define the function [reverse_append], which is + closely related to reverse. [reverse_append l1 l2] appends the list [l2] to the reverse of [l1]. + This can be implemented more efficienctly than appending and is + used to implement reverse. *) + +(*val reverseAppend : forall 'a. list 'a -> list 'a -> list 'a*) (* originally named rev_append *) +(*let rec reverseAppend l1 l2= match l1 with + | [] -> l2 + | x :: xs -> reverseAppend xs (x :: l2) + end*) + +(* Reversing a list *) +(*val reverse : forall 'a. list 'a -> list 'a*) (* originally named rev *) +(*let reverse l= reverseAppend l []*) + +(* ----------------------- *) +(* Map *) +(* ----------------------- *) + +(*val map_tr : forall 'a 'b. list 'b -> ('a -> 'b) -> list 'a -> list 'b*) +function (sequential,domintros) map_tr :: " 'b list \<Rightarrow>('a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> 'b list " where + " map_tr rev_acc f ([]) = ( List.rev rev_acc )" +|" map_tr rev_acc f (x # xs) = ( map_tr ((f x) # rev_acc) f xs )" +by pat_completeness auto + + +(* taken from: https://blogs.janestreet.com/optimizing-list-map/ *) +(*val count_map : forall 'a 'b. ('a -> 'b) -> list 'a -> nat -> list 'b*) +function (sequential,domintros) count_map :: "('a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'b list " where + " count_map f ([]) ctr = ( [])" +|" count_map f (hd1 # tl1) ctr = ( f hd1 # + (if ctr <( 5000 :: nat) then count_map f tl1 (ctr +( 1 :: nat)) + else map_tr [] f tl1))" +by pat_completeness auto + + +(*val map : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*) +(*let map f l= count_map f l 0*) + +(* ----------------------- *) +(* Reverse Map *) +(* ----------------------- *) + +(*val reverseMap : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*) + + +(* ========================================================================== *) +(* Folding *) +(* ========================================================================== *) + +(* ----------------------- *) +(* fold left *) +(* ----------------------- *) + +(*val foldl : forall 'a 'b. ('a -> 'b -> 'a) -> 'a -> list 'b -> 'a*) (* originally foldl *) + +(*let rec foldl f b l= match l with + | [] -> b + | x :: xs -> foldl f (f b x) xs +end*) + + +(* ----------------------- *) +(* fold right *) +(* ----------------------- *) + +(*val foldr : forall 'a 'b. ('a -> 'b -> 'b) -> 'b -> list 'a -> 'b*) (* originally foldr with different argument order *) +(*let rec foldr f b l= match l with + | [] -> b + | x :: xs -> f x (foldr f b xs) +end*) + + +(* ----------------------- *) +(* concatenating lists *) +(* ----------------------- *) + +(*val concat : forall 'a. list (list 'a) -> list 'a*) (* before also called flatten *) +(*let concat= foldr (++) []*) + + +(* -------------------------- *) +(* concatenating with mapping *) +(* -------------------------- *) + +(*val concatMap : forall 'a 'b. ('a -> list 'b) -> list 'a -> list 'b*) + + +(* ------------------------- *) +(* universal qualification *) +(* ------------------------- *) + +(*val all : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally for_all *) +(*let all P l= foldl (fun r e -> P e && r) true l*) + + + +(* ------------------------- *) +(* existential qualification *) +(* ------------------------- *) + +(*val any : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally exist *) +(*let any P l= foldl (fun r e -> P e || r) false l*) + + +(* ------------------------- *) +(* dest_init *) +(* ------------------------- *) + +(* get the initial part and the last element of the list in a safe way *) + +(*val dest_init : forall 'a. list 'a -> maybe (list 'a * 'a)*) + +fun dest_init_aux :: " 'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list*'a " where + " dest_init_aux rev_init last_elem_seen ([]) = ( (List.rev rev_init, last_elem_seen))" +|" dest_init_aux rev_init last_elem_seen (x # xs) = ( dest_init_aux (last_elem_seen # rev_init) x xs )" + + +fun dest_init :: " 'a list \<Rightarrow>('a list*'a)option " where + " dest_init ([]) = ( None )" +|" dest_init (x # xs) = ( Some (dest_init_aux [] x xs))" + + + +(* ========================================================================== *) +(* Indexing lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* index / nth with maybe *) +(* ------------------------- *) + +(*val index : forall 'a. list 'a -> nat -> maybe 'a*) + +(*let rec index l n= match l with + | [] -> Nothing + | x :: xs -> if (Instance_Basic_classes_Eq_nat.=) n 0 then Just x else index xs ((Instance_Num_NumMinus_nat.-)n 1) +end*) + +(* ------------------------- *) +(* findIndices *) +(* ------------------------- *) + +(* [findIndices P l] returns the indices of all elements of list [l] that satisfy predicate [P]. + Counting starts with 0, the result list is sorted ascendingly *) +(*val findIndices : forall 'a. ('a -> bool) -> list 'a -> list nat*) + +fun findIndices_aux :: " nat \<Rightarrow>('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow>(nat)list " where + " findIndices_aux (i::nat) P ([]) = ( [])" +|" findIndices_aux (i::nat) P (x # xs) = ( if P x then i # findIndices_aux (i +( 1 :: nat)) P xs else findIndices_aux (i +( 1 :: nat)) P xs )" + +(*let findIndices P l= findIndices_aux 0 P l*) + + + +(* ------------------------- *) +(* findIndex *) +(* ------------------------- *) + +(* findIndex returns the first index of a list that satisfies a given predicate. *) +(*val findIndex : forall 'a. ('a -> bool) -> list 'a -> maybe nat*) +(*let findIndex P l= match findIndices P l with + | [] -> Nothing + | x :: _ -> Just x +end*) + +(* ------------------------- *) +(* elemIndices *) +(* ------------------------- *) + +(*val elemIndices : forall 'a. Eq 'a => 'a -> list 'a -> list nat*) + +(* ------------------------- *) +(* elemIndex *) +(* ------------------------- *) + +(*val elemIndex : forall 'a. Eq 'a => 'a -> list 'a -> maybe nat*) + + +(* ========================================================================== *) +(* Creating lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* genlist *) +(* ------------------------- *) + +(* [genlist f n] generates the list [f 0; f 1; ... (f (n-1))] *) +(*val genlist : forall 'a. (nat -> 'a) -> nat -> list 'a*) + + +(*let rec genlist f n= + match n with + | 0 -> [] + | n' + 1 -> snoc (f n') (genlist f n') + end*) + + +(* ------------------------- *) +(* replicate *) +(* ------------------------- *) + +(*val replicate : forall 'a. nat -> 'a -> list 'a*) +(*let rec replicate n x= + match n with + | 0 -> [] + | n' + 1 -> x :: replicate n' x + end*) + + +(* ========================================================================== *) +(* Sublists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* splitAt *) +(* ------------------------- *) + +(* [splitAt n xs] returns a tuple (xs1, xs2), with append xs1 xs2 = xs and + length xs1 = n. If there are not enough elements + in [xs], the original list and the empty one are returned. *) +(*val splitAtAcc : forall 'a. list 'a -> nat -> list 'a -> (list 'a * list 'a)*) +function (sequential,domintros) splitAtAcc :: " 'a list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list*'a list " where + " splitAtAcc revAcc n l = ( + (case l of + [] => (List.rev revAcc, []) + | x # xs => if n \<le>( 0 :: nat) then (List.rev revAcc, l) else splitAtAcc (x # revAcc) (n-( 1 :: nat)) xs + ))" +by pat_completeness auto + + +(*val splitAt : forall 'a. nat -> list 'a -> (list 'a * list 'a)*) +(*let rec splitAt n l= + splitAtAcc [] n l*) + + +(* ------------------------- *) +(* take *) +(* ------------------------- *) + +(* take n xs returns the prefix of xs of length n, or xs itself if n > length xs *) +(*val take : forall 'a. nat -> list 'a -> list 'a*) +(*let take n l= fst (splitAt n l)*) + +(* ------------------------- *) +(* drop *) +(* ------------------------- *) + +(* [drop n xs] drops the first [n] elements of [xs]. It returns the empty list, if [n] > [length xs]. *) +(*val drop : forall 'a. nat -> list 'a -> list 'a*) +(*let drop n l= snd (splitAt n l)*) + +(* ------------------------------------ *) +(* splitWhile, takeWhile, and dropWhile *) +(* ------------------------------------ *) + +(*val splitWhile_tr : forall 'a. ('a -> bool) -> list 'a -> list 'a -> (list 'a * list 'a)*) +fun splitWhile_tr :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list*'a list " where + " splitWhile_tr p ([]) acc1 = ( + (List.rev acc1, []))" +|" splitWhile_tr p (x # xs) acc1 = ( + if p x then + splitWhile_tr p xs (x # acc1) + else + (List.rev acc1, (x # xs)))" + + +(*val splitWhile : forall 'a. ('a -> bool) -> list 'a -> (list 'a * list 'a)*) +definition splitWhile :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list*'a list " where + " splitWhile p xs = ( splitWhile_tr p xs [])" + + +(* [takeWhile p xs] takes the first elements of [xs] that satisfy [p]. *) +(*val takeWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*) +definition takeWhile :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list " where + " takeWhile p l = ( fst (splitWhile p l))" + + +(* [dropWhile p xs] drops the first elements of [xs] that satisfy [p]. *) +(*val dropWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*) +definition dropWhile :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list " where + " dropWhile p l = ( snd (splitWhile p l))" + + +(* ------------------------- *) +(* isPrefixOf *) +(* ------------------------- *) + +(*val isPrefixOf : forall 'a. Eq 'a => list 'a -> list 'a -> bool*) +fun isPrefixOf :: " 'a list \<Rightarrow> 'a list \<Rightarrow> bool " where + " isPrefixOf ([]) _ = ( True )" +|" isPrefixOf (_ # _) ([]) = ( False )" +|" isPrefixOf (x # xs) (y # ys) = ( (x = y) \<and> isPrefixOf xs ys )" + + +(* ------------------------- *) +(* update *) +(* ------------------------- *) +(*val update : forall 'a. list 'a -> nat -> 'a -> list 'a*) +(*let rec update l n e= + match l with + | [] -> [] + | x :: xs -> if (Instance_Basic_classes_Eq_nat.=) n 0 then e :: xs else x :: (update xs ((Instance_Num_NumMinus_nat.-) n 1) e) +end*) + + + +(* ========================================================================== *) +(* Searching lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* Membership test *) +(* ------------------------- *) + +(* The membership test, one of the basic list functions, is actually tricky for + Lem, because it is tricky, which equality to use. From Lem`s point of + perspective, we want to use the equality provided by the equality type - class. + This allows for example to check whether a set is in a list of sets. + + However, in order to use the equality type class, elem essentially becomes + existential quantification over lists. For types, which implement semantic + equality (=) with syntactic equality, this is overly complicated. In + our theorem prover backend, we would end up with overly complicated, harder + to read definitions and some of the automation would be harder to apply. + Moreover, nearly all the old Lem generated code would change and require + (hopefully minor) adaptions of proofs. + + For now, we ignore this problem and just demand, that all instances of + the equality type class do the right thing for the theorem prover backends. +*) + +(*val elem : forall 'a. Eq 'a => 'a -> list 'a -> bool*) +(*val elemBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> bool*) + +definition elemBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool " where + " elemBy eq e l = ( ((\<exists> x \<in> (set l). (eq e) x)))" + +(*let elem= elemBy (=)*) + +(* ------------------------- *) +(* Find *) +(* ------------------------- *) +(*val find : forall 'a. ('a -> bool) -> list 'a -> maybe 'a*) (* previously not of maybe type *) +(*let rec find P l= match l with + | [] -> Nothing + | x :: xs -> if P x then Just x else find P xs +end*) + + +(* ----------------------------- *) +(* Lookup in an associative list *) +(* ----------------------------- *) +(*val lookup : forall 'a 'b. Eq 'a => 'a -> list ('a * 'b) -> maybe 'b*) +(*val lookupBy : forall 'a 'b. ('a -> 'a -> bool) -> 'a -> list ('a * 'b) -> maybe 'b*) + +(* DPM: eta-expansion for Coq backend type-inference. *) +definition lookupBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow>('a*'b)list \<Rightarrow> 'b option " where + " lookupBy eq k m = ( map_option (\<lambda> x . snd x) (List.find ( \<lambda>x . + (case x of (k', _) => eq k k' )) m))" + + +(* ------------------------- *) +(* filter *) +(* ------------------------- *) +(*val filter : forall 'a. ('a -> bool) -> list 'a -> list 'a*) +(*let rec filter P l= match l with + | [] -> [] + | x :: xs -> if (P x) then x :: (filter P xs) else filter P xs + end*) + + +(* ------------------------- *) +(* partition *) +(* ------------------------- *) +(*val partition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*) +(*let partition P l= (filter P l, filter (fun x -> not (P x)) l)*) + +(*val reversePartition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*) +definition reversePartition :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list*'a list " where + " reversePartition P l = ( List.partition P (List.rev l))" + + + +(* ------------------------- *) +(* delete first element *) +(* with certain property *) +(* ------------------------- *) + +(*val deleteFirst : forall 'a. ('a -> bool) -> list 'a -> maybe (list 'a)*) +(*let rec deleteFirst P l= match l with + | [] -> Nothing + | x :: xs -> if (P x) then Just xs else Maybe.map (fun xs' -> x :: xs') (deleteFirst P xs) + end*) + + +(*val delete : forall 'a. Eq 'a => 'a -> list 'a -> list 'a*) +(*val deleteBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a*) + +definition deleteBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " deleteBy eq x l = ( case_option l id (delete_first (eq x) l))" + + + +(* ========================================================================== *) +(* Zipping and unzipping lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* zip *) +(* ------------------------- *) + +(* zip takes two lists and returns a list of corresponding pairs. If one input list is short, excess elements of the longer list are discarded. *) +(*val zip : forall 'a 'b. list 'a -> list 'b -> list ('a * 'b)*) (* before combine *) +(*let rec zip l1 l2= match (l1, l2) with + | (x :: xs, y :: ys) -> (x, y) :: zip xs ys + | _ -> [] +end*) + +(* ------------------------- *) +(* unzip *) +(* ------------------------- *) + +(*val unzip: forall 'a 'b. list ('a * 'b) -> (list 'a * list 'b)*) +(*let rec unzip l= match l with + | [] -> ([], []) + | (x, y) :: xys -> let (xs, ys) = unzip xys in (x :: xs, y :: ys) +end*) + +(* ------------------------- *) +(* distinct elements *) +(* ------------------------- *) + +(*val allDistinct : forall 'a. Eq 'a => list 'a -> bool*) +fun allDistinct :: " 'a list \<Rightarrow> bool " where + " allDistinct ([]) = ( True )" +|" allDistinct (x # l') = ( \<not> (Set.member x (set l')) \<and> allDistinct l' )" + + +(* some more useful functions *) +(*val mapMaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> list 'b*) +function (sequential,domintros) mapMaybe :: "('a \<Rightarrow> 'b option)\<Rightarrow> 'a list \<Rightarrow> 'b list " where + " mapMaybe f ([]) = ( [])" +|" mapMaybe f (x # xs) = ( + (case f x of + None => mapMaybe f xs + | Some y => y # (mapMaybe f xs) + ))" +by pat_completeness auto + + +(*val mapi : forall 'a 'b. (nat -> 'a -> 'b) -> list 'a -> list 'b*) +function (sequential,domintros) mapiAux :: "(nat \<Rightarrow> 'b \<Rightarrow> 'a)\<Rightarrow> nat \<Rightarrow> 'b list \<Rightarrow> 'a list " where + " mapiAux f (n :: nat) ([]) = ( [])" +|" mapiAux f (n :: nat) (x # xs) = ( (f n x) # mapiAux f (n +( 1 :: nat)) xs )" +by pat_completeness auto + +definition mapi :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> 'b list " where + " mapi f l = ( mapiAux f(( 0 :: nat)) l )" + + +(*val deletes: forall 'a. Eq 'a => list 'a -> list 'a -> list 'a*) +definition deletes :: " 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " deletes xs ys = ( + List.foldl ((\<lambda> x y. remove1 y x)) xs ys )" + + +(* ========================================================================== *) +(* Comments (not clean yet, please ignore the rest of the file) *) +(* ========================================================================== *) + +(* ----------------------- *) +(* skipped from Haskell Lib*) +(* ----------------------- + +intersperse :: a -> [a] -> [a] +intercalate :: [a] -> [[a]] -> [a] +transpose :: [[a]] -> [[a]] +subsequences :: [a] -> [[a]] +permutations :: [a] -> [[a]] +foldl` :: (a -> b -> a) -> a -> [b] -> aSource +foldl1` :: (a -> a -> a) -> [a] -> aSource + +and +or +sum +product +maximum +minimum +scanl +scanr +scanl1 +scanr1 +Accumulating maps + +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source +mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source + +iterate :: (a -> a) -> a -> [a] +repeat :: a -> [a] +cycle :: [a] -> [a] +unfoldr + + +takeWhile :: (a -> Bool) -> [a] -> [a]Source +dropWhile :: (a -> Bool) -> [a] -> [a]Source +dropWhileEnd :: (a -> Bool) -> [a] -> [a]Source +span :: (a -> Bool) -> [a] -> ([a], [a])Source +break :: (a -> Bool) -> [a] -> ([a], [a])Source +break p is equivalent to span (not . p). +stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]Source +group :: Eq a => [a] -> [[a]]Source +inits :: [a] -> [[a]]Source +tails :: [a] -> [[a]]Source + + +isPrefixOf :: Eq a => [a] -> [a] -> BoolSource +isSuffixOf :: Eq a => [a] -> [a] -> BoolSource +isInfixOf :: Eq a => [a] -> [a] -> BoolSource + + + +notElem :: Eq a => a -> [a] -> BoolSource + +zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]Source +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]Source +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]Source +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]Source +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)]Source + +zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]Source +zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]Source +zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]Source +zipWith5 :: (a -> b -> c -> d -> e -> f) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f]Source +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]Source +zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h]Source + + +unzip3 :: [(a, b, c)] -> ([a], [b], [c])Source +unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])Source +unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])Source +unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f])Source +unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g])Source + + +lines :: String -> [String]Source +words :: String -> [String]Source +unlines :: [String] -> StringSource +unwords :: [String] -> StringSource +nub :: Eq a => [a] -> [a]Source +delete :: Eq a => a -> [a] -> [a]Source + +() :: Eq a => [a] -> [a] -> [a]Source +union :: Eq a => [a] -> [a] -> [a]Source +intersect :: Eq a => [a] -> [a] -> [a]Source +sort :: Ord a => [a] -> [a]Source +insert :: Ord a => a -> [a] -> [a]Source + + +nubBy :: (a -> a -> Bool) -> [a] -> [a]Source +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]Source +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source +groupBy :: (a -> a -> Bool) -> [a] -> [[a]]Source +sortBy :: (a -> a -> Ordering) -> [a] -> [a]Source +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]Source +maximumBy :: (a -> a -> Ordering) -> [a] -> aSource +minimumBy :: (a -> a -> Ordering) -> [a] -> aSource +genericLength :: Num i => [b] -> iSource +genericTake :: Integral i => i -> [a] -> [a]Source +genericDrop :: Integral i => i -> [a] -> [a]Source +genericSplitAt :: Integral i => i -> [b] -> ([b], [b])Source +genericIndex :: Integral a => [b] -> a -> bSource +genericReplicate :: Integral i => i -> a -> [a]Source + + +*) + + +(* ----------------------- *) +(* skipped from Lem Lib *) +(* ----------------------- + + +val for_all2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool +val exists2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool +val map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c +val rev_map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c +val fold_left2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'a) -> 'a -> list 'b -> list 'c -> 'a +val fold_right2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'c) -> list 'a -> list 'b -> 'c -> 'c + + +(* now maybe result and called lookup *) +val assoc : forall 'a 'b. 'a -> list ('a * 'b) -> 'b +let inline {ocaml} assoc = Ocaml.List.assoc + + +val mem_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> bool +val remove_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> list ('a * 'b) + + + +val stable_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a +val fast_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a + +val merge : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a -> list 'a +val intersect : forall 'a. list 'a -> list 'a -> list 'a + + +*) + +(*val catMaybes : forall 'a. list (maybe 'a) -> list 'a*) +function (sequential,domintros) catMaybes :: "('a option)list \<Rightarrow> 'a list " where + " catMaybes ([]) = ( + [])" +|" catMaybes (None # xs') = ( + catMaybes xs' )" +|" catMaybes (Some x # xs') = ( + x # catMaybes xs' )" +by pat_completeness auto + +end diff --git a/snapshots/isabelle/lib/lem/Lem_list_extra.thy b/snapshots/isabelle/lib/lem/Lem_list_extra.thy new file mode 100644 index 00000000..9caf32fc --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_list_extra.thy @@ -0,0 +1,117 @@ +chapter \<open>Generated by Lem from list_extra.lem.\<close> + +theory "Lem_list_extra" + +imports + Main + "Lem_bool" + "Lem_maybe" + "Lem_basic_classes" + "Lem_tuple" + "Lem_num" + "Lem_list" + "Lem_assert_extra" + +begin + + + +(*open import Bool Maybe Basic_classes Tuple Num List Assert_extra*) + +(* ------------------------- *) +(* head of non-empty list *) +(* ------------------------- *) +(*val head : forall 'a. list 'a -> 'a*) +(*let head l= match l with | x::xs -> x | [] -> failwith List_extra.head of empty list end*) + + +(* ------------------------- *) +(* tail of non-empty list *) +(* ------------------------- *) +(*val tail : forall 'a. list 'a -> list 'a*) +(*let tail l= match l with | x::xs -> xs | [] -> failwith List_extra.tail of empty list end*) + + +(* ------------------------- *) +(* last *) +(* ------------------------- *) +(*val last : forall 'a. list 'a -> 'a*) +(*let rec last l= match l with | [x] -> x | x1::x2::xs -> last (x2 :: xs) | [] -> failwith List_extra.last of empty list end*) + + +(* ------------------------- *) +(* init *) +(* ------------------------- *) + +(* All elements of a non-empty list except the last one. *) +(*val init : forall 'a. list 'a -> list 'a*) +(*let rec init l= match l with | [x] -> [] | x1::x2::xs -> x1::(init (x2::xs)) | [] -> failwith List_extra.init of empty list end*) + + +(* ------------------------- *) +(* foldl1 / foldr1 *) +(* ------------------------- *) + +(* folding functions for non-empty lists, + which don`t take the base case *) +(*val foldl1 : forall 'a. ('a -> 'a -> 'a) -> list 'a -> 'a*) +fun foldl1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a)\<Rightarrow> 'a list \<Rightarrow> 'a " where + " foldl1 f (x # xs) = ( List.foldl f x xs )" +|" foldl1 f ([]) = ( failwith (''List_extra.foldl1 of empty list''))" + + +(*val foldr1 : forall 'a. ('a -> 'a -> 'a) -> list 'a -> 'a*) +fun foldr1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a)\<Rightarrow> 'a list \<Rightarrow> 'a " where + " foldr1 f (x # xs) = ( List.foldr f xs x )" +|" foldr1 f ([]) = ( failwith (''List_extra.foldr1 of empty list''))" + + + +(* ------------------------- *) +(* nth element *) +(* ------------------------- *) + +(* get the nth element of a list *) +(*val nth : forall 'a. list 'a -> nat -> 'a*) +(*let nth l n= match index l n with Just e -> e | Nothing -> failwith List_extra.nth end*) + + +(* ------------------------- *) +(* Find_non_pure *) +(* ------------------------- *) +(*val findNonPure : forall 'a. ('a -> bool) -> list 'a -> 'a*) +definition findNonPure :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a " where + " findNonPure P l = ( (case (List.find P l) of + Some e => e + | None => failwith (''List_extra.findNonPure'') +))" + + + +(* ------------------------- *) +(* zip same length *) +(* ------------------------- *) + +(*val zipSameLength : forall 'a 'b. list 'a -> list 'b -> list ('a * 'b)*) +fun zipSameLength :: " 'a list \<Rightarrow> 'b list \<Rightarrow>('a*'b)list " where + " zipSameLength l1 l2 = ( (case (l1, l2) of + (x # xs, y # ys) => (x, y) # zipSameLength xs ys + | ([], []) => [] + | _ => failwith (''List_extra.zipSameLength of different length lists'') + +))" + + +(*val unfoldr: forall 'a 'b. ('a -> maybe ('b * 'a)) -> 'a -> list 'b*) +function (sequential,domintros) unfoldr :: "('a \<Rightarrow>('b*'a)option)\<Rightarrow> 'a \<Rightarrow> 'b list " where + " unfoldr f x = ( + (case f x of + Some (y, x') => + y # unfoldr f x' + | None => + [] + ))" +by pat_completeness auto + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_machine_word.thy b/snapshots/isabelle/lib/lem/Lem_machine_word.thy new file mode 100644 index 00000000..3f83789c --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_machine_word.thy @@ -0,0 +1,450 @@ +chapter \<open>Generated by Lem from machine_word.lem.\<close> + +theory "Lem_machine_word" + +imports + Main + "Lem_bool" + "Lem_num" + "Lem_basic_classes" + "Lem_show" + "~~/src/HOL/Word/Word" + +begin + + + +(*open import Bool Num Basic_classes Show*) + +(*open import {isabelle} `~~/src/HOL/Word/Word`*) +(*open import {hol} `wordsTheory` `wordsLib` `bitstringTheory` `integer_wordTheory`*) + +(*type mword 'a*) + +(*class (Size 'a) + val size : nat +end*) + +(*val native_size : forall 'a. nat*) + +(*val ocaml_inject : forall 'a. nat * natural -> mword 'a*) + +(* A singleton type family that can be used to carry a size as the type parameter *) + +(*type itself 'a*) + +(*val the_value : forall 'a. itself 'a*) + +(*val size_itself : forall 'a. Size 'a => itself 'a -> nat*) +definition size_itself :: "('a::len)itself \<Rightarrow> nat " where + " size_itself x = ( (len_of (TYPE(_) :: 'a itself)))" + + +(*******************************************************************) +(* Fixed bitwidths extracted from Anthony's models. *) +(* *) +(* If you need a size N that is not included here, put the lines *) +(* *) +(* type tyN *) +(* instance (Size tyN) let size = N end *) +(* declare isabelle target_rep type tyN = `N` *) +(* declare hol target_rep type tyN = `N` *) +(* *) +(* in your project, replacing N in each line. *) +(*******************************************************************) + +(*type ty1*) +(*type ty2*) +(*type ty3*) +(*type ty4*) +(*type ty5*) +(*type ty6*) +(*type ty7*) +(*type ty8*) +(*type ty9*) +(*type ty10*) +(*type ty11*) +(*type ty12*) +(*type ty13*) +(*type ty14*) +(*type ty15*) +(*type ty16*) +(*type ty17*) +(*type ty18*) +(*type ty19*) +(*type ty20*) +(*type ty21*) +(*type ty22*) +(*type ty23*) +(*type ty24*) +(*type ty25*) +(*type ty26*) +(*type ty27*) +(*type ty28*) +(*type ty29*) +(*type ty30*) +(*type ty31*) +(*type ty32*) +(*type ty33*) +(*type ty34*) +(*type ty35*) +(*type ty36*) +(*type ty37*) +(*type ty38*) +(*type ty39*) +(*type ty40*) +(*type ty41*) +(*type ty42*) +(*type ty43*) +(*type ty44*) +(*type ty45*) +(*type ty46*) +(*type ty47*) +(*type ty48*) +(*type ty49*) +(*type ty50*) +(*type ty51*) +(*type ty52*) +(*type ty53*) +(*type ty54*) +(*type ty55*) +(*type ty56*) +(*type ty57*) +(*type ty58*) +(*type ty59*) +(*type ty60*) +(*type ty61*) +(*type ty62*) +(*type ty63*) +(*type ty64*) +(*type ty65*) +(*type ty66*) +(*type ty67*) +(*type ty68*) +(*type ty69*) +(*type ty70*) +(*type ty71*) +(*type ty72*) +(*type ty73*) +(*type ty74*) +(*type ty75*) +(*type ty76*) +(*type ty77*) +(*type ty78*) +(*type ty79*) +(*type ty80*) +(*type ty81*) +(*type ty82*) +(*type ty83*) +(*type ty84*) +(*type ty85*) +(*type ty86*) +(*type ty87*) +(*type ty88*) +(*type ty89*) +(*type ty90*) +(*type ty91*) +(*type ty92*) +(*type ty93*) +(*type ty94*) +(*type ty95*) +(*type ty96*) +(*type ty97*) +(*type ty98*) +(*type ty99*) +(*type ty100*) +(*type ty101*) +(*type ty102*) +(*type ty103*) +(*type ty104*) +(*type ty105*) +(*type ty106*) +(*type ty107*) +(*type ty108*) +(*type ty109*) +(*type ty110*) +(*type ty111*) +(*type ty112*) +(*type ty113*) +(*type ty114*) +(*type ty115*) +(*type ty116*) +(*type ty117*) +(*type ty118*) +(*type ty119*) +(*type ty120*) +(*type ty121*) +(*type ty122*) +(*type ty123*) +(*type ty124*) +(*type ty125*) +(*type ty126*) +(*type ty127*) +(*type ty128*) +(*type ty129*) +(*type ty130*) +(*type ty131*) +(*type ty132*) +(*type ty133*) +(*type ty134*) +(*type ty135*) +(*type ty136*) +(*type ty137*) +(*type ty138*) +(*type ty139*) +(*type ty140*) +(*type ty141*) +(*type ty142*) +(*type ty143*) +(*type ty144*) +(*type ty145*) +(*type ty146*) +(*type ty147*) +(*type ty148*) +(*type ty149*) +(*type ty150*) +(*type ty151*) +(*type ty152*) +(*type ty153*) +(*type ty154*) +(*type ty155*) +(*type ty156*) +(*type ty157*) +(*type ty158*) +(*type ty159*) +(*type ty160*) +(*type ty161*) +(*type ty162*) +(*type ty163*) +(*type ty164*) +(*type ty165*) +(*type ty166*) +(*type ty167*) +(*type ty168*) +(*type ty169*) +(*type ty170*) +(*type ty171*) +(*type ty172*) +(*type ty173*) +(*type ty174*) +(*type ty175*) +(*type ty176*) +(*type ty177*) +(*type ty178*) +(*type ty179*) +(*type ty180*) +(*type ty181*) +(*type ty182*) +(*type ty183*) +(*type ty184*) +(*type ty185*) +(*type ty186*) +(*type ty187*) +(*type ty188*) +(*type ty189*) +(*type ty190*) +(*type ty191*) +(*type ty192*) +(*type ty193*) +(*type ty194*) +(*type ty195*) +(*type ty196*) +(*type ty197*) +(*type ty198*) +(*type ty199*) +(*type ty200*) +(*type ty201*) +(*type ty202*) +(*type ty203*) +(*type ty204*) +(*type ty205*) +(*type ty206*) +(*type ty207*) +(*type ty208*) +(*type ty209*) +(*type ty210*) +(*type ty211*) +(*type ty212*) +(*type ty213*) +(*type ty214*) +(*type ty215*) +(*type ty216*) +(*type ty217*) +(*type ty218*) +(*type ty219*) +(*type ty220*) +(*type ty221*) +(*type ty222*) +(*type ty223*) +(*type ty224*) +(*type ty225*) +(*type ty226*) +(*type ty227*) +(*type ty228*) +(*type ty229*) +(*type ty230*) +(*type ty231*) +(*type ty232*) +(*type ty233*) +(*type ty234*) +(*type ty235*) +(*type ty236*) +(*type ty237*) +(*type ty238*) +(*type ty239*) +(*type ty240*) +(*type ty241*) +(*type ty242*) +(*type ty243*) +(*type ty244*) +(*type ty245*) +(*type ty246*) +(*type ty247*) +(*type ty248*) +(*type ty249*) +(*type ty250*) +(*type ty251*) +(*type ty252*) +(*type ty253*) +(*type ty254*) +(*type ty255*) +(*type ty256*) +(*type ty257*) + +(*val word_length : forall 'a. mword 'a -> nat*) + +(******************************************************************) +(* Conversions *) +(******************************************************************) + +(*val signedIntegerFromWord : forall 'a. mword 'a -> integer*) + +(*val unsignedIntegerFromWord : forall 'a. mword 'a -> integer*) + +(* Version without typeclass constraint so that we can derive operations + in Lem for one of the theorem provers without requiring it. *) +(*val proverWordFromInteger : forall 'a. integer -> mword 'a*) + +(*val wordFromInteger : forall 'a. Size 'a => integer -> mword 'a*) +(* The OCaml version is defined after the arithmetic operations, below. *) + +(*val naturalFromWord : forall 'a. mword 'a -> natural*) + +(*val wordFromNatural : forall 'a. Size 'a => natural -> mword 'a*) + +(*val wordToHex : forall 'a. mword 'a -> string*) +(* Building libraries fails if we don't provide implementations for the + type class. *) +definition wordToHex :: "('a::len)Word.word \<Rightarrow> string " where + " wordToHex w = ( (''wordToHex not yet implemented''))" + + +definition instance_Show_Show_Machine_word_mword_dict :: "(('a::len)Word.word)Show_class " where + " instance_Show_Show_Machine_word_mword_dict = ((| + + show_method = wordToHex |) )" + + +(*val wordFromBitlist : forall 'a. Size 'a => list bool -> mword 'a*) + +(*val bitlistFromWord : forall 'a. mword 'a -> list bool*) + + +(*val size_test_fn : forall 'a. Size 'a => mword 'a -> nat*) +definition size_test_fn :: "('a::len)Word.word \<Rightarrow> nat " where + " size_test_fn _ = ( (len_of (TYPE(_) :: 'a itself)))" + + +(******************************************************************) +(* Comparisons *) +(******************************************************************) + +(*val mwordEq : forall 'a. mword 'a -> mword 'a -> bool*) + +(*val signedLess : forall 'a. mword 'a -> mword 'a -> bool*) + +(*val signedLessEq : forall 'a. mword 'a -> mword 'a -> bool*) + +(*val unsignedLess : forall 'a. mword 'a -> mword 'a -> bool*) + +(*val unsignedLessEq : forall 'a. mword 'a -> mword 'a -> bool*) + +(* Comparison tests are below, after the definition of wordFromInteger *) + +(******************************************************************) +(* Appending, splitting and probing words *) +(******************************************************************) + +(*val word_concat : forall 'a 'b 'c. mword 'a -> mword 'b -> mword 'c*) + +(* Note that we assume the result type has the correct size, especially + for Isabelle. *) +(*val word_extract : forall 'a 'b. nat -> nat -> mword 'a -> mword 'b*) + +(* Needs to be in the prover because we'd end up with unknown sizes in the + types in Lem. +*) +(*val word_update : forall 'a 'b. mword 'a -> nat -> nat -> mword 'b -> mword 'a*) + +(*val setBit : forall 'a. mword 'a -> nat -> bool -> mword 'a*) + +(*val getBit : forall 'a. mword 'a -> nat -> bool*) + +(*val msb : forall 'a. mword 'a -> bool*) + +(*val lsb : forall 'a. mword 'a -> bool*) + +(******************************************************************) +(* Bitwise operations, shifts, etc. *) +(******************************************************************) + +(*val shiftLeft : forall 'a. mword 'a -> nat -> mword 'a*) + +(*val shiftRight : forall 'a. mword 'a -> nat -> mword 'a*) + +(*val arithShiftRight : forall 'a. mword 'a -> nat -> mword 'a*) + +(*val lAnd : forall 'a. mword 'a -> mword 'a -> mword 'a*) + +(*val lOr : forall 'a. mword 'a -> mword 'a -> mword 'a*) + +(*val lXor : forall 'a. mword 'a -> mword 'a -> mword 'a*) + +(*val lNot : forall 'a. mword 'a -> mword 'a*) + +(*val rotateRight : forall 'a. nat -> mword 'a -> mword 'a*) + +(*val rotateLeft : forall 'a. nat -> mword 'a -> mword 'a*) + +(*val zeroExtend : forall 'a 'b. Size 'b => mword 'a -> mword 'b*) + +(*val signExtend : forall 'a 'b. Size 'b => mword 'a -> mword 'b*) + +(* Sign extension tests are below, after the definition of wordFromInteger *) + +(*****************************************************************) +(* Arithmetic *) +(*****************************************************************) + +(*val plus : forall 'a. mword 'a -> mword 'a -> mword 'a*) + +(*val minus : forall 'a. mword 'a -> mword 'a -> mword 'a*) + +(*val uminus : forall 'a. mword 'a -> mword 'a*) + +(*val times : forall 'a. mword 'a -> mword 'a -> mword 'a*) + +(*val unsignedDivide : forall 'a. mword 'a -> mword 'a -> mword 'a*) +(*val signedDivide : forall 'a. mword 'a -> mword 'a -> mword 'a*) + +definition signedDivide :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " signedDivide x y = ( + if Bits.msb x then + if Bits.msb y then (- x) div (- y) + else - ((- x) div y) + else if Bits.msb y then - (x div (- y)) + else x div y )" + + +(*val modulo : forall 'a. mword 'a -> mword 'a -> mword 'a*) +end diff --git a/snapshots/isabelle/lib/lem/Lem_map.thy b/snapshots/isabelle/lib/lem/Lem_map.thy new file mode 100644 index 00000000..fbaed71a --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_map.thy @@ -0,0 +1,159 @@ +chapter \<open>Generated by Lem from map.lem.\<close> + +theory "Lem_map" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_function" + "Lem_maybe" + "Lem_list" + "Lem_tuple" + "Lem_set" + "Lem_num" + +begin + + + +(*open import Bool Basic_classes Function Maybe List Tuple Set Num*) +(*open import {hol} `finite_mapTheory` `finite_mapLib`*) + +(*type map 'k 'v*) + + + +(* -------------------------------------------------------------------------- *) +(* Map equality. *) +(* -------------------------------------------------------------------------- *) + +(*val mapEqual : forall 'k 'v. Eq 'k, Eq 'v => map 'k 'v -> map 'k 'v -> bool*) +(*val mapEqualBy : forall 'k 'v. ('k -> 'k -> bool) -> ('v -> 'v -> bool) -> map 'k 'v -> map 'k 'v -> bool*) + + +(* -------------------------------------------------------------------------- *) +(* Map type class *) +(* -------------------------------------------------------------------------- *) + +(*class ( MapKeyType 'a ) + val {ocaml;coq} mapKeyCompare : 'a -> 'a -> ordering +end*) + +(* -------------------------------------------------------------------------- *) +(* Empty maps *) +(* -------------------------------------------------------------------------- *) + +(*val empty : forall 'k 'v. MapKeyType 'k => map 'k 'v*) +(*val emptyBy : forall 'k 'v. ('k -> 'k -> ordering) -> map 'k 'v*) + + +(* -------------------------------------------------------------------------- *) +(* Insertion *) +(* -------------------------------------------------------------------------- *) + +(*val insert : forall 'k 'v. MapKeyType 'k => 'k -> 'v -> map 'k 'v -> map 'k 'v*) + + +(* -------------------------------------------------------------------------- *) +(* Singleton *) +(* -------------------------------------------------------------------------- *) + +(*val singleton : forall 'k 'v. MapKeyType 'k => 'k -> 'v -> map 'k 'v*) + + + +(* -------------------------------------------------------------------------- *) +(* Emptyness check *) +(* -------------------------------------------------------------------------- *) + +(*val null : forall 'k 'v. MapKeyType 'k, Eq 'k, Eq 'v => map 'k 'v -> bool*) + + +(* -------------------------------------------------------------------------- *) +(* lookup *) +(* -------------------------------------------------------------------------- *) + +(*val lookupBy : forall 'k 'v. ('k -> 'k -> ordering) -> 'k -> map 'k 'v -> maybe 'v*) + +(*val lookup : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> maybe 'v*) + +(* -------------------------------------------------------------------------- *) +(* findWithDefault *) +(* -------------------------------------------------------------------------- *) + +(*val findWithDefault : forall 'k 'v. MapKeyType 'k => 'k -> 'v -> map 'k 'v -> 'v*) + +(* -------------------------------------------------------------------------- *) +(* from lists *) +(* -------------------------------------------------------------------------- *) + +(*val fromList : forall 'k 'v. MapKeyType 'k => list ('k * 'v) -> map 'k 'v*) +(*let fromList l= foldl (fun m (k,v) -> insert k v m) empty l*) + + +(* -------------------------------------------------------------------------- *) +(* to sets / domain / range *) +(* -------------------------------------------------------------------------- *) + +(*val toSet : forall 'k 'v. MapKeyType 'k, SetType 'k, SetType 'v => map 'k 'v -> set ('k * 'v)*) +(*val toSetBy : forall 'k 'v. (('k * 'v) -> ('k * 'v) -> ordering) -> map 'k 'v -> set ('k * 'v)*) + + +(*val domainBy : forall 'k 'v. ('k -> 'k -> ordering) -> map 'k 'v -> set 'k*) +(*val domain : forall 'k 'v. MapKeyType 'k, SetType 'k => map 'k 'v -> set 'k*) + + +(*val range : forall 'k 'v. MapKeyType 'k, SetType 'v => map 'k 'v -> set 'v*) +(*val rangeBy : forall 'k 'v. ('v -> 'v -> ordering) -> map 'k 'v -> set 'v*) + + +(* -------------------------------------------------------------------------- *) +(* member *) +(* -------------------------------------------------------------------------- *) + +(*val member : forall 'k 'v. MapKeyType 'k, SetType 'k, Eq 'k => 'k -> map 'k 'v -> bool*) + +(*val notMember : forall 'k 'v. MapKeyType 'k, SetType 'k, Eq 'k => 'k -> map 'k 'v -> bool*) + +(* -------------------------------------------------------------------------- *) +(* Quantification *) +(* -------------------------------------------------------------------------- *) + +(*val any : forall 'k 'v. MapKeyType 'k, Eq 'v => ('k -> 'v -> bool) -> map 'k 'v -> bool*) +(*val all : forall 'k 'v. MapKeyType 'k, Eq 'v => ('k -> 'v -> bool) -> map 'k 'v -> bool*) + +(*let all P m= (forall k v. (P k v && ((Instance_Basic_classes_Eq_Maybe_maybe.=) (lookup k m) (Just v))))*) + + +(* -------------------------------------------------------------------------- *) +(* Set-like operations. *) +(* -------------------------------------------------------------------------- *) +(*val deleteBy : forall 'k 'v. ('k -> 'k -> ordering) -> 'k -> map 'k 'v -> map 'k 'v*) +(*val delete : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> map 'k 'v*) +(*val deleteSwap : forall 'k 'v. MapKeyType 'k => map 'k 'v -> 'k -> map 'k 'v*) + +(*val union : forall 'k 'v. MapKeyType 'k => map 'k 'v -> map 'k 'v -> map 'k 'v*) + +(*val unions : forall 'k 'v. MapKeyType 'k => list (map 'k 'v) -> map 'k 'v*) + + +(* -------------------------------------------------------------------------- *) +(* Maps (in the functor sense). *) +(* -------------------------------------------------------------------------- *) + +(*val map : forall 'k 'v 'w. MapKeyType 'k => ('v -> 'w) -> map 'k 'v -> map 'k 'w*) + +(*val mapi : forall 'k 'v 'w. MapKeyType 'k => ('k -> 'v -> 'w) -> map 'k 'v -> map 'k 'w*) + +(* -------------------------------------------------------------------------- *) +(* Cardinality *) +(* -------------------------------------------------------------------------- *) +(*val size : forall 'k 'v. MapKeyType 'k, SetType 'k => map 'k 'v -> nat*) + +(* instance of SetType *) +definition map_setElemCompare :: "(('d*'c)set \<Rightarrow>('b*'a)set \<Rightarrow> 'e)\<Rightarrow>('d,'c)Map.map \<Rightarrow>('b,'a)Map.map \<Rightarrow> 'e " where + " map_setElemCompare cmp x y = ( + cmp (map_to_set x) (map_to_set y))" + +end diff --git a/snapshots/isabelle/lib/lem/Lem_map_extra.thy b/snapshots/isabelle/lib/lem/Lem_map_extra.thy new file mode 100644 index 00000000..4117fe81 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_map_extra.thy @@ -0,0 +1,82 @@ +chapter \<open>Generated by Lem from map_extra.lem.\<close> + +theory "Lem_map_extra" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_function" + "Lem_assert_extra" + "Lem_maybe" + "Lem_list" + "Lem_num" + "Lem_set" + "Lem_map" + +begin + + + +(*open import Bool Basic_classes Function Assert_extra Maybe List Num Set Map*) + +(* -------------------------------------------------------------------------- *) +(* find *) +(* -------------------------------------------------------------------------- *) + +(*val find : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> 'v*) +(*let find k m= match (lookup k m) with Just x -> x | Nothing -> failwith Map_extra.find end*) + + + +(* -------------------------------------------------------------------------- *) +(* from sets / domain / range *) +(* -------------------------------------------------------------------------- *) + + +(*val fromSet : forall 'k 'v. MapKeyType 'k => ('k -> 'v) -> set 'k -> map 'k 'v*) +definition fromSet :: "('k \<Rightarrow> 'v)\<Rightarrow> 'k set \<Rightarrow>('k,'v)Map.map " where + " fromSet f s = ( Finite_Set.fold (\<lambda> k m . map_update k (f k) m) Map.empty s )" + + +(* +assert fromSet_0: (fromSet succ (Set.empty : set nat) = Map.empty) +assert fromSet_1: (fromSet succ {(2:nat); 3; 4}) = Map.fromList [(2,3); (3, 4); (4, 5)] +*) + +(* -------------------------------------------------------------------------- *) +(* fold *) +(* -------------------------------------------------------------------------- *) + +(*val fold : forall 'k 'v 'r. MapKeyType 'k, SetType 'k, SetType 'v => ('k -> 'v -> 'r -> 'r) -> map 'k 'v -> 'r -> 'r*) +definition fold :: "('k \<Rightarrow> 'v \<Rightarrow> 'r \<Rightarrow> 'r)\<Rightarrow>('k,'v)Map.map \<Rightarrow> 'r \<Rightarrow> 'r " where + " fold f m v = ( Finite_Set.fold ( \<lambda>x . + (case x of (k, v) => \<lambda> r . f k v r )) v (map_to_set m))" + + +(* +assert fold_1: (fold (fun k v a -> (a+k)) (Map.fromList [((2:nat),(3:nat)); (3, 4); (4, 5)]) 0 = 9) +assert fold_2: (fold (fun k v a -> (a+v)) (Map.fromList [((2:nat),(3:nat)); (3, 4); (4, 5)]) 0 = 12) +*) + +(*val toList: forall 'k 'v. MapKeyType 'k => map 'k 'v -> list ('k * 'v)*) +(* declare compile_message toList = Map_extra.toList is only defined for the ocaml, isabelle and coq backend *) + +(* more 'map' functions *) + +(* TODO: this function is in map_extra rather than map just for implementation reasons *) +(*val mapMaybe : forall 'a 'b 'c. MapKeyType 'a => ('a -> 'b -> maybe 'c) -> map 'a 'b -> map 'a 'c*) +(* OLD: TODO: mapMaybe depends on toList that is not defined for hol and isabelle *) +definition option_map :: "('a \<Rightarrow> 'b \<Rightarrow> 'c option)\<Rightarrow>('a,'b)Map.map \<Rightarrow>('a,'c)Map.map " where + " option_map f m = ( + List.foldl + (\<lambda> m' . \<lambda>x . + (case x of + (k, v) => + (case f k v of None => m' | Some v' => map_update k v' m' ) + )) + Map.empty + (list_of_set (LemExtraDefs.map_to_set m)))" + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_maybe.thy b/snapshots/isabelle/lib/lem/Lem_maybe.thy new file mode 100644 index 00000000..da0bde92 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_maybe.thy @@ -0,0 +1,113 @@ +chapter \<open>Generated by Lem from maybe.lem.\<close> + +theory "Lem_maybe" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_function" + +begin + + + +(*open import Bool Basic_classes Function*) + +(* ========================================================================== *) +(* Basic stuff *) +(* ========================================================================== *) + +(*type maybe 'a = + | Nothing + | Just of 'a*) + + +(*val maybeEqual : forall 'a. Eq 'a => maybe 'a -> maybe 'a -> bool*) +(*val maybeEqualBy : forall 'a. ('a -> 'a -> bool) -> maybe 'a -> maybe 'a -> bool*) + +fun maybeEqualBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> bool " where + " maybeEqualBy eq None None = ( True )" +|" maybeEqualBy eq None (Some _) = ( False )" +|" maybeEqualBy eq (Some _) None = ( False )" +|" maybeEqualBy eq (Some x') (Some y') = ( (eq x' y'))" + + + +fun maybeCompare :: "('b \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow> 'b option \<Rightarrow> 'a option \<Rightarrow> ordering " where + " maybeCompare cmp None None = ( EQ )" +|" maybeCompare cmp None (Some _) = ( LT )" +|" maybeCompare cmp (Some _) None = ( GT )" +|" maybeCompare cmp (Some x') (Some y') = ( cmp x' y' )" + + +definition instance_Basic_classes_Ord_Maybe_maybe_dict :: " 'a Ord_class \<Rightarrow>('a option)Ord_class " where + " instance_Basic_classes_Ord_Maybe_maybe_dict dict_Basic_classes_Ord_a = ((| + + compare_method = (maybeCompare + (compare_method dict_Basic_classes_Ord_a)), + + isLess_method = (\<lambda> m1 . (\<lambda> m2 . maybeCompare + (compare_method dict_Basic_classes_Ord_a) m1 m2 = LT)), + + isLessEqual_method = (\<lambda> m1 . (\<lambda> m2 . ((let r = (maybeCompare + (compare_method dict_Basic_classes_Ord_a) m1 m2) in (r = LT) \<or> (r = EQ))))), + + isGreater_method = (\<lambda> m1 . (\<lambda> m2 . maybeCompare + (compare_method dict_Basic_classes_Ord_a) m1 m2 = GT)), + + isGreaterEqual_method = (\<lambda> m1 . (\<lambda> m2 . ((let r = (maybeCompare + (compare_method dict_Basic_classes_Ord_a) m1 m2) in (r = GT) \<or> (r = EQ)))))|) )" + + +(* ----------------------- *) +(* maybe *) +(* ----------------------- *) + +(*val maybe : forall 'a 'b. 'b -> ('a -> 'b) -> maybe 'a -> 'b*) +(*let maybe d f mb= match mb with + | Just a -> f a + | Nothing -> d +end*) + +(* ----------------------- *) +(* isJust / isNothing *) +(* ----------------------- *) + +(*val isJust : forall 'a. maybe 'a -> bool*) +(*let isJust mb= match mb with + | Just _ -> true + | Nothing -> false +end*) + +(*val isNothing : forall 'a. maybe 'a -> bool*) +(*let isNothing mb= match mb with + | Just _ -> false + | Nothing -> true +end*) + +(* ----------------------- *) +(* fromMaybe *) +(* ----------------------- *) + +(*val fromMaybe : forall 'a. 'a -> maybe 'a -> 'a*) +(*let fromMaybe d mb= match mb with + | Just v -> v + | Nothing -> d +end*) + +(* ----------------------- *) +(* map *) +(* ----------------------- *) + +(*val map : forall 'a 'b. ('a -> 'b) -> maybe 'a -> maybe 'b*) +(*let map f= maybe Nothing (fun v -> Just (f v))*) + + +(* ----------------------- *) +(* bind *) +(* ----------------------- *) + +(*val bind : forall 'a 'b. maybe 'a -> ('a -> maybe 'b) -> maybe 'b*) +(*let bind mb f= maybe Nothing f mb*) +end diff --git a/snapshots/isabelle/lib/lem/Lem_maybe_extra.thy b/snapshots/isabelle/lib/lem/Lem_maybe_extra.thy new file mode 100644 index 00000000..0a57814c --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_maybe_extra.thy @@ -0,0 +1,24 @@ +chapter \<open>Generated by Lem from maybe_extra.lem.\<close> + +theory "Lem_maybe_extra" + +imports + Main + "Lem_basic_classes" + "Lem_maybe" + "Lem_assert_extra" + +begin + + + +(*open import Basic_classes Maybe Assert_extra*) + +(* ----------------------- *) +(* fromJust *) +(* ----------------------- *) + +(*val fromJust : forall 'a. maybe 'a -> 'a*) +(*let fromJust op= match op with | Just v -> v | Nothing -> failwith fromJust of Nothing end*) + +end diff --git a/snapshots/isabelle/lib/lem/Lem_num.thy b/snapshots/isabelle/lib/lem/Lem_num.thy new file mode 100644 index 00000000..0d7a72ea --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_num.thy @@ -0,0 +1,1302 @@ +chapter \<open>Generated by Lem from num.lem.\<close> + +theory "Lem_num" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "~~/src/HOL/Word/Word" + "Real" + "~~/src/HOL/NthRoot" + +begin + + + +(*open import Bool Basic_classes*) +(*open import {isabelle} `~~/src/HOL/Word/Word` `Real` `~~/src/HOL/NthRoot`*) +(*open import {hol} `integerTheory` `intReduce` `wordsTheory` `wordsLib` `ratTheory` `realTheory` `intrealTheory`*) +(*open import {coq} `Coq.Numbers.BinNums` `Coq.ZArith.BinInt` `Coq.ZArith.Zpower` `Coq.ZArith.Zdiv` `Coq.ZArith.Zmax` `Coq.Numbers.Natural.Peano.NPeano` `Coq.QArith.Qabs` `Coq.QArith.Qminmax` `Coq.Reals.ROrderedType` `Coq.Reals.Rbase` `Coq.Reals.Rfunctions`*) + +(*class inline ( Numeral 'a ) + val fromNumeral : numeral -> 'a +end*) + +(* ========================================================================== *) +(* Syntactic type-classes for common operations *) +(* ========================================================================== *) + +(* Typeclasses can be used as a mean to overload constants like +, -, etc *) + +record 'a NumNegate_class= + + numNegate_method ::" 'a \<Rightarrow> 'a " + + + +record 'a NumAbs_class= + + abs_method ::" 'a \<Rightarrow> 'a " + + + +record 'a NumAdd_class= + + numAdd_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +record 'a NumMinus_class= + + numMinus_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +record 'a NumMult_class= + + numMult_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +record 'a NumPow_class= + + numPow_method ::" 'a \<Rightarrow> nat \<Rightarrow> 'a " + + + +record 'a NumDivision_class= + + numDivision_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +record 'a NumIntegerDivision_class= + + div_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + + +record 'a NumRemainder_class= + + mod_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +record 'a NumSucc_class= + + succ_method ::" 'a \<Rightarrow> 'a " + + + +record 'a NumPred_class= + + pred_method ::" 'a \<Rightarrow> 'a " + + + + +(* ----------------------- *) +(* natural *) +(* ----------------------- *) + +(* unbounded size natural numbers *) +(*type natural*) + + +(* ----------------------- *) +(* int *) +(* ----------------------- *) + +(* bounded size integers with uncertain length *) + +(*type int*) + + +(* ----------------------- *) +(* integer *) +(* ----------------------- *) + +(* unbounded size integers *) + +(*type integer*) + +(* ----------------------- *) +(* bint *) +(* ----------------------- *) + +(* TODO the bounded ints are only partially implemented, use with care. *) + +(* 32 bit integers *) +(*type int32*) + +(* 64 bit integers *) +(*type int64*) + + +(* ----------------------- *) +(* rational *) +(* ----------------------- *) + +(* unbounded size and precision rational numbers *) + +(*type rational*) (* ???: better type for this in HOL? *) + + +(* ----------------------- *) +(* real *) +(* ----------------------- *) + +(* real numbers *) +(* Note that for OCaml, this is mapped to floats with 64 bits. *) + +(*type real*) (* ???: better type for this in HOL? *) + + +(* ----------------------- *) +(* double *) +(* ----------------------- *) + +(* double precision floating point (64 bits) *) + +(*type float64*) (* ???: better type for this in HOL? *) + +(*type float32*) (* ???: better type for this in HOL? *) + + +(* ========================================================================== *) +(* Binding the standard operations for the number types *) +(* ========================================================================== *) + + +(* ----------------------- *) +(* nat *) +(* ----------------------- *) + +(*val natFromNumeral : numeral -> nat*) + +(*val natEq : nat -> nat -> bool*) + +(*val natLess : nat -> nat -> bool*) +(*val natLessEqual : nat -> nat -> bool*) +(*val natGreater : nat -> nat -> bool*) +(*val natGreaterEqual : nat -> nat -> bool*) + +(*val natCompare : nat -> nat -> ordering*) + +definition instance_Basic_classes_Ord_nat_dict :: "(nat)Ord_class " where + " instance_Basic_classes_Ord_nat_dict = ((| + + compare_method = (genericCompare (op<) (op=)), + + isLess_method = (op<), + + isLessEqual_method = (op \<le>), + + isGreater_method = (op>), + + isGreaterEqual_method = (op \<ge>)|) )" + + +(*val natAdd : nat -> nat -> nat*) + +definition instance_Num_NumAdd_nat_dict :: "(nat)NumAdd_class " where + " instance_Num_NumAdd_nat_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val natMinus : nat -> nat -> nat*) + +definition instance_Num_NumMinus_nat_dict :: "(nat)NumMinus_class " where + " instance_Num_NumMinus_nat_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val natSucc : nat -> nat*) +(*let natSucc n= (Instance_Num_NumAdd_nat.+) n 1*) +definition instance_Num_NumSucc_nat_dict :: "(nat)NumSucc_class " where + " instance_Num_NumSucc_nat_dict = ((| + + succ_method = Suc |) )" + + +(*val natPred : nat -> nat*) +definition instance_Num_NumPred_nat_dict :: "(nat)NumPred_class " where + " instance_Num_NumPred_nat_dict = ((| + + pred_method = (\<lambda> n. n -( 1 :: nat))|) )" + + +(*val natMult : nat -> nat -> nat*) + +definition instance_Num_NumMult_nat_dict :: "(nat)NumMult_class " where + " instance_Num_NumMult_nat_dict = ((| + + numMult_method = (op*)|) )" + + +(*val natDiv : nat -> nat -> nat*) + +definition instance_Num_NumIntegerDivision_nat_dict :: "(nat)NumIntegerDivision_class " where + " instance_Num_NumIntegerDivision_nat_dict = ((| + + div_method = (op div)|) )" + + +definition instance_Num_NumDivision_nat_dict :: "(nat)NumDivision_class " where + " instance_Num_NumDivision_nat_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val natMod : nat -> nat -> nat*) + +definition instance_Num_NumRemainder_nat_dict :: "(nat)NumRemainder_class " where + " instance_Num_NumRemainder_nat_dict = ((| + + mod_method = (op mod)|) )" + + + +(*val gen_pow_aux : forall 'a. ('a -> 'a -> 'a) -> 'a -> 'a -> nat -> 'a*) +fun gen_pow_aux :: "('a \<Rightarrow> 'a \<Rightarrow> 'a)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a " where + " gen_pow_aux (mul :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) (a :: 'a) (b :: 'a) (e :: nat) = ( + (case e of + 0 => a (* cannot happen, call discipline guarentees e >= 1 *) + | (Suc 0) => mul a b + | ( (Suc(Suc e'))) => (let e'' = (e div( 2 :: nat)) in + (let a' = (if (e mod( 2 :: nat)) =( 0 :: nat) then a else mul a b) in + gen_pow_aux mul a' (mul b b) e'')) + ))" + + +definition gen_pow :: " 'a \<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> 'a)\<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a " where + " gen_pow (one :: 'a) (mul :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) (b :: 'a) (e :: nat) = ( + if e <( 0 :: nat) then one else + if (e =( 0 :: nat)) then one else gen_pow_aux mul one b e )" + + +(*val natPow : nat -> nat -> nat*) + +definition instance_Num_NumPow_nat_dict :: "(nat)NumPow_class " where + " instance_Num_NumPow_nat_dict = ((| + + numPow_method = (op^)|) )" + + +(*val natMin : nat -> nat -> nat*) + +(*val natMax : nat -> nat -> nat*) + +definition instance_Basic_classes_OrdMaxMin_nat_dict :: "(nat)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_nat_dict = ((| + + max_method = max, + + min_method = min |) )" + + + +(* ----------------------- *) +(* natural *) +(* ----------------------- *) + +(*val naturalFromNumeral : numeral -> natural*) + +(*val naturalEq : natural -> natural -> bool*) + +(*val naturalLess : natural -> natural -> bool*) +(*val naturalLessEqual : natural -> natural -> bool*) +(*val naturalGreater : natural -> natural -> bool*) +(*val naturalGreaterEqual : natural -> natural -> bool*) + +(*val naturalCompare : natural -> natural -> ordering*) + +definition instance_Basic_classes_Ord_Num_natural_dict :: "(nat)Ord_class " where + " instance_Basic_classes_Ord_Num_natural_dict = ((| + + compare_method = (genericCompare (op<) (op=)), + + isLess_method = (op<), + + isLessEqual_method = (op \<le>), + + isGreater_method = (op>), + + isGreaterEqual_method = (op \<ge>)|) )" + + +(*val naturalAdd : natural -> natural -> natural*) + +definition instance_Num_NumAdd_Num_natural_dict :: "(nat)NumAdd_class " where + " instance_Num_NumAdd_Num_natural_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val naturalMinus : natural -> natural -> natural*) + +definition instance_Num_NumMinus_Num_natural_dict :: "(nat)NumMinus_class " where + " instance_Num_NumMinus_Num_natural_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val naturalSucc : natural -> natural*) +(*let naturalSucc n= (Instance_Num_NumAdd_Num_natural.+) n 1*) +definition instance_Num_NumSucc_Num_natural_dict :: "(nat)NumSucc_class " where + " instance_Num_NumSucc_Num_natural_dict = ((| + + succ_method = Suc |) )" + + +(*val naturalPred : natural -> natural*) +definition instance_Num_NumPred_Num_natural_dict :: "(nat)NumPred_class " where + " instance_Num_NumPred_Num_natural_dict = ((| + + pred_method = (\<lambda> n. n -( 1 :: nat))|) )" + + +(*val naturalMult : natural -> natural -> natural*) + +definition instance_Num_NumMult_Num_natural_dict :: "(nat)NumMult_class " where + " instance_Num_NumMult_Num_natural_dict = ((| + + numMult_method = (op*)|) )" + + + +(*val naturalPow : natural -> nat -> natural*) + +definition instance_Num_NumPow_Num_natural_dict :: "(nat)NumPow_class " where + " instance_Num_NumPow_Num_natural_dict = ((| + + numPow_method = (op^)|) )" + + +(*val naturalDiv : natural -> natural -> natural*) + +definition instance_Num_NumIntegerDivision_Num_natural_dict :: "(nat)NumIntegerDivision_class " where + " instance_Num_NumIntegerDivision_Num_natural_dict = ((| + + div_method = (op div)|) )" + + +definition instance_Num_NumDivision_Num_natural_dict :: "(nat)NumDivision_class " where + " instance_Num_NumDivision_Num_natural_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val naturalMod : natural -> natural -> natural*) + +definition instance_Num_NumRemainder_Num_natural_dict :: "(nat)NumRemainder_class " where + " instance_Num_NumRemainder_Num_natural_dict = ((| + + mod_method = (op mod)|) )" + + +(*val naturalMin : natural -> natural -> natural*) + +(*val naturalMax : natural -> natural -> natural*) + +definition instance_Basic_classes_OrdMaxMin_Num_natural_dict :: "(nat)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Num_natural_dict = ((| + + max_method = max, + + min_method = min |) )" + + + +(* ----------------------- *) +(* int *) +(* ----------------------- *) + +(*val intFromNumeral : numeral -> int*) + +(*val intEq : int -> int -> bool*) + +(*val intLess : int -> int -> bool*) +(*val intLessEqual : int -> int -> bool*) +(*val intGreater : int -> int -> bool*) +(*val intGreaterEqual : int -> int -> bool*) + +(*val intCompare : int -> int -> ordering*) + +definition instance_Basic_classes_Ord_Num_int_dict :: "(int)Ord_class " where + " instance_Basic_classes_Ord_Num_int_dict = ((| + + compare_method = (genericCompare (op<) (op=)), + + isLess_method = (op<), + + isLessEqual_method = (op \<le>), + + isGreater_method = (op>), + + isGreaterEqual_method = (op \<ge>)|) )" + + +(*val intNegate : int -> int*) + +definition instance_Num_NumNegate_Num_int_dict :: "(int)NumNegate_class " where + " instance_Num_NumNegate_Num_int_dict = ((| + + numNegate_method = (\<lambda> i. - i)|) )" + + +(*val intAbs : int -> int*) (* TODO: check *) + +definition instance_Num_NumAbs_Num_int_dict :: "(int)NumAbs_class " where + " instance_Num_NumAbs_Num_int_dict = ((| + + abs_method = abs |) )" + + +(*val intAdd : int -> int -> int*) + +definition instance_Num_NumAdd_Num_int_dict :: "(int)NumAdd_class " where + " instance_Num_NumAdd_Num_int_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val intMinus : int -> int -> int*) + +definition instance_Num_NumMinus_Num_int_dict :: "(int)NumMinus_class " where + " instance_Num_NumMinus_Num_int_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val intSucc : int -> int*) +definition instance_Num_NumSucc_Num_int_dict :: "(int)NumSucc_class " where + " instance_Num_NumSucc_Num_int_dict = ((| + + succ_method = (\<lambda> n. n +( 1 :: int))|) )" + + +(*val intPred : int -> int*) +definition instance_Num_NumPred_Num_int_dict :: "(int)NumPred_class " where + " instance_Num_NumPred_Num_int_dict = ((| + + pred_method = (\<lambda> n. n -( 1 :: int))|) )" + + +(*val intMult : int -> int -> int*) + +definition instance_Num_NumMult_Num_int_dict :: "(int)NumMult_class " where + " instance_Num_NumMult_Num_int_dict = ((| + + numMult_method = (op*)|) )" + + + +(*val intPow : int -> nat -> int*) + +definition instance_Num_NumPow_Num_int_dict :: "(int)NumPow_class " where + " instance_Num_NumPow_Num_int_dict = ((| + + numPow_method = (op^)|) )" + + +(*val intDiv : int -> int -> int*) + +definition instance_Num_NumIntegerDivision_Num_int_dict :: "(int)NumIntegerDivision_class " where + " instance_Num_NumIntegerDivision_Num_int_dict = ((| + + div_method = (op div)|) )" + + +definition instance_Num_NumDivision_Num_int_dict :: "(int)NumDivision_class " where + " instance_Num_NumDivision_Num_int_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val intMod : int -> int -> int*) + +definition instance_Num_NumRemainder_Num_int_dict :: "(int)NumRemainder_class " where + " instance_Num_NumRemainder_Num_int_dict = ((| + + mod_method = (op mod)|) )" + + +(*val intMin : int -> int -> int*) + +(*val intMax : int -> int -> int*) + +definition instance_Basic_classes_OrdMaxMin_Num_int_dict :: "(int)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Num_int_dict = ((| + + max_method = max, + + min_method = min |) )" + + +(* ----------------------- *) +(* int32 *) +(* ----------------------- *) +(*val int32FromNumeral : numeral -> int32*) + +(*val int32Eq : int32 -> int32 -> bool*) + +(*val int32Less : int32 -> int32 -> bool*) +(*val int32LessEqual : int32 -> int32 -> bool*) +(*val int32Greater : int32 -> int32 -> bool*) +(*val int32GreaterEqual : int32 -> int32 -> bool*) + +(*val int32Compare : int32 -> int32 -> ordering*) + +definition instance_Basic_classes_Ord_Num_int32_dict :: "( 32 word)Ord_class " where + " instance_Basic_classes_Ord_Num_int32_dict = ((| + + compare_method = (genericCompare word_sless (op=)), + + isLess_method = word_sless, + + isLessEqual_method = word_sle, + + isGreater_method = (\<lambda> x y. word_sless y x), + + isGreaterEqual_method = (\<lambda> x y. word_sle y x)|) )" + + +(*val int32Negate : int32 -> int32*) + +definition instance_Num_NumNegate_Num_int32_dict :: "( 32 word)NumNegate_class " where + " instance_Num_NumNegate_Num_int32_dict = ((| + + numNegate_method = (\<lambda> i. - i)|) )" + + +(*val int32Abs : int32 -> int32*) +definition int32Abs :: " 32 word \<Rightarrow> 32 word " where + " int32Abs i = ( (if word_sle(((word_of_int 0) :: 32 word)) i then i else - i))" + + +definition instance_Num_NumAbs_Num_int32_dict :: "( 32 word)NumAbs_class " where + " instance_Num_NumAbs_Num_int32_dict = ((| + + abs_method = int32Abs |) )" + + + +(*val int32Add : int32 -> int32 -> int32*) + +definition instance_Num_NumAdd_Num_int32_dict :: "( 32 word)NumAdd_class " where + " instance_Num_NumAdd_Num_int32_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val int32Minus : int32 -> int32 -> int32*) + +definition instance_Num_NumMinus_Num_int32_dict :: "( 32 word)NumMinus_class " where + " instance_Num_NumMinus_Num_int32_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val int32Succ : int32 -> int32*) + +definition instance_Num_NumSucc_Num_int32_dict :: "( 32 word)NumSucc_class " where + " instance_Num_NumSucc_Num_int32_dict = ((| + + succ_method = (\<lambda> n. n +((word_of_int 1) :: 32 word))|) )" + + +(*val int32Pred : int32 -> int32*) +definition instance_Num_NumPred_Num_int32_dict :: "( 32 word)NumPred_class " where + " instance_Num_NumPred_Num_int32_dict = ((| + + pred_method = (\<lambda> n. n -((word_of_int 1) :: 32 word))|) )" + + +(*val int32Mult : int32 -> int32 -> int32*) + +definition instance_Num_NumMult_Num_int32_dict :: "( 32 word)NumMult_class " where + " instance_Num_NumMult_Num_int32_dict = ((| + + numMult_method = (op*)|) )" + + + +(*val int32Pow : int32 -> nat -> int32*) + +definition instance_Num_NumPow_Num_int32_dict :: "( 32 word)NumPow_class " where + " instance_Num_NumPow_Num_int32_dict = ((| + + numPow_method = (op^)|) )" + + +(*val int32Div : int32 -> int32 -> int32*) + +definition instance_Num_NumIntegerDivision_Num_int32_dict :: "( 32 word)NumIntegerDivision_class " where + " instance_Num_NumIntegerDivision_Num_int32_dict = ((| + + div_method = (op div)|) )" + + +definition instance_Num_NumDivision_Num_int32_dict :: "( 32 word)NumDivision_class " where + " instance_Num_NumDivision_Num_int32_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val int32Mod : int32 -> int32 -> int32*) + +definition instance_Num_NumRemainder_Num_int32_dict :: "( 32 word)NumRemainder_class " where + " instance_Num_NumRemainder_Num_int32_dict = ((| + + mod_method = (op mod)|) )" + + +(*val int32Min : int32 -> int32 -> int32*) + +(*val int32Max : int32 -> int32 -> int32*) + +definition instance_Basic_classes_OrdMaxMin_Num_int32_dict :: "( 32 word)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Num_int32_dict = ((| + + max_method = ((\<lambda> x y. if (word_sle y x) then x else y)), + + min_method = ((\<lambda> x y. if (word_sle x y) then x else y))|) )" + + + + +(* ----------------------- *) +(* int64 *) +(* ----------------------- *) +(*val int64FromNumeral : numeral -> int64*) + +(*val int64Eq : int64 -> int64 -> bool*) + +(*val int64Less : int64 -> int64 -> bool*) +(*val int64LessEqual : int64 -> int64 -> bool*) +(*val int64Greater : int64 -> int64 -> bool*) +(*val int64GreaterEqual : int64 -> int64 -> bool*) + +(*val int64Compare : int64 -> int64 -> ordering*) + +definition instance_Basic_classes_Ord_Num_int64_dict :: "( 64 word)Ord_class " where + " instance_Basic_classes_Ord_Num_int64_dict = ((| + + compare_method = (genericCompare word_sless (op=)), + + isLess_method = word_sless, + + isLessEqual_method = word_sle, + + isGreater_method = (\<lambda> x y. word_sless y x), + + isGreaterEqual_method = (\<lambda> x y. word_sle y x)|) )" + + +(*val int64Negate : int64 -> int64*) + +definition instance_Num_NumNegate_Num_int64_dict :: "( 64 word)NumNegate_class " where + " instance_Num_NumNegate_Num_int64_dict = ((| + + numNegate_method = (\<lambda> i. - i)|) )" + + +(*val int64Abs : int64 -> int64*) +definition int64Abs :: " 64 word \<Rightarrow> 64 word " where + " int64Abs i = ( (if word_sle(((word_of_int 0) :: 64 word)) i then i else - i))" + + +definition instance_Num_NumAbs_Num_int64_dict :: "( 64 word)NumAbs_class " where + " instance_Num_NumAbs_Num_int64_dict = ((| + + abs_method = int64Abs |) )" + + + +(*val int64Add : int64 -> int64 -> int64*) + +definition instance_Num_NumAdd_Num_int64_dict :: "( 64 word)NumAdd_class " where + " instance_Num_NumAdd_Num_int64_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val int64Minus : int64 -> int64 -> int64*) + +definition instance_Num_NumMinus_Num_int64_dict :: "( 64 word)NumMinus_class " where + " instance_Num_NumMinus_Num_int64_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val int64Succ : int64 -> int64*) + +definition instance_Num_NumSucc_Num_int64_dict :: "( 64 word)NumSucc_class " where + " instance_Num_NumSucc_Num_int64_dict = ((| + + succ_method = (\<lambda> n. n +((word_of_int 1) :: 64 word))|) )" + + +(*val int64Pred : int64 -> int64*) +definition instance_Num_NumPred_Num_int64_dict :: "( 64 word)NumPred_class " where + " instance_Num_NumPred_Num_int64_dict = ((| + + pred_method = (\<lambda> n. n -((word_of_int 1) :: 64 word))|) )" + + +(*val int64Mult : int64 -> int64 -> int64*) + +definition instance_Num_NumMult_Num_int64_dict :: "( 64 word)NumMult_class " where + " instance_Num_NumMult_Num_int64_dict = ((| + + numMult_method = (op*)|) )" + + + +(*val int64Pow : int64 -> nat -> int64*) + +definition instance_Num_NumPow_Num_int64_dict :: "( 64 word)NumPow_class " where + " instance_Num_NumPow_Num_int64_dict = ((| + + numPow_method = (op^)|) )" + + +(*val int64Div : int64 -> int64 -> int64*) + +definition instance_Num_NumIntegerDivision_Num_int64_dict :: "( 64 word)NumIntegerDivision_class " where + " instance_Num_NumIntegerDivision_Num_int64_dict = ((| + + div_method = (op div)|) )" + + +definition instance_Num_NumDivision_Num_int64_dict :: "( 64 word)NumDivision_class " where + " instance_Num_NumDivision_Num_int64_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val int64Mod : int64 -> int64 -> int64*) + +definition instance_Num_NumRemainder_Num_int64_dict :: "( 64 word)NumRemainder_class " where + " instance_Num_NumRemainder_Num_int64_dict = ((| + + mod_method = (op mod)|) )" + + +(*val int64Min : int64 -> int64 -> int64*) + +(*val int64Max : int64 -> int64 -> int64*) + +definition instance_Basic_classes_OrdMaxMin_Num_int64_dict :: "( 64 word)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Num_int64_dict = ((| + + max_method = ((\<lambda> x y. if (word_sle y x) then x else y)), + + min_method = ((\<lambda> x y. if (word_sle x y) then x else y))|) )" + + + +(* ----------------------- *) +(* integer *) +(* ----------------------- *) + +(*val integerFromNumeral : numeral -> integer*) + +(*val integerFromNat : nat -> integer*) (* TODO: check *) + +(*val integerEq : integer -> integer -> bool*) + +(*val integerLess : integer -> integer -> bool*) +(*val integerLessEqual : integer -> integer -> bool*) +(*val integerGreater : integer -> integer -> bool*) +(*val integerGreaterEqual : integer -> integer -> bool*) + +(*val integerCompare : integer -> integer -> ordering*) + +definition instance_Basic_classes_Ord_Num_integer_dict :: "(int)Ord_class " where + " instance_Basic_classes_Ord_Num_integer_dict = ((| + + compare_method = (genericCompare (op<) (op=)), + + isLess_method = (op<), + + isLessEqual_method = (op \<le>), + + isGreater_method = (op>), + + isGreaterEqual_method = (op \<ge>)|) )" + + +(*val integerNegate : integer -> integer*) + +definition instance_Num_NumNegate_Num_integer_dict :: "(int)NumNegate_class " where + " instance_Num_NumNegate_Num_integer_dict = ((| + + numNegate_method = (\<lambda> i. - i)|) )" + + +(*val integerAbs : integer -> integer*) (* TODO: check *) + +definition instance_Num_NumAbs_Num_integer_dict :: "(int)NumAbs_class " where + " instance_Num_NumAbs_Num_integer_dict = ((| + + abs_method = abs |) )" + + +(*val integerAdd : integer -> integer -> integer*) + +definition instance_Num_NumAdd_Num_integer_dict :: "(int)NumAdd_class " where + " instance_Num_NumAdd_Num_integer_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val integerMinus : integer -> integer -> integer*) + +definition instance_Num_NumMinus_Num_integer_dict :: "(int)NumMinus_class " where + " instance_Num_NumMinus_Num_integer_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val integerSucc : integer -> integer*) +definition instance_Num_NumSucc_Num_integer_dict :: "(int)NumSucc_class " where + " instance_Num_NumSucc_Num_integer_dict = ((| + + succ_method = (\<lambda> n. n +( 1 :: int))|) )" + + +(*val integerPred : integer -> integer*) +definition instance_Num_NumPred_Num_integer_dict :: "(int)NumPred_class " where + " instance_Num_NumPred_Num_integer_dict = ((| + + pred_method = (\<lambda> n. n -( 1 :: int))|) )" + + +(*val integerMult : integer -> integer -> integer*) + +definition instance_Num_NumMult_Num_integer_dict :: "(int)NumMult_class " where + " instance_Num_NumMult_Num_integer_dict = ((| + + numMult_method = (op*)|) )" + + + +(*val integerPow : integer -> nat -> integer*) + +definition instance_Num_NumPow_Num_integer_dict :: "(int)NumPow_class " where + " instance_Num_NumPow_Num_integer_dict = ((| + + numPow_method = (op^)|) )" + + +(*val integerDiv : integer -> integer -> integer*) + +definition instance_Num_NumIntegerDivision_Num_integer_dict :: "(int)NumIntegerDivision_class " where + " instance_Num_NumIntegerDivision_Num_integer_dict = ((| + + div_method = (op div)|) )" + + +definition instance_Num_NumDivision_Num_integer_dict :: "(int)NumDivision_class " where + " instance_Num_NumDivision_Num_integer_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val integerMod : integer -> integer -> integer*) + +definition instance_Num_NumRemainder_Num_integer_dict :: "(int)NumRemainder_class " where + " instance_Num_NumRemainder_Num_integer_dict = ((| + + mod_method = (op mod)|) )" + + +(*val integerMin : integer -> integer -> integer*) + +(*val integerMax : integer -> integer -> integer*) + +definition instance_Basic_classes_OrdMaxMin_Num_integer_dict :: "(int)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Num_integer_dict = ((| + + max_method = max, + + min_method = min |) )" + + + + +(* ----------------------- *) +(* rational *) +(* ----------------------- *) + +(*val rationalFromNumeral : numeral -> rational*) + +(*val rationalFromInt : int -> rational*) + +(*val rationalEq : rational -> rational -> bool*) + +(*val rationalLess : rational -> rational -> bool*) +(*val rationalLessEqual : rational -> rational -> bool*) +(*val rationalGreater : rational -> rational -> bool*) +(*val rationalGreaterEqual : rational -> rational -> bool*) + +(*val rationalCompare : rational -> rational -> ordering*) + +definition instance_Basic_classes_Ord_Num_rational_dict :: "(rat)Ord_class " where + " instance_Basic_classes_Ord_Num_rational_dict = ((| + + compare_method = (genericCompare (op<) (op=)), + + isLess_method = (op<), + + isLessEqual_method = (op \<le>), + + isGreater_method = (op>), + + isGreaterEqual_method = (op \<ge>)|) )" + + +(*val rationalAdd : rational -> rational -> rational*) + +definition instance_Num_NumAdd_Num_rational_dict :: "(rat)NumAdd_class " where + " instance_Num_NumAdd_Num_rational_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val rationalMinus : rational -> rational -> rational*) + +definition instance_Num_NumMinus_Num_rational_dict :: "(rat)NumMinus_class " where + " instance_Num_NumMinus_Num_rational_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val rationalNegate : rational -> rational*) + +definition instance_Num_NumNegate_Num_rational_dict :: "(rat)NumNegate_class " where + " instance_Num_NumNegate_Num_rational_dict = ((| + + numNegate_method = (\<lambda> i. - i)|) )" + + +(*val rationalAbs : rational -> rational*) + +definition instance_Num_NumAbs_Num_rational_dict :: "(rat)NumAbs_class " where + " instance_Num_NumAbs_Num_rational_dict = ((| + + abs_method = abs |) )" + + +(*val rationalSucc : rational -> rational*) +definition instance_Num_NumSucc_Num_rational_dict :: "(rat)NumSucc_class " where + " instance_Num_NumSucc_Num_rational_dict = ((| + + succ_method = (\<lambda> n. n +(Fract ( 1 :: int) (1 :: int)))|) )" + + +(*val rationalPred : rational -> rational*) +definition instance_Num_NumPred_Num_rational_dict :: "(rat)NumPred_class " where + " instance_Num_NumPred_Num_rational_dict = ((| + + pred_method = (\<lambda> n. n -(Fract ( 1 :: int) (1 :: int)))|) )" + + +(*val rationalMult : rational -> rational -> rational*) + +definition instance_Num_NumMult_Num_rational_dict :: "(rat)NumMult_class " where + " instance_Num_NumMult_Num_rational_dict = ((| + + numMult_method = (op*)|) )" + + +(*val rationalDiv : rational -> rational -> rational*) + +definition instance_Num_NumDivision_Num_rational_dict :: "(rat)NumDivision_class " where + " instance_Num_NumDivision_Num_rational_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val rationalFromFrac : int -> int -> rational*) +(*let rationalFromFrac n d= (Instance_Num_NumDivision_Num_rational./) (rationalFromInt n) (rationalFromInt d)*) + +(*val rationalPowInteger : rational -> integer -> rational*) +fun rationalPowInteger :: " rat \<Rightarrow> int \<Rightarrow> rat " where + " rationalPowInteger b e = ( + if e =( 0 :: int) then(Fract ( 1 :: int) (1 :: int)) else + if e >( 0 :: int) then rationalPowInteger b (e -( 1 :: int)) * b else + rationalPowInteger b (e +( 1 :: int)) div b )" + + +(*val rationalPowNat : rational -> nat -> rational*) +(*let rationalPowNat r e= rationalPowInteger r (integerFromNat e)*) + +definition instance_Num_NumPow_Num_rational_dict :: "(rat)NumPow_class " where + " instance_Num_NumPow_Num_rational_dict = ((| + + numPow_method = power |) )" + + +(*val rationalMin : rational -> rational -> rational*) + +(*val rationalMax : rational -> rational -> rational*) + +definition instance_Basic_classes_OrdMaxMin_Num_rational_dict :: "(rat)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Num_rational_dict = ((| + + max_method = max, + + min_method = min |) )" + + + + +(* ----------------------- *) +(* real *) +(* ----------------------- *) + +(*val realFromNumeral : numeral -> real*) + +(*val realFromInteger : integer -> real*) + +(*val realEq : real -> real -> bool*) + +(*val realLess : real -> real -> bool*) +(*val realLessEqual : real -> real -> bool*) +(*val realGreater : real -> real -> bool*) +(*val realGreaterEqual : real -> real -> bool*) + +(*val realCompare : real -> real -> ordering*) + +definition instance_Basic_classes_Ord_Num_real_dict :: "(real)Ord_class " where + " instance_Basic_classes_Ord_Num_real_dict = ((| + + compare_method = (genericCompare (op<) (op=)), + + isLess_method = (op<), + + isLessEqual_method = (op \<le>), + + isGreater_method = (op>), + + isGreaterEqual_method = (op \<ge>)|) )" + + +(*val realAdd : real -> real -> real*) + +definition instance_Num_NumAdd_Num_real_dict :: "(real)NumAdd_class " where + " instance_Num_NumAdd_Num_real_dict = ((| + + numAdd_method = (op+)|) )" + + +(*val realMinus : real -> real -> real*) + +definition instance_Num_NumMinus_Num_real_dict :: "(real)NumMinus_class " where + " instance_Num_NumMinus_Num_real_dict = ((| + + numMinus_method = (op-)|) )" + + +(*val realNegate : real -> real*) + +definition instance_Num_NumNegate_Num_real_dict :: "(real)NumNegate_class " where + " instance_Num_NumNegate_Num_real_dict = ((| + + numNegate_method = (\<lambda> i. - i)|) )" + + +(*val realAbs : real -> real*) + +definition instance_Num_NumAbs_Num_real_dict :: "(real)NumAbs_class " where + " instance_Num_NumAbs_Num_real_dict = ((| + + abs_method = abs |) )" + + +(*val realSucc : real -> real*) +definition instance_Num_NumSucc_Num_real_dict :: "(real)NumSucc_class " where + " instance_Num_NumSucc_Num_real_dict = ((| + + succ_method = (\<lambda> n. n +( 1 :: real))|) )" + + +(*val realPred : real -> real*) +definition instance_Num_NumPred_Num_real_dict :: "(real)NumPred_class " where + " instance_Num_NumPred_Num_real_dict = ((| + + pred_method = (\<lambda> n. n -( 1 :: real))|) )" + + +(*val realMult : real -> real -> real*) + +definition instance_Num_NumMult_Num_real_dict :: "(real)NumMult_class " where + " instance_Num_NumMult_Num_real_dict = ((| + + numMult_method = (op*)|) )" + + +(*val realDiv : real -> real -> real*) + +definition instance_Num_NumDivision_Num_real_dict :: "(real)NumDivision_class " where + " instance_Num_NumDivision_Num_real_dict = ((| + + numDivision_method = (op div)|) )" + + +(*val realFromFrac : integer -> integer -> real*) +definition realFromFrac :: " int \<Rightarrow> int \<Rightarrow> real " where + " realFromFrac n d = ( ((real_of_int n)) div ((real_of_int d)))" + + +(*val realPowInteger : real -> integer -> real*) +fun realPowInteger :: " real \<Rightarrow> int \<Rightarrow> real " where + " realPowInteger b e = ( + if e =( 0 :: int) then( 1 :: real) else + if e >( 0 :: int) then realPowInteger b (e -( 1 :: int)) * b else + realPowInteger b (e +( 1 :: int)) div b )" + + +(*val realPowNat : real -> nat -> real*) +(*let realPowNat r e= realPowInteger r (integerFromNat e)*) + +definition instance_Num_NumPow_Num_real_dict :: "(real)NumPow_class " where + " instance_Num_NumPow_Num_real_dict = ((| + + numPow_method = power |) )" + + +(*val realSqrt : real -> real*) + +(*val realMin : real -> real -> real*) + +(*val realMax : real -> real -> real*) + +definition instance_Basic_classes_OrdMaxMin_Num_real_dict :: "(real)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Num_real_dict = ((| + + max_method = max, + + min_method = min |) )" + + +(*val realCeiling : real -> integer*) + +(*val realFloor : real -> integer*) + +(* ========================================================================== *) +(* Translation between number types *) +(* ========================================================================== *) + +(******************) +(* integerFrom... *) +(******************) + +(*val integerFromInt : int -> integer*) + +(*val integerFromNatural : natural -> integer*) + + +(*val integerFromInt32 : int32 -> integer*) + + +(*val integerFromInt64 : int64 -> integer*) + + +(******************) +(* naturalFrom... *) +(******************) + +(*val naturalFromNat : nat -> natural*) + +(*val naturalFromInteger : integer -> natural*) + + +(******************) +(* intFrom ... *) +(******************) + +(*val intFromInteger : integer -> int*) + +(*val intFromNat : nat -> int*) + + +(******************) +(* natFrom ... *) +(******************) + +(*val natFromNatural : natural -> nat*) + +(*val natFromInt : int -> nat*) + + +(******************) +(* int32From ... *) +(******************) + +(*val int32FromNat : nat -> int32*) + +(*val int32FromNatural : natural -> int32*) + +(*val int32FromInteger : integer -> int32*) +(*let int32FromInteger i= ( + let abs_int32 = int32FromNatural (naturalFromInteger i) in + if ((Instance_Basic_classes_Ord_Num_integer.<) i 0) then (Instance_Num_NumNegate_Num_int32.~ abs_int32) else abs_int32 +)*) + +(*val int32FromInt : int -> int32*) +(*let int32FromInt i= int32FromInteger (integerFromInt i)*) + + +(*val int32FromInt64 : int64 -> int32*) +(*let int32FromInt64 i= int32FromInteger (integerFromInt64 i)*) + + + + +(******************) +(* int64From ... *) +(******************) + +(*val int64FromNat : nat -> int64*) + +(*val int64FromNatural : natural -> int64*) + +(*val int64FromInteger : integer -> int64*) +(*let int64FromInteger i= ( + let abs_int64 = int64FromNatural (naturalFromInteger i) in + if ((Instance_Basic_classes_Ord_Num_integer.<) i 0) then (Instance_Num_NumNegate_Num_int64.~ abs_int64) else abs_int64 +)*) + +(*val int64FromInt : int -> int64*) +(*let int64FromInt i= int64FromInteger (integerFromInt i)*) + + +(*val int64FromInt32 : int32 -> int64*) +(*let int64FromInt32 i= int64FromInteger (integerFromInt32 i)*) + + +(******************) +(* what's missing *) +(******************) + +(*val naturalFromInt : int -> natural*) +(*val naturalFromInt32 : int32 -> natural*) +(*val naturalFromInt64 : int64 -> natural*) + + +(*val intFromNatural : natural -> int*) +(*val intFromInt32 : int32 -> int*) +(*val intFromInt64 : int64 -> int*) + +(*val natFromInteger : integer -> nat*) +(*val natFromInt32 : int32 -> nat*) +(*val natFromInt64 : int64 -> nat*) +end diff --git a/snapshots/isabelle/lib/lem/Lem_num_extra.thy b/snapshots/isabelle/lib/lem/Lem_num_extra.thy new file mode 100644 index 00000000..0611862e --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_num_extra.thy @@ -0,0 +1,34 @@ +chapter \<open>Generated by Lem from num_extra.lem.\<close> + +theory "Lem_num_extra" + +imports + Main + "Lem_num" + "Lem_string" + +begin + +(* **************************************************** *) +(* *) +(* A library of additional functions on numbers *) +(* *) +(* **************************************************** *) + +(*open import Num*) +(*open import String*) + +(*val naturalOfString : string -> natural*) + +(*val integerOfString : string -> integer*) + + +(* Truncation integer division (round toward zero) *) +(*val integerDiv_t: integer -> integer -> integer*) + +(* Truncation modulo *) +(*val integerRem_t: integer -> integer -> integer*) + +(* Flooring modulo *) +(*val integerRem_f: integer -> integer -> integer*) +end diff --git a/snapshots/isabelle/lib/lem/Lem_pervasives.thy b/snapshots/isabelle/lib/lem/Lem_pervasives.thy new file mode 100644 index 00000000..37da1224 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_pervasives.thy @@ -0,0 +1,31 @@ +chapter \<open>Generated by Lem from pervasives.lem.\<close> + +theory "Lem_pervasives" + +imports + Main + "Lem_basic_classes" + "Lem_bool" + "Lem_tuple" + "Lem_maybe" + "Lem_either" + "Lem_function" + "Lem_num" + "Lem_map" + "Lem_set" + "Lem_list" + "Lem_string" + "Lem_word" + "Lem_show" + "Lem_sorting" + "Lem_relation" + +begin + + + +(*include import Basic_classes Bool Tuple Maybe Either Function Num Map Set List String Word Show*) + +(*import Sorting Relation*) + +end diff --git a/snapshots/isabelle/lib/lem/Lem_pervasives_extra.thy b/snapshots/isabelle/lib/lem/Lem_pervasives_extra.thy new file mode 100644 index 00000000..0e3e5a88 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_pervasives_extra.thy @@ -0,0 +1,26 @@ +chapter \<open>Generated by Lem from pervasives_extra.lem.\<close> + +theory "Lem_pervasives_extra" + +imports + Main + "Lem_pervasives" + "Lem_function_extra" + "Lem_maybe_extra" + "Lem_map_extra" + "Lem_num_extra" + "Lem_set_extra" + "Lem_set_helpers" + "Lem_list_extra" + "Lem_string_extra" + "Lem_assert_extra" + "Lem_show_extra" + "Lem_machine_word" + +begin + + + +(*include import Pervasives*) +(*include import Function_extra Maybe_extra Map_extra Num_extra Set_extra Set_helpers List_extra String_extra Assert_extra Show_extra Machine_word*) +end diff --git a/snapshots/isabelle/lib/lem/Lem_relation.thy b/snapshots/isabelle/lib/lem/Lem_relation.thy new file mode 100644 index 00000000..23e7d707 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_relation.thy @@ -0,0 +1,449 @@ +chapter \<open>Generated by Lem from relation.lem.\<close> + +theory "Lem_relation" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_tuple" + "Lem_set" + "Lem_num" + +begin + + + +(*open import Bool Basic_classes Tuple Set Num*) +(*open import {hol} `set_relationTheory`*) + +(* ========================================================================== *) +(* The type of relations *) +(* ========================================================================== *) + +type_synonym( 'a, 'b) rel_pred =" 'a \<Rightarrow> 'b \<Rightarrow> bool " +type_synonym( 'a, 'b) rel_set =" ('a * 'b) set " + +(* Binary relations are usually represented as either + sets of pairs (rel_set) or as curried functions (rel_pred). + + The choice depends on taste and the backend. Lem should not take a + decision, but supports both representations. There is an abstract type + pred, which can be converted to both representations. The representation + of pred itself then depends on the backend. However, for the time beeing, + let's implement relations as sets to get them working more quickly. *) + +type_synonym( 'a, 'b) rel =" ('a, 'b) rel_set " + +(*val relToSet : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel_set 'a 'b*) +(*val relFromSet : forall 'a 'b. SetType 'a, SetType 'b => rel_set 'a 'b -> rel 'a 'b*) + +(*val relEq : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel 'a 'b -> bool*) +definition relEq :: "('a*'b)set \<Rightarrow>('a*'b)set \<Rightarrow> bool " where + " relEq r1 r2 = ( (r1 = r2))" + + +(*val relToPred : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> rel_pred 'a 'b*) +(*val relFromPred : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => set 'a -> set 'b -> rel_pred 'a 'b -> rel 'a 'b*) + +definition relToPred :: "('a*'b)set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool " where + " relToPred r = ( (\<lambda> x y . (x, y) \<in> r))" + +definition relFromPred :: " 'a set \<Rightarrow> 'b set \<Rightarrow>('a \<Rightarrow> 'b \<Rightarrow> bool)\<Rightarrow>('a*'b)set " where + " relFromPred xs ys p = ( set_filter ( \<lambda>x . + (case x of (x,y) => p x y )) (xs \<times> ys))" + + + +(* ========================================================================== *) +(* Basic Operations *) +(* ========================================================================== *) + +(* ----------------------- *) +(* membership test *) +(* ----------------------- *) + +(*val inRel : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => 'a -> 'b -> rel 'a 'b -> bool*) + + +(* ----------------------- *) +(* empty relation *) +(* ----------------------- *) + +(*val relEmpty : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b*) + +(* ----------------------- *) +(* Insertion *) +(* ----------------------- *) + +(*val relAdd : forall 'a 'b. SetType 'a, SetType 'b => 'a -> 'b -> rel 'a 'b -> rel 'a 'b*) + + +(* ----------------------- *) +(* Identity relation *) +(* ----------------------- *) + +(*val relIdOn : forall 'a. SetType 'a, Eq 'a => set 'a -> rel 'a 'a*) +definition relIdOn :: " 'a set \<Rightarrow>('a*'a)set " where + " relIdOn s = ( relFromPred s s (op=))" + + +(*val relId : forall 'a. SetType 'a, Eq 'a => rel 'a 'a*) + +(* ----------------------- *) +(* relation union *) +(* ----------------------- *) + +(*val relUnion : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel 'a 'b -> rel 'a 'b*) + +(* ----------------------- *) +(* relation intersection *) +(* ----------------------- *) + +(*val relIntersection : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> rel 'a 'b -> rel 'a 'b*) + +(* ----------------------- *) +(* Relation Composition *) +(* ----------------------- *) + +(*val relComp : forall 'a 'b 'c. SetType 'a, SetType 'b, SetType 'c, Eq 'a, Eq 'b => rel 'a 'b -> rel 'b 'c -> rel 'a 'c*) +(*let relComp r1 r2= relFromSet {(e1, e3) | forall ((e1,e2) IN (relToSet r1)) ((e2',e3) IN (relToSet r2)) | e2 = e2'}*) + +(* ----------------------- *) +(* restrict *) +(* ----------------------- *) + +(*val relRestrict : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> rel 'a 'a*) +definition relRestrict :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow>('a*'a)set " where + " relRestrict r s = ( ((let x2 = + ({}) in Finite_Set.fold + (\<lambda>a x2 . Finite_Set.fold + (\<lambda>b x2 . + if (a, b) \<in> r then Set.insert (a, b) x2 else x2) + x2 s) x2 s)))" + + + +(* ----------------------- *) +(* Converse *) +(* ----------------------- *) + +(*val relConverse : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel 'b 'a*) +(*let relConverse r= relFromSet (Set.map swap (relToSet r))*) + + +(* ----------------------- *) +(* domain *) +(* ----------------------- *) + +(*val relDomain : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> set 'a*) +(*let relDomain r= Set.map (fun x -> fst x) (relToSet r)*) + +(* ----------------------- *) +(* range *) +(* ----------------------- *) + +(*val relRange : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> set 'b*) +(*let relRange r= Set.map (fun x -> snd x) (relToSet r)*) + + +(* ----------------------- *) +(* field / definedOn *) +(* *) +(* avoid the keyword field *) +(* ----------------------- *) + +(*val relDefinedOn : forall 'a. SetType 'a => rel 'a 'a -> set 'a*) + +(* ----------------------- *) +(* relOver *) +(* *) +(* avoid the keyword field *) +(* ----------------------- *) + +(*val relOver : forall 'a. SetType 'a => rel 'a 'a -> set 'a -> bool*) +definition relOver :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " relOver r s = ( ((((Domain r) \<union> (Range r))) \<subseteq> s))" + + + +(* ----------------------- *) +(* apply a relation *) +(* ----------------------- *) + +(* Given a relation r and a set s, relApply r s applies s to r, i.e. + it returns the set of all value reachable via r from a value in s. + This operation can be seen as a generalisation of function application. *) + +(*val relApply : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a => rel 'a 'b -> set 'a -> set 'b*) +(*let relApply r s= { y | forall ((x, y) IN (relToSet r)) | x IN s }*) + + +(* ========================================================================== *) +(* Properties *) +(* ========================================================================== *) + +(* ----------------------- *) +(* subrel *) +(* ----------------------- *) + +(*val isSubrel : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> rel 'a 'b -> bool*) + +(* ----------------------- *) +(* reflexivity *) +(* ----------------------- *) + +(*val isReflexiveOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isReflexiveOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isReflexiveOn r s = ( ((\<forall> e \<in> s. (e, e) \<in> r)))" + + +(*val isReflexive : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +(*let ~{ocaml;coq} isReflexive r= (forall e. inRel e e r)*) + + +(* ----------------------- *) +(* irreflexivity *) +(* ----------------------- *) + +(*val isIrreflexiveOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isIrreflexiveOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isIrreflexiveOn r s = ( ((\<forall> e \<in> s. \<not> ((e, e) \<in> r))))" + + +(*val isIrreflexive : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +(*let isIrreflexive r= (forall ((e1, e2) IN (relToSet r)). not (e1 = e2))*) + + +(* ----------------------- *) +(* symmetry *) +(* ----------------------- *) + +(*val isSymmetricOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isSymmetricOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isSymmetricOn r s = ( ((\<forall> e1 \<in> s. \<forall> e2 \<in> s. ((e1, e2) \<in> r) \<longrightarrow> ((e2, e1) \<in> r))))" + + +(*val isSymmetric : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +(*let isSymmetric r= (forall ((e1, e2) IN relToSet r). inRel e2 e1 r)*) + + +(* ----------------------- *) +(* antisymmetry *) +(* ----------------------- *) + +(*val isAntisymmetricOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isAntisymmetricOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isAntisymmetricOn r s = ( ((\<forall> e1 \<in> s. \<forall> e2 \<in> s. ((e1, e2) \<in> r) \<longrightarrow> (((e2, e1) \<in> r) \<longrightarrow> (e1 = e2)))))" + + +(*val isAntisymmetric : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +(*let isAntisymmetric r= (forall ((e1, e2) IN relToSet r). (inRel e2 e1 r) --> (e1 = e2))*) + + +(* ----------------------- *) +(* transitivity *) +(* ----------------------- *) + +(*val isTransitiveOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isTransitiveOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isTransitiveOn r s = ( ((\<forall> e1 \<in> s. \<forall> e2 \<in> s. \<forall> e3 \<in> s. ((e1, e2) \<in> r) \<longrightarrow> (((e2, e3) \<in> r) \<longrightarrow> ((e1, e3) \<in> r)))))" + + +(*val isTransitive : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +(*let isTransitive r= (forall ((e1, e2) IN relToSet r) (e3 IN relApply r {e2}). inRel e1 e3 r)*) + +(* ----------------------- *) +(* total *) +(* ----------------------- *) + +(*val isTotalOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isTotalOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isTotalOn r s = ( ((\<forall> e1 \<in> s. \<forall> e2 \<in> s. ((e1, e2) \<in> r) \<or> ((e2, e1) \<in> r))))" + + + +(*val isTotal : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +(*let ~{ocaml;coq} isTotal r= (forall e1 e2. (inRel e1 e2 r) || (inRel e2 e1 r))*) + +(*val isTrichotomousOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isTrichotomousOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isTrichotomousOn r s = ( ((\<forall> e1 \<in> s. \<forall> e2 \<in> s. ((e1, e2) \<in> r) \<or> ((e1 = e2) \<or> ((e2, e1) \<in> r)))))" + + +(*val isTrichotomous : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isTrichotomous :: "('a*'a)set \<Rightarrow> bool " where + " isTrichotomous r = ( ((\<forall> e1. \<forall> e2. ((e1, e2) \<in> r) \<or> ((e1 = e2) \<or> ((e2, e1) \<in> r)))))" + + + +(* ----------------------- *) +(* is_single_valued *) +(* ----------------------- *) + +(*val isSingleValued : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> bool*) +definition isSingleValued :: "('a*'b)set \<Rightarrow> bool " where + " isSingleValued r = ( ((\<forall> (e1, e2a) \<in> r. \<forall> e2b \<in> Image r {e1}. e2a = e2b)))" + + + +(* ----------------------- *) +(* equivalence relation *) +(* ----------------------- *) + +(*val isEquivalenceOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isEquivalenceOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isEquivalenceOn r s = ( isReflexiveOn r s \<and> (isSymmetricOn r s \<and> isTransitiveOn r s))" + + + +(*val isEquivalence : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isEquivalence :: "('a*'a)set \<Rightarrow> bool " where + " isEquivalence r = ( refl r \<and> (sym r \<and> trans r))" + + + +(* ----------------------- *) +(* well founded *) +(* ----------------------- *) + +(*val isWellFounded : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isWellFounded :: "('a*'a)set \<Rightarrow> bool " where + " isWellFounded r = ( ((\<forall> P. ((\<forall> x. ((\<forall> y. ((y, x) \<in> r) \<longrightarrow> P x)) \<longrightarrow> P x)) \<longrightarrow> ((\<forall> x. P x)))))" + + + +(* ========================================================================== *) +(* Orders *) +(* ========================================================================== *) + + +(* ----------------------- *) +(* pre- or quasiorders *) +(* ----------------------- *) + +(*val isPreorderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isPreorderOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isPreorderOn r s = ( isReflexiveOn r s \<and> isTransitiveOn r s )" + + +(*val isPreorder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isPreorder :: "('a*'a)set \<Rightarrow> bool " where + " isPreorder r = ( refl r \<and> trans r )" + + + +(* ----------------------- *) +(* partial orders *) +(* ----------------------- *) + +(*val isPartialOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isPartialOrderOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isPartialOrderOn r s = ( isReflexiveOn r s \<and> (isTransitiveOn r s \<and> isAntisymmetricOn r s))" + + + +(*val isStrictPartialOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isStrictPartialOrderOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isStrictPartialOrderOn r s = ( isIrreflexiveOn r s \<and> isTransitiveOn r s )" + + + +(*val isStrictPartialOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isStrictPartialOrder :: "('a*'a)set \<Rightarrow> bool " where + " isStrictPartialOrder r = ( irrefl r \<and> trans r )" + + +(*val isPartialOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isPartialOrder :: "('a*'a)set \<Rightarrow> bool " where + " isPartialOrder r = ( refl r \<and> (trans r \<and> antisym r))" + + +(* ----------------------- *) +(* total / linear orders *) +(* ----------------------- *) + +(*val isTotalOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isTotalOrderOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isTotalOrderOn r s = ( isPartialOrderOn r s \<and> isTotalOn r s )" + + +(*val isStrictTotalOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +definition isStrictTotalOrderOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow> bool " where + " isStrictTotalOrderOn r s = ( isStrictPartialOrderOn r s \<and> isTrichotomousOn r s )" + + +(*val isTotalOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isTotalOrder :: "('a*'a)set \<Rightarrow> bool " where + " isTotalOrder r = ( isPartialOrder r \<and> total r )" + + +(*val isStrictTotalOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +definition isStrictTotalOrder :: "('a*'a)set \<Rightarrow> bool " where + " isStrictTotalOrder r = ( isStrictPartialOrder r \<and> isTrichotomous r )" + + + + +(* ========================================================================== *) +(* closures *) +(* ========================================================================== *) + +(* ----------------------- *) +(* transitive closure *) +(* ----------------------- *) + +(*val transitiveClosure : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> rel 'a 'a*) +(*val transitiveClosureByEq : forall 'a. ('a -> 'a -> bool) -> rel 'a 'a -> rel 'a 'a*) +(*val transitiveClosureByCmp : forall 'a. ('a * 'a -> 'a * 'a -> ordering) -> rel 'a 'a -> rel 'a 'a*) + + +(* ----------------------- *) +(* transitive closure step *) +(* ----------------------- *) + +(*val transitiveClosureAdd : forall 'a. SetType 'a, Eq 'a => 'a -> 'a -> rel 'a 'a -> rel 'a 'a*) + +definition transitiveClosureAdd :: " 'a \<Rightarrow> 'a \<Rightarrow>('a*'a)set \<Rightarrow>('a*'a)set " where + " transitiveClosureAdd x y r = ( + (((((Set.insert (x,y) (r)))) \<union> ((((((let x2 = + ({}) in Finite_Set.fold + (\<lambda>z x2 . if (y, z) \<in> r then Set.insert (x, z) x2 else x2) + x2 (Range r)))) \<union> (((let x2 = + ({}) in Finite_Set.fold + (\<lambda>z x2 . if (z, x) \<in> r then Set.insert (z, y) x2 else x2) + x2 (Domain r))))))))))" + + + +(* ========================================================================== *) +(* reflexive closure *) +(* ========================================================================== *) + +(*val reflexiveTransitiveClosureOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> rel 'a 'a*) +definition reflexiveTransitiveClosureOn :: "('a*'a)set \<Rightarrow> 'a set \<Rightarrow>('a*'a)set " where + " reflexiveTransitiveClosureOn r s = ( trancl (((r) \<union> ((relIdOn s)))))" + + + +(*val reflexiveTransitiveClosure : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> rel 'a 'a*) +definition reflexiveTransitiveClosure :: "('a*'a)set \<Rightarrow>('a*'a)set " where + " reflexiveTransitiveClosure r = ( trancl (((r) \<union> (Id))))" + + + + +(* ========================================================================== *) +(* inverse of closures *) +(* ========================================================================== *) + +(* ----------------------- *) +(* without transitve edges *) +(* ----------------------- *) + +(*val withoutTransitiveEdges: forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> rel 'a 'a*) +(*let withoutTransitiveEdges r= + let tc = transitiveClosure r in + {(a, c) | forall ((a, c) IN r) + | forall (b IN relRange r). a <> b && b <> c --> not ((a, b) IN tc && (b, c) IN tc)}*) +end diff --git a/snapshots/isabelle/lib/lem/Lem_set.thy b/snapshots/isabelle/lib/lem/Lem_set.thy new file mode 100644 index 00000000..f77d4d98 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_set.thy @@ -0,0 +1,325 @@ +chapter \<open>Generated by Lem from set.lem.\<close> + +theory "Lem_set" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_maybe" + "Lem_function" + "Lem_num" + "Lem_list" + "Lem_set_helpers" + "Lem" + +begin + +(******************************************************************************) +(* A library for sets *) +(* *) +(* It mainly follows the Haskell Set-library *) +(******************************************************************************) + +(* Sets in Lem are a bit tricky. On the one hand, we want efficiently executable sets. + OCaml and Haskell both represent sets by some kind of balancing trees. This means + that sets are finite and an order on the element type is required. + Such sets are constructed by simple, executable operations like inserting or + deleting elements, union, intersection, filtering etc. + + On the other hand, we want to use sets for specifications. This leads often + infinite sets, which are specificied in complicated, perhaps even undecidable + ways. + + The set library in this file, chooses the first approach. It describes + *finite* sets with an underlying order. Infinite sets should in the medium + run be represented by a separate type. Since this would require some significant + changes to Lem, for the moment also infinite sets are represented using this + class. However, a run-time exception might occour when using these sets. + This problem needs adressing in the future. *) + + +(* ========================================================================== *) +(* Header *) +(* ========================================================================== *) + +(*open import Bool Basic_classes Maybe Function Num List Set_helpers*) + +(* DPM: sets currently implemented as lists due to mismatch between Coq type + * class hierarchy and the hierarchy implemented in Lem. + *) +(*open import {coq} `Coq.Lists.List`*) +(*open import {hol} `lemTheory`*) +(*open import {isabelle} `$LIB_DIR/Lem`*) + +(* ----------------------- *) +(* Equality check *) +(* ----------------------- *) + +(*val setEqualBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> bool*) + +(*val setEqual : forall 'a. SetType 'a => set 'a -> set 'a -> bool*) + +(* ----------------------- *) +(* Empty set *) +(* ----------------------- *) + +(*val empty : forall 'a. SetType 'a => set 'a*) +(*val emptyBy : forall 'a. ('a -> 'a -> ordering) -> set 'a*) + +(* ----------------------- *) +(* any / all *) +(* ----------------------- *) + +(*val any : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> bool*) + +(*val all : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> bool*) + + +(* ----------------------- *) +(* (IN) *) +(* ----------------------- *) + +(*val IN [member] : forall 'a. SetType 'a => 'a -> set 'a -> bool*) +(*val memberBy : forall 'a. ('a -> 'a -> ordering) -> 'a -> set 'a -> bool*) + +(* ----------------------- *) +(* not (IN) *) +(* ----------------------- *) + +(*val NIN [notMember] : forall 'a. SetType 'a => 'a -> set 'a -> bool*) + + + +(* ----------------------- *) +(* Emptyness check *) +(* ----------------------- *) + +(*val null : forall 'a. SetType 'a => set 'a -> bool*) + + +(* ------------------------ *) +(* singleton *) +(* ------------------------ *) + +(*val singletonBy : forall 'a. ('a -> 'a -> ordering) -> 'a -> set 'a*) +(*val singleton : forall 'a. SetType 'a => 'a -> set 'a*) + + +(* ----------------------- *) +(* size *) +(* ----------------------- *) + +(*val size : forall 'a. SetType 'a => set 'a -> nat*) + + +(* ----------------------------*) +(* setting up pattern matching *) +(* --------------------------- *) + +(*val set_case : forall 'a 'b. SetType 'a => set 'a -> 'b -> ('a -> 'b) -> 'b -> 'b*) + + +(* ------------------------ *) +(* union *) +(* ------------------------ *) + +(*val unionBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> set 'a*) +(*val union : forall 'a. SetType 'a => set 'a -> set 'a -> set 'a*) + +(* ----------------------- *) +(* insert *) +(* ----------------------- *) + +(*val insert : forall 'a. SetType 'a => 'a -> set 'a -> set 'a*) + +(* ----------------------- *) +(* filter *) +(* ----------------------- *) + +(*val filter : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> set 'a*) +(*let filter P s= {e | forall (e IN s) | P e}*) + + +(* ----------------------- *) +(* partition *) +(* ----------------------- *) + +(*val partition : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> set 'a * set 'a*) +definition partition :: "('a \<Rightarrow> bool)\<Rightarrow> 'a set \<Rightarrow> 'a set*'a set " where + " partition P s = ( (set_filter P s, set_filter (\<lambda> e . \<not> (P e)) s))" + + + +(* ----------------------- *) +(* split *) +(* ----------------------- *) + +(*val split : forall 'a. SetType 'a, Ord 'a => 'a -> set 'a -> set 'a * set 'a*) +definition split :: " 'a Ord_class \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> 'a set*'a set " where + " split dict_Basic_classes_Ord_a p s = ( (set_filter ( + (isGreater_method dict_Basic_classes_Ord_a) p) s, set_filter ((isLess_method dict_Basic_classes_Ord_a) p) s))" + + +(*val splitMember : forall 'a. SetType 'a, Ord 'a => 'a -> set 'a -> set 'a * bool * set 'a*) +definition splitMember :: " 'a Ord_class \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> 'a set*bool*'a set " where + " splitMember dict_Basic_classes_Ord_a p s = ( (set_filter ( + (isLess_method dict_Basic_classes_Ord_a) p) s, (p \<in> s), set_filter ( + (isGreater_method dict_Basic_classes_Ord_a) p) s))" + + +(* ------------------------ *) +(* subset and proper subset *) +(* ------------------------ *) + +(*val isSubsetOfBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> bool*) +(*val isProperSubsetOfBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> bool*) + +(*val isSubsetOf : forall 'a. SetType 'a => set 'a -> set 'a -> bool*) +(*val isProperSubsetOf : forall 'a. SetType 'a => set 'a -> set 'a -> bool*) + + +(* ------------------------ *) +(* delete *) +(* ------------------------ *) + +(*val delete : forall 'a. SetType 'a, Eq 'a => 'a -> set 'a -> set 'a*) +(*val deleteBy : forall 'a. SetType 'a => ('a -> 'a -> bool) -> 'a -> set 'a -> set 'a*) + + +(* ------------------------ *) +(* bigunion *) +(* ------------------------ *) + +(*val bigunion : forall 'a. SetType 'a => set (set 'a) -> set 'a*) +(*val bigunionBy : forall 'a. ('a -> 'a -> ordering) -> set (set 'a) -> set 'a*) + +(*let bigunion bs= {x | forall (s IN bs) (x IN s) | true}*) + +(* ------------------------ *) +(* big intersection *) +(* ------------------------ *) + +(* Shaked's addition, for which he is now forever responsible as a de facto + * Lem maintainer... + *) +(*val bigintersection : forall 'a. SetType 'a => set (set 'a) -> set 'a*) +definition bigintersection :: "('a set)set \<Rightarrow> 'a set " where + " bigintersection bs = ( (let x2 = + ({}) in Finite_Set.fold + (\<lambda>x x2 . + if( \<forall> s \<in> bs. x \<in> s) then Set.insert x x2 else x2) + x2 (\<Union> bs)))" + + +(* ------------------------ *) +(* difference *) +(* ------------------------ *) + +(*val differenceBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> set 'a*) +(*val difference : forall 'a. SetType 'a => set 'a -> set 'a -> set 'a*) + +(* ------------------------ *) +(* intersection *) +(* ------------------------ *) + +(*val intersection : forall 'a. SetType 'a => set 'a -> set 'a -> set 'a*) +(*val intersectionBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> set 'a*) + + +(* ------------------------ *) +(* map *) +(* ------------------------ *) + +(*val map : forall 'a 'b. SetType 'a, SetType 'b => ('a -> 'b) -> set 'a -> set 'b*) (* before image *) +(*let map f s= { f e | forall (e IN s) | true }*) + +(*val mapBy : forall 'a 'b. ('b -> 'b -> ordering) -> ('a -> 'b) -> set 'a -> set 'b*) + + +(* ------------------------ *) +(* bigunionMap *) +(* ------------------------ *) + +(* In order to avoid providing an comparison function for sets of sets, + it might be better to combine bigunion and map sometimes into a single operation. *) + +(*val bigunionMap : forall 'a 'b. SetType 'a, SetType 'b => ('a -> set 'b) -> set 'a -> set 'b*) +(*val bigunionMapBy : forall 'a 'b. ('b -> 'b -> ordering) -> ('a -> set 'b) -> set 'a -> set 'b*) + +(* ------------------------ *) +(* mapMaybe and fromMaybe *) +(* ------------------------ *) + +(* If the mapping function returns Just x, x is added to the result + set. If it returns Nothing, no element is added. *) + +(*val mapMaybe : forall 'a 'b. SetType 'a, SetType 'b => ('a -> maybe 'b) -> set 'a -> set 'b*) +definition setMapMaybe :: "('a \<Rightarrow> 'b option)\<Rightarrow> 'a set \<Rightarrow> 'b set " where + " setMapMaybe f s = ( + \<Union> (Set.image (\<lambda> x . (case f x of + Some y => {y} + | None => {} + )) s))" + + +(*val removeMaybe : forall 'a. SetType 'a => set (maybe 'a) -> set 'a*) +definition removeMaybe :: "('a option)set \<Rightarrow> 'a set " where + " removeMaybe s = ( setMapMaybe (\<lambda> x . x) s )" + + +(* ------------------------ *) +(* min and max *) +(* ------------------------ *) + +(*val findMin : forall 'a. SetType 'a, Eq 'a => set 'a -> maybe 'a*) +(*val findMax : forall 'a. SetType 'a, Eq 'a => set 'a -> maybe 'a*) + +(* ------------------------ *) +(* fromList *) +(* ------------------------ *) + +(*val fromList : forall 'a. SetType 'a => list 'a -> set 'a*) (* before from_list *) +(*val fromListBy : forall 'a. ('a -> 'a -> ordering) -> list 'a -> set 'a*) + + +(* ------------------------ *) +(* Sigma *) +(* ------------------------ *) + +(*val sigma : forall 'a 'b. SetType 'a, SetType 'b => set 'a -> ('a -> set 'b) -> set ('a * 'b)*) +(*val sigmaBy : forall 'a 'b. (('a * 'b) -> ('a * 'b) -> ordering) -> set 'a -> ('a -> set 'b) -> set ('a * 'b)*) + +(*let sigma sa sb= { (a, b) | forall (a IN sa) (b IN sb a) | true }*) + + +(* ------------------------ *) +(* cross product *) +(* ------------------------ *) + +(*val cross : forall 'a 'b. SetType 'a, SetType 'b => set 'a -> set 'b -> set ('a * 'b)*) +(*val crossBy : forall 'a 'b. (('a * 'b) -> ('a * 'b) -> ordering) -> set 'a -> set 'b -> set ('a * 'b)*) + +(*let cross s1 s2= { (e1, e2) | forall (e1 IN s1) (e2 IN s2) | true }*) + + +(* ------------------------ *) +(* finite *) +(* ------------------------ *) + +(*val finite : forall 'a. SetType 'a => set 'a -> bool*) + + +(* ----------------------------*) +(* fixed point *) +(* --------------------------- *) + +(*val leastFixedPoint : forall 'a. SetType 'a + => nat -> (set 'a -> set 'a) -> set 'a -> set 'a*) +fun leastFixedPoint :: " nat \<Rightarrow>('a set \<Rightarrow> 'a set)\<Rightarrow> 'a set \<Rightarrow> 'a set " where + " leastFixedPoint 0 f x = ( x )" +|" leastFixedPoint ((Suc bound')) f x = ( (let fx = (f x) in + if fx \<subseteq> x then x + else leastFixedPoint bound' f (fx \<union> x)))" + +end diff --git a/snapshots/isabelle/lib/lem/Lem_set_extra.thy b/snapshots/isabelle/lib/lem/Lem_set_extra.thy new file mode 100644 index 00000000..33516be7 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_set_extra.thy @@ -0,0 +1,121 @@ +chapter \<open>Generated by Lem from set_extra.lem.\<close> + +theory "Lem_set_extra" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_maybe" + "Lem_function" + "Lem_num" + "Lem_list" + "Lem_sorting" + "Lem_set" + +begin + +(******************************************************************************) +(* A library for sets *) +(* *) +(* It mainly follows the Haskell Set-library *) +(******************************************************************************) + +(* ========================================================================== *) +(* Header *) +(* ========================================================================== *) + +(*open import Bool Basic_classes Maybe Function Num List Sorting Set*) + + +(* ----------------------------*) +(* set choose (be careful !) *) +(* --------------------------- *) + +(*val choose : forall 'a. SetType 'a => set 'a -> 'a*) + +(* ------------------------ *) +(* chooseAndSplit *) +(* ------------------------ *) +(* The idea here is to provide a simple primitive that Lem code can use + * to perform its own custom searches within the set -- likely using a + * search criterion related to the element ordering, but not necessarily). + * For example, sometimes we don't necessarily want to search for a specific + * element, but want to search for elements greater than or less than some other. + * Someties we'd like to use split but don't know a good value to split at. + * This function lets the set implementation decide that value. + * + * The contract of chooseAndSplit is simply to select an element nondeterministically + * and return that element, together with the subsets of elements less than and + * greater than it. In this way, we can recursively traverse the set with any + * search criterion, and we avoid baking in the tree representation (although that + * is the obvious choice). + *) +(*val chooseAndSplit : forall 'a. SetType 'a, Ord 'a => set 'a -> maybe (set 'a * 'a * set 'a)*) +definition chooseAndSplit :: " 'a Ord_class \<Rightarrow> 'a set \<Rightarrow>('a set*'a*'a set)option " where + " chooseAndSplit dict_Basic_classes_Ord_a s = ( + if s = {} then + None + else + (let element = (set_choose s) in + (let (lt, gt) = (Lem_set.split + dict_Basic_classes_Ord_a element s) in + Some (lt, element, gt))))" + + +(* ----------------------------*) +(* universal set *) +(* --------------------------- *) + +(*val universal : forall 'a. SetType 'a => set 'a*) + + +(* ----------------------------*) +(* toList *) +(* --------------------------- *) + +(*val toList : forall 'a. SetType 'a => set 'a -> list 'a*) + + +(* ----------------------------*) +(* toOrderedList *) +(* --------------------------- *) + +(* toOrderedList returns a sorted list. Therefore the result is (given a suitable order) deterministic. + Therefore, it is much preferred to toList. However, it still is only defined for finite sets. So, please + use carefully and consider using set-operations instead of translating sets to lists, performing list manipulations + and then transforming back to sets. *) + +(*val toOrderedListBy : forall 'a. ('a -> 'a -> bool) -> set 'a -> list 'a*) + +(*val toOrderedList : forall 'a. SetType 'a, Ord 'a => set 'a -> list 'a*) + +(* ----------------------- *) +(* compare *) +(* ----------------------- *) + +(*val setCompareBy: forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> ordering*) +definition setCompareBy :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> ordering " where + " setCompareBy cmp ss ts = ( + (let ss' = (ordered_list_of_set (\<lambda> x y . cmp x y = LT) ss) in + (let ts' = (ordered_list_of_set (\<lambda> x y . cmp x y = LT) ts) in + lexicographicCompareBy cmp ss' ts')))" + + +(*val setCompare : forall 'a. SetType 'a, Ord 'a => set 'a -> set 'a -> ordering*) +definition setCompare :: " 'a Ord_class \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> ordering " where + " setCompare dict_Basic_classes_Ord_a = ( setCompareBy + (compare_method dict_Basic_classes_Ord_a) )" + + +(* ----------------------------*) +(* unbounded fixed point *) +(* --------------------------- *) + +(* Is NOT supported by the coq backend! *) +(*val leastFixedPointUnbounded : forall 'a. SetType 'a => (set 'a -> set 'a) -> set 'a -> set 'a*) +(*let rec leastFixedPointUnbounded f x= + let fx = f x in + if fx subset x then x + else leastFixedPointUnbounded f (fx union x)*) +end diff --git a/snapshots/isabelle/lib/lem/Lem_set_helpers.thy b/snapshots/isabelle/lib/lem/Lem_set_helpers.thy new file mode 100644 index 00000000..1a2f5f50 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_set_helpers.thy @@ -0,0 +1,50 @@ +chapter \<open>Generated by Lem from set_helpers.lem.\<close> + +theory "Lem_set_helpers" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_maybe" + "Lem_function" + "Lem_num" + +begin + +(******************************************************************************) +(* Helper functions for sets *) +(******************************************************************************) + +(* Usually there is a something.lem file containing the main definitions and a + something_extra.lem one containing functions that might cause problems for + some backends or are just seldomly used. + + For sets the situation is different. folding is not well defined, since it + is only sensibly defined for finite sets and the traversal + order is underspecified. *) + +(* ========================================================================== *) +(* Header *) +(* ========================================================================== *) + +(*open import Bool Basic_classes Maybe Function Num*) + +(*open import {coq} `Coq.Lists.List`*) + +(* ------------------------ *) +(* fold *) +(* ------------------------ *) + +(* fold is suspicious, because if given a function, for which + the order, in which the arguments are given, matters, its + results are undefined. On the other hand, it is very handy to + define other - non suspicious functions. + + Moreover, fold is central for OCaml, since it is used to + compile set comprehensions *) + +(*val fold : forall 'a 'b. ('a -> 'b -> 'b) -> set 'a -> 'b -> 'b*) + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_show.thy b/snapshots/isabelle/lib/lem/Lem_show.thy new file mode 100644 index 00000000..fced534d --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_show.thy @@ -0,0 +1,87 @@ +chapter \<open>Generated by Lem from show.lem.\<close> + +theory "Lem_show" + +imports + Main + "Lem_string" + "Lem_maybe" + "Lem_num" + "Lem_basic_classes" + +begin + + + +(*open import String Maybe Num Basic_classes*) + +(*open import {hol} `lemTheory`*) + +record 'a Show_class= + + show_method::" 'a \<Rightarrow> string " + + + +definition instance_Show_Show_string_dict :: "(string)Show_class " where + " instance_Show_Show_string_dict = ((| + + show_method = (\<lambda> s. ([(char_of_nat 34)]) @ (s @ ([(char_of_nat 34)])))|) )" + + +(*val stringFromMaybe : forall 'a. ('a -> string) -> maybe 'a -> string*) +fun stringFromMaybe :: "('a \<Rightarrow> string)\<Rightarrow> 'a option \<Rightarrow> string " where + " stringFromMaybe showX (Some x) = ( (''Just ('') @ (showX x @ ('')'')))" +|" stringFromMaybe showX None = ( (''Nothing''))" + + +definition instance_Show_Show_Maybe_maybe_dict :: " 'a Show_class \<Rightarrow>('a option)Show_class " where + " instance_Show_Show_Maybe_maybe_dict dict_Show_Show_a = ((| + + show_method = (\<lambda> x_opt. stringFromMaybe + (show_method dict_Show_Show_a) x_opt)|) )" + + +(*val stringFromListAux : forall 'a. ('a -> string) -> list 'a -> string*) +function (sequential,domintros) stringFromListAux :: "('a \<Rightarrow> string)\<Rightarrow> 'a list \<Rightarrow> string " where + " stringFromListAux showX ([]) = ( (''''))" +|" stringFromListAux showX (x # xs') = ( + (case xs' of + [] => showX x + | _ => showX x @ ((''; '') @ stringFromListAux showX xs') + ))" +by pat_completeness auto + + +(*val stringFromList : forall 'a. ('a -> string) -> list 'a -> string*) +definition stringFromList :: "('a \<Rightarrow> string)\<Rightarrow> 'a list \<Rightarrow> string " where + " stringFromList showX xs = ( + (''['') @ (stringFromListAux showX xs @ ('']'')))" + + +definition instance_Show_Show_list_dict :: " 'a Show_class \<Rightarrow>('a list)Show_class " where + " instance_Show_Show_list_dict dict_Show_Show_a = ((| + + show_method = (\<lambda> xs. stringFromList + (show_method dict_Show_Show_a) xs)|) )" + + +(*val stringFromPair : forall 'a 'b. ('a -> string) -> ('b -> string) -> ('a * 'b) -> string*) +fun stringFromPair :: "('a \<Rightarrow> string)\<Rightarrow>('b \<Rightarrow> string)\<Rightarrow> 'a*'b \<Rightarrow> string " where + " stringFromPair showX showY (x,y) = ( + (''('') @ (showX x @ (('', '') @ (showY y @ ('')'')))))" + + +definition instance_Show_Show_tup2_dict :: " 'a Show_class \<Rightarrow> 'b Show_class \<Rightarrow>('a*'b)Show_class " where + " instance_Show_Show_tup2_dict dict_Show_Show_a dict_Show_Show_b = ((| + + show_method = (stringFromPair + (show_method dict_Show_Show_a) (show_method dict_Show_Show_b))|) )" + + +definition instance_Show_Show_bool_dict :: "(bool)Show_class " where + " instance_Show_Show_bool_dict = ((| + + show_method = (\<lambda> b. if b then (''true'') else (''false''))|) )" + +end diff --git a/snapshots/isabelle/lib/lem/Lem_show_extra.thy b/snapshots/isabelle/lib/lem/Lem_show_extra.thy new file mode 100644 index 00000000..25ab2570 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_show_extra.thy @@ -0,0 +1,74 @@ +chapter \<open>Generated by Lem from show_extra.lem.\<close> + +theory "Lem_show_extra" + +imports + Main + "Lem_string" + "Lem_maybe" + "Lem_num" + "Lem_basic_classes" + "Lem_set" + "Lem_relation" + "Lem_show" + "Lem_set_extra" + "Lem_string_extra" + +begin + + + +(*open import String Maybe Num Basic_classes Set Relation Show*) +(*import Set_extra String_extra*) + +definition instance_Show_Show_nat_dict :: "(nat)Show_class " where + " instance_Show_Show_nat_dict = ((| + + show_method = Lem_string_extra.stringFromNat |) )" + + +definition instance_Show_Show_Num_natural_dict :: "(nat)Show_class " where + " instance_Show_Show_Num_natural_dict = ((| + + show_method = Lem_string_extra.stringFromNatural |) )" + + +definition instance_Show_Show_Num_int_dict :: "(int)Show_class " where + " instance_Show_Show_Num_int_dict = ((| + + show_method = Lem_string_extra.stringFromInt |) )" + + +definition instance_Show_Show_Num_integer_dict :: "(int)Show_class " where + " instance_Show_Show_Num_integer_dict = ((| + + show_method = Lem_string_extra.stringFromInteger |) )" + + +definition stringFromSet :: "('a \<Rightarrow> string)\<Rightarrow> 'a set \<Rightarrow> string " where + " stringFromSet showX xs = ( + (''{'') @ (Lem_show.stringFromListAux showX (list_of_set xs) @ (''}'')))" + + +(* Abbreviates the representation if the relation is transitive. *) +definition stringFromRelation :: "('a*'a \<Rightarrow> string)\<Rightarrow>('a*'a)set \<Rightarrow> string " where + " stringFromRelation showX rel = ( + if trans rel then + (let pruned_rel = (LemExtraDefs.without_trans_edges rel) in + if ((\<forall> e \<in> rel. (e \<in> pruned_rel))) then + (* The relations are the same (there are no transitive edges), + so we can just as well print the original one. *) + stringFromSet showX rel + else + (''trancl of '') @ stringFromSet showX pruned_rel) + else + stringFromSet showX rel )" + + +definition instance_Show_Show_set_dict :: " 'a Show_class \<Rightarrow>('a set)Show_class " where + " instance_Show_Show_set_dict dict_Show_Show_a = ((| + + show_method = (\<lambda> xs. stringFromSet + (show_method dict_Show_Show_a) xs)|) )" + +end diff --git a/snapshots/isabelle/lib/lem/Lem_sorting.thy b/snapshots/isabelle/lib/lem/Lem_sorting.thy new file mode 100644 index 00000000..d42425a2 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_sorting.thy @@ -0,0 +1,110 @@ +chapter \<open>Generated by Lem from sorting.lem.\<close> + +theory "Lem_sorting" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_maybe" + "Lem_list" + "Lem_num" + "Lem" + "~~/src/HOL/Library/Permutation" + +begin + + + +(*open import Bool Basic_classes Maybe List Num*) + +(*open import {isabelle} `~~/src/HOL/Library/Permutation`*) +(*open import {coq} `Coq.Lists.List`*) +(*open import {hol} `sortingTheory` `permLib`*) +(*open import {isabelle} `$LIB_DIR/Lem`*) + +(* ------------------------- *) +(* permutations *) +(* ------------------------- *) + +(*val isPermutation : forall 'a. Eq 'a => list 'a -> list 'a -> bool*) +(*val isPermutationBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) + +fun isPermutationBy :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool " where + " isPermutationBy eq ([]) l2 = ( (l2 = []))" +|" isPermutationBy eq (x # xs) l2 = ( ( + (case delete_first (eq x) l2 of + None => False + | Some ys => isPermutationBy eq xs ys + ) + ))" + + + + +(* ------------------------- *) +(* isSorted *) +(* ------------------------- *) + +(* isSortedBy R l + checks, whether the list l is sorted by ordering R. + R should represent an order, i.e. it should be transitive. + Different backends defined isSorted slightly differently. However, + the definitions coincide for transitive R. Therefore there is the + following restriction: + + WARNING: Use isSorted and isSortedBy only with transitive relations! +*) + +(*val isSorted : forall 'a. Ord 'a => list 'a -> bool*) +(*val isSortedBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> bool*) + +(* DPM: rejigged the definition with a nested match to get past Coq's termination checker. *) +(*let rec isSortedBy cmp l= match l with + | [] -> true + | x1 :: xs -> + match xs with + | [] -> true + | x2 :: _ -> (cmp x1 x2 && isSortedBy cmp xs) + end +end*) + + +(* ----------------------- *) +(* insertion sort *) +(* ----------------------- *) + +(*val insert : forall 'a. Ord 'a => 'a -> list 'a -> list 'a*) +(*val insertBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a*) + +(*val insertSort: forall 'a. Ord 'a => list 'a -> list 'a*) +(*val insertSortBy: forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a*) + +(*let rec insertBy cmp e l= match l with + | [] -> [e] + | x :: xs -> if cmp x e then x :: (insertBy cmp e xs) else (e :: x :: xs) +end*) + +(*let insertSortBy cmp l= List.foldl (fun l e -> insertBy cmp e l) [] l*) + + +(* ----------------------- *) +(* general sorting *) +(* ----------------------- *) + +(*val sort: forall 'a. Ord 'a => list 'a -> list 'a*) +(*val sortBy: forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a*) +(*val sortByOrd: forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a*) + +(*val predicate_of_ord : forall 'a. ('a -> 'a -> ordering) -> 'a -> 'a -> bool*) +definition predicate_of_ord :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool " where + " predicate_of_ord f x y = ( + (case f x y of + LT => True + | EQ => True + | GT => False + ))" + + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_string.thy b/snapshots/isabelle/lib/lem/Lem_string.thy new file mode 100644 index 00000000..9df246c4 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_string.thy @@ -0,0 +1,75 @@ +chapter \<open>Generated by Lem from string.lem.\<close> + +theory "Lem_string" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + "Lem_list" + +begin + + + +(*open import Bool Basic_classes List*) +(*open import {ocaml} `Xstring`*) +(*open import {hol} `lemTheory` `stringTheory`*) +(*open import {coq} `Coq.Strings.Ascii` `Coq.Strings.String`*) + +(* ------------------------------------------- *) +(* translations between strings and char lists *) +(* ------------------------------------------- *) + +(*val toCharList : string -> list char*) + +(*val toString : list char -> string*) + + +(* ----------------------- *) +(* generating strings *) +(* ----------------------- *) + +(*val makeString : nat -> char -> string*) +(*let makeString len c= toString (replicate len c)*) + +(* ----------------------- *) +(* length *) +(* ----------------------- *) + +(*val stringLength : string -> nat*) + +(* ----------------------- *) +(* string concatenation *) +(* ----------------------- *) + +(*val ^ [stringAppend] : string -> string -> string*) + + +(* ----------------------------*) +(* setting up pattern matching *) +(* --------------------------- *) + +(*val string_case : forall 'a. string -> 'a -> (char -> string -> 'a) -> 'a*) + +(*let string_case s c_empty c_cons= + match (toCharList s) with + | [] -> c_empty + | c :: cs -> c_cons c (toString cs) + end*) + +(*val empty_string : string*) + +(*val cons_string : char -> string -> string*) + +(*val concat : string -> list string -> string*) +function (sequential,domintros) concat :: " string \<Rightarrow>(string)list \<Rightarrow> string " where + " concat sep ([]) = ( (''''))" +|" concat sep (s # ss') = ( + (case ss' of + [] => s + | _ => s @ (sep @ concat sep ss') + ))" +by pat_completeness auto + +end diff --git a/snapshots/isabelle/lib/lem/Lem_string_extra.thy b/snapshots/isabelle/lib/lem/Lem_string_extra.thy new file mode 100644 index 00000000..bd8317ba --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_string_extra.thy @@ -0,0 +1,137 @@ +chapter \<open>Generated by Lem from string_extra.lem.\<close> + +theory "Lem_string_extra" + +imports + Main + "Lem_num" + "Lem_list" + "Lem_basic_classes" + "Lem_string" + "Lem_list_extra" + +begin + +(******************************************************************************) +(* String functions *) +(******************************************************************************) + +(*open import Basic_classes*) +(*open import Num*) +(*open import List*) +(*open import String*) +(*open import List_extra*) +(*open import {hol} `stringLib`*) +(*open import {hol} `ASCIInumbersTheory`*) + + +(******************************************************************************) +(* Character's to numbers *) +(******************************************************************************) + +(*val ord : char -> nat*) + +(*val chr : nat -> char*) + +(******************************************************************************) +(* Converting to strings *) +(******************************************************************************) + +(*val stringFromNatHelper : nat -> list char -> list char*) +fun stringFromNatHelper :: " nat \<Rightarrow>(char)list \<Rightarrow>(char)list " where + " stringFromNatHelper n acc1 = ( + if n =( 0 :: nat) then + acc1 + else + stringFromNatHelper (n div( 10 :: nat)) (char_of_nat ((n mod( 10 :: nat)) +( 48 :: nat)) # acc1))" + + +(*val stringFromNat : nat -> string*) +definition stringFromNat :: " nat \<Rightarrow> string " where + " stringFromNat n = ( + if n =( 0 :: nat) then (''0'') else (stringFromNatHelper n []))" + + +(*val stringFromNaturalHelper : natural -> list char -> list char*) +fun stringFromNaturalHelper :: " nat \<Rightarrow>(char)list \<Rightarrow>(char)list " where + " stringFromNaturalHelper n acc1 = ( + if n =( 0 :: nat) then + acc1 + else + stringFromNaturalHelper (n div( 10 :: nat)) (char_of_nat ( ((n mod( 10 :: nat)) +( 48 :: nat))) # acc1))" + + +(*val stringFromNatural : natural -> string*) +definition stringFromNatural :: " nat \<Rightarrow> string " where + " stringFromNatural n = ( + if n =( 0 :: nat) then (''0'') else (stringFromNaturalHelper n []))" + + +(*val stringFromInt : int -> string*) +definition stringFromInt :: " int \<Rightarrow> string " where + " stringFromInt i = ( + if i <( 0 :: int) then + (''-'') @ stringFromNat (nat (abs i)) + else + stringFromNat (nat (abs i)))" + + +(*val stringFromInteger : integer -> string*) +definition stringFromInteger :: " int \<Rightarrow> string " where + " stringFromInteger i = ( + if i <( 0 :: int) then + (''-'') @ stringFromNatural (nat (abs i)) + else + stringFromNatural (nat (abs i)))" + + + +(******************************************************************************) +(* List-like operations *) +(******************************************************************************) + +(*val nth : string -> nat -> char*) +definition nth :: " string \<Rightarrow> nat \<Rightarrow> char " where + " nth s n = ( List.nth ( s) n )" + + +(*val stringConcat : list string -> string*) +definition stringConcat :: "(string)list \<Rightarrow> string " where + " stringConcat s = ( + List.foldr (op@) s (''''))" + + +(******************************************************************************) +(* String comparison *) +(******************************************************************************) + +(*val stringCompare : string -> string -> ordering*) + +definition stringLess :: " string \<Rightarrow> string \<Rightarrow> bool " where + " stringLess x y = ( orderingIsLess (EQ))" + +definition stringLessEq :: " string \<Rightarrow> string \<Rightarrow> bool " where + " stringLessEq x y = ( \<not> (orderingIsGreater (EQ)))" + +definition stringGreater :: " string \<Rightarrow> string \<Rightarrow> bool " where + " stringGreater x y = ( stringLess y x )" + +definition stringGreaterEq :: " string \<Rightarrow> string \<Rightarrow> bool " where + " stringGreaterEq x y = ( stringLessEq y x )" + + +definition instance_Basic_classes_Ord_string_dict :: "(string)Ord_class " where + " instance_Basic_classes_Ord_string_dict = ((| + + compare_method = (\<lambda> x y. EQ), + + isLess_method = stringLess, + + isLessEqual_method = stringLessEq, + + isGreater_method = stringGreater, + + isGreaterEqual_method = stringGreaterEq |) )" + + +end diff --git a/snapshots/isabelle/lib/lem/Lem_tuple.thy b/snapshots/isabelle/lib/lem/Lem_tuple.thy new file mode 100644 index 00000000..66f1a209 --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_tuple.thy @@ -0,0 +1,51 @@ +chapter \<open>Generated by Lem from tuple.lem.\<close> + +theory "Lem_tuple" + +imports + Main + "Lem_bool" + "Lem_basic_classes" + +begin + + + +(*open import Bool Basic_classes*) + +(* ----------------------- *) +(* fst *) +(* ----------------------- *) + +(*val fst : forall 'a 'b. 'a * 'b -> 'a*) +(*let fst (v1, v2)= v1*) + +(* ----------------------- *) +(* snd *) +(* ----------------------- *) + +(*val snd : forall 'a 'b. 'a * 'b -> 'b*) +(*let snd (v1, v2)= v2*) + + +(* ----------------------- *) +(* curry *) +(* ----------------------- *) + +(*val curry : forall 'a 'b 'c. ('a * 'b -> 'c) -> ('a -> 'b -> 'c)*) + +(* ----------------------- *) +(* uncurry *) +(* ----------------------- *) + +(*val uncurry : forall 'a 'b 'c. ('a -> 'b -> 'c) -> ('a * 'b -> 'c)*) + + +(* ----------------------- *) +(* swap *) +(* ----------------------- *) + +(*val swap : forall 'a 'b. ('a * 'b) -> ('b * 'a)*) +(*let swap (v1, v2)= (v2, v1)*) + +end diff --git a/snapshots/isabelle/lib/lem/Lem_word.thy b/snapshots/isabelle/lib/lem/Lem_word.thy new file mode 100644 index 00000000..bc56da3c --- /dev/null +++ b/snapshots/isabelle/lib/lem/Lem_word.thy @@ -0,0 +1,1024 @@ +chapter \<open>Generated by Lem from word.lem.\<close> + +theory "Lem_word" + +imports + Main + "Lem_bool" + "Lem_maybe" + "Lem_num" + "Lem_basic_classes" + "Lem_list" + "~~/src/HOL/Word/Word" + +begin + + + +(*open import Bool Maybe Num Basic_classes List*) + +(*open import {isabelle} `~~/src/HOL/Word/Word`*) +(*open import {hol} `wordsTheory` `wordsLib`*) + + +(* ========================================================================== *) +(* Define general purpose word, i.e. sequences of bits of arbitrary length *) +(* ========================================================================== *) + +datatype bitSequence = BitSeq " + nat option " " (* length of the sequence, Nothing means infinite length *) + bool " " bool (* sign of the word, used to fill up after concrete value is exhausted *) + list " (* the initial part of the sequence, least significant bit first *) + +(*val bitSeqEq : bitSequence -> bitSequence -> bool*) + +(*val boolListFrombitSeq : nat -> bitSequence -> list bool*) + +fun boolListFrombitSeqAux :: " nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " boolListFrombitSeqAux n s bl = ( + if n =( 0 :: nat) then [] else + (case bl of + [] => List.replicate n s + | b # bl' => b # (boolListFrombitSeqAux (n-( 1 :: nat)) s bl') + ))" + + +fun boolListFrombitSeq :: " nat \<Rightarrow> bitSequence \<Rightarrow>(bool)list " where + " boolListFrombitSeq n (BitSeq _ s bl) = ( boolListFrombitSeqAux n s bl )" + + + +(*val bitSeqFromBoolList : list bool -> maybe bitSequence*) +definition bitSeqFromBoolList :: "(bool)list \<Rightarrow>(bitSequence)option " where + " bitSeqFromBoolList bl = ( + (case dest_init bl of + None => None + | Some (bl', s) => Some (BitSeq (Some (List.length bl)) s bl') + ))" + + + +(* cleans up the representation of a bitSequence without changing its semantics *) +(*val cleanBitSeq : bitSequence -> bitSequence*) +fun cleanBitSeq :: " bitSequence \<Rightarrow> bitSequence " where + " cleanBitSeq (BitSeq len s bl) = ( (case len of + None => (BitSeq len s (List.rev (dropWhile ((op \<longleftrightarrow>) s) (List.rev bl)))) + | Some n => (BitSeq len s (List.rev (dropWhile ((op \<longleftrightarrow>) s) (List.rev (List.take (n-( 1 :: nat)) bl))))) +))" + + + +(*val bitSeqTestBit : bitSequence -> nat -> maybe bool*) +fun bitSeqTestBit :: " bitSequence \<Rightarrow> nat \<Rightarrow>(bool)option " where + " bitSeqTestBit (BitSeq None s bl) pos = ( if pos < List.length bl then index bl pos else Some s )" +|" bitSeqTestBit (BitSeq(Some l) s bl) pos = ( if (pos \<ge> l) then None else + if ((pos = (l -( 1 :: nat))) \<or> (pos \<ge> List.length bl)) then Some s else + index bl pos )" + + +(*val bitSeqSetBit : bitSequence -> nat -> bool -> bitSequence*) +fun bitSeqSetBit :: " bitSequence \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bitSequence " where + " bitSeqSetBit (BitSeq len s bl) pos v = ( + (let bl' = (if (pos < List.length bl) then bl else bl @ List.replicate pos s) in + (let bl'' = (List.list_update bl' pos v) in + (let bs' = (BitSeq len s bl'') in + cleanBitSeq bs'))))" + + + +(*val resizeBitSeq : maybe nat -> bitSequence -> bitSequence*) +definition resizeBitSeq :: "(nat)option \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " resizeBitSeq new_len bs = ( + (case cleanBitSeq bs of + (BitSeq len s bl) => + (let shorten_opt = ((case (new_len, len) of + (None, _) => None + | (Some l1, None) => Some l1 + | (Some l1, Some l2) => + if (l1 < l2) then Some l1 else None + )) in + (case shorten_opt of + None => BitSeq new_len s bl + | Some l1 => ( + (let bl' = (List.take l1 (bl @ [s])) in + (case dest_init bl' of + None => (BitSeq len s bl) (* do nothing if size 0 is requested *) + | Some (bl'', s') => cleanBitSeq (BitSeq new_len s' bl'') + ))) + )) + ) )" + + +(*val bitSeqNot : bitSequence -> bitSequence*) +fun bitSeqNot :: " bitSequence \<Rightarrow> bitSequence " where + " bitSeqNot (BitSeq len s bl) = ( BitSeq len (\<not> s) (List.map (\<lambda> x. \<not> x) bl))" + + +(*val bitSeqBinop : (bool -> bool -> bool) -> bitSequence -> bitSequence -> bitSequence*) + +(*val bitSeqBinopAux : (bool -> bool -> bool) -> bool -> list bool -> bool -> list bool -> list bool*) +fun bitSeqBinopAux :: "(bool \<Rightarrow> bool \<Rightarrow> bool)\<Rightarrow> bool \<Rightarrow>(bool)list \<Rightarrow> bool \<Rightarrow>(bool)list \<Rightarrow>(bool)list " where + " bitSeqBinopAux binop s1 ([]) s2 ([]) = ( [])" +|" bitSeqBinopAux binop s1 (b1 # bl1') s2 ([]) = ( (binop b1 s2) # bitSeqBinopAux binop s1 bl1' s2 [])" +|" bitSeqBinopAux binop s1 ([]) s2 (b2 # bl2') = ( (binop s1 b2) # bitSeqBinopAux binop s1 [] s2 bl2' )" +|" bitSeqBinopAux binop s1 (b1 # bl1') s2 (b2 # bl2') = ( (binop b1 b2) # bitSeqBinopAux binop s1 bl1' s2 bl2' )" + + +definition bitSeqBinop :: "(bool \<Rightarrow> bool \<Rightarrow> bool)\<Rightarrow> bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqBinop binop bs1 bs2 = ( ( + (case cleanBitSeq bs1 of + (BitSeq len1 s1 bl1) => + (case cleanBitSeq bs2 of + (BitSeq len2 s2 bl2) => + (let len = ((case (len1, len2) of + (Some l1, Some l2) => Some (max l1 l2) + | _ => None + )) in + (let s = (binop s1 s2) in + (let bl = (bitSeqBinopAux binop s1 bl1 s2 bl2) in + cleanBitSeq (BitSeq len s bl)))) + ) + ) +))" + + +definition bitSeqAnd :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqAnd = ( bitSeqBinop (op \<and>))" + +definition bitSeqOr :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqOr = ( bitSeqBinop (op \<or>))" + +definition bitSeqXor :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqXor = ( bitSeqBinop (\<lambda> b1 b2. \<not> (b1 \<longleftrightarrow> b2)))" + + +(*val bitSeqShiftLeft : bitSequence -> nat -> bitSequence*) +fun bitSeqShiftLeft :: " bitSequence \<Rightarrow> nat \<Rightarrow> bitSequence " where + " bitSeqShiftLeft (BitSeq len s bl) n = ( cleanBitSeq (BitSeq len s (List.replicate n False @ bl)))" + + +(*val bitSeqArithmeticShiftRight : bitSequence -> nat -> bitSequence*) +definition bitSeqArithmeticShiftRight :: " bitSequence \<Rightarrow> nat \<Rightarrow> bitSequence " where + " bitSeqArithmeticShiftRight bs n = ( + (case cleanBitSeq bs of + (BitSeq len s bl) => + cleanBitSeq (BitSeq len s (List.drop n bl)) + ) )" + + +(*val bitSeqLogicalShiftRight : bitSequence -> nat -> bitSequence*) +definition bitSeqLogicalShiftRight :: " bitSequence \<Rightarrow> nat \<Rightarrow> bitSequence " where + " bitSeqLogicalShiftRight bs n = ( + if (n =( 0 :: nat)) then cleanBitSeq bs else + (case cleanBitSeq bs of + (BitSeq len s bl) => + (case len of + None => cleanBitSeq (BitSeq len s (List.drop n bl)) + | Some l => cleanBitSeq + (BitSeq len False ((List.drop n bl) @ List.replicate l s)) + ) + ) )" + + + +(* integerFromBoolList sign bl creates an integer from a list of bits + (least significant bit first) and an explicitly given sign bit. + It uses two's complement encoding. *) +(*val integerFromBoolList : (bool * list bool) -> integer*) + +fun integerFromBoolListAux :: " int \<Rightarrow>(bool)list \<Rightarrow> int " where + " integerFromBoolListAux (acc1 :: int) (([]) :: bool list) = ( acc1 )" +|" integerFromBoolListAux (acc1 :: int) ((True # bl') :: bool list) = ( integerFromBoolListAux ((acc1 *( 2 :: int)) +( 1 :: int)) bl' )" +|" integerFromBoolListAux (acc1 :: int) ((False # bl') :: bool list) = ( integerFromBoolListAux (acc1 *( 2 :: int)) bl' )" + + +fun integerFromBoolList :: " bool*(bool)list \<Rightarrow> int " where + " integerFromBoolList (sign, bl) = ( + if sign then + - (integerFromBoolListAux(( 0 :: int)) (List.rev (List.map (\<lambda> x. \<not> x) bl)) +( 1 :: int)) + else integerFromBoolListAux(( 0 :: int)) (List.rev bl))" + + +(* [boolListFromInteger i] creates a sign bit and a list of booleans from an integer. The len_opt tells it when to stop.*) +(*val boolListFromInteger : integer -> bool * list bool*) + +fun boolListFromNatural :: "(bool)list \<Rightarrow> nat \<Rightarrow>(bool)list " where + " boolListFromNatural acc1 (remainder :: nat) = ( + if (remainder >( 0 :: nat)) then + (boolListFromNatural (((remainder mod( 2 :: nat)) =( 1 :: nat)) # acc1) + (remainder div( 2 :: nat))) + else + List.rev acc1 )" + + +definition boolListFromInteger :: " int \<Rightarrow> bool*(bool)list " where + " boolListFromInteger (i :: int) = ( + if (i <( 0 :: int)) then + (True, List.map (\<lambda> x. \<not> x) (boolListFromNatural [] (nat (abs (- (i +( 1 :: int))))))) + else + (False, boolListFromNatural [] (nat (abs i))))" + + + +(* [bitSeqFromInteger len_opt i] encodes [i] as a bitsequence with [len_opt] bits. If there are not enough + bits, truncation happens *) +(*val bitSeqFromInteger : maybe nat -> integer -> bitSequence*) +definition bitSeqFromInteger :: "(nat)option \<Rightarrow> int \<Rightarrow> bitSequence " where + " bitSeqFromInteger len_opt i = ( + (let (s, bl) = (boolListFromInteger i) in + resizeBitSeq len_opt (BitSeq None s bl)))" + + + +(*val integerFromBitSeq : bitSequence -> integer*) +definition integerFromBitSeq :: " bitSequence \<Rightarrow> int " where + " integerFromBitSeq bs = ( + (case cleanBitSeq bs of (BitSeq len s bl) => integerFromBoolList (s, bl) ) )" + + + +(* Now we can via translation to integers map arithmetic operations to bitSequences *) + +(*val bitSeqArithUnaryOp : (integer -> integer) -> bitSequence -> bitSequence*) +definition bitSeqArithUnaryOp :: "(int \<Rightarrow> int)\<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqArithUnaryOp uop bs = ( + (case bs of + (BitSeq len _ _) => + bitSeqFromInteger len (uop (integerFromBitSeq bs)) + ) )" + + +(*val bitSeqArithBinOp : (integer -> integer -> integer) -> bitSequence -> bitSequence -> bitSequence*) +definition bitSeqArithBinOp :: "(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqArithBinOp binop bs1 bs2 = ( + (case bs1 of + (BitSeq len1 _ _) => + (case bs2 of + (BitSeq len2 _ _) => + (let len = ((case (len1, len2) of + (Some l1, Some l2) => Some (max l1 l2) + | _ => None + )) in + bitSeqFromInteger len + (binop (integerFromBitSeq bs1) (integerFromBitSeq bs2))) + ) + ) )" + + +(*val bitSeqArithBinTest : forall 'a. (integer -> integer -> 'a) -> bitSequence -> bitSequence -> 'a*) +definition bitSeqArithBinTest :: "(int \<Rightarrow> int \<Rightarrow> 'a)\<Rightarrow> bitSequence \<Rightarrow> bitSequence \<Rightarrow> 'a " where + " bitSeqArithBinTest binop bs1 bs2 = ( binop (integerFromBitSeq bs1) (integerFromBitSeq bs2))" + + + +(* now instantiate the number interface for bit-sequences *) + +(*val bitSeqFromNumeral : numeral -> bitSequence*) + +(*val bitSeqLess : bitSequence -> bitSequence -> bool*) +definition bitSeqLess :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bool " where + " bitSeqLess bs1 bs2 = ( bitSeqArithBinTest (op<) bs1 bs2 )" + + +(*val bitSeqLessEqual : bitSequence -> bitSequence -> bool*) +definition bitSeqLessEqual :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bool " where + " bitSeqLessEqual bs1 bs2 = ( bitSeqArithBinTest (op \<le>) bs1 bs2 )" + + +(*val bitSeqGreater : bitSequence -> bitSequence -> bool*) +definition bitSeqGreater :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bool " where + " bitSeqGreater bs1 bs2 = ( bitSeqArithBinTest (op>) bs1 bs2 )" + + +(*val bitSeqGreaterEqual : bitSequence -> bitSequence -> bool*) +definition bitSeqGreaterEqual :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bool " where + " bitSeqGreaterEqual bs1 bs2 = ( bitSeqArithBinTest (op \<ge>) bs1 bs2 )" + + +(*val bitSeqCompare : bitSequence -> bitSequence -> ordering*) +definition bitSeqCompare :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> ordering " where + " bitSeqCompare bs1 bs2 = ( bitSeqArithBinTest (genericCompare (op<) (op=)) bs1 bs2 )" + + +definition instance_Basic_classes_Ord_Word_bitSequence_dict :: "(bitSequence)Ord_class " where + " instance_Basic_classes_Ord_Word_bitSequence_dict = ((| + + compare_method = bitSeqCompare, + + isLess_method = bitSeqLess, + + isLessEqual_method = bitSeqLessEqual, + + isGreater_method = bitSeqGreater, + + isGreaterEqual_method = bitSeqGreaterEqual |) )" + + +(* arithmetic negation, don't mix up with bitwise negation *) +(*val bitSeqNegate : bitSequence -> bitSequence*) +definition bitSeqNegate :: " bitSequence \<Rightarrow> bitSequence " where + " bitSeqNegate bs = ( bitSeqArithUnaryOp (\<lambda> i. - i) bs )" + + +definition instance_Num_NumNegate_Word_bitSequence_dict :: "(bitSequence)NumNegate_class " where + " instance_Num_NumNegate_Word_bitSequence_dict = ((| + + numNegate_method = bitSeqNegate |) )" + + + +(*val bitSeqAdd : bitSequence -> bitSequence -> bitSequence*) +definition bitSeqAdd :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqAdd bs1 bs2 = ( bitSeqArithBinOp (op+) bs1 bs2 )" + + +definition instance_Num_NumAdd_Word_bitSequence_dict :: "(bitSequence)NumAdd_class " where + " instance_Num_NumAdd_Word_bitSequence_dict = ((| + + numAdd_method = bitSeqAdd |) )" + + +(*val bitSeqMinus : bitSequence -> bitSequence -> bitSequence*) +definition bitSeqMinus :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqMinus bs1 bs2 = ( bitSeqArithBinOp (op-) bs1 bs2 )" + + +definition instance_Num_NumMinus_Word_bitSequence_dict :: "(bitSequence)NumMinus_class " where + " instance_Num_NumMinus_Word_bitSequence_dict = ((| + + numMinus_method = bitSeqMinus |) )" + + +(*val bitSeqSucc : bitSequence -> bitSequence*) +definition bitSeqSucc :: " bitSequence \<Rightarrow> bitSequence " where + " bitSeqSucc bs = ( bitSeqArithUnaryOp (\<lambda> n. n +( 1 :: int)) bs )" + + +definition instance_Num_NumSucc_Word_bitSequence_dict :: "(bitSequence)NumSucc_class " where + " instance_Num_NumSucc_Word_bitSequence_dict = ((| + + succ_method = bitSeqSucc |) )" + + +(*val bitSeqPred : bitSequence -> bitSequence*) +definition bitSeqPred :: " bitSequence \<Rightarrow> bitSequence " where + " bitSeqPred bs = ( bitSeqArithUnaryOp (\<lambda> n. n -( 1 :: int)) bs )" + + +definition instance_Num_NumPred_Word_bitSequence_dict :: "(bitSequence)NumPred_class " where + " instance_Num_NumPred_Word_bitSequence_dict = ((| + + pred_method = bitSeqPred |) )" + + +(*val bitSeqMult : bitSequence -> bitSequence -> bitSequence*) +definition bitSeqMult :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqMult bs1 bs2 = ( bitSeqArithBinOp (op*) bs1 bs2 )" + + +definition instance_Num_NumMult_Word_bitSequence_dict :: "(bitSequence)NumMult_class " where + " instance_Num_NumMult_Word_bitSequence_dict = ((| + + numMult_method = bitSeqMult |) )" + + + +(*val bitSeqPow : bitSequence -> nat -> bitSequence*) +definition bitSeqPow :: " bitSequence \<Rightarrow> nat \<Rightarrow> bitSequence " where + " bitSeqPow bs n = ( bitSeqArithUnaryOp (\<lambda> i . i ^ n) bs )" + + +definition instance_Num_NumPow_Word_bitSequence_dict :: "(bitSequence)NumPow_class " where + " instance_Num_NumPow_Word_bitSequence_dict = ((| + + numPow_method = bitSeqPow |) )" + + +(*val bitSeqDiv : bitSequence -> bitSequence -> bitSequence*) +definition bitSeqDiv :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqDiv bs1 bs2 = ( bitSeqArithBinOp (op div) bs1 bs2 )" + + +definition instance_Num_NumIntegerDivision_Word_bitSequence_dict :: "(bitSequence)NumIntegerDivision_class " where + " instance_Num_NumIntegerDivision_Word_bitSequence_dict = ((| + + div_method = bitSeqDiv |) )" + + +definition instance_Num_NumDivision_Word_bitSequence_dict :: "(bitSequence)NumDivision_class " where + " instance_Num_NumDivision_Word_bitSequence_dict = ((| + + numDivision_method = bitSeqDiv |) )" + + +(*val bitSeqMod : bitSequence -> bitSequence -> bitSequence*) +definition bitSeqMod :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqMod bs1 bs2 = ( bitSeqArithBinOp (op mod) bs1 bs2 )" + + +definition instance_Num_NumRemainder_Word_bitSequence_dict :: "(bitSequence)NumRemainder_class " where + " instance_Num_NumRemainder_Word_bitSequence_dict = ((| + + mod_method = bitSeqMod |) )" + + +(*val bitSeqMin : bitSequence -> bitSequence -> bitSequence*) +definition bitSeqMin :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqMin bs1 bs2 = ( bitSeqArithBinOp min bs1 bs2 )" + + +(*val bitSeqMax : bitSequence -> bitSequence -> bitSequence*) +definition bitSeqMax :: " bitSequence \<Rightarrow> bitSequence \<Rightarrow> bitSequence " where + " bitSeqMax bs1 bs2 = ( bitSeqArithBinOp max bs1 bs2 )" + + +definition instance_Basic_classes_OrdMaxMin_Word_bitSequence_dict :: "(bitSequence)OrdMaxMin_class " where + " instance_Basic_classes_OrdMaxMin_Word_bitSequence_dict = ((| + + max_method = bitSeqMax, + + min_method = bitSeqMin |) )" + + + + + +(* ========================================================================== *) +(* Interface for bitoperations *) +(* ========================================================================== *) + +record 'a WordNot_class= + + lnot_method ::" 'a \<Rightarrow> 'a " + + + +record 'a WordAnd_class= + + land_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +record 'a WordOr_class= + + lor_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + + +record 'a WordXor_class= + + lxor_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +record 'a WordLsl_class= + + lsl_method ::" 'a \<Rightarrow> nat \<Rightarrow> 'a " + + + +record 'a WordLsr_class= + + lsr_method ::" 'a \<Rightarrow> nat \<Rightarrow> 'a " + + + +record 'a WordAsr_class= + + asr_method ::" 'a \<Rightarrow> nat \<Rightarrow> 'a " + + + +(* ----------------------- *) +(* bitSequence *) +(* ----------------------- *) + +definition instance_Word_WordNot_Word_bitSequence_dict :: "(bitSequence)WordNot_class " where + " instance_Word_WordNot_Word_bitSequence_dict = ((| + + lnot_method = bitSeqNot |) )" + + +definition instance_Word_WordAnd_Word_bitSequence_dict :: "(bitSequence)WordAnd_class " where + " instance_Word_WordAnd_Word_bitSequence_dict = ((| + + land_method = bitSeqAnd |) )" + + +definition instance_Word_WordOr_Word_bitSequence_dict :: "(bitSequence)WordOr_class " where + " instance_Word_WordOr_Word_bitSequence_dict = ((| + + lor_method = bitSeqOr |) )" + + +definition instance_Word_WordXor_Word_bitSequence_dict :: "(bitSequence)WordXor_class " where + " instance_Word_WordXor_Word_bitSequence_dict = ((| + + lxor_method = bitSeqXor |) )" + + +definition instance_Word_WordLsl_Word_bitSequence_dict :: "(bitSequence)WordLsl_class " where + " instance_Word_WordLsl_Word_bitSequence_dict = ((| + + lsl_method = bitSeqShiftLeft |) )" + + +definition instance_Word_WordLsr_Word_bitSequence_dict :: "(bitSequence)WordLsr_class " where + " instance_Word_WordLsr_Word_bitSequence_dict = ((| + + lsr_method = bitSeqLogicalShiftRight |) )" + + +definition instance_Word_WordAsr_Word_bitSequence_dict :: "(bitSequence)WordAsr_class " where + " instance_Word_WordAsr_Word_bitSequence_dict = ((| + + asr_method = bitSeqArithmeticShiftRight |) )" + + + +(* ----------------------- *) +(* int32 *) +(* ----------------------- *) + +(*val int32Lnot : int32 -> int32*) (* XXX: fix *) + +definition instance_Word_WordNot_Num_int32_dict :: "( 32 word)WordNot_class " where + " instance_Word_WordNot_Num_int32_dict = ((| + + lnot_method = (\<lambda> w. (NOT w))|) )" + + + +(*val int32Lor : int32 -> int32 -> int32*) (* XXX: fix *) + +definition instance_Word_WordOr_Num_int32_dict :: "( 32 word)WordOr_class " where + " instance_Word_WordOr_Num_int32_dict = ((| + + lor_method = (op OR)|) )" + + +(*val int32Lxor : int32 -> int32 -> int32*) (* XXX: fix *) + +definition instance_Word_WordXor_Num_int32_dict :: "( 32 word)WordXor_class " where + " instance_Word_WordXor_Num_int32_dict = ((| + + lxor_method = (op XOR)|) )" + + +(*val int32Land : int32 -> int32 -> int32*) (* XXX: fix *) + +definition instance_Word_WordAnd_Num_int32_dict :: "( 32 word)WordAnd_class " where + " instance_Word_WordAnd_Num_int32_dict = ((| + + land_method = (op AND)|) )" + + +(*val int32Lsl : int32 -> nat -> int32*) (* XXX: fix *) + +definition instance_Word_WordLsl_Num_int32_dict :: "( 32 word)WordLsl_class " where + " instance_Word_WordLsl_Num_int32_dict = ((| + + lsl_method = (op<<)|) )" + + +(*val int32Lsr : int32 -> nat -> int32*) (* XXX: fix *) + +definition instance_Word_WordLsr_Num_int32_dict :: "( 32 word)WordLsr_class " where + " instance_Word_WordLsr_Num_int32_dict = ((| + + lsr_method = (op>>)|) )" + + + +(*val int32Asr : int32 -> nat -> int32*) (* XXX: fix *) + +definition instance_Word_WordAsr_Num_int32_dict :: "( 32 word)WordAsr_class " where + " instance_Word_WordAsr_Num_int32_dict = ((| + + asr_method = (op>>>)|) )" + + + +(* ----------------------- *) +(* int64 *) +(* ----------------------- *) + +(*val int64Lnot : int64 -> int64*) (* XXX: fix *) + +definition instance_Word_WordNot_Num_int64_dict :: "( 64 word)WordNot_class " where + " instance_Word_WordNot_Num_int64_dict = ((| + + lnot_method = (\<lambda> w. (NOT w))|) )" + + +(*val int64Lor : int64 -> int64 -> int64*) (* XXX: fix *) + +definition instance_Word_WordOr_Num_int64_dict :: "( 64 word)WordOr_class " where + " instance_Word_WordOr_Num_int64_dict = ((| + + lor_method = (op OR)|) )" + + +(*val int64Lxor : int64 -> int64 -> int64*) (* XXX: fix *) + +definition instance_Word_WordXor_Num_int64_dict :: "( 64 word)WordXor_class " where + " instance_Word_WordXor_Num_int64_dict = ((| + + lxor_method = (op XOR)|) )" + + +(*val int64Land : int64 -> int64 -> int64*) (* XXX: fix *) + +definition instance_Word_WordAnd_Num_int64_dict :: "( 64 word)WordAnd_class " where + " instance_Word_WordAnd_Num_int64_dict = ((| + + land_method = (op AND)|) )" + + +(*val int64Lsl : int64 -> nat -> int64*) (* XXX: fix *) + +definition instance_Word_WordLsl_Num_int64_dict :: "( 64 word)WordLsl_class " where + " instance_Word_WordLsl_Num_int64_dict = ((| + + lsl_method = (op<<)|) )" + + +(*val int64Lsr : int64 -> nat -> int64*) (* XXX: fix *) + +definition instance_Word_WordLsr_Num_int64_dict :: "( 64 word)WordLsr_class " where + " instance_Word_WordLsr_Num_int64_dict = ((| + + lsr_method = (op>>)|) )" + + +(*val int64Asr : int64 -> nat -> int64*) (* XXX: fix *) + +definition instance_Word_WordAsr_Num_int64_dict :: "( 64 word)WordAsr_class " where + " instance_Word_WordAsr_Num_int64_dict = ((| + + asr_method = (op>>>)|) )" + + + +(* ----------------------- *) +(* Words via bit sequences *) +(* ----------------------- *) + +(*val defaultLnot : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a*) +definition defaultLnot :: "(bitSequence \<Rightarrow> 'a)\<Rightarrow>('a \<Rightarrow> bitSequence)\<Rightarrow> 'a \<Rightarrow> 'a " where + " defaultLnot fromBitSeq toBitSeq x = ( fromBitSeq (bitSeqNegate (toBitSeq x)))" + + +(*val defaultLand : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a -> 'a*) +definition defaultLand :: "(bitSequence \<Rightarrow> 'a)\<Rightarrow>('a \<Rightarrow> bitSequence)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a " where + " defaultLand fromBitSeq toBitSeq x1 x2 = ( fromBitSeq (bitSeqAnd (toBitSeq x1) (toBitSeq x2)))" + + +(*val defaultLor : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a -> 'a*) +definition defaultLor :: "(bitSequence \<Rightarrow> 'a)\<Rightarrow>('a \<Rightarrow> bitSequence)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a " where + " defaultLor fromBitSeq toBitSeq x1 x2 = ( fromBitSeq (bitSeqOr (toBitSeq x1) (toBitSeq x2)))" + + +(*val defaultLxor : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a -> 'a*) +definition defaultLxor :: "(bitSequence \<Rightarrow> 'a)\<Rightarrow>('a \<Rightarrow> bitSequence)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a " where + " defaultLxor fromBitSeq toBitSeq x1 x2 = ( fromBitSeq (bitSeqXor (toBitSeq x1) (toBitSeq x2)))" + + +(*val defaultLsl : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> nat -> 'a*) +definition defaultLsl :: "(bitSequence \<Rightarrow> 'a)\<Rightarrow>('a \<Rightarrow> bitSequence)\<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a " where + " defaultLsl fromBitSeq toBitSeq x n = ( fromBitSeq (bitSeqShiftLeft (toBitSeq x) n))" + + +(*val defaultLsr : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> nat -> 'a*) +definition defaultLsr :: "(bitSequence \<Rightarrow> 'a)\<Rightarrow>('a \<Rightarrow> bitSequence)\<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a " where + " defaultLsr fromBitSeq toBitSeq x n = ( fromBitSeq (bitSeqLogicalShiftRight (toBitSeq x) n))" + + +(*val defaultAsr : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> nat -> 'a*) +definition defaultAsr :: "(bitSequence \<Rightarrow> 'a)\<Rightarrow>('a \<Rightarrow> bitSequence)\<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a " where + " defaultAsr fromBitSeq toBitSeq x n = ( fromBitSeq (bitSeqArithmeticShiftRight (toBitSeq x) n))" + + +(* ----------------------- *) +(* integer *) +(* ----------------------- *) + +(*val integerLnot : integer -> integer*) +definition integerLnot :: " int \<Rightarrow> int " where + " integerLnot i = ( - (i +( 1 :: int)))" + + +definition instance_Word_WordNot_Num_integer_dict :: "(int)WordNot_class " where + " instance_Word_WordNot_Num_integer_dict = ((| + + lnot_method = integerLnot |) )" + + + +(*val integerLor : integer -> integer -> integer*) +definition integerLor :: " int \<Rightarrow> int \<Rightarrow> int " where + " integerLor i1 i2 = ( defaultLor integerFromBitSeq (bitSeqFromInteger None) i1 i2 )" + + +definition instance_Word_WordOr_Num_integer_dict :: "(int)WordOr_class " where + " instance_Word_WordOr_Num_integer_dict = ((| + + lor_method = integerLor |) )" + + +(*val integerLxor : integer -> integer -> integer*) +definition integerLxor :: " int \<Rightarrow> int \<Rightarrow> int " where + " integerLxor i1 i2 = ( defaultLxor integerFromBitSeq (bitSeqFromInteger None) i1 i2 )" + + +definition instance_Word_WordXor_Num_integer_dict :: "(int)WordXor_class " where + " instance_Word_WordXor_Num_integer_dict = ((| + + lxor_method = integerLxor |) )" + + +(*val integerLand : integer -> integer -> integer*) +definition integerLand :: " int \<Rightarrow> int \<Rightarrow> int " where + " integerLand i1 i2 = ( defaultLand integerFromBitSeq (bitSeqFromInteger None) i1 i2 )" + + +definition instance_Word_WordAnd_Num_integer_dict :: "(int)WordAnd_class " where + " instance_Word_WordAnd_Num_integer_dict = ((| + + land_method = integerLand |) )" + + +(*val integerLsl : integer -> nat -> integer*) +definition integerLsl :: " int \<Rightarrow> nat \<Rightarrow> int " where + " integerLsl i n = ( defaultLsl integerFromBitSeq (bitSeqFromInteger None) i n )" + + +definition instance_Word_WordLsl_Num_integer_dict :: "(int)WordLsl_class " where + " instance_Word_WordLsl_Num_integer_dict = ((| + + lsl_method = integerLsl |) )" + + +(*val integerAsr : integer -> nat -> integer*) +definition integerAsr :: " int \<Rightarrow> nat \<Rightarrow> int " where + " integerAsr i n = ( defaultAsr integerFromBitSeq (bitSeqFromInteger None) i n )" + + +definition instance_Word_WordLsr_Num_integer_dict :: "(int)WordLsr_class " where + " instance_Word_WordLsr_Num_integer_dict = ((| + + lsr_method = integerAsr |) )" + + +definition instance_Word_WordAsr_Num_integer_dict :: "(int)WordAsr_class " where + " instance_Word_WordAsr_Num_integer_dict = ((| + + asr_method = integerAsr |) )" + + + +(* ----------------------- *) +(* int *) +(* ----------------------- *) + +(* sometimes it is convenient to be able to perform bit-operations on ints. + However, since int is not well-defined (it has different size on different systems), + it should be used very carefully and only for operations that don't depend on the + bitwidth of int *) + +(*val intFromBitSeq : bitSequence -> int*) +definition intFromBitSeq :: " bitSequence \<Rightarrow> int " where + " intFromBitSeq bs = ( (integerFromBitSeq (resizeBitSeq (Some(( 31 :: nat))) bs)))" + + + +(*val bitSeqFromInt : int -> bitSequence*) +definition bitSeqFromInt :: " int \<Rightarrow> bitSequence " where + " bitSeqFromInt i = ( bitSeqFromInteger (Some(( 31 :: nat))) ( i))" + + + +(*val intLnot : int -> int*) +definition intLnot :: " int \<Rightarrow> int " where + " intLnot i = ( - (i +( 1 :: int)))" + + +definition instance_Word_WordNot_Num_int_dict :: "(int)WordNot_class " where + " instance_Word_WordNot_Num_int_dict = ((| + + lnot_method = intLnot |) )" + + +(*val intLor : int -> int -> int*) +definition intLor :: " int \<Rightarrow> int \<Rightarrow> int " where + " intLor i1 i2 = ( defaultLor intFromBitSeq bitSeqFromInt i1 i2 )" + + +definition instance_Word_WordOr_Num_int_dict :: "(int)WordOr_class " where + " instance_Word_WordOr_Num_int_dict = ((| + + lor_method = intLor |) )" + + +(*val intLxor : int -> int -> int*) +definition intLxor :: " int \<Rightarrow> int \<Rightarrow> int " where + " intLxor i1 i2 = ( defaultLxor intFromBitSeq bitSeqFromInt i1 i2 )" + + +definition instance_Word_WordXor_Num_int_dict :: "(int)WordXor_class " where + " instance_Word_WordXor_Num_int_dict = ((| + + lxor_method = intLxor |) )" + + +(*val intLand : int -> int -> int*) +definition intLand :: " int \<Rightarrow> int \<Rightarrow> int " where + " intLand i1 i2 = ( defaultLand intFromBitSeq bitSeqFromInt i1 i2 )" + + +definition instance_Word_WordAnd_Num_int_dict :: "(int)WordAnd_class " where + " instance_Word_WordAnd_Num_int_dict = ((| + + land_method = intLand |) )" + + +(*val intLsl : int -> nat -> int*) +definition intLsl :: " int \<Rightarrow> nat \<Rightarrow> int " where + " intLsl i n = ( defaultLsl intFromBitSeq bitSeqFromInt i n )" + + +definition instance_Word_WordLsl_Num_int_dict :: "(int)WordLsl_class " where + " instance_Word_WordLsl_Num_int_dict = ((| + + lsl_method = intLsl |) )" + + +(*val intAsr : int -> nat -> int*) +definition intAsr :: " int \<Rightarrow> nat \<Rightarrow> int " where + " intAsr i n = ( defaultAsr intFromBitSeq bitSeqFromInt i n )" + + +definition instance_Word_WordAsr_Num_int_dict :: "(int)WordAsr_class " where + " instance_Word_WordAsr_Num_int_dict = ((| + + asr_method = intAsr |) )" + + + + +(* ----------------------- *) +(* natural *) +(* ----------------------- *) + +(* some operations work also on positive numbers *) + +(*val naturalFromBitSeq : bitSequence -> natural*) +definition naturalFromBitSeq :: " bitSequence \<Rightarrow> nat " where + " naturalFromBitSeq bs = ( nat (abs (integerFromBitSeq bs)))" + + +(*val bitSeqFromNatural : maybe nat -> natural -> bitSequence*) +definition bitSeqFromNatural :: "(nat)option \<Rightarrow> nat \<Rightarrow> bitSequence " where + " bitSeqFromNatural len n = ( bitSeqFromInteger len (int n))" + + +(*val naturalLor : natural -> natural -> natural*) +definition naturalLor :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " naturalLor i1 i2 = ( defaultLor naturalFromBitSeq (bitSeqFromNatural None) i1 i2 )" + + +definition instance_Word_WordOr_Num_natural_dict :: "(nat)WordOr_class " where + " instance_Word_WordOr_Num_natural_dict = ((| + + lor_method = naturalLor |) )" + + +(*val naturalLxor : natural -> natural -> natural*) +definition naturalLxor :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " naturalLxor i1 i2 = ( defaultLxor naturalFromBitSeq (bitSeqFromNatural None) i1 i2 )" + + +definition instance_Word_WordXor_Num_natural_dict :: "(nat)WordXor_class " where + " instance_Word_WordXor_Num_natural_dict = ((| + + lxor_method = naturalLxor |) )" + + +(*val naturalLand : natural -> natural -> natural*) +definition naturalLand :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " naturalLand i1 i2 = ( defaultLand naturalFromBitSeq (bitSeqFromNatural None) i1 i2 )" + + +definition instance_Word_WordAnd_Num_natural_dict :: "(nat)WordAnd_class " where + " instance_Word_WordAnd_Num_natural_dict = ((| + + land_method = naturalLand |) )" + + +(*val naturalLsl : natural -> nat -> natural*) +definition naturalLsl :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " naturalLsl i n = ( defaultLsl naturalFromBitSeq (bitSeqFromNatural None) i n )" + + +definition instance_Word_WordLsl_Num_natural_dict :: "(nat)WordLsl_class " where + " instance_Word_WordLsl_Num_natural_dict = ((| + + lsl_method = naturalLsl |) )" + + +(*val naturalAsr : natural -> nat -> natural*) +definition naturalAsr :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " naturalAsr i n = ( defaultAsr naturalFromBitSeq (bitSeqFromNatural None) i n )" + + +definition instance_Word_WordLsr_Num_natural_dict :: "(nat)WordLsr_class " where + " instance_Word_WordLsr_Num_natural_dict = ((| + + lsr_method = naturalAsr |) )" + + +definition instance_Word_WordAsr_Num_natural_dict :: "(nat)WordAsr_class " where + " instance_Word_WordAsr_Num_natural_dict = ((| + + asr_method = naturalAsr |) )" + + + +(* ----------------------- *) +(* nat *) +(* ----------------------- *) + +(* sometimes it is convenient to be able to perform bit-operations on nats. + However, since nat is not well-defined (it has different size on different systems), + it should be used very carefully and only for operations that don't depend on the + bitwidth of nat *) + +(*val natFromBitSeq : bitSequence -> nat*) +definition natFromBitSeq :: " bitSequence \<Rightarrow> nat " where + " natFromBitSeq bs = ( (naturalFromBitSeq (resizeBitSeq (Some(( 31 :: nat))) bs)))" + + + +(*val bitSeqFromNat : nat -> bitSequence*) +definition bitSeqFromNat :: " nat \<Rightarrow> bitSequence " where + " bitSeqFromNat i = ( bitSeqFromNatural (Some(( 31 :: nat))) ( i))" + + + +(*val natLor : nat -> nat -> nat*) +definition natLor :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " natLor i1 i2 = ( defaultLor natFromBitSeq bitSeqFromNat i1 i2 )" + + +definition instance_Word_WordOr_nat_dict :: "(nat)WordOr_class " where + " instance_Word_WordOr_nat_dict = ((| + + lor_method = natLor |) )" + + +(*val natLxor : nat -> nat -> nat*) +definition natLxor :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " natLxor i1 i2 = ( defaultLxor natFromBitSeq bitSeqFromNat i1 i2 )" + + +definition instance_Word_WordXor_nat_dict :: "(nat)WordXor_class " where + " instance_Word_WordXor_nat_dict = ((| + + lxor_method = natLxor |) )" + + +(*val natLand : nat -> nat -> nat*) +definition natLand :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " natLand i1 i2 = ( defaultLand natFromBitSeq bitSeqFromNat i1 i2 )" + + +definition instance_Word_WordAnd_nat_dict :: "(nat)WordAnd_class " where + " instance_Word_WordAnd_nat_dict = ((| + + land_method = natLand |) )" + + +(*val natLsl : nat -> nat -> nat*) +definition natLsl :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " natLsl i n = ( defaultLsl natFromBitSeq bitSeqFromNat i n )" + + +definition instance_Word_WordLsl_nat_dict :: "(nat)WordLsl_class " where + " instance_Word_WordLsl_nat_dict = ((| + + lsl_method = natLsl |) )" + + +(*val natAsr : nat -> nat -> nat*) +definition natAsr :: " nat \<Rightarrow> nat \<Rightarrow> nat " where + " natAsr i n = ( defaultAsr natFromBitSeq bitSeqFromNat i n )" + + +definition instance_Word_WordAsr_nat_dict :: "(nat)WordAsr_class " where + " instance_Word_WordAsr_nat_dict = ((| + + asr_method = natAsr |) )" + + +end diff --git a/snapshots/isabelle/lib/lem/ROOT b/snapshots/isabelle/lib/lem/ROOT new file mode 100644 index 00000000..443687f9 --- /dev/null +++ b/snapshots/isabelle/lib/lem/ROOT @@ -0,0 +1,7 @@ +session LEM = "HOL-Word" + + description {* + HOL + LEM specific theories + *} + theories Lem_pervasives Lem_pervasives_extra + + diff --git a/snapshots/isabelle/lib/sail/Hoare.thy b/snapshots/isabelle/lib/sail/Hoare.thy new file mode 100644 index 00000000..ee7a5fa6 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Hoare.thy @@ -0,0 +1,320 @@ +theory Hoare + imports + State_lemmas + "HOL-Eisbach.Eisbach_Tools" +begin + +(*adhoc_overloading + Monad_Syntax.bind State_monad.bindS*) + +section \<open>Hoare logic for the state, exception and nondeterminism monad\<close> + +subsection \<open>Hoare triples\<close> + +type_synonym 'regs predS = "'regs sequential_state \<Rightarrow> bool" + +definition PrePost :: "'regs predS \<Rightarrow> ('regs, 'a, 'e) monadS \<Rightarrow> (('a, 'e) result \<Rightarrow> 'regs predS) \<Rightarrow> bool" + where "PrePost P f Q \<equiv> (\<forall>s. P s \<longrightarrow> (\<forall>(r, s') \<in> f s. Q r s'))" + +lemma PrePostI: + assumes "\<And>s r s'. P s \<Longrightarrow> (r, s') \<in> f s \<Longrightarrow> Q r s'" + shows "PrePost P f Q" + using assms unfolding PrePost_def by auto + +lemma PrePost_elim: + assumes "PrePost P f Q" and "P s" and "(r, s') \<in> f s" + obtains "Q r s'" + using assms by (fastforce simp: PrePost_def) + +lemma PrePost_consequence: + assumes "PrePost A f B" + and "\<And>s. P s \<Longrightarrow> A s" and "\<And>v s. B v s \<Longrightarrow> Q v s" + shows "PrePost P f Q" + using assms unfolding PrePost_def by (blast intro: list.pred_mono_strong) + +lemma PrePost_strengthen_pre: + assumes "PrePost A f C" and "\<And>s. B s \<Longrightarrow> A s" + shows "PrePost B f C" + using assms by (rule PrePost_consequence) + +lemma PrePost_weaken_post: + assumes "PrePost A f B" and "\<And>v s. B v s \<Longrightarrow> C v s" + shows "PrePost A f C" + using assms by (blast intro: PrePost_consequence) + +named_theorems PrePost_intro + +lemma PrePost_True_post[PrePost_intro, intro, simp]: + "PrePost P m (\<lambda>_ _. True)" + unfolding PrePost_def by auto + +lemma PrePost_any: "PrePost (\<lambda>s. \<forall>(r, s') \<in> m s. Q r s') m Q" + unfolding PrePost_def by auto + +lemma PrePost_returnS[intro, PrePost_intro]: "PrePost (P (Value x)) (returnS x) P" + unfolding PrePost_def returnS_def by auto + +lemma PrePost_bindS[intro, PrePost_intro]: + assumes f: "\<And>s a s'. (Value a, s') \<in> m s \<Longrightarrow> PrePost (R a) (f a) Q" + and m: "PrePost P m (\<lambda>r. case r of Value a \<Rightarrow> R a | Ex e \<Rightarrow> Q (Ex e))" + shows "PrePost P (bindS m f) Q" +proof (intro PrePostI) + fix s r s' + assume P: "P s" and bind: "(r, s') \<in> bindS m f s" + from bind show "Q r s'" + proof (cases r s' m f s rule: bindS_cases) + case (Value a a' s'') + then have "R a' s''" using P m by (auto elim: PrePost_elim) + then show ?thesis using Value f by (auto elim: PrePost_elim) + next + case (Ex_Left e) + then show ?thesis using P m by (auto elim: PrePost_elim) + next + case (Ex_Right e a s'') + then have "R a s''" using P m by (auto elim: PrePost_elim) + then show ?thesis using Ex_Right f by (auto elim: PrePost_elim) + qed +qed + +lemma PrePost_bindS_ignore: + assumes f: "PrePost R f Q" + and m : "PrePost P m (\<lambda>r. case r of Value a \<Rightarrow> R | Ex e \<Rightarrow> Q (Ex e))" + shows "PrePost P (bindS m (\<lambda>_. f)) Q" + using assms by auto + +lemma PrePost_bindS_unit: + fixes m :: "('regs, unit, 'e) monadS" + assumes f: "PrePost R (f ()) Q" + and m: "PrePost P m (\<lambda>r. case r of Value a \<Rightarrow> R | Ex e \<Rightarrow> Q (Ex e))" + shows "PrePost P (bindS m f) Q" + using assms by auto + +lemma PrePost_readS[intro, PrePost_intro]: "PrePost (\<lambda>s. P (Value (f s)) s) (readS f) P" + unfolding PrePost_def readS_def returnS_def by auto + +lemma PrePost_updateS[intro, PrePost_intro]: "PrePost (\<lambda>s. P (Value ()) (f s)) (updateS f) P" + unfolding PrePost_def updateS_def returnS_def by auto + +lemma PrePost_if: + assumes "b \<Longrightarrow> PrePost P f Q" and "\<not>b \<Longrightarrow> PrePost P g Q" + shows "PrePost P (if b then f else g) Q" + using assms by auto + +lemma PrePost_if_branch[PrePost_intro]: + assumes "b \<Longrightarrow> PrePost Pf f Q" and "\<not>b \<Longrightarrow> PrePost Pg g Q" + shows "PrePost (if b then Pf else Pg) (if b then f else g) Q" + using assms by auto + +lemma PrePost_if_then: + assumes "b" and "PrePost P f Q" + shows "PrePost P (if b then f else g) Q" + using assms by auto + +lemma PrePost_if_else: + assumes "\<not>b" and "PrePost P g Q" + shows "PrePost P (if b then f else g) Q" + using assms by auto + +lemma PrePost_prod_cases[PrePost_intro]: + assumes "PrePost P (f (fst x) (snd x)) Q" + shows "PrePost P (case x of (a, b) \<Rightarrow> f a b) Q" + using assms by (auto split: prod.splits) + +lemma PrePost_option_cases[PrePost_intro]: + assumes "\<And>a. PrePost (PS a) (s a) Q" and "PrePost PN n Q" + shows "PrePost (case x of Some a \<Rightarrow> PS a | None \<Rightarrow> PN) (case x of Some a \<Rightarrow> s a | None \<Rightarrow> n) Q" + using assms by (auto split: option.splits) + +lemma PrePost_let[intro, PrePost_intro]: + assumes "PrePost P (m y) Q" + shows "PrePost P (let x = y in m x) Q" + using assms by auto + +lemma PrePost_assert_expS[intro, PrePost_intro]: "PrePost (if c then P (Value ()) else P (Ex (Failure m))) (assert_expS c m) P" + unfolding PrePost_def assert_expS_def by (auto simp: returnS_def failS_def) + +lemma PrePost_chooseS[intro, PrePost_intro]: "PrePost (\<lambda>s. \<forall>x \<in> xs. Q (Value x) s) (chooseS xs) Q" + by (auto simp: PrePost_def chooseS_def) + +lemma PrePost_failS[intro, PrePost_intro]: "PrePost (Q (Ex (Failure msg))) (failS msg) Q" + by (auto simp: PrePost_def failS_def) + +lemma case_result_combine[simp]: + "(case r of Value a \<Rightarrow> Q (Value a) | Ex e \<Rightarrow> Q (Ex e)) = Q r" + by (auto split: result.splits) + +lemma PrePost_foreachS_Nil[intro, simp, PrePost_intro]: + "PrePost (Q (Value vars)) (foreachS [] vars body) Q" + by auto + +lemma PrePost_foreachS_Cons: + assumes "\<And>s vars' s'. (Value vars', s') \<in> body x vars s \<Longrightarrow> PrePost (Q (Value vars')) (foreachS xs vars' body) Q" + and "PrePost (Q (Value vars)) (body x vars) Q" + shows "PrePost (Q (Value vars)) (foreachS (x # xs) vars body) Q" + using assms by fastforce + +lemma PrePost_foreachS_invariant: + assumes "\<And>x vars. x \<in> set xs \<Longrightarrow> PrePost (Q (Value vars)) (body x vars) Q" + shows "PrePost (Q (Value vars)) (foreachS xs vars body) Q" +proof (use assms in \<open>induction xs arbitrary: vars\<close>) + case (Cons x xs) + have "PrePost (Q (Value vars)) (bindS (body x vars) (\<lambda>vars. foreachS xs vars body)) Q" + proof (rule PrePost_bindS) + fix vars' + show "PrePost (Q (Value vars')) (foreachS xs vars' body) Q" + using Cons by auto + show "PrePost (Q (Value vars)) (body x vars) (\<lambda>r. case r of Value a \<Rightarrow> Q (Value a) | result.Ex e \<Rightarrow> Q (result.Ex e))" + unfolding case_result_combine + using Cons by auto + qed + then show ?case by auto +qed auto + +subsection \<open>Hoare quadruples\<close> + +text \<open>It is often convenient to treat the exception case separately. For this purpose, we use +a Hoare logic similar to the one used in [1]. It features not only Hoare triples, but also quadruples +with two postconditions: one for the case where the computation succeeds, and one for the case where +there is an exception. + +[1] D. Cock, G. Klein, and T. Sewell, ‘Secure Microkernels, State Monads and Scalable Refinement’, +in Theorem Proving in Higher Order Logics, 2008, pp. 167–182.\<close> + +definition PrePostE :: "'regs predS \<Rightarrow> ('regs, 'a, 'e) monadS \<Rightarrow> ('a \<Rightarrow> 'regs predS) \<Rightarrow> ('e ex \<Rightarrow> 'regs predS) \<Rightarrow> bool" + where "PrePostE P f Q E \<equiv> PrePost P f (\<lambda>v. case v of Value a \<Rightarrow> Q a | Ex e \<Rightarrow> E e)" + +lemmas PrePost_defs = PrePost_def PrePostE_def + +lemma PrePostE_I[case_names Val Err]: + assumes "\<And>s a s'. P s \<Longrightarrow> (Value a, s') \<in> f s \<Longrightarrow> Q a s'" + and "\<And>s e s'. P s \<Longrightarrow> (Ex e, s') \<in> f s \<Longrightarrow> E e s'" + shows "PrePostE P f Q E" + using assms unfolding PrePostE_def by (intro PrePostI) (auto split: result.splits) + +lemma PrePostE_PrePost: + assumes "PrePost P m (\<lambda>v. case v of Value a \<Rightarrow> Q a | Ex e \<Rightarrow> E e)" + shows "PrePostE P m Q E" + using assms unfolding PrePostE_def by auto + +lemma PrePostE_elim: + assumes "PrePostE P f Q E" and "P s" and "(r, s') \<in> f s" + obtains + (Val) v where "r = Value v" "Q v s'" + | (Ex) e where "r = Ex e" "E e s'" + using assms by (cases r; fastforce simp: PrePost_defs) + +lemma PrePostE_consequence: + assumes "PrePostE A f B C" + and "\<And>s. P s \<Longrightarrow> A s" and "\<And>v s. B v s \<Longrightarrow> Q v s" and "\<And>e s. C e s \<Longrightarrow> E e s" + shows "PrePostE P f Q E" + using assms unfolding PrePostE_def by (auto elim: PrePost_consequence split: result.splits) + +lemma PrePostE_strengthen_pre: + assumes "PrePostE R f Q E" and "\<And>s. P s \<Longrightarrow> R s" + shows "PrePostE P f Q E" + using assms PrePostE_consequence by blast + +lemma PrePostE_weaken_post: + assumes "PrePostE A f B E" and "\<And>v s. B v s \<Longrightarrow> C v s" + shows "PrePostE A f C E" + using assms by (blast intro: PrePostE_consequence) + +named_theorems PrePostE_intro + +lemma PrePostE_True_post[PrePost_intro, intro, simp]: + "PrePostE P m (\<lambda>_ _. True) (\<lambda>_ _. True)" + unfolding PrePost_defs by (auto split: result.splits) + +lemma PrePostE_any: "PrePostE (\<lambda>s. \<forall>(r, s') \<in> m s. case r of Value a \<Rightarrow> Q a s' | Ex e \<Rightarrow> E e s') m Q E" + by (intro PrePostE_I) auto + +lemma PrePostE_returnS[PrePostE_intro, intro, simp]: + "PrePostE (P x) (returnS x) P Q" + unfolding PrePostE_def by (auto intro: PrePost_strengthen_pre) + +lemma PrePostE_bindS[intro, PrePostE_intro]: + assumes f: "\<And>s a s'. (Value a, s') \<in> m s \<Longrightarrow> PrePostE (R a) (f a) Q E" + and m: "PrePostE P m R E" + shows "PrePostE P (bindS m f) Q E" + using assms + by (fastforce simp: PrePostE_def cong: result.case_cong) + +lemma PrePostE_bindS_ignore: + assumes f: "PrePostE R f Q E" + and m : "PrePostE P m (\<lambda>_. R) E" + shows "PrePostE P (bindS m (\<lambda>_. f)) Q E" + using assms by auto + +lemma PrePostE_bindS_unit: + fixes m :: "('regs, unit, 'e) monadS" + assumes f: "PrePostE R (f ()) Q E" + and m: "PrePostE P m (\<lambda>_. R) E" + shows "PrePostE P (bindS m f) Q E" + using assms by auto + +lemma PrePostE_readS[PrePostE_intro, intro]: "PrePostE (\<lambda>s. Q (f s) s) (readS f) Q E" + unfolding PrePostE_def by (auto intro: PrePost_strengthen_pre) + +lemma PrePostE_updateS[PrePostE_intro, intro]: "PrePostE (\<lambda>s. Q () (f s)) (updateS f) Q E" + unfolding PrePostE_def by (auto intro: PrePost_strengthen_pre) + +lemma PrePostE_if_branch[PrePostE_intro]: + assumes "b \<Longrightarrow> PrePostE Pf f Q E" and "\<not>b \<Longrightarrow> PrePostE Pg g Q E" + shows "PrePostE (if b then Pf else Pg) (if b then f else g) Q E" + using assms by (auto) + +lemma PrePostE_if: + assumes "b \<Longrightarrow> PrePostE P f Q E" and "\<not>b \<Longrightarrow> PrePostE P g Q E" + shows "PrePostE P (if b then f else g) Q E" + using assms by auto + +lemma PrePostE_if_then: + assumes "b" and "PrePostE P f Q E" + shows "PrePostE P (if b then f else g) Q E" + using assms by auto + +lemma PrePostE_if_else: + assumes "\<not> b" and "PrePostE P g Q E" + shows "PrePostE P (if b then f else g) Q E" + using assms by auto + +lemma PrePostE_prod_cases[PrePostE_intro]: + assumes "PrePostE P (f (fst x) (snd x)) Q E" + shows "PrePostE P (case x of (a, b) \<Rightarrow> f a b) Q E" + using assms by (auto split: prod.splits) + +lemma PrePostE_option_cases[PrePostE_intro]: + assumes "\<And>a. PrePostE (PS a) (s a) Q E" and "PrePostE PN n Q E" + shows "PrePostE (case x of Some a \<Rightarrow> PS a | None \<Rightarrow> PN) (case x of Some a \<Rightarrow> s a | None \<Rightarrow> n) Q E" + using assms by (auto split: option.splits) + +lemma PrePostE_let[PrePostE_intro]: + assumes "PrePostE P (m y) Q E" + shows "PrePostE P (let x = y in m x) Q E" + using assms by auto + +lemma PrePostE_assert_expS[PrePostE_intro, intro]: + "PrePostE (if c then P () else Q (Failure m)) (assert_expS c m) P Q" + unfolding PrePostE_def by (auto intro: PrePost_strengthen_pre) + +lemma PrePostE_failS[PrePost_intro, intro]: + "PrePostE (E (Failure msg)) (failS msg) Q E" + unfolding PrePostE_def by (auto intro: PrePost_strengthen_pre) + +lemma PrePostE_chooseS[intro, PrePostE_intro]: + "PrePostE (\<lambda>s. \<forall>x \<in> xs. Q x s) (chooseS xs) Q E" + unfolding PrePostE_def by (auto intro: PrePost_strengthen_pre) + +lemma PrePostE_foreachS_Cons: + assumes "\<And>s vars' s'. (Value vars', s') \<in> body x vars s \<Longrightarrow> PrePostE (Q vars') (foreachS xs vars' body) Q E" + and "PrePostE (Q vars) (body x vars) Q E" + shows "PrePostE (Q vars) (foreachS (x # xs) vars body) Q E" + using assms by fastforce + +lemma PrePostE_foreachS_invariant: + assumes "\<And>x vars. x \<in> set xs \<Longrightarrow> PrePostE (Q vars) (body x vars) Q E" + shows "PrePostE (Q vars) (foreachS xs vars body) Q E" + using assms unfolding PrePostE_def + by (intro PrePost_foreachS_invariant[THEN PrePost_strengthen_pre]) auto + +end diff --git a/snapshots/isabelle/lib/sail/Prompt.thy b/snapshots/isabelle/lib/sail/Prompt.thy new file mode 100644 index 00000000..5792e575 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Prompt.thy @@ -0,0 +1,150 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/prompt.lem.\<close> + +theory "Prompt" + +imports + Main + "Lem_pervasives_extra" + "Sail_values" + "Prompt_monad" + "Prompt_monad_lemmas" + +begin + +(*open import Pervasives_extra*) +(*open import Sail_impl_base*) +(*open import Sail_values*) +(*open import Prompt_monad*) +(*open import {isabelle} `Prompt_monad_lemmas`*) + +(*val >>= : forall 'rv 'a 'b 'e. monad 'rv 'a 'e -> ('a -> monad 'rv 'b 'e) -> monad 'rv 'b 'e*) + +(*val >> : forall 'rv 'b 'e. monad 'rv unit 'e -> monad 'rv 'b 'e -> monad 'rv 'b 'e*) + +(*val iter_aux : forall 'rv 'a 'e. integer -> (integer -> 'a -> monad 'rv unit 'e) -> list 'a -> monad 'rv unit 'e*) +fun iter_aux :: " int \<Rightarrow>(int \<Rightarrow> 'a \<Rightarrow>('rv,(unit),'e)monad)\<Rightarrow> 'a list \<Rightarrow>('rv,(unit),'e)monad " where + " iter_aux i f (x # xs) = ( f i x \<then> iter_aux (i +( 1 :: int)) f xs )" +|" iter_aux i f ([]) = ( return () )" + + +(*val iteri : forall 'rv 'a 'e. (integer -> 'a -> monad 'rv unit 'e) -> list 'a -> monad 'rv unit 'e*) +definition iteri :: "(int \<Rightarrow> 'a \<Rightarrow>('rv,(unit),'e)monad)\<Rightarrow> 'a list \<Rightarrow>('rv,(unit),'e)monad " where + " iteri f xs = ( iter_aux(( 0 :: int)) f xs )" + + +(*val iter : forall 'rv 'a 'e. ('a -> monad 'rv unit 'e) -> list 'a -> monad 'rv unit 'e*) +definition iter :: "('a \<Rightarrow>('rv,(unit),'e)monad)\<Rightarrow> 'a list \<Rightarrow>('rv,(unit),'e)monad " where + " iter f xs = ( iteri ( \<lambda>x . + (case x of _ => \<lambda> x . f x )) xs )" + + +(*val foreachM : forall 'a 'rv 'vars 'e. + list 'a -> 'vars -> ('a -> 'vars -> monad 'rv 'vars 'e) -> monad 'rv 'vars 'e*) +fun foreachM :: " 'a list \<Rightarrow> 'vars \<Rightarrow>('a \<Rightarrow> 'vars \<Rightarrow>('rv,'vars,'e)monad)\<Rightarrow>('rv,'vars,'e)monad " where + " foreachM ([]) vars body = ( return vars )" +|" foreachM (x # xs) vars body = ( + body x vars \<bind> (\<lambda> vars . + foreachM xs vars body))" + + +(*val and_boolM : forall 'rv 'e. monad 'rv bool 'e -> monad 'rv bool 'e -> monad 'rv bool 'e*) +definition and_boolM :: "('rv,(bool),'e)monad \<Rightarrow>('rv,(bool),'e)monad \<Rightarrow>('rv,(bool),'e)monad " where + " and_boolM l r = ( l \<bind> (\<lambda> l . if l then r else return False))" + + +(*val or_boolM : forall 'rv 'e. monad 'rv bool 'e -> monad 'rv bool 'e -> monad 'rv bool 'e*) +definition or_boolM :: "('rv,(bool),'e)monad \<Rightarrow>('rv,(bool),'e)monad \<Rightarrow>('rv,(bool),'e)monad " where + " or_boolM l r = ( l \<bind> (\<lambda> l . if l then return True else r))" + + +(*val bool_of_bitU_fail : forall 'rv 'e. bitU -> monad 'rv bool 'e*) +definition bool_of_bitU_fail :: " bitU \<Rightarrow>('rv,(bool),'e)monad " where + " bool_of_bitU_fail = ( \<lambda>x . + (case x of + B0 => return False + | B1 => return True + | BU => Fail (''bool_of_bitU'') + ) )" + + +(*val bool_of_bitU_oracle : forall 'rv 'e. bitU -> monad 'rv bool 'e*) +definition bool_of_bitU_oracle :: " bitU \<Rightarrow>('rv,(bool),'e)monad " where + " bool_of_bitU_oracle = ( \<lambda>x . + (case x of + B0 => return False + | B1 => return True + | BU => undefined_bool () + ) )" + + +(*val bools_of_bits_oracle : forall 'rv 'e. list bitU -> monad 'rv (list bool) 'e*) +definition bools_of_bits_oracle :: "(bitU)list \<Rightarrow>('rv,((bool)list),'e)monad " where + " bools_of_bits_oracle bits = ( + foreachM bits [] + (\<lambda> b bools . + bool_of_bitU_oracle b \<bind> (\<lambda> b . + return (bools @ [b]))))" + + +(*val of_bits_oracle : forall 'rv 'a 'e. Bitvector 'a => list bitU -> monad 'rv 'a 'e*) +definition of_bits_oracle :: " 'a Bitvector_class \<Rightarrow>(bitU)list \<Rightarrow>('rv,'a,'e)monad " where + " of_bits_oracle dict_Sail_values_Bitvector_a bits = ( + bools_of_bits_oracle bits \<bind> (\<lambda> bs . + return ((of_bools_method dict_Sail_values_Bitvector_a) bs)))" + + +(*val of_bits_fail : forall 'rv 'a 'e. Bitvector 'a => list bitU -> monad 'rv 'a 'e*) +definition of_bits_fail :: " 'a Bitvector_class \<Rightarrow>(bitU)list \<Rightarrow>('rv,'a,'e)monad " where + " of_bits_fail dict_Sail_values_Bitvector_a bits = ( maybe_fail (''of_bits'') ( + (of_bits_method dict_Sail_values_Bitvector_a) bits))" + + +(*val mword_oracle : forall 'rv 'a 'e. Size 'a => unit -> monad 'rv (mword 'a) 'e*) +definition mword_oracle :: " unit \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " mword_oracle _ = ( + bools_of_bits_oracle (repeat [BU] (int (len_of (TYPE(_) :: 'a itself)))) \<bind> (\<lambda> bs . + return (Word.of_bl bs)))" + + +(*val whileM : forall 'rv 'vars 'e. 'vars -> ('vars -> monad 'rv bool 'e) -> + ('vars -> monad 'rv 'vars 'e) -> monad 'rv 'vars 'e*) +function (sequential,domintros) whileM :: " 'vars \<Rightarrow>('vars \<Rightarrow>('rv,(bool),'e)monad)\<Rightarrow>('vars \<Rightarrow>('rv,'vars,'e)monad)\<Rightarrow>('rv,'vars,'e)monad " where + " whileM vars cond body = ( + cond vars \<bind> (\<lambda> cond_val . + if cond_val then + body vars \<bind> (\<lambda> vars . whileM vars cond body) + else return vars))" +by pat_completeness auto + + +(*val untilM : forall 'rv 'vars 'e. 'vars -> ('vars -> monad 'rv bool 'e) -> + ('vars -> monad 'rv 'vars 'e) -> monad 'rv 'vars 'e*) +function (sequential,domintros) untilM :: " 'vars \<Rightarrow>('vars \<Rightarrow>('rv,(bool),'e)monad)\<Rightarrow>('vars \<Rightarrow>('rv,'vars,'e)monad)\<Rightarrow>('rv,'vars,'e)monad " where + " untilM vars cond body = ( + body vars \<bind> (\<lambda> vars . + cond vars \<bind> (\<lambda> cond_val . + if cond_val then return vars else untilM vars cond body)))" +by pat_completeness auto + + +(*let write_two_regs r1 r2 vec = + let is_inc = + let is_inc_r1 = is_inc_of_reg r1 in + let is_inc_r2 = is_inc_of_reg r2 in + let () = ensure (is_inc_r1 = is_inc_r2) + write_two_regs called with vectors of different direction in + is_inc_r1 in + + let (size_r1 : integer) = size_of_reg r1 in + let (start_vec : integer) = get_start vec in + let size_vec = length vec in + let r1_v = + if is_inc + then slice vec start_vec (size_r1 - start_vec - 1) + else slice vec start_vec (start_vec - size_r1 - 1) in + let r2_v = + if is_inc + then slice vec (size_r1 - start_vec) (size_vec - start_vec) + else slice vec (start_vec - size_r1) (start_vec - size_vec) in + write_reg r1 r1_v >> write_reg r2 r2_v*) +end diff --git a/snapshots/isabelle/lib/sail/Prompt_monad.thy b/snapshots/isabelle/lib/sail/Prompt_monad.thy new file mode 100644 index 00000000..e4aecfba --- /dev/null +++ b/snapshots/isabelle/lib/sail/Prompt_monad.thy @@ -0,0 +1,267 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/prompt_monad.lem.\<close> + +theory "Prompt_monad" + +imports + Main + "Lem_pervasives_extra" + "Sail_instr_kinds" + "Sail_values" + +begin + +(*open import Pervasives_extra*) +(*open import Sail_impl_base*) +(*open import Sail_instr_kinds*) +(*open import Sail_values*) + +type_synonym register_name =" string " +type_synonym address =" bitU list " + +datatype( 'regval, 'a, 'e) monad = + Done " 'a " + (* Read a number of bytes from memory, returned in little endian order *) + | Read_mem " read_kind " " address " " nat " " ( memory_byte list \<Rightarrow> ('regval, 'a, 'e) monad)" + (* Read the tag of a memory address *) + | Read_tag " address " " (bitU \<Rightarrow> ('regval, 'a, 'e) monad)" + (* Tell the system a write is imminent, at address lifted, of size nat *) + | Write_ea " write_kind " " address " " nat " " ('regval, 'a, 'e) monad " + (* Request the result of store-exclusive *) + | Excl_res " (bool \<Rightarrow> ('regval, 'a, 'e) monad)" + (* Request to write memory at last signalled address. Memory value should be 8 + times the size given in ea signal, given in little endian order *) + | Write_memv " memory_byte list " " (bool \<Rightarrow> ('regval, 'a, 'e) monad)" + (* Request to write the tag at given address. *) + | Write_tag " address " " bitU " " (bool \<Rightarrow> ('regval, 'a, 'e) monad)" + (* Tell the system to dynamically recalculate dependency footprint *) + | Footprint " ('regval, 'a, 'e) monad " + (* Request a memory barrier *) + | Barrier " barrier_kind " " ('regval, 'a, 'e) monad " + (* Request to read register, will track dependency when mode.track_values *) + | Read_reg " register_name " " ('regval \<Rightarrow> ('regval, 'a, 'e) monad)" + (* Request to write register *) + | Write_reg " register_name " " 'regval " " ('regval, 'a, 'e) monad " + | Undefined " (bool \<Rightarrow> ('regval, 'a, 'e) monad)" + (* Print debugging or tracing information *) + | Print " string " " ('regval, 'a, 'e) monad " + (*Result of a failed assert with possible error message to report*) + | Fail " string " + (* Exception of type 'e *) + | Exception " 'e " + +(*val return : forall 'rv 'a 'e. 'a -> monad 'rv 'a 'e*) +definition return :: " 'a \<Rightarrow>('rv,'a,'e)monad " where + " return a = ( Done a )" + + +(*val bind : forall 'rv 'a 'b 'e. monad 'rv 'a 'e -> ('a -> monad 'rv 'b 'e) -> monad 'rv 'b 'e*) +function (sequential,domintros) bind :: "('rv,'a,'e)monad \<Rightarrow>('a \<Rightarrow>('rv,'b,'e)monad)\<Rightarrow>('rv,'b,'e)monad " where + " bind (Done a) f = ( f a )" +|" bind (Read_mem rk a sz k) f = ( Read_mem rk a sz (\<lambda> v . bind (k v) f))" +|" bind (Read_tag a k) f = ( Read_tag a (\<lambda> v . bind (k v) f))" +|" bind (Write_memv descr k) f = ( Write_memv descr (\<lambda> v . bind (k v) f))" +|" bind (Write_tag a t k) f = ( Write_tag a t (\<lambda> v . bind (k v) f))" +|" bind (Read_reg descr k) f = ( Read_reg descr (\<lambda> v . bind (k v) f))" +|" bind (Excl_res k) f = ( Excl_res (\<lambda> v . bind (k v) f))" +|" bind (Undefined k) f = ( Undefined (\<lambda> v . bind (k v) f))" +|" bind (Write_ea wk a sz k) f = ( Write_ea wk a sz (bind k f))" +|" bind (Footprint k) f = ( Footprint (bind k f))" +|" bind (Barrier bk k) f = ( Barrier bk (bind k f))" +|" bind (Write_reg r v k) f = ( Write_reg r v (bind k f))" +|" bind (Print msg k) f = ( Print msg (bind k f))" +|" bind (Fail descr) f = ( Fail descr )" +|" bind (Exception e) f = ( Exception e )" +by pat_completeness auto + + +(*val exit : forall 'rv 'a 'e. unit -> monad 'rv 'a 'e*) +definition exit0 :: " unit \<Rightarrow>('rv,'a,'e)monad " where + " exit0 _ = ( Fail (''exit''))" + + +(*val undefined_bool : forall 'rv 'e. unit -> monad 'rv bool 'e*) +definition undefined_bool :: " unit \<Rightarrow>('rv,(bool),'e)monad " where + " undefined_bool _ = ( Undefined return )" + + +(*val assert_exp : forall 'rv 'e. bool -> string -> monad 'rv unit 'e*) +definition assert_exp :: " bool \<Rightarrow> string \<Rightarrow>('rv,(unit),'e)monad " where + " assert_exp exp msg = ( if exp then Done () else Fail msg )" + + +(*val throw : forall 'rv 'a 'e. 'e -> monad 'rv 'a 'e*) +definition throw :: " 'e \<Rightarrow>('rv,'a,'e)monad " where + " throw e = ( Exception e )" + + +(*val try_catch : forall 'rv 'a 'e1 'e2. monad 'rv 'a 'e1 -> ('e1 -> monad 'rv 'a 'e2) -> monad 'rv 'a 'e2*) +function (sequential,domintros) try_catch :: "('rv,'a,'e1)monad \<Rightarrow>('e1 \<Rightarrow>('rv,'a,'e2)monad)\<Rightarrow>('rv,'a,'e2)monad " where + " try_catch (Done a) h = ( Done a )" +|" try_catch (Read_mem rk a sz k) h = ( Read_mem rk a sz (\<lambda> v . try_catch (k v) h))" +|" try_catch (Read_tag a k) h = ( Read_tag a (\<lambda> v . try_catch (k v) h))" +|" try_catch (Write_memv descr k) h = ( Write_memv descr (\<lambda> v . try_catch (k v) h))" +|" try_catch (Write_tag a t k) h = ( Write_tag a t (\<lambda> v . try_catch (k v) h))" +|" try_catch (Read_reg descr k) h = ( Read_reg descr (\<lambda> v . try_catch (k v) h))" +|" try_catch (Excl_res k) h = ( Excl_res (\<lambda> v . try_catch (k v) h))" +|" try_catch (Undefined k) h = ( Undefined (\<lambda> v . try_catch (k v) h))" +|" try_catch (Write_ea wk a sz k) h = ( Write_ea wk a sz (try_catch k h))" +|" try_catch (Footprint k) h = ( Footprint (try_catch k h))" +|" try_catch (Barrier bk k) h = ( Barrier bk (try_catch k h))" +|" try_catch (Write_reg r v k) h = ( Write_reg r v (try_catch k h))" +|" try_catch (Print msg k) h = ( Print msg (try_catch k h))" +|" try_catch (Fail descr) h = ( Fail descr )" +|" try_catch (Exception e) h = ( h e )" +by pat_completeness auto + + +(* For early return, we abuse exceptions by throwing and catching + the return value. The exception type is either 'r 'e, where Right e + represents a proper exception and Left r an early return of value r. *) +type_synonym( 'rv, 'a, 'r, 'e) monadR =" ('rv, 'a, ( ('r, 'e)sum)) monad " + +(*val early_return : forall 'rv 'a 'r 'e. 'r -> monadR 'rv 'a 'r 'e*) +definition early_return :: " 'r \<Rightarrow>('rv,'a,(('r,'e)sum))monad " where + " early_return r = ( throw (Inl r))" + + +(*val catch_early_return : forall 'rv 'a 'e. monadR 'rv 'a 'a 'e -> monad 'rv 'a 'e*) +definition catch_early_return :: "('rv,'a,(('a,'e)sum))monad \<Rightarrow>('rv,'a,'e)monad " where + " catch_early_return m = ( + try_catch m + (\<lambda>x . (case x of Inl a => return a | Inr e => throw e )))" + + +(* Lift to monad with early return by wrapping exceptions *) +(*val liftR : forall 'rv 'a 'r 'e. monad 'rv 'a 'e -> monadR 'rv 'a 'r 'e*) +definition liftR :: "('rv,'a,'e)monad \<Rightarrow>('rv,'a,(('r,'e)sum))monad " where + " liftR m = ( try_catch m (\<lambda> e . throw (Inr e)))" + + +(* Catch exceptions in the presence of early returns *) +(*val try_catchR : forall 'rv 'a 'r 'e1 'e2. monadR 'rv 'a 'r 'e1 -> ('e1 -> monadR 'rv 'a 'r 'e2) -> monadR 'rv 'a 'r 'e2*) +definition try_catchR :: "('rv,'a,(('r,'e1)sum))monad \<Rightarrow>('e1 \<Rightarrow>('rv,'a,(('r,'e2)sum))monad)\<Rightarrow>('rv,'a,(('r,'e2)sum))monad " where + " try_catchR m h = ( + try_catch m + (\<lambda>x . (case x of Inl r => throw (Inl r) | Inr e => h e )))" + + +(*val maybe_fail : forall 'rv 'a 'e. string -> maybe 'a -> monad 'rv 'a 'e*) +definition maybe_fail :: " string \<Rightarrow> 'a option \<Rightarrow>('rv,'a,'e)monad " where + " maybe_fail msg = ( \<lambda>x . + (case x of Some a => return a | None => Fail msg ) )" + + +(*val read_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte) 'e*) +definition read_mem_bytes :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> read_kind \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>('rv,((memory_byte)list),'e)monad " where + " read_mem_bytes dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b rk addr sz = ( + Read_mem rk ((bits_of_method dict_Sail_values_Bitvector_a) addr) (nat_of_int sz) return )" + + +(*val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv 'b 'e*) +definition read_mem :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> read_kind \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>('rv,'b,'e)monad " where + " read_mem dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b rk addr sz = ( + bind + (read_mem_bytes dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_a rk addr sz) + (\<lambda> bytes . + maybe_fail (''bits_of_mem_bytes'') ( + (of_bits_method dict_Sail_values_Bitvector_b) (bits_of_mem_bytes bytes))))" + + +(*val read_tag : forall 'rv 'a 'e. Bitvector 'a => 'a -> monad 'rv bitU 'e*) +definition read_tag :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow>('rv,(bitU),'e)monad " where + " read_tag dict_Sail_values_Bitvector_a addr = ( Read_tag ( + (bits_of_method dict_Sail_values_Bitvector_a) addr) return )" + + +(*val excl_result : forall 'rv 'e. unit -> monad 'rv bool 'e*) +definition excl_result :: " unit \<Rightarrow>('rv,(bool),'e)monad " where + " excl_result _ = ( + (let k = (\<lambda> successful . (return successful)) in Excl_res k) )" + + +(*val write_mem_ea : forall 'rv 'a 'e. Bitvector 'a => write_kind -> 'a -> integer -> monad 'rv unit 'e*) +definition write_mem_ea :: " 'a Bitvector_class \<Rightarrow> write_kind \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>('rv,(unit),'e)monad " where + " write_mem_ea dict_Sail_values_Bitvector_a wk addr sz = ( Write_ea wk ( + (bits_of_method dict_Sail_values_Bitvector_a) addr) (nat_of_int sz) (Done () ))" + + +(*val write_mem_val : forall 'rv 'a 'e. Bitvector 'a => 'a -> monad 'rv bool 'e*) +definition write_mem_val :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow>('rv,(bool),'e)monad " where + " write_mem_val dict_Sail_values_Bitvector_a v = ( (case mem_bytes_of_bits + dict_Sail_values_Bitvector_a v of + Some v => Write_memv v return + | None => Fail (''write_mem_val'') +))" + + +(*val write_tag : forall 'rv 'a 'e. Bitvector 'a => 'a -> bitU -> monad 'rv bool 'e*) +definition write_tag :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('rv,(bool),'e)monad " where + " write_tag dict_Sail_values_Bitvector_a addr b = ( Write_tag ( + (bits_of_method dict_Sail_values_Bitvector_a) addr) b return )" + + +(*val read_reg : forall 's 'rv 'a 'e. register_ref 's 'rv 'a -> monad 'rv 'a 'e*) +definition read_reg :: "('s,'rv,'a)register_ref \<Rightarrow>('rv,'a,'e)monad " where + " read_reg reg = ( + (let k = (\<lambda> v . + (case (of_regval reg) v of + Some v => Done v + | None => Fail (''read_reg: unrecognised value'') + )) in Read_reg (name reg) k) )" + + +(* TODO +val read_reg_range : forall 's 'r 'rv 'a 'e. Bitvector 'a => register_ref 's 'rv 'r -> integer -> integer -> monad 'rv 'a 'e +let read_reg_range reg i j = + read_reg_aux of_bits (external_reg_slice reg (nat_of_int i,nat_of_int j)) + +let read_reg_bit reg i = + read_reg_aux (fun v -> v) (external_reg_slice reg (nat_of_int i,nat_of_int i)) >>= fun v -> + return (extract_only_element v) + +let read_reg_field reg regfield = + read_reg_aux (external_reg_field_whole reg regfield) + +let read_reg_bitfield reg regfield = + read_reg_aux (external_reg_field_whole reg regfield) >>= fun v -> + return (extract_only_element v)*) + +definition reg_deref :: "('d,'c,'b)register_ref \<Rightarrow>('c,'b,'a)monad " where + " reg_deref = ( read_reg )" + + +(*val write_reg : forall 's 'rv 'a 'e. register_ref 's 'rv 'a -> 'a -> monad 'rv unit 'e*) +definition write_reg :: "('s,'rv,'a)register_ref \<Rightarrow> 'a \<Rightarrow>('rv,(unit),'e)monad " where + " write_reg reg v = ( Write_reg(name reg) ((regval_of reg) v) (Done () ))" + + +(* TODO +let write_reg reg v = + write_reg_aux (external_reg_whole reg) v +let write_reg_range reg i j v = + write_reg_aux (external_reg_slice reg (nat_of_int i,nat_of_int j)) v +let write_reg_pos reg i v = + let iN = nat_of_int i in + write_reg_aux (external_reg_slice reg (iN,iN)) [v] +let write_reg_bit = write_reg_pos +let write_reg_field reg regfield v = + write_reg_aux (external_reg_field_whole reg regfield.field_name) v +let write_reg_field_bit reg regfield bit = + write_reg_aux (external_reg_field_whole reg regfield.field_name) + (Vector [bit] 0 (is_inc_of_reg reg)) +let write_reg_field_range reg regfield i j v = + write_reg_aux (external_reg_field_slice reg regfield.field_name (nat_of_int i,nat_of_int j)) v +let write_reg_field_pos reg regfield i v = + write_reg_field_range reg regfield i i [v] +let write_reg_field_bit = write_reg_field_pos*) + +(*val barrier : forall 'rv 'e. barrier_kind -> monad 'rv unit 'e*) +definition barrier :: " barrier_kind \<Rightarrow>('rv,(unit),'e)monad " where + " barrier bk = ( Barrier bk (Done () ))" + + +(*val footprint : forall 'rv 'e. unit -> monad 'rv unit 'e*) +definition footprint :: " unit \<Rightarrow>('rv,(unit),'e)monad " where + " footprint _ = ( Footprint (Done () ))" + +end diff --git a/snapshots/isabelle/lib/sail/Prompt_monad_lemmas.thy b/snapshots/isabelle/lib/sail/Prompt_monad_lemmas.thy new file mode 100644 index 00000000..e883c2a0 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Prompt_monad_lemmas.thy @@ -0,0 +1,170 @@ +theory Prompt_monad_lemmas + imports + Prompt_monad + Sail_values_lemmas +begin + +notation bind (infixr "\<bind>" 54) + +abbreviation seq :: "('rv,unit,'e)monad \<Rightarrow> ('rv,'b,'e)monad \<Rightarrow>('rv,'b,'e)monad" (infixr "\<then>" 54) where + "m \<then> n \<equiv> m \<bind> (\<lambda>_. n)" + +lemma All_bind_dom: "bind_dom (m, f)" + by (induction m) (auto intro: bind.domintros) + +termination bind using All_bind_dom by auto +lemmas bind_induct[case_names Done Read_mem Write_memv Read_reg Excl_res Write_ea Barrier Write_reg Fail Exception] = bind.induct + +lemma bind_return[simp]: "bind (return a) f = f a" + by (auto simp: return_def) + +lemma bind_assoc[simp]: "bind (bind m f) g = bind m (\<lambda>x. bind (f x) g)" + by (induction m f arbitrary: g rule: bind.induct) auto + +lemma bind_assert_True[simp]: "bind (assert_exp True msg) f = f ()" + by (auto simp: assert_exp_def) + +lemma All_try_catch_dom: "try_catch_dom (m, h)" + by (induction m) (auto intro: try_catch.domintros) +termination try_catch using All_try_catch_dom by auto +lemmas try_catch_induct[case_names Done Read_mem Write_memv Read_reg Excl_res Write_ea Barrier Write_reg Fail Exception] = try_catch.induct + +datatype 'regval event = + (* Request to read memory *) + e_read_mem read_kind "bitU list" nat "memory_byte list" + | e_read_tag "bitU list" bitU + (* Write is imminent, at address lifted, of size nat *) + | e_write_ea write_kind "bitU list" nat + (* Request the result of store-exclusive *) + | e_excl_res bool + (* Request to write memory at last signalled address. Memory value should be 8 + times the size given in ea signal *) + | e_write_memv "memory_byte list" bool + | e_write_tag "bitU list" bitU bool + (* Tell the system to dynamically recalculate dependency footprint *) + | e_footprint + (* Request a memory barrier *) + | e_barrier " barrier_kind " + (* Request to read register *) + | e_read_reg string 'regval + (* Request to write register *) + | e_write_reg string 'regval + | e_undefined bool + | e_print string + +inductive_set T :: "(('rv, 'a, 'e) monad \<times> 'rv event \<times> ('rv, 'a, 'e) monad) set" where + Read_mem: "((Read_mem rk addr sz k), e_read_mem rk addr sz v, k v) \<in> T" +| Read_tag: "((Read_tag addr k), e_read_tag addr v, k v) \<in> T" +| Write_ea: "((Write_ea wk addr sz k), e_write_ea wk addr sz, k) \<in> T" +| Excl_res: "((Excl_res k), e_excl_res r, k r) \<in> T" +| Write_memv: "((Write_memv v k), e_write_memv v r, k r) \<in> T" +| Write_tag: "((Write_tag a v k), e_write_tag a v r, k r) \<in> T" +| Footprint: "((Footprint k), e_footprint, k) \<in> T" +| Barrier: "((Barrier bk k), e_barrier bk, k) \<in> T" +| Read_reg: "((Read_reg r k), e_read_reg r v, k v) \<in> T" +| Write_reg: "((Write_reg r v k), e_write_reg r v, k) \<in> T" +| Undefined : "((Undefined k), e_undefined v, k v) \<in> T" +| Print: "((Print msg k), e_print msg, k) \<in> T" + +inductive_set Traces :: "(('rv, 'a, 'e) monad \<times> 'rv event list \<times> ('rv, 'a, 'e) monad) set" where + Nil: "(s, [], s) \<in> Traces" +| Step: "\<lbrakk>(s, e, s'') \<in> T; (s'', t, s') \<in> Traces\<rbrakk> \<Longrightarrow> (s, e # t, s') \<in> Traces" + +declare Traces.intros[intro] +declare T.intros[intro] + +declare prod.splits[split] + +lemmas Traces_ConsI = T.intros[THEN Step, rotated] + +inductive_cases Traces_NilE[elim]: "(s, [], s') \<in> Traces" +inductive_cases Traces_ConsE[elim]: "(s, e # t, s') \<in> Traces" + +lemma Traces_cases: + fixes m :: "('rv, 'a, 'e) monad" + assumes Run: "(m, t, m') \<in> Traces" + obtains (Nil) a where "m = m'" and "t = []" + | (Read_mem) rk addr s k t' v where "m = Read_mem rk addr s k" and "t = e_read_mem rk addr s v # t'" and "(k v, t', m') \<in> Traces" + | (Read_tag) addr k t' v where "m = Read_tag addr k" and "t = e_read_tag addr v # t'" and "(k v, t', m') \<in> Traces" + | (Write_memv) val k t' v where "m = Write_memv val k" and "t = e_write_memv val v # t'" and "(k v, t', m') \<in> Traces" + | (Write_tag) a val k t' v where "m = Write_tag a val k" and "t = e_write_tag a val v # t'" and "(k v, t', m') \<in> Traces" + | (Barrier) bk k t' v where "m = Barrier bk k" and "t = e_barrier bk # t'" and "(k, t', m') \<in> Traces" + | (Read_reg) reg k t' v where "m = Read_reg reg k" and "t = e_read_reg reg v # t'" and "(k v, t', m') \<in> Traces" + | (Excl_res) k t' v where "m = Excl_res k" and "t = e_excl_res v # t'" and "(k v, t', m') \<in> Traces" + | (Write_ea) wk addr s k t' where "m = Write_ea wk addr s k" and "t = e_write_ea wk addr s # t'" and "(k, t', m') \<in> Traces" + | (Footprint) k t' where "m = Footprint k" and "t = e_footprint # t'" and "(k, t', m') \<in> Traces" + | (Write_reg) reg v k t' where "m = Write_reg reg v k" and "t = e_write_reg reg v # t'" and "(k, t', m') \<in> Traces" + | (Undefined) v k t' where "m = Undefined k" and "t = e_undefined v # t'" and "(k v, t', m') \<in> Traces" + | (Print) msg k t' where "m = Print msg k" and "t = e_print msg # t'" and "(k, t', m') \<in> Traces" +proof (use Run in \<open>cases m t m' set: Traces\<close>) + case Nil + then show ?thesis by (auto intro: that(1)) +next + case (Step e m'' t') + from \<open>(m, e, m'') \<in> T\<close> and \<open>t = e # t'\<close> and \<open>(m'', t', m') \<in> Traces\<close> + show ?thesis by (cases m e m'' rule: T.cases; elim that; blast) +qed + +abbreviation Run :: "('rv, 'a, 'e) monad \<Rightarrow> 'rv event list \<Rightarrow> 'a \<Rightarrow> bool" + where "Run s t a \<equiv> (s, t, Done a) \<in> Traces" + +lemma Run_appendI: + assumes "(s, t1, s') \<in> Traces" + and "Run s' t2 a" + shows "Run s (t1 @ t2) a" +proof (use assms in \<open>induction t1 arbitrary: s\<close>) + case (Cons e t1) + then show ?case by (elim Traces_ConsE) auto +qed auto + +lemma bind_DoneE: + assumes "bind m f = Done a" + obtains a' where "m = Done a'" and "f a' = Done a" + using assms by (auto elim: bind.elims) + +lemma bind_T_cases: + assumes "(bind m f, e, s') \<in> T" + obtains (Done) a where "m = Done a" + | (Bind) m' where "s' = bind m' f" and "(m, e, m') \<in> T" + using assms by (cases; blast elim: bind.elims) + +lemma Run_bindE: + fixes m :: "('rv, 'b, 'e) monad" and a :: 'a + assumes "Run (bind m f) t a" + obtains tm am tf where "t = tm @ tf" and "Run m tm am" and "Run (f am) tf a" +proof (use assms in \<open>induction "bind m f" t "Done a :: ('rv, 'a, 'e) monad" arbitrary: m rule: Traces.induct\<close>) + case Nil + obtain am where "m = Done am" and "f am = Done a" using Nil(1) by (elim bind_DoneE) + then show ?case by (intro Nil(2)) auto +next + case (Step e s'' t m) + show thesis using Step(1) + proof (cases rule: bind_T_cases) + case (Done am) + then show ?thesis using Step(1,2) by (intro Step(4)[of "[]" "e # t" am]) auto + next + case (Bind m') + show ?thesis proof (rule Step(3)[OF Bind(1)]) + fix tm tf am + assume "t = tm @ tf" and "Run m' tm am" and "Run (f am) tf a" + then show thesis using Bind by (intro Step(4)[of "e # tm" tf am]) auto + qed + qed +qed + +lemma Run_DoneE: + assumes "Run (Done a) t a'" + obtains "t = []" and "a' = a" + using assms by (auto elim: Traces.cases T.cases) + +lemma Run_Done_iff_Nil[simp]: "Run (Done a) t a' \<longleftrightarrow> t = [] \<and> a' = a" + by (auto elim: Run_DoneE) + +lemma bind_cong[fundef_cong]: + assumes m: "m1 = m2" + and f: "\<And>t a. Run m2 t a \<Longrightarrow> f1 a = f2 a" + shows "bind m1 f1 = bind m2 f2" + unfolding m using f + by (induction m2 f1 arbitrary: f2 rule: bind.induct; unfold bind.simps; blast) + +end diff --git a/snapshots/isabelle/lib/sail/ROOT b/snapshots/isabelle/lib/sail/ROOT new file mode 100644 index 00000000..3189f216 --- /dev/null +++ b/snapshots/isabelle/lib/sail/ROOT @@ -0,0 +1,11 @@ +session "Sail" = "LEM" + + options [document = false] + sessions + "HOL-Eisbach" + theories + Sail_values_lemmas + Prompt + State_lemmas + Sail_operators_mwords_lemmas + Sail_operators_bitlists + Hoare diff --git a/snapshots/isabelle/lib/sail/Sail_instr_kinds.thy b/snapshots/isabelle/lib/sail/Sail_instr_kinds.thy new file mode 100644 index 00000000..088ff4a8 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Sail_instr_kinds.thy @@ -0,0 +1,494 @@ +chapter \<open>Generated by Lem from ../../src/lem_interp/sail_instr_kinds.lem.\<close> + +theory "Sail_instr_kinds" + +imports + Main + "Lem_pervasives_extra" + +begin + +(*========================================================================*) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(*========================================================================*) + +(*open import Pervasives_extra*) + + +record 'a EnumerationType_class= + + toNat_method ::" 'a \<Rightarrow> nat " + + + + +(*val enumeration_typeCompare : forall 'a. EnumerationType 'a => 'a -> 'a -> ordering*) +definition enumeration_typeCompare :: " 'a EnumerationType_class \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ordering " where + " enumeration_typeCompare dict_Sail_instr_kinds_EnumerationType_a e1 e2 = ( + (genericCompare (op<) (op=) ( + (toNat_method dict_Sail_instr_kinds_EnumerationType_a) e1) ((toNat_method dict_Sail_instr_kinds_EnumerationType_a) e2)))" + + + +definition instance_Basic_classes_Ord_var_dict :: " 'a EnumerationType_class \<Rightarrow> 'a Ord_class " where + " instance_Basic_classes_Ord_var_dict dict_Sail_instr_kinds_EnumerationType_a = ((| + + compare_method = + (enumeration_typeCompare dict_Sail_instr_kinds_EnumerationType_a), + + isLess_method = (\<lambda> r1 r2. (enumeration_typeCompare + dict_Sail_instr_kinds_EnumerationType_a r1 r2) = LT), + + isLessEqual_method = (\<lambda> r1 r2. (enumeration_typeCompare + dict_Sail_instr_kinds_EnumerationType_a r1 r2) \<noteq> GT), + + isGreater_method = (\<lambda> r1 r2. (enumeration_typeCompare + dict_Sail_instr_kinds_EnumerationType_a r1 r2) = GT), + + isGreaterEqual_method = (\<lambda> r1 r2. (enumeration_typeCompare + dict_Sail_instr_kinds_EnumerationType_a r1 r2) \<noteq> LT)|) )" + + + +(* Data structures for building up instructions *) + +(* careful: changes in the read/write/barrier kinds have to be + reflected in deep_shallow_convert *) +datatype read_kind = + (* common reads *) + Read_plain + (* Power reads *) + | Read_reserve + (* AArch64 reads *) + | Read_acquire | Read_exclusive | Read_exclusive_acquire | Read_stream + (* RISC-V reads *) + | Read_RISCV_acquire | Read_RISCV_strong_acquire + | Read_RISCV_reserved | Read_RISCV_reserved_acquire + | Read_RISCV_reserved_strong_acquire + (* x86 reads *) + | Read_X86_locked (* the read part of a lock'd instruction (rmw) *) + +definition instance_Show_Show_Sail_instr_kinds_read_kind_dict :: "(read_kind)Show_class " where + " instance_Show_Show_Sail_instr_kinds_read_kind_dict = ((| + + show_method = (\<lambda>x . + (case x of + Read_plain => (''Read_plain'') + | Read_reserve => (''Read_reserve'') + | Read_acquire => (''Read_acquire'') + | Read_exclusive => (''Read_exclusive'') + | Read_exclusive_acquire => (''Read_exclusive_acquire'') + | Read_stream => (''Read_stream'') + | Read_RISCV_acquire => (''Read_RISCV_acquire'') + | Read_RISCV_strong_acquire => (''Read_RISCV_strong_acquire'') + | Read_RISCV_reserved => (''Read_RISCV_reserved'') + | Read_RISCV_reserved_acquire => (''Read_RISCV_reserved_acquire'') + | Read_RISCV_reserved_strong_acquire => (''Read_RISCV_reserved_strong_acquire'') + | Read_X86_locked => (''Read_X86_locked'') + ))|) )" + + +datatype write_kind = + (* common writes *) + Write_plain + (* Power writes *) + | Write_conditional + (* AArch64 writes *) + | Write_release | Write_exclusive | Write_exclusive_release + (* RISC-V *) + | Write_RISCV_release | Write_RISCV_strong_release + | Write_RISCV_conditional | Write_RISCV_conditional_release + | Write_RISCV_conditional_strong_release + (* x86 writes *) + | Write_X86_locked (* the write part of a lock'd instruction (rmw) *) + +definition instance_Show_Show_Sail_instr_kinds_write_kind_dict :: "(write_kind)Show_class " where + " instance_Show_Show_Sail_instr_kinds_write_kind_dict = ((| + + show_method = (\<lambda>x . + (case x of + Write_plain => (''Write_plain'') + | Write_conditional => (''Write_conditional'') + | Write_release => (''Write_release'') + | Write_exclusive => (''Write_exclusive'') + | Write_exclusive_release => (''Write_exclusive_release'') + | Write_RISCV_release => (''Write_RISCV_release'') + | Write_RISCV_strong_release => (''Write_RISCV_strong_release'') + | Write_RISCV_conditional => (''Write_RISCV_conditional'') + | Write_RISCV_conditional_release => (''Write_RISCV_conditional_release'') + | Write_RISCV_conditional_strong_release => (''Write_RISCV_conditional_strong_release'') + | Write_X86_locked => (''Write_X86_locked'') + ))|) )" + + +datatype barrier_kind = + (* Power barriers *) + Barrier_Sync | Barrier_LwSync | Barrier_Eieio | Barrier_Isync + (* AArch64 barriers *) + | Barrier_DMB | Barrier_DMB_ST | Barrier_DMB_LD | Barrier_DSB + | Barrier_DSB_ST | Barrier_DSB_LD | Barrier_ISB + | Barrier_TM_COMMIT + (* MIPS barriers *) + | Barrier_MIPS_SYNC + (* RISC-V barriers *) + | Barrier_RISCV_rw_rw + | Barrier_RISCV_r_rw + | Barrier_RISCV_r_r + | Barrier_RISCV_rw_w + | Barrier_RISCV_w_w + | Barrier_RISCV_i + (* X86 *) + | Barrier_x86_MFENCE + + +definition instance_Show_Show_Sail_instr_kinds_barrier_kind_dict :: "(barrier_kind)Show_class " where + " instance_Show_Show_Sail_instr_kinds_barrier_kind_dict = ((| + + show_method = (\<lambda>x . + (case x of + Barrier_Sync => (''Barrier_Sync'') + | Barrier_LwSync => (''Barrier_LwSync'') + | Barrier_Eieio => (''Barrier_Eieio'') + | Barrier_Isync => (''Barrier_Isync'') + | Barrier_DMB => (''Barrier_DMB'') + | Barrier_DMB_ST => (''Barrier_DMB_ST'') + | Barrier_DMB_LD => (''Barrier_DMB_LD'') + | Barrier_DSB => (''Barrier_DSB'') + | Barrier_DSB_ST => (''Barrier_DSB_ST'') + | Barrier_DSB_LD => (''Barrier_DSB_LD'') + | Barrier_ISB => (''Barrier_ISB'') + | Barrier_TM_COMMIT => (''Barrier_TM_COMMIT'') + | Barrier_MIPS_SYNC => (''Barrier_MIPS_SYNC'') + | Barrier_RISCV_rw_rw => (''Barrier_RISCV_rw_rw'') + | Barrier_RISCV_r_rw => (''Barrier_RISCV_r_rw'') + | Barrier_RISCV_r_r => (''Barrier_RISCV_r_r'') + | Barrier_RISCV_rw_w => (''Barrier_RISCV_rw_w'') + | Barrier_RISCV_w_w => (''Barrier_RISCV_w_w'') + | Barrier_RISCV_i => (''Barrier_RISCV_i'') + | Barrier_x86_MFENCE => (''Barrier_x86_MFENCE'') + ))|) )" + + +datatype trans_kind = + (* AArch64 *) + Transaction_start | Transaction_commit | Transaction_abort + +definition instance_Show_Show_Sail_instr_kinds_trans_kind_dict :: "(trans_kind)Show_class " where + " instance_Show_Show_Sail_instr_kinds_trans_kind_dict = ((| + + show_method = (\<lambda>x . + (case x of + Transaction_start => (''Transaction_start'') + | Transaction_commit => (''Transaction_commit'') + | Transaction_abort => (''Transaction_abort'') + ))|) )" + + +datatype instruction_kind = + IK_barrier " barrier_kind " + | IK_mem_read " read_kind " + | IK_mem_write " write_kind " + | IK_mem_rmw " (read_kind * write_kind)" + | IK_branch (* this includes conditional-branch (multiple nias, none of which is NIA_indirect_address), + indirect/computed-branch (single nia of kind NIA_indirect_address) + and branch/jump (single nia of kind NIA_concrete_address) *) + | IK_trans " trans_kind " + | IK_simple + + +definition instance_Show_Show_Sail_instr_kinds_instruction_kind_dict :: "(instruction_kind)Show_class " where + " instance_Show_Show_Sail_instr_kinds_instruction_kind_dict = ((| + + show_method = (\<lambda>x . + (case x of + IK_barrier barrier_kind => (''IK_barrier '') @ + (((\<lambda>x . (case x of + Barrier_Sync => + (''Barrier_Sync'') + | Barrier_LwSync => + (''Barrier_LwSync'') + | Barrier_Eieio => + (''Barrier_Eieio'') + | Barrier_Isync => + (''Barrier_Isync'') + | Barrier_DMB => + (''Barrier_DMB'') + | Barrier_DMB_ST => + (''Barrier_DMB_ST'') + | Barrier_DMB_LD => + (''Barrier_DMB_LD'') + | Barrier_DSB => + (''Barrier_DSB'') + | Barrier_DSB_ST => + (''Barrier_DSB_ST'') + | Barrier_DSB_LD => + (''Barrier_DSB_LD'') + | Barrier_ISB => + (''Barrier_ISB'') + | Barrier_TM_COMMIT => + (''Barrier_TM_COMMIT'') + | Barrier_MIPS_SYNC => + (''Barrier_MIPS_SYNC'') + | Barrier_RISCV_rw_rw => + (''Barrier_RISCV_rw_rw'') + | Barrier_RISCV_r_rw => + (''Barrier_RISCV_r_rw'') + | Barrier_RISCV_r_r => + (''Barrier_RISCV_r_r'') + | Barrier_RISCV_rw_w => + (''Barrier_RISCV_rw_w'') + | Barrier_RISCV_w_w => + (''Barrier_RISCV_w_w'') + | Barrier_RISCV_i => + (''Barrier_RISCV_i'') + | Barrier_x86_MFENCE => + (''Barrier_x86_MFENCE'') + )) barrier_kind)) + | IK_mem_read read_kind => (''IK_mem_read '') @ + (((\<lambda>x . (case x of + Read_plain => + (''Read_plain'') + | Read_reserve => + (''Read_reserve'') + | Read_acquire => + (''Read_acquire'') + | Read_exclusive => + (''Read_exclusive'') + | Read_exclusive_acquire => + (''Read_exclusive_acquire'') + | Read_stream => + (''Read_stream'') + | Read_RISCV_acquire => + (''Read_RISCV_acquire'') + | Read_RISCV_strong_acquire => + (''Read_RISCV_strong_acquire'') + | Read_RISCV_reserved => + (''Read_RISCV_reserved'') + | Read_RISCV_reserved_acquire => + (''Read_RISCV_reserved_acquire'') + | Read_RISCV_reserved_strong_acquire => + (''Read_RISCV_reserved_strong_acquire'') + | Read_X86_locked => + (''Read_X86_locked'') + )) read_kind)) + | IK_mem_write write_kind => (''IK_mem_write '') @ + (((\<lambda>x . (case x of + Write_plain => + (''Write_plain'') + | Write_conditional => + (''Write_conditional'') + | Write_release => + (''Write_release'') + | Write_exclusive => + (''Write_exclusive'') + | Write_exclusive_release => + (''Write_exclusive_release'') + | Write_RISCV_release => + (''Write_RISCV_release'') + | Write_RISCV_strong_release => + (''Write_RISCV_strong_release'') + | Write_RISCV_conditional => + (''Write_RISCV_conditional'') + | Write_RISCV_conditional_release => + (''Write_RISCV_conditional_release'') + | Write_RISCV_conditional_strong_release => + (''Write_RISCV_conditional_strong_release'') + | Write_X86_locked => + (''Write_X86_locked'') + )) write_kind)) + | IK_mem_rmw (r, w) => (''IK_mem_rmw '') @ + ((((\<lambda>x . (case x of + Read_plain => (''Read_plain'') + | Read_reserve => (''Read_reserve'') + | Read_acquire => (''Read_acquire'') + | Read_exclusive => + (''Read_exclusive'') + | Read_exclusive_acquire => + (''Read_exclusive_acquire'') + | Read_stream => (''Read_stream'') + | Read_RISCV_acquire => + (''Read_RISCV_acquire'') + | Read_RISCV_strong_acquire => + (''Read_RISCV_strong_acquire'') + | Read_RISCV_reserved => + (''Read_RISCV_reserved'') + | Read_RISCV_reserved_acquire => + (''Read_RISCV_reserved_acquire'') + | Read_RISCV_reserved_strong_acquire => + (''Read_RISCV_reserved_strong_acquire'') + | Read_X86_locked => + (''Read_X86_locked'') + )) r)) @ + (('' '') @ + (((\<lambda>x . (case x of + Write_plain => + (''Write_plain'') + | Write_conditional => + (''Write_conditional'') + | Write_release => + (''Write_release'') + | Write_exclusive => + (''Write_exclusive'') + | Write_exclusive_release => + (''Write_exclusive_release'') + | Write_RISCV_release => + (''Write_RISCV_release'') + | Write_RISCV_strong_release => + (''Write_RISCV_strong_release'') + | Write_RISCV_conditional => + (''Write_RISCV_conditional'') + | Write_RISCV_conditional_release => + (''Write_RISCV_conditional_release'') + | Write_RISCV_conditional_strong_release => + (''Write_RISCV_conditional_strong_release'') + | Write_X86_locked => + (''Write_X86_locked'') + )) w)))) + | IK_branch => (''IK_branch'') + | IK_trans trans_kind => (''IK_trans '') @ + (((\<lambda>x . (case x of + Transaction_start => + (''Transaction_start'') + | Transaction_commit => + (''Transaction_commit'') + | Transaction_abort => + (''Transaction_abort'') + )) trans_kind)) + | IK_simple => (''IK_simple'') + ))|) )" + + + +definition read_is_exclusive :: " read_kind \<Rightarrow> bool " where + " read_is_exclusive = ( \<lambda>x . + (case x of + Read_plain => False + | Read_reserve => True + | Read_acquire => False + | Read_exclusive => True + | Read_exclusive_acquire => True + | Read_stream => False + | Read_RISCV_acquire => False + | Read_RISCV_strong_acquire => False + | Read_RISCV_reserved => True + | Read_RISCV_reserved_acquire => True + | Read_RISCV_reserved_strong_acquire => True + | Read_X86_locked => True + ) )" + + + + +definition instance_Sail_instr_kinds_EnumerationType_Sail_instr_kinds_read_kind_dict :: "(read_kind)EnumerationType_class " where + " instance_Sail_instr_kinds_EnumerationType_Sail_instr_kinds_read_kind_dict = ((| + + toNat_method = (\<lambda>x . + (case x of + Read_plain =>( 0 :: nat) + | Read_reserve =>( 1 :: nat) + | Read_acquire =>( 2 :: nat) + | Read_exclusive =>( 3 :: nat) + | Read_exclusive_acquire =>( 4 :: nat) + | Read_stream =>( 5 :: nat) + | Read_RISCV_acquire =>( 6 :: nat) + | Read_RISCV_strong_acquire =>( 7 :: nat) + | Read_RISCV_reserved =>( 8 :: nat) + | Read_RISCV_reserved_acquire =>( 9 :: nat) + | Read_RISCV_reserved_strong_acquire =>( 10 :: nat) + | Read_X86_locked =>( 11 :: nat) + ))|) )" + + +definition instance_Sail_instr_kinds_EnumerationType_Sail_instr_kinds_write_kind_dict :: "(write_kind)EnumerationType_class " where + " instance_Sail_instr_kinds_EnumerationType_Sail_instr_kinds_write_kind_dict = ((| + + toNat_method = (\<lambda>x . + (case x of + Write_plain =>( 0 :: nat) + | Write_conditional =>( 1 :: nat) + | Write_release =>( 2 :: nat) + | Write_exclusive =>( 3 :: nat) + | Write_exclusive_release =>( 4 :: nat) + | Write_RISCV_release =>( 5 :: nat) + | Write_RISCV_strong_release =>( 6 :: nat) + | Write_RISCV_conditional =>( 7 :: nat) + | Write_RISCV_conditional_release =>( 8 :: nat) + | Write_RISCV_conditional_strong_release =>( 9 :: nat) + | Write_X86_locked =>( 10 :: nat) + ))|) )" + + +definition instance_Sail_instr_kinds_EnumerationType_Sail_instr_kinds_barrier_kind_dict :: "(barrier_kind)EnumerationType_class " where + " instance_Sail_instr_kinds_EnumerationType_Sail_instr_kinds_barrier_kind_dict = ((| + + toNat_method = (\<lambda>x . + (case x of + Barrier_Sync =>( 0 :: nat) + | Barrier_LwSync =>( 1 :: nat) + | Barrier_Eieio =>( 2 :: nat) + | Barrier_Isync =>( 3 :: nat) + | Barrier_DMB =>( 4 :: nat) + | Barrier_DMB_ST =>( 5 :: nat) + | Barrier_DMB_LD =>( 6 :: nat) + | Barrier_DSB =>( 7 :: nat) + | Barrier_DSB_ST =>( 8 :: nat) + | Barrier_DSB_LD =>( 9 :: nat) + | Barrier_ISB =>( 10 :: nat) + | Barrier_TM_COMMIT =>( 11 :: nat) + | Barrier_MIPS_SYNC =>( 12 :: nat) + | Barrier_RISCV_rw_rw =>( 13 :: nat) + | Barrier_RISCV_r_rw =>( 14 :: nat) + | Barrier_RISCV_r_r =>( 15 :: nat) + | Barrier_RISCV_rw_w =>( 16 :: nat) + | Barrier_RISCV_w_w =>( 17 :: nat) + | Barrier_RISCV_i =>( 18 :: nat) + | Barrier_x86_MFENCE =>( 19 :: nat) + ))|) )" + +end diff --git a/snapshots/isabelle/lib/sail/Sail_operators.thy b/snapshots/isabelle/lib/sail/Sail_operators.thy new file mode 100644 index 00000000..00b32a85 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Sail_operators.thy @@ -0,0 +1,326 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/sail_operators.lem.\<close> + +theory "Sail_operators" + +imports + Main + "Lem_pervasives_extra" + "Lem_machine_word" + "Sail_values" + +begin + +(*open import Pervasives_extra*) +(*open import Machine_word*) +(*open import Sail_values*) + +(*** Bit vector operations *) + +(*val concat_bv : forall 'a 'b. Bitvector 'a, Bitvector 'b => 'a -> 'b -> list bitU*) +definition concat_bv :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow>(bitU)list " where + " concat_bv dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b l r = ( ( + (bits_of_method dict_Sail_values_Bitvector_a) l @(bits_of_method dict_Sail_values_Bitvector_b) r))" + + +(*val cons_bv : forall 'a. Bitvector 'a => bitU -> 'a -> list bitU*) +definition cons_bv :: " 'a Bitvector_class \<Rightarrow> bitU \<Rightarrow> 'a \<Rightarrow>(bitU)list " where + " cons_bv dict_Sail_values_Bitvector_a b v = ( b # + (bits_of_method dict_Sail_values_Bitvector_a) v )" + + +(*val cast_unit_bv : bitU -> list bitU*) +definition cast_unit_bv :: " bitU \<Rightarrow>(bitU)list " where + " cast_unit_bv b = ( [b])" + + +(*val bv_of_bit : integer -> bitU -> list bitU*) +definition bv_of_bit :: " int \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " bv_of_bit len b = ( extz_bits len [b])" + + +definition most_significant :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU " where + " most_significant dict_Sail_values_Bitvector_a v = ( (case + (bits_of_method dict_Sail_values_Bitvector_a) v of + b # _ => b + | _ => B0 (* Treat empty bitvector as all zeros *) + ))" + + +definition get_max_representable_in :: " bool \<Rightarrow> int \<Rightarrow> int " where + " get_max_representable_in sign (n :: int) = ( + if (n =( 64 :: int)) then (case sign of True => max_64 | False => max_64u ) + else if (n=( 32 :: int)) then (case sign of True => max_32 | False => max_32u ) + else if (n=( 8 :: int)) then max_8 + else if (n=( 5 :: int)) then max_5 + else (case sign of True => (( 2 :: int))^ ((nat (abs ( n))) -( 1 :: nat)) + | False => (( 2 :: int))^ (nat (abs ( n))) + ))" + + +definition get_min_representable_in :: " 'a \<Rightarrow> int \<Rightarrow> int " where + " get_min_representable_in _ (n :: int) = ( + if n =( 64 :: int) then min_64 + else if n =( 32 :: int) then min_32 + else if n =( 8 :: int) then min_8 + else if n =( 5 :: int) then min_5 + else( 0 :: int) - ((( 2 :: int))^ (nat (abs ( n)))))" + + +(*val arith_op_bv_int : forall 'a 'b. Bitvector 'a => + (integer -> integer -> integer) -> bool -> 'a -> integer -> 'a*) +definition arith_op_bv_int :: " 'a Bitvector_class \<Rightarrow>(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> 'a " where + " arith_op_bv_int dict_Sail_values_Bitvector_a op1 sign l r = ( + (let r' = ((of_int_method dict_Sail_values_Bitvector_a) ((length_method dict_Sail_values_Bitvector_a) l) r) in (arith_op_bv_method dict_Sail_values_Bitvector_a) op1 sign l r'))" + + +(*val arith_op_int_bv : forall 'a 'b. Bitvector 'a => + (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a*) +definition arith_op_int_bv :: " 'a Bitvector_class \<Rightarrow>(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> 'a " where + " arith_op_int_bv dict_Sail_values_Bitvector_a op1 sign l r = ( + (let l' = ((of_int_method dict_Sail_values_Bitvector_a) ((length_method dict_Sail_values_Bitvector_a) r) l) in (arith_op_bv_method dict_Sail_values_Bitvector_a) op1 sign l' r))" + + +definition arith_op_bv_bool :: " 'a Bitvector_class \<Rightarrow>(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a " where + " arith_op_bv_bool dict_Sail_values_Bitvector_a op1 sign l r = ( arith_op_bv_int + dict_Sail_values_Bitvector_a op1 sign l (if r then( 1 :: int) else( 0 :: int)))" + +definition arith_op_bv_bit :: " 'a Bitvector_class \<Rightarrow>(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow> 'a option " where + " arith_op_bv_bit dict_Sail_values_Bitvector_a op1 sign l r = ( map_option (arith_op_bv_bool + dict_Sail_values_Bitvector_a op1 sign l) (bool_of_bitU r))" + + +(* TODO (or just omit and define it per spec if needed) +val arith_op_overflow_bv : forall 'a. Bitvector 'a => + (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a -> (list bitU * bitU * bitU) +let arith_op_overflow_bv op sign size l r = + let len = length l in + let act_size = len * size in + match (int_of_bv sign l, int_of_bv sign r, int_of_bv false l, int_of_bv false r) with + | (Just l_sign, Just r_sign, Just l_unsign, Just r_unsign) -> + let n = op l_sign r_sign in + let n_unsign = op l_unsign r_unsign in + let correct_size = of_int act_size n in + let one_more_size_u = bits_of_int (act_size + 1) n_unsign in + let overflow = + if n <= get_max_representable_in sign len && + n >= get_min_representable_in sign len + then B0 else B1 in + let c_out = most_significant one_more_size_u in + (correct_size,overflow,c_out) + | (_, _, _, _) -> + (repeat [BU] act_size, BU, BU) + end + +let add_overflow_bv = arith_op_overflow_bv integerAdd false 1 +let adds_overflow_bv = arith_op_overflow_bv integerAdd true 1 +let sub_overflow_bv = arith_op_overflow_bv integerMinus false 1 +let subs_overflow_bv = arith_op_overflow_bv integerMinus true 1 +let mult_overflow_bv = arith_op_overflow_bv integerMult false 2 +let mults_overflow_bv = arith_op_overflow_bv integerMult true 2 + +val arith_op_overflow_bv_bit : forall 'a. Bitvector 'a => + (integer -> integer -> integer) -> bool -> integer -> 'a -> bitU -> (list bitU * bitU * bitU) +let arith_op_overflow_bv_bit op sign size l r_bit = + let act_size = length l * size in + match (int_of_bv sign l, int_of_bv false l, r_bit = BU) with + | (Just l', Just l_u, false) -> + let (n, nu, changed) = match r_bit with + | B1 -> (op l' 1, op l_u 1, true) + | B0 -> (l', l_u, false) + | BU -> (* unreachable due to check above *) + failwith arith_op_overflow_bv_bit applied to undefined bit + end in + let correct_size = of_int act_size n in + let one_larger = bits_of_int (act_size + 1) nu in + let overflow = + if changed + then + if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size + then B0 else B1 + else B0 in + (correct_size, overflow, most_significant one_larger) + | (_, _, _) -> + (repeat [BU] act_size, BU, BU) + end + +let add_overflow_bv_bit = arith_op_overflow_bv_bit integerAdd false 1 +let adds_overflow_bv_bit = arith_op_overflow_bv_bit integerAdd true 1 +let sub_overflow_bv_bit = arith_op_overflow_bv_bit integerMinus false 1 +let subs_overflow_bv_bit = arith_op_overflow_bv_bit integerMinus true 1*) + +datatype shift = LL_shift | RR_shift | RR_shift_arith | LL_rot | RR_rot + +definition invert_shift :: " shift \<Rightarrow> shift " where + " invert_shift = ( \<lambda>x . + (case x of + LL_shift => RR_shift + | RR_shift => LL_shift + | RR_shift_arith => LL_shift + | LL_rot => RR_rot + | RR_rot => LL_rot + ) )" + + +(*val shift_op_bv : forall 'a. Bitvector 'a => shift -> 'a -> integer -> list bitU*) +definition shift_op_bv :: " 'a Bitvector_class \<Rightarrow> shift \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " shift_op_bv dict_Sail_values_Bitvector_a op1 v n = ( + (let v = ((bits_of_method dict_Sail_values_Bitvector_a) v) in + if n =( 0 :: int) then v else + (let (op1, n) = (if n >( 0 :: int) then (op1, n) else (invert_shift op1, - n)) in + (case op1 of + LL_shift => + subrange_list True v n (int (List.length v) -( 1 :: int)) @ repeat [B0] n + | RR_shift => + repeat [B0] n @ subrange_list True v(( 0 :: int)) ((int (List.length v) - n) -( 1 :: int)) + | RR_shift_arith => + repeat [most_significant + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) v] n @ subrange_list True v(( 0 :: int)) ((int (List.length v) - n) -( 1 :: int)) + | LL_rot => + subrange_list True v n (int (List.length v) -( 1 :: int)) @ subrange_list True v(( 0 :: int)) (n -( 1 :: int)) + | RR_rot => + subrange_list False v(( 0 :: int)) (n -( 1 :: int)) @ subrange_list False v n (int (List.length v) -( 1 :: int)) + ))))" + + +definition shiftl_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " shiftl_bv dict_Sail_values_Bitvector_a = ( shift_op_bv + dict_Sail_values_Bitvector_a LL_shift )" + (*<<*) +definition shiftr_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " shiftr_bv dict_Sail_values_Bitvector_a = ( shift_op_bv + dict_Sail_values_Bitvector_a RR_shift )" + (*>>*) +definition arith_shiftr_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " arith_shiftr_bv dict_Sail_values_Bitvector_a = ( shift_op_bv + dict_Sail_values_Bitvector_a RR_shift_arith )" + +definition rotl_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " rotl_bv dict_Sail_values_Bitvector_a = ( shift_op_bv + dict_Sail_values_Bitvector_a LL_rot )" + (*<<<*) +definition rotr_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " rotr_bv dict_Sail_values_Bitvector_a = ( shift_op_bv + dict_Sail_values_Bitvector_a LL_rot )" + (*>>>*) + +definition shiftl_mword :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " shiftl_mword w n = ( w << (nat_of_int n))" + +definition shiftr_mword :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " shiftr_mword w n = ( w >> (nat_of_int n))" + +definition arith_shiftr_mword :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " arith_shiftr_mword w n = ( w >>> (nat_of_int n))" + +definition rotl_mword :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " rotl_mword w n = ( Word.word_rotl (nat_of_int n) w )" + +definition rotr_mword :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " rotr_mword w n = ( Word.word_rotr (nat_of_int n) w )" + + +fun arith_op_no0 :: "(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> int \<Rightarrow> int \<Rightarrow>(int)option " where + " arith_op_no0 (op1 :: int \<Rightarrow> int \<Rightarrow> int) l r = ( + if r =( 0 :: int) + then None + else Some (op1 l r))" + + +(*val arith_op_bv_no0 : forall 'a 'b. Bitvector 'a, Bitvector 'b => + (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a -> maybe 'b*) +definition arith_op_bv_no0 :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow>(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b option " where + " arith_op_bv_no0 dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b op1 sign size1 l r = ( + Option.bind (int_of_bv + dict_Sail_values_Bitvector_a sign l) (\<lambda> l' . + Option.bind (int_of_bv + dict_Sail_values_Bitvector_a sign r) (\<lambda> r' . + if r' =( 0 :: int) then None else Some ( + (of_int_method dict_Sail_values_Bitvector_b) ((length_method dict_Sail_values_Bitvector_a) l * size1) (op1 l' r')))))" + + +definition mod_bv :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'a option " where + " mod_bv dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b = ( arith_op_bv_no0 + dict_Sail_values_Bitvector_b dict_Sail_values_Bitvector_a hardware_mod False(( 1 :: int)))" + +definition quot_bv :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'a option " where + " quot_bv dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b = ( arith_op_bv_no0 + dict_Sail_values_Bitvector_b dict_Sail_values_Bitvector_a hardware_quot False(( 1 :: int)))" + +definition quots_bv :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'a option " where + " quots_bv dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b = ( arith_op_bv_no0 + dict_Sail_values_Bitvector_b dict_Sail_values_Bitvector_a hardware_quot True(( 1 :: int)))" + + +definition mod_mword :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " mod_mword = ( (op mod))" + +definition quot_mword :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " quot_mword = ( (op div))" + +definition quots_mword :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " quots_mword = ( Lem_machine_word.signedDivide )" + + +definition arith_op_bv_int_no0 :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow>(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> 'b option " where + " arith_op_bv_int_no0 dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b op1 sign size1 l r = ( + arith_op_bv_no0 dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b op1 sign size1 l ((of_int_method dict_Sail_values_Bitvector_a) ((length_method dict_Sail_values_Bitvector_a) l) r))" + + +definition quot_bv_int :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'b \<Rightarrow> int \<Rightarrow> 'a option " where + " quot_bv_int dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b = ( arith_op_bv_int_no0 + dict_Sail_values_Bitvector_b dict_Sail_values_Bitvector_a hardware_quot False(( 1 :: int)))" + +definition mod_bv_int :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'b \<Rightarrow> int \<Rightarrow> 'a option " where + " mod_bv_int dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b = ( arith_op_bv_int_no0 + dict_Sail_values_Bitvector_b dict_Sail_values_Bitvector_a hardware_mod False(( 1 :: int)))" + + +definition mod_mword_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " mod_mword_int l r = ( l mod (Word.word_of_int r))" + +definition quot_mword_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " quot_mword_int l r = ( l div (Word.word_of_int r))" + +definition quots_mword_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " quots_mword_int l r = ( Lem_machine_word.signedDivide l (Word.word_of_int r))" + + +definition replicate_bits_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " replicate_bits_bv dict_Sail_values_Bitvector_a v count1 = ( repeat ( + (bits_of_method dict_Sail_values_Bitvector_a) v) count1 )" + +definition duplicate_bit_bv :: " 'a BitU_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>(bitU)list " where + " duplicate_bit_bv dict_Sail_values_BitU_a bit len = ( replicate_bits_bv + (instance_Sail_values_Bitvector_list_dict dict_Sail_values_BitU_a) [bit] len )" + + +(*val eq_bv : forall 'a. Bitvector 'a => 'a -> 'a -> bool*) +definition eq_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool " where + " eq_bv dict_Sail_values_Bitvector_a l r = ( ( + (bits_of_method dict_Sail_values_Bitvector_a) l =(bits_of_method dict_Sail_values_Bitvector_a) r))" + + +(*val neq_bv : forall 'a. Bitvector 'a => 'a -> 'a -> bool*) +definition neq_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool " where + " neq_bv dict_Sail_values_Bitvector_a l r = ( \<not> (eq_bv + dict_Sail_values_Bitvector_a l r))" + + +(*val get_slice_int_bv : forall 'a. Bitvector 'a => integer -> integer -> integer -> 'a*) +definition get_slice_int_bv :: " 'a Bitvector_class \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a " where + " get_slice_int_bv dict_Sail_values_Bitvector_a len n lo = ( + (let hi = ((lo + len) -( 1 :: int)) in + (let bs = (bools_of_int (hi +( 1 :: int)) n) in + (of_bools_method dict_Sail_values_Bitvector_a) (subrange_list False bs hi lo))))" + + +(*val set_slice_int_bv : forall 'a. Bitvector 'a => integer -> integer -> integer -> 'a -> integer*) +definition set_slice_int_bv :: " 'a Bitvector_class \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> int " where + " set_slice_int_bv dict_Sail_values_Bitvector_a len n lo v = ( + (let hi = ((lo + len) -( 1 :: int)) in + (let bs = (bits_of_int (hi +( 1 :: int)) n) in + maybe_failwith (signed_of_bits (update_subrange_list False bs hi lo ( + (bits_of_method dict_Sail_values_Bitvector_a) v))))))" + +end diff --git a/snapshots/isabelle/lib/sail/Sail_operators_bitlists.thy b/snapshots/isabelle/lib/sail/Sail_operators_bitlists.thy new file mode 100644 index 00000000..d3d886ed --- /dev/null +++ b/snapshots/isabelle/lib/sail/Sail_operators_bitlists.thy @@ -0,0 +1,773 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/sail_operators_bitlists.lem.\<close> + +theory "Sail_operators_bitlists" + +imports + Main + "Lem_pervasives_extra" + "Lem_machine_word" + "Sail_values" + "Sail_operators" + "Prompt_monad" + "Prompt" + +begin + +(*open import Pervasives_extra*) +(*open import Machine_word*) +(*open import Sail_values*) +(*open import Sail_operators*) +(*open import Prompt_monad*) +(*open import Prompt*) + +(* Specialisation of operators to bit lists *) + +(*val uint_maybe : list bitU -> maybe integer*) +definition uint_maybe :: "(bitU)list \<Rightarrow>(int)option " where + " uint_maybe v = ( unsigned_of_bits (List.map (\<lambda> b. b) v))" + +definition uint_fail :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow>('c,(int),'b)monad " where + " uint_fail dict_Sail_values_Bitvector_a v = ( maybe_fail (''uint'') ( + (unsigned_method dict_Sail_values_Bitvector_a) v))" + +definition uint_oracle :: "(bitU)list \<Rightarrow>('b,(int),'a)monad " where + " uint_oracle v = ( + bools_of_bits_oracle v \<bind> (\<lambda> bs . + return (int_of_bools False bs)))" + +definition uint :: "(bitU)list \<Rightarrow> int " where + " uint v = ( maybe_failwith (uint_maybe v))" + + +(*val sint_maybe : list bitU -> maybe integer*) +definition sint_maybe :: "(bitU)list \<Rightarrow>(int)option " where + " sint_maybe v = ( signed_of_bits (List.map (\<lambda> b. b) v))" + +definition sint_fail :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow>('c,(int),'b)monad " where + " sint_fail dict_Sail_values_Bitvector_a v = ( maybe_fail (''sint'') ( + (signed_method dict_Sail_values_Bitvector_a) v))" + +definition sint_oracle :: "(bitU)list \<Rightarrow>('b,(int),'a)monad " where + " sint_oracle v = ( + bools_of_bits_oracle v \<bind> (\<lambda> bs . + return (int_of_bools True bs)))" + +definition sint :: "(bitU)list \<Rightarrow> int " where + " sint v = ( maybe_failwith (sint_maybe v))" + + +(*val extz_vec : integer -> list bitU -> list bitU*) +definition extz_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " extz_vec = ( + extz_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val exts_vec : integer -> list bitU -> list bitU*) +definition exts_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " exts_vec = ( + exts_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val zero_extend : list bitU -> integer -> list bitU*) +definition zero_extend :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " zero_extend bits len = ( extz_bits len bits )" + + +(*val sign_extend : list bitU -> integer -> list bitU*) +definition sign_extend :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " sign_extend bits len = ( exts_bits len bits )" + + +(*val zeros : integer -> list bitU*) +definition zeros :: " int \<Rightarrow>(bitU)list " where + " zeros len = ( repeat [B0] len )" + + +(*val vector_truncate : list bitU -> integer -> list bitU*) +definition vector_truncate :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " vector_truncate bs len = ( extz_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) len bs )" + + +(*val vec_of_bits_maybe : list bitU -> maybe (list bitU)*) +(*val vec_of_bits_fail : forall 'rv 'e. list bitU -> monad 'rv (list bitU) 'e*) +(*val vec_of_bits_oracle : forall 'rv 'e. list bitU -> monad 'rv (list bitU) 'e*) +(*val vec_of_bits_failwith : list bitU -> list bitU*) +(*val vec_of_bits : list bitU -> list bitU*) + +(*val access_vec_inc : list bitU -> integer -> bitU*) +definition access_vec_inc :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU " where + " access_vec_inc = ( + access_bv_inc + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val access_vec_dec : list bitU -> integer -> bitU*) +definition access_vec_dec :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU " where + " access_vec_dec = ( + access_bv_dec + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val update_vec_inc : list bitU -> integer -> bitU -> list bitU*) +definition update_vec_inc :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " update_vec_inc = ( + update_bv_inc + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition update_vec_inc_maybe :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>((bitU)list)option " where + " update_vec_inc_maybe v i b = ( Some (update_vec_inc v i b))" + +definition update_vec_inc_fail :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " update_vec_inc_fail v i b = ( return (update_vec_inc v i b))" + +definition update_vec_inc_oracle :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " update_vec_inc_oracle v i b = ( return (update_vec_inc v i b))" + + +(*val update_vec_dec : list bitU -> integer -> bitU -> list bitU*) +definition update_vec_dec :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " update_vec_dec = ( + update_bv_dec + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition update_vec_dec_maybe :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>((bitU)list)option " where + " update_vec_dec_maybe v i b = ( Some (update_vec_dec v i b))" + +definition update_vec_dec_fail :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " update_vec_dec_fail v i b = ( return (update_vec_dec v i b))" + +definition update_vec_dec_oracle :: "(bitU)list \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " update_vec_dec_oracle v i b = ( return (update_vec_dec v i b))" + + +(*val subrange_vec_inc : list bitU -> integer -> integer -> list bitU*) +definition subrange_vec_inc :: "(bitU)list \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list " where + " subrange_vec_inc = ( + subrange_bv_inc + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val subrange_vec_dec : list bitU -> integer -> integer -> list bitU*) +definition subrange_vec_dec :: "(bitU)list \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list " where + " subrange_vec_dec = ( + subrange_bv_dec + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val update_subrange_vec_inc : list bitU -> integer -> integer -> list bitU -> list bitU*) +definition update_subrange_vec_inc :: "(bitU)list \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " update_subrange_vec_inc = ( + update_subrange_bv_inc + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val update_subrange_vec_dec : list bitU -> integer -> integer -> list bitU -> list bitU*) +definition update_subrange_vec_dec :: "(bitU)list \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " update_subrange_vec_dec = ( + update_subrange_bv_dec + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val concat_vec : list bitU -> list bitU -> list bitU*) +definition concat_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " concat_vec = ( + concat_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val cons_vec : bitU -> list bitU -> list bitU*) +definition cons_vec :: " bitU \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " cons_vec = ( + cons_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition cons_vec_maybe :: " bitU \<Rightarrow>(bitU)list \<Rightarrow>((bitU)list)option " where + " cons_vec_maybe b v = ( Some (cons_vec b v))" + +definition cons_vec_fail :: " bitU \<Rightarrow>(bitU)list \<Rightarrow>('b,((bitU)list),'a)monad " where + " cons_vec_fail b v = ( return (cons_vec b v))" + +definition cons_vec_oracle :: " bitU \<Rightarrow>(bitU)list \<Rightarrow>('b,((bitU)list),'a)monad " where + " cons_vec_oracle b v = ( return (cons_vec b v))" + + +(*val cast_unit_vec : bitU -> list bitU*) +definition cast_unit_vec :: " bitU \<Rightarrow>(bitU)list " where + " cast_unit_vec = ( cast_unit_bv )" + +definition cast_unit_vec_maybe :: " bitU \<Rightarrow>((bitU)list)option " where + " cast_unit_vec_maybe b = ( Some (cast_unit_vec b))" + +definition cast_unit_vec_fail :: " bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " cast_unit_vec_fail b = ( return (cast_unit_vec b))" + +definition cast_unit_vec_oracle :: " bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " cast_unit_vec_oracle b = ( return (cast_unit_vec b))" + + +(*val vec_of_bit : integer -> bitU -> list bitU*) +definition vec_of_bit :: " int \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " vec_of_bit = ( bv_of_bit )" + +definition vec_of_bit_maybe :: " int \<Rightarrow> bitU \<Rightarrow>((bitU)list)option " where + " vec_of_bit_maybe len b = ( Some (vec_of_bit len b))" + +definition vec_of_bit_fail :: " int \<Rightarrow> bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " vec_of_bit_fail len b = ( return (vec_of_bit len b))" + +definition vec_of_bit_oracle :: " int \<Rightarrow> bitU \<Rightarrow>('b,((bitU)list),'a)monad " where + " vec_of_bit_oracle len b = ( return (vec_of_bit len b))" + + +(*val msb : list bitU -> bitU*) +definition msb :: "(bitU)list \<Rightarrow> bitU " where + " msb = ( + most_significant + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val int_of_vec_maybe : bool -> list bitU -> maybe integer*) +definition int_of_vec_maybe :: " bool \<Rightarrow>(bitU)list \<Rightarrow>(int)option " where + " int_of_vec_maybe = ( + int_of_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition int_of_vec_fail :: " bool \<Rightarrow>(bitU)list \<Rightarrow>('b,(int),'a)monad " where + " int_of_vec_fail sign v = ( maybe_fail (''int_of_vec'') (int_of_vec_maybe sign v))" + +definition int_of_vec_oracle :: " bool \<Rightarrow>(bitU)list \<Rightarrow>('b,(int),'a)monad " where + " int_of_vec_oracle sign v = ( bools_of_bits_oracle v \<bind> (\<lambda> v . return (int_of_bools sign v)))" + +definition int_of_vec :: " bool \<Rightarrow>(bitU)list \<Rightarrow> int " where + " int_of_vec sign v = ( maybe_failwith (int_of_vec_maybe sign v))" + + +(*val string_of_vec : list bitU -> string*) +definition string_of_vec :: "(bitU)list \<Rightarrow> string " where + " string_of_vec = ( + string_of_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val and_vec : list bitU -> list bitU -> list bitU*) +(*val or_vec : list bitU -> list bitU -> list bitU*) +(*val xor_vec : list bitU -> list bitU -> list bitU*) +(*val not_vec : list bitU -> list bitU*) +definition and_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " and_vec = ( binop_list and_bit )" + +definition or_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " or_vec = ( binop_list or_bit )" + +definition xor_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " xor_vec = ( binop_list xor_bit )" + +definition not_vec :: "(bitU)list \<Rightarrow>(bitU)list " where + " not_vec = ( List.map not_bit )" + + +(*val arith_op_double_bl : forall 'a 'b. Bitvector 'a => + (integer -> integer -> integer) -> bool -> 'a -> 'a -> list bitU*) +definition arith_op_double_bl :: " 'a Bitvector_class \<Rightarrow>(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>(bitU)list " where + " arith_op_double_bl dict_Sail_values_Bitvector_a op1 sign l r = ( + (let len =(( 2 :: int) * + (length_method dict_Sail_values_Bitvector_a) l) in + (let l' = (if sign then exts_bv + dict_Sail_values_Bitvector_a len l else extz_bv dict_Sail_values_Bitvector_a len l) in + (let r' = (if sign then exts_bv + dict_Sail_values_Bitvector_a len r else extz_bv dict_Sail_values_Bitvector_a len r) in + List.map (\<lambda> b. b) (arith_op_bits op1 sign (List.map (\<lambda> b. b) l') (List.map (\<lambda> b. b) r'))))))" + + +(*val add_vec : list bitU -> list bitU -> list bitU*) +(*val adds_vec : list bitU -> list bitU -> list bitU*) +(*val sub_vec : list bitU -> list bitU -> list bitU*) +(*val subs_vec : list bitU -> list bitU -> list bitU*) +(*val mult_vec : list bitU -> list bitU -> list bitU*) +(*val mults_vec : list bitU -> list bitU -> list bitU*) +definition add_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " add_vec = ( (\<lambda> l r. List.map (\<lambda> b. b) (arith_op_bits (op+) False (List.map (\<lambda> b. b) l) (List.map (\<lambda> b. b) r))))" + +definition adds_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " adds_vec = ( (\<lambda> l r. List.map (\<lambda> b. b) (arith_op_bits (op+) True (List.map (\<lambda> b. b) l) (List.map (\<lambda> b. b) r))))" + +definition sub_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " sub_vec = ( (\<lambda> l r. List.map (\<lambda> b. b) (arith_op_bits (op-) False (List.map (\<lambda> b. b) l) (List.map (\<lambda> b. b) r))))" + +definition subs_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " subs_vec = ( (\<lambda> l r. List.map (\<lambda> b. b) (arith_op_bits (op-) True (List.map (\<lambda> b. b) l) (List.map (\<lambda> b. b) r))))" + +definition mult_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " mult_vec = ( arith_op_double_bl + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op*) False )" + +definition mults_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " mults_vec = ( arith_op_double_bl + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op*) True )" + + +(*val add_vec_int : list bitU -> integer -> list bitU*) +(*val adds_vec_int : list bitU -> integer -> list bitU*) +(*val sub_vec_int : list bitU -> integer -> list bitU*) +(*val subs_vec_int : list bitU -> integer -> list bitU*) +(*val mult_vec_int : list bitU -> integer -> list bitU*) +(*val mults_vec_int : list bitU -> integer -> list bitU*) +definition add_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " add_vec_int l r = ( arith_op_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op+) False l r )" + +definition adds_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " adds_vec_int l r = ( arith_op_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op+) True l r )" + +definition sub_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " sub_vec_int l r = ( arith_op_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op-) False l r )" + +definition subs_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " subs_vec_int l r = ( arith_op_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op-) True l r )" + +definition mult_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " mult_vec_int l r = ( arith_op_double_bl + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op*) False l (List.map (\<lambda> b. b) (bits_of_int (int (List.length l)) r)))" + +definition mults_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " mults_vec_int l r = ( arith_op_double_bl + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op*) True l (List.map (\<lambda> b. b) (bits_of_int (int (List.length l)) r)))" + + +(*val add_int_vec : integer -> list bitU -> list bitU*) +(*val adds_int_vec : integer -> list bitU -> list bitU*) +(*val sub_int_vec : integer -> list bitU -> list bitU*) +(*val subs_int_vec : integer -> list bitU -> list bitU*) +(*val mult_int_vec : integer -> list bitU -> list bitU*) +(*val mults_int_vec : integer -> list bitU -> list bitU*) +definition add_int_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " add_int_vec l r = ( arith_op_int_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op+) False l r )" + +definition adds_int_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " adds_int_vec l r = ( arith_op_int_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op+) True l r )" + +definition sub_int_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " sub_int_vec l r = ( arith_op_int_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op-) False l r )" + +definition subs_int_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " subs_int_vec l r = ( arith_op_int_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op-) True l r )" + +definition mult_int_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " mult_int_vec l r = ( arith_op_double_bl + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op*) False (List.map (\<lambda> b. b) (bits_of_int (int (List.length r)) l)) r )" + +definition mults_int_vec :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " mults_int_vec l r = ( arith_op_double_bl + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (op*) True (List.map (\<lambda> b. b) (bits_of_int (int (List.length r)) l)) r )" + + +(*val add_vec_bit : list bitU -> bitU -> list bitU*) +(*val adds_vec_bit : list bitU -> bitU -> list bitU*) +(*val sub_vec_bit : list bitU -> bitU -> list bitU*) +(*val subs_vec_bit : list bitU -> bitU -> list bitU*) + +definition add_vec_bool :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a " where + " add_vec_bool dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bool + dict_Sail_values_Bitvector_a (op+) False l r )" + +definition add_vec_bit_maybe :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow> 'a option " where + " add_vec_bit_maybe dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bit + dict_Sail_values_Bitvector_a (op+) False l r )" + +definition add_vec_bit_fail :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " add_vec_bit_fail dict_Sail_values_Bitvector_a l r = ( maybe_fail (''add_vec_bit'') (add_vec_bit_maybe + dict_Sail_values_Bitvector_a l r))" + +definition add_vec_bit_oracle :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " add_vec_bit_oracle dict_Sail_values_Bitvector_a l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (add_vec_bool + dict_Sail_values_Bitvector_a l r)))" + +definition add_vec_bit :: "(bitU)list \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " add_vec_bit l r = ( case_option (repeat [BU] (int (List.length l))) id (add_vec_bit_maybe + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + + +definition adds_vec_bool :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a " where + " adds_vec_bool dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bool + dict_Sail_values_Bitvector_a (op+) True l r )" + +definition adds_vec_bit_maybe :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow> 'a option " where + " adds_vec_bit_maybe dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bit + dict_Sail_values_Bitvector_a (op+) True l r )" + +definition adds_vec_bit_fail :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " adds_vec_bit_fail dict_Sail_values_Bitvector_a l r = ( maybe_fail (''adds_vec_bit'') (adds_vec_bit_maybe + dict_Sail_values_Bitvector_a l r))" + +definition adds_vec_bit_oracle :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " adds_vec_bit_oracle dict_Sail_values_Bitvector_a l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (adds_vec_bool + dict_Sail_values_Bitvector_a l r)))" + +definition adds_vec_bit :: "(bitU)list \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " adds_vec_bit l r = ( case_option (repeat [BU] (int (List.length l))) id (adds_vec_bit_maybe + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + + +definition sub_vec_bool :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a " where + " sub_vec_bool dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bool + dict_Sail_values_Bitvector_a (op-) False l r )" + +definition sub_vec_bit_maybe :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow> 'a option " where + " sub_vec_bit_maybe dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bit + dict_Sail_values_Bitvector_a (op-) False l r )" + +definition sub_vec_bit_fail :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " sub_vec_bit_fail dict_Sail_values_Bitvector_a l r = ( maybe_fail (''sub_vec_bit'') (sub_vec_bit_maybe + dict_Sail_values_Bitvector_a l r))" + +definition sub_vec_bit_oracle :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " sub_vec_bit_oracle dict_Sail_values_Bitvector_a l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (sub_vec_bool + dict_Sail_values_Bitvector_a l r)))" + +definition sub_vec_bit :: "(bitU)list \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " sub_vec_bit l r = ( case_option (repeat [BU] (int (List.length l))) id (sub_vec_bit_maybe + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + + +definition subs_vec_bool :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a " where + " subs_vec_bool dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bool + dict_Sail_values_Bitvector_a (op-) True l r )" + +definition subs_vec_bit_maybe :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow> 'a option " where + " subs_vec_bit_maybe dict_Sail_values_Bitvector_a l r = ( arith_op_bv_bit + dict_Sail_values_Bitvector_a (op-) True l r )" + +definition subs_vec_bit_fail :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " subs_vec_bit_fail dict_Sail_values_Bitvector_a l r = ( maybe_fail (''sub_vec_bit'') (subs_vec_bit_maybe + dict_Sail_values_Bitvector_a l r))" + +definition subs_vec_bit_oracle :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('d,'a,'c)monad " where + " subs_vec_bit_oracle dict_Sail_values_Bitvector_a l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (subs_vec_bool + dict_Sail_values_Bitvector_a l r)))" + +definition subs_vec_bit :: "(bitU)list \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " subs_vec_bit l r = ( case_option (repeat [BU] (int (List.length l))) id (subs_vec_bit_maybe + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + + +(*val add_overflow_vec : list bitU -> list bitU -> (list bitU * bitU * bitU) +val add_overflow_vec_signed : list bitU -> list bitU -> (list bitU * bitU * bitU) +val sub_overflow_vec : list bitU -> list bitU -> (list bitU * bitU * bitU) +val sub_overflow_vec_signed : list bitU -> list bitU -> (list bitU * bitU * bitU) +val mult_overflow_vec : list bitU -> list bitU -> (list bitU * bitU * bitU) +val mult_overflow_vec_signed : list bitU -> list bitU -> (list bitU * bitU * bitU) +let add_overflow_vec = add_overflow_bv +let add_overflow_vec_signed = add_overflow_bv_signed +let sub_overflow_vec = sub_overflow_bv +let sub_overflow_vec_signed = sub_overflow_bv_signed +let mult_overflow_vec = mult_overflow_bv +let mult_overflow_vec_signed = mult_overflow_bv_signed + +val add_overflow_vec_bit : list bitU -> bitU -> (list bitU * bitU * bitU) +val add_overflow_vec_bit_signed : list bitU -> bitU -> (list bitU * bitU * bitU) +val sub_overflow_vec_bit : list bitU -> bitU -> (list bitU * bitU * bitU) +val sub_overflow_vec_bit_signed : list bitU -> bitU -> (list bitU * bitU * bitU) +let add_overflow_vec_bit = add_overflow_bv_bit +let add_overflow_vec_bit_signed = add_overflow_bv_bit_signed +let sub_overflow_vec_bit = sub_overflow_bv_bit +let sub_overflow_vec_bit_signed = sub_overflow_bv_bit_signed*) + +(*val shiftl : list bitU -> integer -> list bitU*) +(*val shiftr : list bitU -> integer -> list bitU*) +(*val arith_shiftr : list bitU -> integer -> list bitU*) +(*val rotl : list bitU -> integer -> list bitU*) +(*val rotr : list bitU -> integer -> list bitU*) +definition shiftl :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " shiftl = ( + shiftl_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition shiftr :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " shiftr = ( + shiftr_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition arith_shiftr :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " arith_shiftr = ( + arith_shiftr_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition rotl :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " rotl = ( + rotl_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition rotr :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " rotr = ( + rotr_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val mod_vec : list bitU -> list bitU -> list bitU*) +(*val mod_vec_maybe : list bitU -> list bitU -> maybe (list bitU)*) +(*val mod_vec_fail : forall 'rv 'e. list bitU -> list bitU -> monad 'rv (list bitU) 'e*) +(*val mod_vec_oracle : forall 'rv 'e. list bitU -> list bitU -> monad 'rv (list bitU) 'e*) +definition mod_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " mod_vec l r = ( case_option (repeat [BU] (int (List.length l))) id (mod_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition mod_vec_maybe :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>((bitU)list)option " where + " mod_vec_maybe l r = ( mod_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r )" + +definition mod_vec_fail :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>('rv,((bitU)list),'e)monad " where + " mod_vec_fail l r = ( maybe_fail (''mod_vec'') (mod_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition mod_vec_oracle :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>('rv,((bitU)list),'e)monad " where + " mod_vec_oracle l r = ( of_bits_oracle + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (mod_vec l r))" + + +(*val quot_vec : list bitU -> list bitU -> list bitU*) +(*val quot_vec_maybe : list bitU -> list bitU -> maybe (list bitU)*) +(*val quot_vec_fail : forall 'rv 'e. list bitU -> list bitU -> monad 'rv (list bitU) 'e*) +(*val quot_vec_oracle : forall 'rv 'e. list bitU -> list bitU -> monad 'rv (list bitU) 'e*) +definition quot_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " quot_vec l r = ( case_option (repeat [BU] (int (List.length l))) id (quot_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition quot_vec_maybe :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>((bitU)list)option " where + " quot_vec_maybe l r = ( quot_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r )" + +definition quot_vec_fail :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>('rv,((bitU)list),'e)monad " where + " quot_vec_fail l r = ( maybe_fail (''quot_vec'') (quot_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition quot_vec_oracle :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>('rv,((bitU)list),'e)monad " where + " quot_vec_oracle l r = ( of_bits_oracle + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (quot_vec l r))" + + +(*val quots_vec : list bitU -> list bitU -> list bitU*) +(*val quots_vec_maybe : list bitU -> list bitU -> maybe (list bitU)*) +(*val quots_vec_fail : forall 'rv 'e. list bitU -> list bitU -> monad 'rv (list bitU) 'e*) +(*val quots_vec_oracle : forall 'rv 'e. list bitU -> list bitU -> monad 'rv (list bitU) 'e*) +definition quots_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " quots_vec l r = ( case_option (repeat [BU] (int (List.length l))) id (quots_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition quots_vec_maybe :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>((bitU)list)option " where + " quots_vec_maybe l r = ( quots_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r )" + +definition quots_vec_fail :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>('rv,((bitU)list),'e)monad " where + " quots_vec_fail l r = ( maybe_fail (''quots_vec'') (quots_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition quots_vec_oracle :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>('rv,((bitU)list),'e)monad " where + " quots_vec_oracle l r = ( of_bits_oracle + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (quots_vec l r))" + + +(*val mod_vec_int : list bitU -> integer -> list bitU*) +(*val mod_vec_int_maybe : list bitU -> integer -> maybe (list bitU)*) +(*val mod_vec_int_fail : forall 'rv 'e. list bitU -> integer -> monad 'rv (list bitU) 'e*) +(*val mod_vec_int_oracle : forall 'rv 'e. list bitU -> integer -> monad 'rv (list bitU) 'e*) +definition mod_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " mod_vec_int l r = ( case_option (repeat [BU] (int (List.length l))) id (mod_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition mod_vec_int_maybe :: "(bitU)list \<Rightarrow> int \<Rightarrow>((bitU)list)option " where + " mod_vec_int_maybe l r = ( mod_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r )" + +definition mod_vec_int_fail :: "(bitU)list \<Rightarrow> int \<Rightarrow>('rv,((bitU)list),'e)monad " where + " mod_vec_int_fail l r = ( maybe_fail (''mod_vec_int'') (mod_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition mod_vec_int_oracle :: "(bitU)list \<Rightarrow> int \<Rightarrow>('rv,((bitU)list),'e)monad " where + " mod_vec_int_oracle l r = ( of_bits_oracle + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (mod_vec_int l r))" + + +(*val quot_vec_int : list bitU -> integer -> list bitU*) +(*val quot_vec_int_maybe : list bitU -> integer -> maybe (list bitU)*) +(*val quot_vec_int_fail : forall 'rv 'e. list bitU -> integer -> monad 'rv (list bitU) 'e*) +(*val quot_vec_int_oracle : forall 'rv 'e. list bitU -> integer -> monad 'rv (list bitU) 'e*) +definition quot_vec_int :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " quot_vec_int l r = ( case_option (repeat [BU] (int (List.length l))) id (quot_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition quot_vec_int_maybe :: "(bitU)list \<Rightarrow> int \<Rightarrow>((bitU)list)option " where + " quot_vec_int_maybe l r = ( quot_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r )" + +definition quot_vec_int_fail :: "(bitU)list \<Rightarrow> int \<Rightarrow>('rv,((bitU)list),'e)monad " where + " quot_vec_int_fail l r = ( maybe_fail (''quot_vec_int'') (quot_bv_int + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) l r))" + +definition quot_vec_int_oracle :: "(bitU)list \<Rightarrow> int \<Rightarrow>('rv,((bitU)list),'e)monad " where + " quot_vec_int_oracle l r = ( of_bits_oracle + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) (quot_vec_int l r))" + + +(*val replicate_bits : list bitU -> integer -> list bitU*) +definition replicate_bits :: "(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list " where + " replicate_bits = ( + replicate_bits_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val duplicate : bitU -> integer -> list bitU*) +definition duplicate :: " bitU \<Rightarrow> int \<Rightarrow>(bitU)list " where + " duplicate = ( + duplicate_bit_bv instance_Sail_values_BitU_Sail_values_bitU_dict )" + +definition duplicate_maybe :: " bitU \<Rightarrow> int \<Rightarrow>((bitU)list)option " where + " duplicate_maybe b n = ( Some (duplicate b n))" + +definition duplicate_fail :: " bitU \<Rightarrow> int \<Rightarrow>('b,((bitU)list),'a)monad " where + " duplicate_fail b n = ( return (duplicate b n))" + +definition duplicate_oracle :: " bitU \<Rightarrow> int \<Rightarrow>('b,((bitU)list),'a)monad " where + " duplicate_oracle b n = ( + bool_of_bitU_oracle b \<bind> (\<lambda> b . + return (duplicate (bitU_of_bool b) n)))" + + +(*val reverse_endianness : list bitU -> list bitU*) +definition reverse_endianness :: "(bitU)list \<Rightarrow>(bitU)list " where + " reverse_endianness v = ( reverse_endianness_list v )" + + +(*val get_slice_int : integer -> integer -> integer -> list bitU*) +definition get_slice_int :: " int \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list " where + " get_slice_int = ( + get_slice_int_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val set_slice_int : integer -> integer -> integer -> list bitU -> integer*) +definition set_slice_int :: " int \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list \<Rightarrow> int " where + " set_slice_int = ( + set_slice_int_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + + +(*val slice : list bitU -> integer -> integer -> list bitU*) +definition slice :: "(bitU)list \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list " where + " slice v lo len = ( + subrange_vec_dec v ((lo + len) -( 1 :: int)) lo )" + + +(*val set_slice : integer -> integer -> list bitU -> integer -> list bitU -> list bitU*) +definition set_slice :: " int \<Rightarrow> int \<Rightarrow>(bitU)list \<Rightarrow> int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " set_slice (out_len::ii) (slice_len::ii) out (n::ii) v = ( + update_subrange_vec_dec out ((n + slice_len) -( 1 :: int)) n v )" + + +(*val eq_vec : list bitU -> list bitU -> bool*) +(*val neq_vec : list bitU -> list bitU -> bool*) +definition eq_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow> bool " where + " eq_vec = ( + eq_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +definition neq_vec :: "(bitU)list \<Rightarrow>(bitU)list \<Rightarrow> bool " where + " neq_vec = ( + neq_bv + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) )" + +end diff --git a/snapshots/isabelle/lib/sail/Sail_operators_mwords.thy b/snapshots/isabelle/lib/sail/Sail_operators_mwords.thy new file mode 100644 index 00000000..edaec4e3 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Sail_operators_mwords.thy @@ -0,0 +1,638 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/sail_operators_mwords.lem.\<close> + +theory "Sail_operators_mwords" + +imports + Main + "Lem_pervasives_extra" + "Lem_machine_word" + "Sail_values" + "Sail_operators" + "Prompt_monad" + "Prompt" + +begin + +(*open import Pervasives_extra*) +(*open import Machine_word*) +(*open import Sail_values*) +(*open import Sail_operators*) +(*open import Prompt_monad*) +(*open import Prompt*) +definition uint_maybe :: "('a::len)Word.word \<Rightarrow>(int)option " where + " uint_maybe v = ( Some (Word.uint v))" + +definition uint_fail :: "('a::len)Word.word \<Rightarrow>('c,(int),'b)monad " where + " uint_fail v = ( return (Word.uint v))" + +definition uint_oracle :: "('a::len)Word.word \<Rightarrow>('c,(int),'b)monad " where + " uint_oracle v = ( return (Word.uint v))" + +definition sint_maybe :: "('a::len)Word.word \<Rightarrow>(int)option " where + " sint_maybe v = ( Some (Word.sint v))" + +definition sint_fail :: "('a::len)Word.word \<Rightarrow>('c,(int),'b)monad " where + " sint_fail v = ( return (Word.sint v))" + +definition sint_oracle :: "('a::len)Word.word \<Rightarrow>('c,(int),'b)monad " where + " sint_oracle v = ( return (Word.sint v))" + + +(*val vec_of_bits_maybe : forall 'a. Size 'a => list bitU -> maybe (mword 'a)*) +(*val vec_of_bits_fail : forall 'rv 'a 'e. Size 'a => list bitU -> monad 'rv (mword 'a) 'e*) +(*val vec_of_bits_oracle : forall 'rv 'a 'e. Size 'a => list bitU -> monad 'rv (mword 'a) 'e*) +(*val vec_of_bits_failwith : forall 'a. Size 'a => list bitU -> mword 'a*) +(*val vec_of_bits : forall 'a. Size 'a => list bitU -> mword 'a*) +definition vec_of_bits_maybe :: "(bitU)list \<Rightarrow>(('a::len)Word.word)option " where + " vec_of_bits_maybe bits = ( map_option Word.of_bl (just_list (List.map bool_of_bitU bits)))" + +definition vec_of_bits_fail :: "(bitU)list \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " vec_of_bits_fail bits = ( of_bits_fail + instance_Sail_values_Bitvector_Machine_word_mword_dict bits )" + +definition vec_of_bits_oracle :: "(bitU)list \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " vec_of_bits_oracle bits = ( of_bits_oracle + instance_Sail_values_Bitvector_Machine_word_mword_dict bits )" + +definition vec_of_bits_failwith :: "(bitU)list \<Rightarrow>('a::len)Word.word " where + " vec_of_bits_failwith bits = ( of_bits_failwith + instance_Sail_values_Bitvector_Machine_word_mword_dict bits )" + +definition vec_of_bits :: "(bitU)list \<Rightarrow>('a::len)Word.word " where + " vec_of_bits bits = ( of_bits_failwith + instance_Sail_values_Bitvector_Machine_word_mword_dict bits )" + + +(*val access_vec_inc : forall 'a. Size 'a => mword 'a -> integer -> bitU*) +definition access_vec_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU " where + " access_vec_inc = ( + access_bv_inc instance_Sail_values_Bitvector_Machine_word_mword_dict )" + + +(*val access_vec_dec : forall 'a. Size 'a => mword 'a -> integer -> bitU*) +definition access_vec_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU " where + " access_vec_dec = ( + access_bv_dec instance_Sail_values_Bitvector_Machine_word_mword_dict )" + + +definition update_vec_dec_maybe :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " update_vec_dec_maybe w i b = ( update_mword_dec w i b )" + +definition update_vec_dec_fail :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " update_vec_dec_fail w i b = ( + bool_of_bitU_fail b \<bind> (\<lambda> b . + return (update_mword_bool_dec w i b)))" + +definition update_vec_dec_oracle :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " update_vec_dec_oracle w i b = ( + bool_of_bitU_oracle b \<bind> (\<lambda> b . + return (update_mword_bool_dec w i b)))" + +definition update_vec_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('a::len)Word.word " where + " update_vec_dec w i b = ( maybe_failwith (update_vec_dec_maybe w i b))" + + +definition update_vec_inc_maybe :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " update_vec_inc_maybe w i b = ( update_mword_inc w i b )" + +definition update_vec_inc_fail :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " update_vec_inc_fail w i b = ( + bool_of_bitU_fail b \<bind> (\<lambda> b . + return (update_mword_bool_inc w i b)))" + +definition update_vec_inc_oracle :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " update_vec_inc_oracle w i b = ( + bool_of_bitU_oracle b \<bind> (\<lambda> b . + return (update_mword_bool_inc w i b)))" + +definition update_vec_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>('a::len)Word.word " where + " update_vec_inc w i b = ( maybe_failwith (update_vec_inc_maybe w i b))" + + +(*val subrange_vec_dec : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b*) +definition subrange_vec_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " subrange_vec_dec w i j = ( Word.slice (nat_of_int j) w )" + + +(*val subrange_vec_inc : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b*) +definition subrange_vec_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " subrange_vec_inc w i j = ( subrange_vec_dec w ((int (size w) -( 1 :: int)) - i) ((int (size w) -( 1 :: int)) - j))" + + +(*val update_subrange_vec_dec : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b -> mword 'a*) +definition update_subrange_vec_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word \<Rightarrow>('a::len)Word.word " where + " update_subrange_vec_dec w i j w' = ( Lem.word_update w (nat_of_int j) (nat_of_int i) w' )" + + +(*val update_subrange_vec_inc : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b -> mword 'a*) +definition update_subrange_vec_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word \<Rightarrow>('a::len)Word.word " where + " update_subrange_vec_inc w i j w' = ( update_subrange_vec_dec w ((int (size w) -( 1 :: int)) - i) ((int (size w) -( 1 :: int)) - j) w' )" + + +(*val extz_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*) +definition extz_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " extz_vec _ w = ( Word.ucast w )" + + +(*val exts_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*) +definition exts_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " exts_vec _ w = ( Word.scast w )" + + +(*val zero_extend : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*) +definition zero_extend :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " zero_extend w _ = ( Word.ucast w )" + + +(*val sign_extend : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*) +definition sign_extend :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " sign_extend w _ = ( Word.scast w )" + + +(*val zeros : forall 'a. Size 'a => integer -> mword 'a*) +definition zeros :: " int \<Rightarrow>('a::len)Word.word " where + " zeros _ = ( Word.word_of_int (int(( 0 :: nat))))" + + +(*val vector_truncate : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*) +definition vector_truncate :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " vector_truncate w _ = ( Word.ucast w )" + + +(*val concat_vec : forall 'a 'b 'c. Size 'a, Size 'b, Size 'c => mword 'a -> mword 'b -> mword 'c*) +definition concat_vec :: "('a::len)Word.word \<Rightarrow>('b::len)Word.word \<Rightarrow>('c::len)Word.word " where + " concat_vec = ( Word.word_cat )" + + +(*val cons_vec_bool : forall 'a 'b 'c. Size 'a, Size 'b => bool -> mword 'a -> mword 'b*) +definition cons_vec_bool :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " cons_vec_bool b w = ( Word.of_bl (b # Word.to_bl w))" + +definition cons_vec_maybe :: " bitU \<Rightarrow>('c::len)Word.word \<Rightarrow>(('b::len)Word.word)option " where + " cons_vec_maybe b w = ( map_option (\<lambda> b . cons_vec_bool b w) (bool_of_bitU b))" + +definition cons_vec_fail :: " bitU \<Rightarrow>('c::len)Word.word \<Rightarrow>('e,(('b::len)Word.word),'d)monad " where + " cons_vec_fail b w = ( bool_of_bitU_fail b \<bind> (\<lambda> b . return (cons_vec_bool b w)))" + +definition cons_vec_oracle :: " bitU \<Rightarrow>('c::len)Word.word \<Rightarrow>('e,(('b::len)Word.word),'d)monad " where + " cons_vec_oracle b w = ( bool_of_bitU_oracle b \<bind> (\<lambda> b . return (cons_vec_bool b w)))" + +definition cons_vec :: " bitU \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " cons_vec b w = ( maybe_failwith (cons_vec_maybe b w))" + + +(*val vec_of_bool : forall 'a. Size 'a => integer -> bool -> mword 'a*) +definition vec_of_bool :: " int \<Rightarrow> bool \<Rightarrow>('a::len)Word.word " where + " vec_of_bool _ b = ( Word.of_bl [b])" + +definition vec_of_bit_maybe :: " int \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " vec_of_bit_maybe len b = ( map_option (vec_of_bool len) (bool_of_bitU b))" + +definition vec_of_bit_fail :: " int \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " vec_of_bit_fail len b = ( bool_of_bitU_fail b \<bind> (\<lambda> b . return (vec_of_bool len b)))" + +definition vec_of_bit_oracle :: " int \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " vec_of_bit_oracle len b = ( bool_of_bitU_oracle b \<bind> (\<lambda> b . return (vec_of_bool len b)))" + +definition vec_of_bit :: " int \<Rightarrow> bitU \<Rightarrow>('a::len)Word.word " where + " vec_of_bit len b = ( maybe_failwith (vec_of_bit_maybe len b))" + + +(*val cast_bool_vec : bool -> mword ty1*) +definition cast_bool_vec :: " bool \<Rightarrow>(1)Word.word " where + " cast_bool_vec b = ( vec_of_bool(( 1 :: int)) b )" + +definition cast_unit_vec_maybe :: " bitU \<Rightarrow>(('a::len)Word.word)option " where + " cast_unit_vec_maybe b = ( vec_of_bit_maybe(( 1 :: int)) b )" + +definition cast_unit_vec_fail :: " bitU \<Rightarrow>('b,((1)Word.word),'a)monad " where + " cast_unit_vec_fail b = ( bool_of_bitU_fail b \<bind> (\<lambda> b . return (cast_bool_vec b)))" + +definition cast_unit_vec_oracle :: " bitU \<Rightarrow>('b,((1)Word.word),'a)monad " where + " cast_unit_vec_oracle b = ( bool_of_bitU_oracle b \<bind> (\<lambda> b . return (cast_bool_vec b)))" + +definition cast_unit_vec :: " bitU \<Rightarrow>('a::len)Word.word " where + " cast_unit_vec b = ( maybe_failwith (cast_unit_vec_maybe b))" + + +(*val msb : forall 'a. Size 'a => mword 'a -> bitU*) +definition msb :: "('a::len)Word.word \<Rightarrow> bitU " where + " msb = ( + most_significant instance_Sail_values_Bitvector_Machine_word_mword_dict )" + + +(*val int_of_vec : forall 'a. Size 'a => bool -> mword 'a -> integer*) +definition int_of_vec :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow> int " where + " int_of_vec sign w = ( + if sign + then Word.sint w + else Word.uint w )" + +definition int_of_vec_maybe :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow>(int)option " where + " int_of_vec_maybe sign w = ( Some (int_of_vec sign w))" + +definition int_of_vec_fail :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow>('c,(int),'b)monad " where + " int_of_vec_fail sign w = ( return (int_of_vec sign w))" + + +(*val string_of_vec : forall 'a. Size 'a => mword 'a -> string*) +definition string_of_vec :: "('a::len)Word.word \<Rightarrow> string " where + " string_of_vec = ( + string_of_bv instance_Sail_values_Bitvector_Machine_word_mword_dict )" + + +(*val and_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val or_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val xor_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val not_vec : forall 'a. Size 'a => mword 'a -> mword 'a*) +definition and_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " and_vec = ( Bits.bitAND )" + +definition or_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " or_vec = ( Bits.bitOR )" + +definition xor_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " xor_vec = ( Bits.bitXOR )" + +definition not_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " not_vec = ( Bits.bitNOT )" + + +(*val add_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val adds_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val sub_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val subs_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val mult_vec : forall 'a 'b. Size 'a, Size 'b => mword 'a -> mword 'a -> mword 'b*) +(*val mults_vec : forall 'a 'b. Size 'a, Size 'b => mword 'a -> mword 'a -> mword 'b*) +definition add_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " add_vec l r = ( Word.word_of_int ((int_of_mword False l) + (int_of_mword False r)))" + +definition adds_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " adds_vec l r = ( Word.word_of_int ((int_of_mword True l) + (int_of_mword True r)))" + +definition sub_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " sub_vec l r = ( Word.word_of_int ((int_of_mword False l) - (int_of_mword False r)))" + +definition subs_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " subs_vec l r = ( Word.word_of_int ((int_of_mword True l) - (int_of_mword True r)))" + +definition mult_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " mult_vec l r = ( Word.word_of_int ((int_of_mword False (Word.ucast l :: ( 'b::len)Word.word)) * (int_of_mword False (Word.ucast r :: ( 'b::len)Word.word))))" + +definition mults_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " mults_vec l r = ( Word.word_of_int ((int_of_mword True (Word.scast l :: ( 'b::len)Word.word)) * (int_of_mword True (Word.scast r :: ( 'b::len)Word.word))))" + + +(*val add_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val adds_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val sub_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val subs_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val mult_vec_int : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*) +(*val mults_vec_int : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*) +definition add_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " add_vec_int l r = ( arith_op_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict (op+) False l r )" + +definition adds_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " adds_vec_int l r = ( arith_op_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict (op+) True l r )" + +definition sub_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " sub_vec_int l r = ( arith_op_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict (op-) False l r )" + +definition subs_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " subs_vec_int l r = ( arith_op_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict (op-) True l r )" + +definition mult_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " mult_vec_int l r = ( arith_op_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict (op*) False (Word.ucast l :: ( 'b::len)Word.word) r )" + +definition mults_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " mults_vec_int l r = ( arith_op_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict (op*) True (Word.scast l :: ( 'b::len)Word.word) r )" + + +(*val add_int_vec : forall 'a. Size 'a => integer -> mword 'a -> mword 'a*) +(*val adds_int_vec : forall 'a. Size 'a => integer -> mword 'a -> mword 'a*) +(*val sub_int_vec : forall 'a. Size 'a => integer -> mword 'a -> mword 'a*) +(*val subs_int_vec : forall 'a. Size 'a => integer -> mword 'a -> mword 'a*) +(*val mult_int_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*) +(*val mults_int_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*) +definition add_int_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " add_int_vec l r = ( arith_op_int_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict (op+) False l r )" + +definition adds_int_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " adds_int_vec l r = ( arith_op_int_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict (op+) True l r )" + +definition sub_int_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " sub_int_vec l r = ( arith_op_int_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict (op-) False l r )" + +definition subs_int_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " subs_int_vec l r = ( arith_op_int_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict (op-) True l r )" + +definition mult_int_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " mult_int_vec l r = ( arith_op_int_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict (op*) False l (Word.ucast r :: ( 'b::len)Word.word))" + +definition mults_int_vec :: " int \<Rightarrow>('a::len)Word.word \<Rightarrow>('b::len)Word.word " where + " mults_int_vec l r = ( arith_op_int_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict (op*) True l (Word.scast r :: ( 'b::len)Word.word))" + + +(*val add_vec_bool : forall 'a. Size 'a => mword 'a -> bool -> mword 'a*) +(*val adds_vec_bool : forall 'a. Size 'a => mword 'a -> bool -> mword 'a*) +(*val sub_vec_bool : forall 'a. Size 'a => mword 'a -> bool -> mword 'a*) +(*val subs_vec_bool : forall 'a. Size 'a => mword 'a -> bool -> mword 'a*) + +definition add_vec_bool :: "('a::len)Word.word \<Rightarrow> bool \<Rightarrow>('a::len)Word.word " where + " add_vec_bool l r = ( arith_op_bv_bool + instance_Sail_values_Bitvector_Machine_word_mword_dict (op+) False l r )" + +definition add_vec_bit_maybe :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " add_vec_bit_maybe l r = ( map_option (add_vec_bool l) (bool_of_bitU r))" + +definition add_vec_bit_fail :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " add_vec_bit_fail l r = ( bool_of_bitU_fail r \<bind> (\<lambda> r . return (add_vec_bool l r)))" + +definition add_vec_bit_oracle :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " add_vec_bit_oracle l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (add_vec_bool l r)))" + +definition add_vec_bit :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('a::len)Word.word " where + " add_vec_bit l r = ( maybe_failwith (add_vec_bit_maybe l r))" + + +definition adds_vec_bool :: "('a::len)Word.word \<Rightarrow> bool \<Rightarrow>('a::len)Word.word " where + " adds_vec_bool l r = ( arith_op_bv_bool + instance_Sail_values_Bitvector_Machine_word_mword_dict (op+) True l r )" + +definition adds_vec_bit_maybe :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " adds_vec_bit_maybe l r = ( map_option (adds_vec_bool l) (bool_of_bitU r))" + +definition adds_vec_bit_fail :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " adds_vec_bit_fail l r = ( bool_of_bitU_fail r \<bind> (\<lambda> r . return (adds_vec_bool l r)))" + +definition adds_vec_bit_oracle :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " adds_vec_bit_oracle l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (adds_vec_bool l r)))" + +definition adds_vec_bit :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('a::len)Word.word " where + " adds_vec_bit l r = ( maybe_failwith (adds_vec_bit_maybe l r))" + + +definition sub_vec_bool :: "('a::len)Word.word \<Rightarrow> bool \<Rightarrow>('a::len)Word.word " where + " sub_vec_bool l r = ( arith_op_bv_bool + instance_Sail_values_Bitvector_Machine_word_mword_dict (op-) False l r )" + +definition sub_vec_bit_maybe :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " sub_vec_bit_maybe l r = ( map_option (sub_vec_bool l) (bool_of_bitU r))" + +definition sub_vec_bit_fail :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " sub_vec_bit_fail l r = ( bool_of_bitU_fail r \<bind> (\<lambda> r . return (sub_vec_bool l r)))" + +definition sub_vec_bit_oracle :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " sub_vec_bit_oracle l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (sub_vec_bool l r)))" + +definition sub_vec_bit :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('a::len)Word.word " where + " sub_vec_bit l r = ( maybe_failwith (sub_vec_bit_maybe l r))" + + +definition subs_vec_bool :: "('a::len)Word.word \<Rightarrow> bool \<Rightarrow>('a::len)Word.word " where + " subs_vec_bool l r = ( arith_op_bv_bool + instance_Sail_values_Bitvector_Machine_word_mword_dict (op-) True l r )" + +definition subs_vec_bit_maybe :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " subs_vec_bit_maybe l r = ( map_option (subs_vec_bool l) (bool_of_bitU r))" + +definition subs_vec_bit_fail :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " subs_vec_bit_fail l r = ( bool_of_bitU_fail r \<bind> (\<lambda> r . return (subs_vec_bool l r)))" + +definition subs_vec_bit_oracle :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " subs_vec_bit_oracle l r = ( bool_of_bitU_oracle r \<bind> (\<lambda> r . return (subs_vec_bool l r)))" + +definition subs_vec_bit :: "('a::len)Word.word \<Rightarrow> bitU \<Rightarrow>('a::len)Word.word " where + " subs_vec_bit l r = ( maybe_failwith (subs_vec_bit_maybe l r))" + + +(* TODO +val maybe_mword_of_bits_overflow : forall 'a. Size 'a => (list bitU * bitU * bitU) -> maybe (mword 'a * bitU * bitU) +let maybe_mword_of_bits_overflow (bits, overflow, carry) = + Maybe.map (fun w -> (w, overflow, carry)) (of_bits bits) + +val add_overflow_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a * bitU * bitU) +val adds_overflow_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a * bitU * bitU) +val sub_overflow_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a * bitU * bitU) +val subs_overflow_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a * bitU * bitU) +val mult_overflow_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a * bitU * bitU) +val mults_overflow_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a * bitU * bitU) +let add_overflow_vec l r = maybe_mword_of_bits_overflow (add_overflow_bv l r) +let adds_overflow_vec l r = maybe_mword_of_bits_overflow (adds_overflow_bv l r) +let sub_overflow_vec l r = maybe_mword_of_bits_overflow (sub_overflow_bv l r) +let subs_overflow_vec l r = maybe_mword_of_bits_overflow (subs_overflow_bv l r) +let mult_overflow_vec l r = maybe_mword_of_bits_overflow (mult_overflow_bv l r) +let mults_overflow_vec l r = maybe_mword_of_bits_overflow (mults_overflow_bv l r) + +val add_overflow_vec_bit : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU) +val add_overflow_vec_bit_signed : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU) +val sub_overflow_vec_bit : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU) +val sub_overflow_vec_bit_signed : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU) +let add_overflow_vec_bit = add_overflow_bv_bit +let add_overflow_vec_bit_signed = add_overflow_bv_bit_signed +let sub_overflow_vec_bit = sub_overflow_bv_bit +let sub_overflow_vec_bit_signed = sub_overflow_bv_bit_signed*) + +(*val shiftl : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val shiftr : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val arith_shiftr : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val rotl : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val rotr : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +definition shiftl :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " shiftl = ( shiftl_mword )" + +definition shiftr :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " shiftr = ( shiftr_mword )" + +definition arith_shiftr :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " arith_shiftr = ( arith_shiftr_mword )" + +definition rotl :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " rotl = ( rotl_mword )" + +definition rotr :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " rotr = ( rotr_mword )" + + +(*val mod_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val mod_vec_maybe : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a)*) +(*val mod_vec_fail : forall 'rv 'a 'e. Size 'a => mword 'a -> mword 'a -> monad 'rv (mword 'a) 'e*) +(*val mod_vec_oracle : forall 'rv 'a 'e. Size 'a => mword 'a -> mword 'a -> monad 'rv (mword 'a) 'e*) +definition mod_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " mod_vec l r = ( mod_mword l r )" + +definition mod_vec_maybe :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>(('a::len)Word.word)option " where + " mod_vec_maybe l r = ( mod_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r )" + +definition mod_vec_fail :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " mod_vec_fail l r = ( maybe_fail (''mod_vec'') (mod_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r))" + +definition mod_vec_oracle :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " mod_vec_oracle l r = ( + (case (mod_bv instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r) of + Some w => return w + | None => mword_oracle () + ))" + + +(*val quot_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val quot_vec_maybe : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a)*) +(*val quot_vec_fail : forall 'rv 'a 'e. Size 'a => mword 'a -> mword 'a -> monad 'rv (mword 'a) 'e*) +(*val quot_vec_oracle : forall 'rv 'a 'e. Size 'a => mword 'a -> mword 'a -> monad 'rv (mword 'a) 'e*) +definition quot_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " quot_vec l r = ( quot_mword l r )" + +definition quot_vec_maybe :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>(('a::len)Word.word)option " where + " quot_vec_maybe l r = ( quot_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r )" + +definition quot_vec_fail :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " quot_vec_fail l r = ( maybe_fail (''quot_vec'') (quot_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r))" + +definition quot_vec_oracle :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " quot_vec_oracle l r = ( + (case (quot_bv instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r) of + Some w => return w + | None => mword_oracle () + ))" + + +(*val quots_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a*) +(*val quots_vec_maybe : forall 'a. Size 'a => mword 'a -> mword 'a -> maybe (mword 'a)*) +(*val quots_vec_fail : forall 'rv 'a 'e. Size 'a => mword 'a -> mword 'a -> monad 'rv (mword 'a) 'e*) +(*val quots_vec_oracle : forall 'rv 'a 'e. Size 'a => mword 'a -> mword 'a -> monad 'rv (mword 'a) 'e*) +definition quots_vec :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " quots_vec l r = ( quots_mword l r )" + +definition quots_vec_maybe :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>(('a::len)Word.word)option " where + " quots_vec_maybe l r = ( quots_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r )" + +definition quots_vec_fail :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " quots_vec_fail l r = ( maybe_fail (''quots_vec'') (quots_bv + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r))" + +definition quots_vec_oracle :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " quots_vec_oracle l r = ( + (case (quots_bv instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r) of + Some w => return w + | None => mword_oracle () + ))" + + +(*val mod_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val mod_vec_int_maybe : forall 'a. Size 'a => mword 'a -> integer -> maybe (mword 'a)*) +(*val mod_vec_int_fail : forall 'rv 'a 'e. Size 'a => mword 'a -> integer -> monad 'rv (mword 'a) 'e*) +(*val mod_vec_int_oracle : forall 'rv 'a 'e. Size 'a => mword 'a -> integer -> monad 'rv (mword 'a) 'e*) +definition mod_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " mod_vec_int l r = ( mod_mword_int l r )" + +definition mod_vec_int_maybe :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>(('a::len)Word.word)option " where + " mod_vec_int_maybe l r = ( mod_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r )" + +definition mod_vec_int_fail :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " mod_vec_int_fail l r = ( maybe_fail (''mod_vec_int'') (mod_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r))" + +definition mod_vec_int_oracle :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " mod_vec_int_oracle l r = ( + (case (mod_bv_int instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r) of + Some w => return w + | None => mword_oracle () + ))" + + +(*val quot_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*) +(*val quot_vec_int_maybe : forall 'a. Size 'a => mword 'a -> integer -> maybe (mword 'a)*) +(*val quot_vec_int_fail : forall 'rv 'a 'e. Size 'a => mword 'a -> integer -> monad 'rv (mword 'a) 'e*) +(*val quot_vec_int_oracle : forall 'rv 'a 'e. Size 'a => mword 'a -> integer -> monad 'rv (mword 'a) 'e*) +definition quot_vec_int :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " quot_vec_int l r = ( quot_mword_int l r )" + +definition quot_vec_int_maybe :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>(('a::len)Word.word)option " where + " quot_vec_int_maybe l r = ( quot_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r )" + +definition quot_vec_int_fail :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " quot_vec_int_fail l r = ( maybe_fail (''quot_vec_int'') (quot_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r))" + +definition quot_vec_int_oracle :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('rv,(('a::len)Word.word),'e)monad " where + " quot_vec_int_oracle l r = ( + (case (quot_bv_int + instance_Sail_values_Bitvector_Machine_word_mword_dict instance_Sail_values_Bitvector_Machine_word_mword_dict l r) of + Some w => return w + | None => mword_oracle () + ))" + + +(*val replicate_bits : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*) +definition replicate_bits :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " replicate_bits v count1 = ( Word.of_bl (repeat (Word.to_bl v) count1))" + + +(*val duplicate_bool : forall 'a. Size 'a => bool -> integer -> mword 'a*) +definition duplicate_bool :: " bool \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " duplicate_bool b n = ( Word.of_bl (repeat [b] n))" + +definition duplicate_maybe :: " bitU \<Rightarrow> int \<Rightarrow>(('a::len)Word.word)option " where + " duplicate_maybe b n = ( map_option (\<lambda> b . duplicate_bool b n) (bool_of_bitU b))" + +definition duplicate_fail :: " bitU \<Rightarrow> int \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " duplicate_fail b n = ( bool_of_bitU_fail b \<bind> (\<lambda> b . return (duplicate_bool b n)))" + +definition duplicate_oracle :: " bitU \<Rightarrow> int \<Rightarrow>('c,(('a::len)Word.word),'b)monad " where + " duplicate_oracle b n = ( bool_of_bitU_oracle b \<bind> (\<lambda> b . return (duplicate_bool b n)))" + +definition duplicate :: " bitU \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " duplicate b n = ( maybe_failwith (duplicate_maybe b n))" + + +(*val reverse_endianness : forall 'a. Size 'a => mword 'a -> mword 'a*) +definition reverse_endianness :: "('a::len)Word.word \<Rightarrow>('a::len)Word.word " where + " reverse_endianness v = ( Word.of_bl (reverse_endianness_list (Word.to_bl v)))" + + +(*val get_slice_int : forall 'a. Size 'a => integer -> integer -> integer -> mword 'a*) +definition get_slice_int :: " int \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('a::len)Word.word " where + " get_slice_int = ( + get_slice_int_bv instance_Sail_values_Bitvector_Machine_word_mword_dict )" + + +(*val set_slice_int : forall 'a. Size 'a => integer -> integer -> integer -> mword 'a -> integer*) +definition set_slice_int :: " int \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('a::len)Word.word \<Rightarrow> int " where + " set_slice_int = ( + set_slice_int_bv instance_Sail_values_Bitvector_Machine_word_mword_dict )" + + +(*val slice : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b*) +definition slice :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " slice v lo len = ( + subrange_vec_dec v ((lo + len) -( 1 :: int)) lo )" + + +(*val set_slice : forall 'a 'b. Size 'a, Size 'b => integer -> integer -> mword 'a -> integer -> mword 'b -> mword 'a*) +definition set_slice :: " int \<Rightarrow> int \<Rightarrow>('a::len)Word.word \<Rightarrow> int \<Rightarrow>('b::len)Word.word \<Rightarrow>('a::len)Word.word " where + " set_slice (out_len::ii) (slice_len::ii) out (n::ii) v = ( + update_subrange_vec_dec out ((n + slice_len) -( 1 :: int)) n v )" + + +(*val eq_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> bool*) +(*val neq_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> bool*) +end diff --git a/snapshots/isabelle/lib/sail/Sail_operators_mwords_lemmas.thy b/snapshots/isabelle/lib/sail/Sail_operators_mwords_lemmas.thy new file mode 100644 index 00000000..22c35e1f --- /dev/null +++ b/snapshots/isabelle/lib/sail/Sail_operators_mwords_lemmas.thy @@ -0,0 +1,112 @@ +theory "Sail_operators_mwords_lemmas" + imports Sail_operators_mwords +begin + +lemmas uint_simps[simp] = uint_maybe_def uint_fail_def uint_oracle_def +lemmas sint_simps[simp] = sint_maybe_def sint_fail_def sint_oracle_def + +lemma bools_of_bits_oracle_just_list[simp]: + assumes "just_list (map bool_of_bitU bus) = Some bs" + shows "bools_of_bits_oracle bus = return bs" +proof - + have f: "foreachM bus bools (\<lambda>b bools. bool_of_bitU_oracle b \<bind> (\<lambda>b. return (bools @ [b]))) = return (bools @ bs)" + if "just_list (map bool_of_bitU bus) = Some bs" for bus bs bools + proof (use that in \<open>induction bus arbitrary: bs bools\<close>) + case (Cons bu bus bs) + obtain b bs' where bs: "bs = b # bs'" and bu: "bool_of_bitU bu = Some b" + using Cons.prems by (cases bu) (auto split: option.splits) + then show ?case + using Cons.prems Cons.IH[where bs = bs' and bools = "bools @ [b]"] + by (cases bu) (auto simp: bool_of_bitU_oracle_def split: option.splits) + qed auto + then show ?thesis using f[OF assms, of "[]"] unfolding bools_of_bits_oracle_def + by auto +qed + +lemma of_bits_mword_return_of_bl[simp]: + assumes "just_list (map bool_of_bitU bus) = Some bs" + shows "of_bits_oracle BC_mword bus = return (of_bl bs)" + and "of_bits_fail BC_mword bus = return (of_bl bs)" + by (auto simp: of_bits_oracle_def of_bits_fail_def maybe_fail_def assms BC_mword_defs) + +lemma vec_of_bits_of_bl[simp]: + assumes "just_list (map bool_of_bitU bus) = Some bs" + shows "vec_of_bits_maybe bus = Some (of_bl bs)" + and "vec_of_bits_fail bus = return (of_bl bs)" + and "vec_of_bits_oracle bus = return (of_bl bs)" + and "vec_of_bits_failwith bus = of_bl bs" + and "vec_of_bits bus = of_bl bs" + unfolding vec_of_bits_maybe_def vec_of_bits_fail_def vec_of_bits_oracle_def + vec_of_bits_failwith_def vec_of_bits_def + by (auto simp: assms) + +lemmas access_vec_dec_test_bit[simp] = access_bv_dec_mword[folded access_vec_dec_def] + +lemma access_vec_inc_test_bit[simp]: + fixes w :: "('a::len) word" + assumes "n \<ge> 0" and "nat n < LENGTH('a)" + shows "access_vec_inc w n = bitU_of_bool (w !! (LENGTH('a) - 1 - nat n))" + using assms + by (auto simp: access_vec_inc_def access_bv_inc_def access_list_def BC_mword_defs rev_nth test_bit_bl) + +lemma bool_of_bitU_monadic_simps[simp]: + "bool_of_bitU_fail B0 = return False" + "bool_of_bitU_fail B1 = return True" + "bool_of_bitU_fail BU = Fail ''bool_of_bitU''" + "bool_of_bitU_oracle B0 = return False" + "bool_of_bitU_oracle B1 = return True" + "bool_of_bitU_oracle BU = undefined_bool ()" + unfolding bool_of_bitU_fail_def bool_of_bitU_oracle_def + by auto + +lemma update_vec_dec_simps[simp]: + "update_vec_dec_maybe w i B0 = Some (set_bit w (nat i) False)" + "update_vec_dec_maybe w i B1 = Some (set_bit w (nat i) True)" + "update_vec_dec_maybe w i BU = None" + "update_vec_dec_fail w i B0 = return (set_bit w (nat i) False)" + "update_vec_dec_fail w i B1 = return (set_bit w (nat i) True)" + "update_vec_dec_fail w i BU = Fail ''bool_of_bitU''" + "update_vec_dec_oracle w i B0 = return (set_bit w (nat i) False)" + "update_vec_dec_oracle w i B1 = return (set_bit w (nat i) True)" + "update_vec_dec_oracle w i BU = undefined_bool () \<bind> (\<lambda>b. return (set_bit w (nat i) b))" + "update_vec_dec w i B0 = set_bit w (nat i) False" + "update_vec_dec w i B1 = set_bit w (nat i) True" + unfolding update_vec_dec_maybe_def update_vec_dec_fail_def update_vec_dec_oracle_def update_vec_dec_def + by (auto simp: update_mword_dec_def update_mword_bool_dec_def maybe_failwith_def) + +lemma len_of_minus_One_minus_nonneg_lt_len_of[simp]: + "n \<ge> 0 \<Longrightarrow> nat (int LENGTH('a::len) - 1 - n) < LENGTH('a)" + by (metis diff_mono diff_zero len_gt_0 nat_eq_iff2 nat_less_iff order_refl zle_diff1_eq) + +declare extz_vec_def[simp] +declare exts_vec_def[simp] +declare concat_vec_def[simp] + +lemma msb_Bits_msb[simp]: + "msb w = bitU_of_bool (Bits.msb w)" + by (auto simp: msb_def most_significant_def BC_mword_defs word_msb_alt split: list.splits) + +declare and_vec_def[simp] +declare or_vec_def[simp] +declare xor_vec_def[simp] +declare not_vec_def[simp] + +lemma arith_vec_simps[simp]: + "add_vec l r = l + r" + "sub_vec l r = l - r" + "mult_vec l r = (ucast l) * (ucast r)" + unfolding add_vec_def sub_vec_def mult_vec_def + by (auto simp: int_of_mword_def word_add_def word_sub_wi word_mult_def) + +declare adds_vec_def[simp] +declare subs_vec_def[simp] +declare mults_vec_def[simp] + +lemma arith_vec_int_simps[simp]: + "add_vec_int l r = l + (word_of_int r)" + "sub_vec_int l r = l - (word_of_int r)" + "mult_vec_int l r = (ucast l) * (word_of_int r)" + unfolding add_vec_int_def sub_vec_int_def mult_vec_int_def + by (auto simp: arith_op_bv_int_def BC_mword_defs word_add_def word_sub_wi word_mult_def) + +end diff --git a/snapshots/isabelle/lib/sail/Sail_values.thy b/snapshots/isabelle/lib/sail/Sail_values.thy new file mode 100644 index 00000000..7338ac40 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Sail_values.thy @@ -0,0 +1,1215 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/sail_values.lem.\<close> + +theory "Sail_values" + +imports + Main + "Lem_pervasives_extra" + "Lem_machine_word" + +begin + +(*open import Pervasives_extra*) +(*open import Machine_word*) +(*open import Sail_impl_base*) + + +type_synonym ii =" int " +type_synonym nn =" nat " + +(*val nat_of_int : integer -> nat*) +definition nat_of_int :: " int \<Rightarrow> nat " where + " nat_of_int i = ( if i <( 0 :: int) then( 0 :: nat) else nat (abs ( i)))" + + +(*val pow : integer -> integer -> integer*) +definition pow :: " int \<Rightarrow> int \<Rightarrow> int " where + " pow m n = ( m ^ (nat_of_int n))" + + +definition pow2 :: " int \<Rightarrow> int " where + " pow2 n = ( pow(( 2 :: int)) n )" + + +(*val eq : forall 'a. Eq 'a => 'a -> 'a -> bool*) + +(*val neq : forall 'a. Eq 'a => 'a -> 'a -> bool*) + +(*let add_int l r = integerAdd l r +let add_signed l r = integerAdd l r +let sub_int l r = integerMinus l r +let mult_int l r = integerMult l r +let div_int l r = integerDiv l r +let div_nat l r = natDiv l r +let power_int_nat l r = integerPow l r +let power_int_int l r = integerPow l (nat_of_int r) +let negate_int i = integerNegate i +let min_int l r = integerMin l r +let max_int l r = integerMax l r + +let add_real l r = realAdd l r +let sub_real l r = realMinus l r +let mult_real l r = realMult l r +let div_real l r = realDiv l r +let negate_real r = realNegate r +let abs_real r = realAbs r +let power_real b e = realPowInteger b e*) + +(*val prerr_endline : string -> unit*) +definition prerr_endline :: " string \<Rightarrow> unit " where + " prerr_endline _ = ( () )" + + +(*val print_int : string -> integer -> unit*) +definition print_int :: " string \<Rightarrow> int \<Rightarrow> unit " where + " print_int msg i = ( prerr_endline (msg @ (stringFromInteger i)))" + + +(*val putchar : integer -> unit*) +definition putchar :: " int \<Rightarrow> unit " where + " putchar _ = ( () )" + + +(*val shr_int : ii -> ii -> ii*) +function (sequential,domintros) shr_int :: " int \<Rightarrow> int \<Rightarrow> int " where + " shr_int x s = ( if s >( 0 :: int) then shr_int (x div( 2 :: int)) (s -( 1 :: int)) else x )" +by pat_completeness auto + + +(*val shl_int : integer -> integer -> integer*) +function (sequential,domintros) shl_int :: " int \<Rightarrow> int \<Rightarrow> int " where + " shl_int i shift = ( if shift >( 0 :: int) then( 2 :: int) * shl_int i (shift -( 1 :: int)) else i )" +by pat_completeness auto + +definition take_list :: " int \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " take_list n xs = ( List.take (nat_of_int n) xs )" + +definition drop_list :: " int \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " drop_list n xs = ( List.drop (nat_of_int n) xs )" + + +(*val repeat : forall 'a. list 'a -> integer -> list 'a*) +fun repeat :: " 'a list \<Rightarrow> int \<Rightarrow> 'a list " where + " repeat xs n = ( + if n \<le>( 0 :: int) then [] + else xs @ repeat xs (n-( 1 :: int)))" + + +definition duplicate_to_list :: " 'a \<Rightarrow> int \<Rightarrow> 'a list " where + " duplicate_to_list bit length1 = ( repeat [bit] length1 )" + + +fun replace :: " 'a list \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> 'a list " where + " replace ([]) (n :: int) b' = ( [])" +|" replace (b # bs) (n :: int) b' = ( + if n =( 0 :: int) then b' # bs + else b # replace bs (n -( 1 :: int)) b' )" + + +definition upper :: " 'a \<Rightarrow> 'a " where + " upper n = ( n )" + + +(* Modulus operation corresponding to quot below -- result + has sign of dividend. *) +definition hardware_mod :: " int \<Rightarrow> int \<Rightarrow> int " where + " hardware_mod (a:: int) (b::int) = ( + (let m = ((abs a) mod (abs b)) in + if a <( 0 :: int) then - m else m))" + + +(* There are different possible answers for integer divide regarding +rounding behaviour on negative operands. Positive operands always +round down so derive the one we want (trucation towards zero) from +that *) +definition hardware_quot :: " int \<Rightarrow> int \<Rightarrow> int " where + " hardware_quot (a::int) (b::int) = ( + (let q = ((abs a) div (abs b)) in + if ((a<( 0 :: int)) \<longleftrightarrow> (b<( 0 :: int))) then + q (* same sign -- result positive *) + else + - q))" + (* different sign -- result negative *) + +definition max_64u :: " int " where + " max_64u = ( ((( 2 :: int))^(( 64 :: nat))) -( 1 :: int))" + +definition max_64 :: " int " where + " max_64 = ( ((( 2 :: int))^(( 63 :: nat))) -( 1 :: int))" + +definition min_64 :: " int " where + " min_64 = (( 0 :: int) - ((( 2 :: int))^(( 63 :: nat))))" + +definition max_32u :: " int " where + " max_32u = ( (( 4294967295 :: int) :: int))" + +definition max_32 :: " int " where + " max_32 = ( (( 2147483647 :: int) :: int))" + +definition min_32 :: " int " where + " min_32 = ( (( 0 :: int) -( 2147483648 :: int) :: int))" + +definition max_8 :: " int " where + " max_8 = ( (( 127 :: int) :: int))" + +definition min_8 :: " int " where + " min_8 = ( (( 0 :: int) -( 128 :: int) :: int))" + +definition max_5 :: " int " where + " max_5 = ( (( 31 :: int) :: int))" + +definition min_5 :: " int " where + " min_5 = ( (( 0 :: int) -( 32 :: int) :: int))" + + +(* just_list takes a list of maybes and returns Just xs if all elements have + a value, and Nothing if one of the elements is Nothing. *) +(*val just_list : forall 'a. list (maybe 'a) -> maybe (list 'a)*) +fun just_list :: "('a option)list \<Rightarrow>('a list)option " where + " just_list ([]) = ( Some [])" +|" just_list (x # xs) = ( + (case (x, just_list xs) of + (Some x, Some xs) => Some (x # xs) + | (_, _) => None + ))" + + +(*val maybe_failwith : forall 'a. maybe 'a -> 'a*) +definition maybe_failwith :: " 'a option \<Rightarrow> 'a " where + " maybe_failwith = ( \<lambda>x . + (case x of Some a => a | None => failwith (''maybe_failwith'') ) )" + + +(*** Bits *) +datatype bitU = B0 | B1 | BU + +definition showBitU :: " bitU \<Rightarrow> string " where + " showBitU = ( \<lambda>x . + (case x of B0 => (''O'') | B1 => (''I'') | BU => (''U'') ) )" + + +definition bitU_char :: " bitU \<Rightarrow> char " where + " bitU_char = ( \<lambda>x . + (case x of B0 => (CHR ''0'') | B1 => (CHR ''1'') | BU => (CHR ''?'') ) )" + + +definition instance_Show_Show_Sail_values_bitU_dict :: "(bitU)Show_class " where + " instance_Show_Show_Sail_values_bitU_dict = ((| + + show_method = showBitU |) )" + + +(*val compare_bitU : bitU -> bitU -> ordering*) +fun compare_bitU :: " bitU \<Rightarrow> bitU \<Rightarrow> ordering " where + " compare_bitU BU BU = ( EQ )" +|" compare_bitU B0 B0 = ( EQ )" +|" compare_bitU B1 B1 = ( EQ )" +|" compare_bitU BU _ = ( LT )" +|" compare_bitU _ BU = ( GT )" +|" compare_bitU B0 _ = ( LT )" +|" compare_bitU _ _ = ( GT )" + + +definition instance_Basic_classes_Ord_Sail_values_bitU_dict :: "(bitU)Ord_class " where + " instance_Basic_classes_Ord_Sail_values_bitU_dict = ((| + + compare_method = compare_bitU, + + isLess_method = (\<lambda> l r. (compare_bitU l r) = LT), + + isLessEqual_method = (\<lambda> l r. (compare_bitU l r) \<noteq> GT), + + isGreater_method = (\<lambda> l r. (compare_bitU l r) = GT), + + isGreaterEqual_method = (\<lambda> l r. (compare_bitU l r) \<noteq> LT)|) )" + + +record 'a BitU_class= + + to_bitU_method ::" 'a \<Rightarrow> bitU " + + of_bitU_method ::" bitU \<Rightarrow> 'a " + + + +definition instance_Sail_values_BitU_Sail_values_bitU_dict :: "(bitU)BitU_class " where + " instance_Sail_values_BitU_Sail_values_bitU_dict = ((| + + to_bitU_method = (\<lambda> b. b), + + of_bitU_method = (\<lambda> b. b)|) )" + + +definition bool_of_bitU :: " bitU \<Rightarrow>(bool)option " where + " bool_of_bitU = ( \<lambda>x . + (case x of B0 => Some False | B1 => Some True | BU => None ) )" + + +definition bitU_of_bool :: " bool \<Rightarrow> bitU " where + " bitU_of_bool b = ( if b then B1 else B0 )" + + +(*instance (BitU bool) + let to_bitU = bitU_of_bool + let of_bitU = bool_of_bitU +end*) + +definition cast_bit_bool :: " bitU \<Rightarrow>(bool)option " where + " cast_bit_bool = ( bool_of_bitU )" + + +definition not_bit :: " bitU \<Rightarrow> bitU " where + " not_bit = ( \<lambda>x . + (case x of B1 => B0 | B0 => B1 | BU => BU ) )" + + +(*val is_one : integer -> bitU*) +definition is_one :: " int \<Rightarrow> bitU " where + " is_one i = ( + if i =( 1 :: int) then B1 else B0 )" + + +(*val and_bit : bitU -> bitU -> bitU*) +fun and_bit :: " bitU \<Rightarrow> bitU \<Rightarrow> bitU " where + " and_bit B0 _ = ( B0 )" +|" and_bit _ B0 = ( B0 )" +|" and_bit B1 B1 = ( B1 )" +|" and_bit _ _ = ( BU )" + + +(*val or_bit : bitU -> bitU -> bitU*) +fun or_bit :: " bitU \<Rightarrow> bitU \<Rightarrow> bitU " where + " or_bit B1 _ = ( B1 )" +|" or_bit _ B1 = ( B1 )" +|" or_bit B0 B0 = ( B0 )" +|" or_bit _ _ = ( BU )" + + +(*val xor_bit : bitU -> bitU -> bitU*) +fun xor_bit :: " bitU \<Rightarrow> bitU \<Rightarrow> bitU " where + " xor_bit B0 B0 = ( B0 )" +|" xor_bit B0 B1 = ( B1 )" +|" xor_bit B1 B0 = ( B1 )" +|" xor_bit B1 B1 = ( B0 )" +|" xor_bit _ _ = ( BU )" + + +(*val &. : bitU -> bitU -> bitU*) + +(*val |. : bitU -> bitU -> bitU*) + +(*val +. : bitU -> bitU -> bitU*) + + +(*** Bool lists ***) + +(*val bools_of_nat_aux : integer -> natural -> list bool -> list bool*) +fun bools_of_nat_aux :: " int \<Rightarrow> nat \<Rightarrow>(bool)list \<Rightarrow>(bool)list " where + " bools_of_nat_aux len x acc1 = ( + if len \<le>( 0 :: int) then acc1 + else bools_of_nat_aux (len -( 1 :: int)) (x div( 2 :: nat)) ((if (x mod( 2 :: nat)) =( 1 :: nat) then True else False) # acc1))" + +definition bools_of_nat :: " int \<Rightarrow> nat \<Rightarrow>(bool)list " where + " bools_of_nat len n = ( bools_of_nat_aux len n [])" + (*List.reverse (bools_of_nat_aux n)*) + +(*val nat_of_bools_aux : natural -> list bool -> natural*) +fun nat_of_bools_aux :: " nat \<Rightarrow>(bool)list \<Rightarrow> nat " where + " nat_of_bools_aux acc1 ([]) = ( acc1 )" +|" nat_of_bools_aux acc1 (True # bs) = ( nat_of_bools_aux ((( 2 :: nat) * acc1) +( 1 :: nat)) bs )" +|" nat_of_bools_aux acc1 (False # bs) = ( nat_of_bools_aux (( 2 :: nat) * acc1) bs )" + +definition nat_of_bools :: "(bool)list \<Rightarrow> nat " where + " nat_of_bools bs = ( nat_of_bools_aux(( 0 :: nat)) bs )" + + +(*val unsigned_of_bools : list bool -> integer*) +definition unsigned_of_bools :: "(bool)list \<Rightarrow> int " where + " unsigned_of_bools bs = ( int (nat_of_bools bs))" + + +(*val signed_of_bools : list bool -> integer*) +definition signed_of_bools :: "(bool)list \<Rightarrow> int " where + " signed_of_bools bs = ( + (case bs of + True # _ =>( 0 :: int) - (( 1 :: int) + (unsigned_of_bools (List.map (\<lambda> x. \<not> x) bs))) + | False # _ => unsigned_of_bools bs + | [] =>( 0 :: int) (* Treat empty list as all zeros *) + ))" + + +(*val int_of_bools : bool -> list bool -> integer*) +definition int_of_bools :: " bool \<Rightarrow>(bool)list \<Rightarrow> int " where + " int_of_bools sign bs = ( if sign then signed_of_bools bs else unsigned_of_bools bs )" + + +(*val pad_list : forall 'a. 'a -> list 'a -> integer -> list 'a*) +fun pad_list :: " 'a \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> 'a list " where + " pad_list x xs n = ( + if n \<le>( 0 :: int) then xs else pad_list x (x # xs) (n -( 1 :: int)))" + + +definition ext_list :: " 'a \<Rightarrow> int \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " ext_list pad len xs = ( + (let longer = (len - (int (List.length xs))) in + if longer <( 0 :: int) then List.drop (nat_of_int (abs (longer))) xs + else pad_list pad xs longer))" + + +definition extz_bools :: " int \<Rightarrow>(bool)list \<Rightarrow>(bool)list " where + " extz_bools len bs = ( ext_list False len bs )" + +definition exts_bools :: " int \<Rightarrow>(bool)list \<Rightarrow>(bool)list " where + " exts_bools len bs = ( + (case bs of + True # _ => ext_list True len bs + | _ => ext_list False len bs + ))" + + +fun add_one_bool_ignore_overflow_aux :: "(bool)list \<Rightarrow>(bool)list " where + " add_one_bool_ignore_overflow_aux ([]) = ( [])" +|" add_one_bool_ignore_overflow_aux (False # bits) = ( True # bits )" +|" add_one_bool_ignore_overflow_aux (True # bits) = ( False # add_one_bool_ignore_overflow_aux bits )" + + +definition add_one_bool_ignore_overflow :: "(bool)list \<Rightarrow>(bool)list " where + " add_one_bool_ignore_overflow bits = ( + List.rev (add_one_bool_ignore_overflow_aux (List.rev bits)))" + + +(*let bool_list_of_int n = + let bs_abs = false :: bools_of_nat (naturalFromInteger (abs n)) in + if n >= (0 : integer) then bs_abs + else add_one_bool_ignore_overflow (List.map not bs_abs) +let bools_of_int len n = exts_bools len (bool_list_of_int n)*) +definition bools_of_int :: " int \<Rightarrow> int \<Rightarrow>(bool)list " where + " bools_of_int len n = ( + (let bs_abs = (bools_of_nat len (nat (abs (abs n)))) in + if n \<ge> (( 0 :: int) :: int) then bs_abs + else add_one_bool_ignore_overflow (List.map (\<lambda> x. \<not> x) bs_abs)))" + + +(*** Bit lists ***) + +(*val has_undefined_bits : list bitU -> bool*) +definition has_undefined_bits :: "(bitU)list \<Rightarrow> bool " where + " has_undefined_bits bs = ( ((\<exists> x \<in> (set bs). (\<lambda>x . + (case x of BU => True | _ => False )) x)))" + + +definition bits_of_nat :: " int \<Rightarrow> nat \<Rightarrow>(bitU)list " where + " bits_of_nat len n = ( List.map bitU_of_bool (bools_of_nat len n))" + + +definition nat_of_bits :: "(bitU)list \<Rightarrow>(nat)option " where + " nat_of_bits bits = ( + (case (just_list (List.map bool_of_bitU bits)) of + Some bs => Some (nat_of_bools bs) + | None => None + ))" + + +definition not_bits :: "(bitU)list \<Rightarrow>(bitU)list " where + " not_bits = ( List.map not_bit )" + + +(*val binop_list : forall 'a. ('a -> 'a -> 'a) -> list 'a -> list 'a -> list 'a*) +definition binop_list :: "('a \<Rightarrow> 'a \<Rightarrow> 'a)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " binop_list op1 xs ys = ( + List.foldr ( \<lambda>x . + (case x of (x, y) => \<lambda> acc1 . op1 x y # acc1 )) (List.zip xs ys) [])" + + +definition unsigned_of_bits :: "(bitU)list \<Rightarrow>(int)option " where + " unsigned_of_bits bits = ( + (case (just_list (List.map bool_of_bitU bits)) of + Some bs => Some (unsigned_of_bools bs) + | None => None + ))" + + +definition signed_of_bits :: "(bitU)list \<Rightarrow>(int)option " where + " signed_of_bits bits = ( + (case (just_list (List.map bool_of_bitU bits)) of + Some bs => Some (signed_of_bools bs) + | None => None + ))" + + +(*val int_of_bits : bool -> list bitU -> maybe integer*) +definition int_of_bits :: " bool \<Rightarrow>(bitU)list \<Rightarrow>(int)option " where + " int_of_bits sign bs = ( if sign then signed_of_bits bs else unsigned_of_bits bs )" + + +definition extz_bits :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " extz_bits len bits = ( ext_list B0 len bits )" + +definition exts_bits :: " int \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " exts_bits len bits = ( + (case bits of + BU # _ => ext_list BU len bits + | B1 # _ => ext_list B1 len bits + | _ => ext_list B0 len bits + ))" + + +fun add_one_bit_ignore_overflow_aux :: "(bitU)list \<Rightarrow>(bitU)list " where + " add_one_bit_ignore_overflow_aux ([]) = ( [])" +|" add_one_bit_ignore_overflow_aux (B0 # bits) = ( B1 # bits )" +|" add_one_bit_ignore_overflow_aux (B1 # bits) = ( B0 # add_one_bit_ignore_overflow_aux bits )" +|" add_one_bit_ignore_overflow_aux (BU # bits) = ( BU # List.map ( \<lambda>x . + (case x of _ => BU )) bits )" + + +definition add_one_bit_ignore_overflow :: "(bitU)list \<Rightarrow>(bitU)list " where + " add_one_bit_ignore_overflow bits = ( + List.rev (add_one_bit_ignore_overflow_aux (List.rev bits)))" + + +(*let bit_list_of_int n = List.map bitU_of_bool (bool_list_of_int n) +let bits_of_int len n = exts_bits len (bit_list_of_int n)*) +definition bits_of_int :: " int \<Rightarrow> int \<Rightarrow>(bitU)list " where + " bits_of_int len n = ( List.map bitU_of_bool (bools_of_int len n))" + + +(*val arith_op_bits : + (integer -> integer -> integer) -> bool -> list bitU -> list bitU -> list bitU*) +definition arith_op_bits :: "(int \<Rightarrow> int \<Rightarrow> int)\<Rightarrow> bool \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list \<Rightarrow>(bitU)list " where + " arith_op_bits op1 sign l r = ( + (case (int_of_bits sign l, int_of_bits sign r) of + (Some li, Some ri) => bits_of_int (int (List.length l)) (op1 li ri) + | (_, _) => repeat [BU] (int (List.length l)) + ))" + + +definition char_of_nibble :: " bitU*bitU*bitU*bitU \<Rightarrow>(char)option " where + " char_of_nibble = ( \<lambda>x . + (case x of + (B0, B0, B0, B0) => Some (CHR ''0'') + | (B0, B0, B0, B1) => Some (CHR ''1'') + | (B0, B0, B1, B0) => Some (CHR ''2'') + | (B0, B0, B1, B1) => Some (CHR ''3'') + | (B0, B1, B0, B0) => Some (CHR ''4'') + | (B0, B1, B0, B1) => Some (CHR ''5'') + | (B0, B1, B1, B0) => Some (CHR ''6'') + | (B0, B1, B1, B1) => Some (CHR ''7'') + | (B1, B0, B0, B0) => Some (CHR ''8'') + | (B1, B0, B0, B1) => Some (CHR ''9'') + | (B1, B0, B1, B0) => Some (CHR ''A'') + | (B1, B0, B1, B1) => Some (CHR ''B'') + | (B1, B1, B0, B0) => Some (CHR ''C'') + | (B1, B1, B0, B1) => Some (CHR ''D'') + | (B1, B1, B1, B0) => Some (CHR ''E'') + | (B1, B1, B1, B1) => Some (CHR ''F'') + | _ => None + ) )" + + +fun hexstring_of_bits :: "(bitU)list \<Rightarrow>((char)list)option " where + " hexstring_of_bits (b1 # b2 # b3 # b4 # bs) = ( + (let n = (char_of_nibble (b1, b2, b3, b4)) in + (let s = (hexstring_of_bits bs) in + (case (n, s) of + (Some n, Some s) => Some (n # s) + | _ => None + ))))" +|" hexstring_of_bits ([]) = ( Some [])" +|" hexstring_of_bits _ = ( None )" + + +definition show_bitlist :: "(bitU)list \<Rightarrow> string " where + " show_bitlist bs = ( + (case hexstring_of_bits bs of + Some s => ((CHR ''0'') # ((CHR ''x'') # s)) + | None => ((CHR ''0'') # ((CHR ''b'') # List.map bitU_char bs)) + ))" + + +(*val subrange_list_inc : forall 'a. list 'a -> integer -> integer -> list 'a*) +definition subrange_list_inc :: " 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a list " where + " subrange_list_inc xs i j = ( + (let (toJ,suffix0) = (split_at (nat_of_int (j +( 1 :: int))) xs) in + (let (prefix0,fromItoJ) = (split_at (nat_of_int i) toJ) in + fromItoJ)))" + + +(*val subrange_list_dec : forall 'a. list 'a -> integer -> integer -> list 'a*) +definition subrange_list_dec :: " 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a list " where + " subrange_list_dec xs i j = ( + (let top1 = ((int (List.length xs)) -( 1 :: int)) in + subrange_list_inc xs (top1 - i) (top1 - j)))" + + +(*val subrange_list : forall 'a. bool -> list 'a -> integer -> integer -> list 'a*) +definition subrange_list :: " bool \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a list " where + " subrange_list is_inc xs i j = ( if is_inc then subrange_list_inc xs i j else subrange_list_dec xs i j )" + + +(*val update_subrange_list_inc : forall 'a. list 'a -> integer -> integer -> list 'a -> list 'a*) +definition update_subrange_list_inc :: " 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " update_subrange_list_inc xs i j xs' = ( + (let (toJ,suffix) = (split_at (nat_of_int (j +( 1 :: int))) xs) in + (let (prefix,fromItoJ0) = (split_at (nat_of_int i) toJ) in + (prefix @ xs') @ suffix)))" + + +(*val update_subrange_list_dec : forall 'a. list 'a -> integer -> integer -> list 'a -> list 'a*) +definition update_subrange_list_dec :: " 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " update_subrange_list_dec xs i j xs' = ( + (let top1 = ((int (List.length xs)) -( 1 :: int)) in + update_subrange_list_inc xs (top1 - i) (top1 - j) xs'))" + + +(*val update_subrange_list : forall 'a. bool -> list 'a -> integer -> integer -> list 'a -> list 'a*) +definition update_subrange_list :: " bool \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a list \<Rightarrow> 'a list " where + " update_subrange_list is_inc xs i j xs' = ( + if is_inc then update_subrange_list_inc xs i j xs' else update_subrange_list_dec xs i j xs' )" + + +(*val access_list_inc : forall 'a. list 'a -> integer -> 'a*) +definition access_list_inc :: " 'a list \<Rightarrow> int \<Rightarrow> 'a " where + " access_list_inc xs n = ( List.nth xs (nat_of_int n))" + + +(*val access_list_dec : forall 'a. list 'a -> integer -> 'a*) +definition access_list_dec :: " 'a list \<Rightarrow> int \<Rightarrow> 'a " where + " access_list_dec xs n = ( + (let top1 = ((int (List.length xs)) -( 1 :: int)) in + access_list_inc xs (top1 - n)))" + + +(*val access_list : forall 'a. bool -> list 'a -> integer -> 'a*) +definition access_list :: " bool \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> 'a " where + " access_list is_inc xs n = ( + if is_inc then access_list_inc xs n else access_list_dec xs n )" + + +(*val update_list_inc : forall 'a. list 'a -> integer -> 'a -> list 'a*) +definition update_list_inc :: " 'a list \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> 'a list " where + " update_list_inc xs n x = ( List.list_update xs (nat_of_int n) x )" + + +(*val update_list_dec : forall 'a. list 'a -> integer -> 'a -> list 'a*) +definition update_list_dec :: " 'a list \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> 'a list " where + " update_list_dec xs n x = ( + (let top1 = ((int (List.length xs)) -( 1 :: int)) in + update_list_inc xs (top1 - n) x))" + + +(*val update_list : forall 'a. bool -> list 'a -> integer -> 'a -> list 'a*) +definition update_list :: " bool \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow> 'a list " where + " update_list is_inc xs n x = ( + if is_inc then update_list_inc xs n x else update_list_dec xs n x )" + + +definition extract_only_bit :: "(bitU)list \<Rightarrow> bitU " where + " extract_only_bit = ( \<lambda>x . + (case x of [] => BU | [e] => e | _ => BU ) )" + + +(*** Machine words *) + +(*val length_mword : forall 'a. mword 'a -> integer*) + +(*val slice_mword_dec : forall 'a 'b. mword 'a -> integer -> integer -> mword 'b*) +definition slice_mword_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " slice_mword_dec w i j = ( Word.slice (nat_of_int i) w )" + + +(*val slice_mword_inc : forall 'a 'b. mword 'a -> integer -> integer -> mword 'b*) +definition slice_mword_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " slice_mword_inc w i j = ( + (let top1 = ((int (size w)) -( 1 :: int)) in + slice_mword_dec w (top1 - i) (top1 - j)))" + + +(*val slice_mword : forall 'a 'b. bool -> mword 'a -> integer -> integer -> mword 'b*) +definition slice_mword :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word " where + " slice_mword is_inc w i j = ( if is_inc then slice_mword_inc w i j else slice_mword_dec w i j )" + + +(*val update_slice_mword_dec : forall 'a 'b. mword 'a -> integer -> integer -> mword 'b -> mword 'a*) +definition update_slice_mword_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word \<Rightarrow>('a::len)Word.word " where + " update_slice_mword_dec w i j w' = ( Lem.word_update w (nat_of_int i) (nat_of_int j) w' )" + + +(*val update_slice_mword_inc : forall 'a 'b. mword 'a -> integer -> integer -> mword 'b -> mword 'a*) +definition update_slice_mword_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word \<Rightarrow>('a::len)Word.word " where + " update_slice_mword_inc w i j w' = ( + (let top1 = ((int (size w)) -( 1 :: int)) in + update_slice_mword_dec w (top1 - i) (top1 - j) w'))" + + +(*val update_slice_mword : forall 'a 'b. bool -> mword 'a -> integer -> integer -> mword 'b -> mword 'a*) +definition update_slice_mword :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow> int \<Rightarrow> int \<Rightarrow>('b::len)Word.word \<Rightarrow>('a::len)Word.word " where + " update_slice_mword is_inc w i j w' = ( + if is_inc then update_slice_mword_inc w i j w' else update_slice_mword_dec w i j w' )" + + +(*val access_mword_dec : forall 'a. mword 'a -> integer -> bitU*) +definition access_mword_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU " where + " access_mword_dec w n = ( bitU_of_bool (Bits.test_bit w (nat_of_int n)))" + + +(*val access_mword_inc : forall 'a. mword 'a -> integer -> bitU*) +definition access_mword_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU " where + " access_mword_inc w n = ( + (let top1 = ((int (size w)) -( 1 :: int)) in + access_mword_dec w (top1 - n)))" + + +(*val access_mword : forall 'a. bool -> mword 'a -> integer -> bitU*) +definition access_mword :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU " where + " access_mword is_inc w n = ( + if is_inc then access_mword_inc w n else access_mword_dec w n )" + + +(*val update_mword_bool_dec : forall 'a. mword 'a -> integer -> bool -> mword 'a*) +definition update_mword_bool_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bool \<Rightarrow>('a::len)Word.word " where + " update_mword_bool_dec w n b = ( Bits.set_bit w (nat_of_int n) b )" + +definition update_mword_dec :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " update_mword_dec w n b = ( map_option (update_mword_bool_dec w n) (bool_of_bitU b))" + + +(*val update_mword_bool_inc : forall 'a. mword 'a -> integer -> bool -> mword 'a*) +definition update_mword_bool_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bool \<Rightarrow>('a::len)Word.word " where + " update_mword_bool_inc w n b = ( + (let top1 = ((int (size w)) -( 1 :: int)) in + update_mword_bool_dec w (top1 - n) b))" + +definition update_mword_inc :: "('a::len)Word.word \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(('a::len)Word.word)option " where + " update_mword_inc w n b = ( map_option (update_mword_bool_inc w n) (bool_of_bitU b))" + + +(*val int_of_mword : forall 'a. bool -> mword 'a -> integer*) +definition int_of_mword :: " bool \<Rightarrow>('a::len)Word.word \<Rightarrow> int " where + " int_of_mword sign w = ( + if sign then Word.sint w else Word.uint w )" + + +(* Translating between a type level number (itself 'n) and an integer *) + +definition size_itself_int :: "('a::len)itself \<Rightarrow> int " where + " size_itself_int x = ( int (size_itself x))" + + +(* NB: the corresponding sail type is forall 'n. atom('n) -> itself('n), + the actual integer is ignored. *) + +(*val make_the_value : forall 'n. integer -> itself 'n*) +definition make_the_value :: " int \<Rightarrow>('n::len)itself " where + " make_the_value _ = ( TYPE(_) )" + + +(*** Bitvectors *) + +record 'a Bitvector_class= + + bits_of_method ::" 'a \<Rightarrow> bitU list " + + (* We allow of_bits to be partial, as not all bitvector representations + support undefined bits *) + of_bits_method ::" bitU list \<Rightarrow> 'a option " + + of_bools_method ::" bool list \<Rightarrow> 'a " + + length_method ::" 'a \<Rightarrow> int " + + (* of_int: the first parameter specifies the desired length of the bitvector *) + of_int_method ::" int \<Rightarrow> int \<Rightarrow> 'a " + + (* Conversion to integers is undefined if any bit is undefined *) + unsigned_method ::" 'a \<Rightarrow> int option " + + signed_method ::" 'a \<Rightarrow> int option " + + (* Lifting of integer operations to bitvectors: The boolean flag indicates + whether to treat the bitvectors as signed (true) or not (false). *) + arith_op_bv_method ::" (int \<Rightarrow> int \<Rightarrow> int) \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a " + + + +(*val of_bits_failwith : forall 'a. Bitvector 'a => list bitU -> 'a*) +definition of_bits_failwith :: " 'a Bitvector_class \<Rightarrow>(bitU)list \<Rightarrow> 'a " where + " of_bits_failwith dict_Sail_values_Bitvector_a bits = ( maybe_failwith ( + (of_bits_method dict_Sail_values_Bitvector_a) bits))" + + +definition int_of_bv :: " 'a Bitvector_class \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow>(int)option " where + " int_of_bv dict_Sail_values_Bitvector_a sign = ( if sign then + (signed_method dict_Sail_values_Bitvector_a) else (unsigned_method dict_Sail_values_Bitvector_a) )" + + +definition instance_Sail_values_Bitvector_list_dict :: " 'a BitU_class \<Rightarrow>('a list)Bitvector_class " where + " instance_Sail_values_Bitvector_list_dict dict_Sail_values_BitU_a = ((| + + bits_of_method = (\<lambda> v. List.map + (to_bitU_method dict_Sail_values_BitU_a) v), + + of_bits_method = (\<lambda> v. Some (List.map + (of_bitU_method dict_Sail_values_BitU_a) v)), + + of_bools_method = (\<lambda> v. List.map + (of_bitU_method dict_Sail_values_BitU_a) (List.map bitU_of_bool v)), + + length_method = (\<lambda> xs. int (List.length xs)), + + of_int_method = (\<lambda> len n. List.map + (of_bitU_method dict_Sail_values_BitU_a) (bits_of_int len n)), + + unsigned_method = (\<lambda> v. unsigned_of_bits (List.map + (to_bitU_method dict_Sail_values_BitU_a) v)), + + signed_method = (\<lambda> v. signed_of_bits (List.map + (to_bitU_method dict_Sail_values_BitU_a) v)), + + arith_op_bv_method = (\<lambda> op1 sign l r. List.map + (of_bitU_method dict_Sail_values_BitU_a) (arith_op_bits op1 sign (List.map + (to_bitU_method dict_Sail_values_BitU_a) l) (List.map (to_bitU_method dict_Sail_values_BitU_a) r)))|) )" + + +definition instance_Sail_values_Bitvector_Machine_word_mword_dict :: "(('a::len)Word.word)Bitvector_class " where + " instance_Sail_values_Bitvector_Machine_word_mword_dict = ((| + + bits_of_method = (\<lambda> v. List.map bitU_of_bool (Word.to_bl v)), + + of_bits_method = (\<lambda> v. map_option Word.of_bl (just_list (List.map bool_of_bitU v))), + + of_bools_method = (\<lambda> v. Word.of_bl v), + + length_method = (\<lambda> v. int (size v)), + + of_int_method = ( \<lambda>x . + (case x of _ => \<lambda> n . Word.word_of_int n )), + + unsigned_method = (\<lambda> v. Some (Word.uint v)), + + signed_method = (\<lambda> v. Some (Word.sint v)), + + arith_op_bv_method = (\<lambda> op1 sign l r. Word.word_of_int (op1 (int_of_mword sign l) (int_of_mword sign r)))|) )" + + +definition access_bv_inc :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> bitU " where + " access_bv_inc dict_Sail_values_Bitvector_a v n = ( access_list True ( + (bits_of_method dict_Sail_values_Bitvector_a) v) n )" + +definition access_bv_dec :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> bitU " where + " access_bv_dec dict_Sail_values_Bitvector_a v n = ( access_list False ( + (bits_of_method dict_Sail_values_Bitvector_a) v) n )" + + +definition update_bv_inc :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " update_bv_inc dict_Sail_values_Bitvector_a v n b = ( update_list True ( + (bits_of_method dict_Sail_values_Bitvector_a) v) n b )" + +definition update_bv_dec :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> bitU \<Rightarrow>(bitU)list " where + " update_bv_dec dict_Sail_values_Bitvector_a v n b = ( update_list False ( + (bits_of_method dict_Sail_values_Bitvector_a) v) n b )" + + +definition subrange_bv_inc :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list " where + " subrange_bv_inc dict_Sail_values_Bitvector_a v i j = ( subrange_list True ( + (bits_of_method dict_Sail_values_Bitvector_a) v) i j )" + +definition subrange_bv_dec :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(bitU)list " where + " subrange_bv_dec dict_Sail_values_Bitvector_a v i j = ( subrange_list False ( + (bits_of_method dict_Sail_values_Bitvector_a) v) i j )" + + +definition update_subrange_bv_inc :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'b \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow>(bitU)list " where + " update_subrange_bv_inc dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b v i j v' = ( update_subrange_list True ( + (bits_of_method dict_Sail_values_Bitvector_b) v) i j ((bits_of_method dict_Sail_values_Bitvector_a) v'))" + +definition update_subrange_bv_dec :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> 'b \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow>(bitU)list " where + " update_subrange_bv_dec dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b v i j v' = ( update_subrange_list False ( + (bits_of_method dict_Sail_values_Bitvector_b) v) i j ((bits_of_method dict_Sail_values_Bitvector_a) v'))" + + +(*val extz_bv : forall 'a. Bitvector 'a => integer -> 'a -> list bitU*) +definition extz_bv :: " 'a Bitvector_class \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow>(bitU)list " where + " extz_bv dict_Sail_values_Bitvector_a n v = ( extz_bits n ( + (bits_of_method dict_Sail_values_Bitvector_a) v))" + + +(*val exts_bv : forall 'a. Bitvector 'a => integer -> 'a -> list bitU*) +definition exts_bv :: " 'a Bitvector_class \<Rightarrow> int \<Rightarrow> 'a \<Rightarrow>(bitU)list " where + " exts_bv dict_Sail_values_Bitvector_a n v = ( exts_bits n ( + (bits_of_method dict_Sail_values_Bitvector_a) v))" + + +(*val string_of_bv : forall 'a. Bitvector 'a => 'a -> string*) +definition string_of_bv :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> string " where + " string_of_bv dict_Sail_values_Bitvector_a v = ( show_bitlist ( + (bits_of_method dict_Sail_values_Bitvector_a) v))" + + +(*** Bytes and addresses *) + +type_synonym memory_byte =" bitU list " + +(*val byte_chunks : forall 'a. list 'a -> maybe (list (list 'a))*) +fun byte_chunks :: " 'a list \<Rightarrow>(('a list)list)option " where + " byte_chunks ([]) = ( Some [])" +|" byte_chunks (a # b # c # d # e # f # g # h # rest) = ( + Option.bind (byte_chunks rest) (\<lambda> rest . Some ([a,b,c,d,e,f,g,h] # rest)))" +|" byte_chunks _ = ( None )" + + +(*val bytes_of_bits : forall 'a. Bitvector 'a => 'a -> maybe (list memory_byte)*) +definition bytes_of_bits :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow>(((bitU)list)list)option " where + " bytes_of_bits dict_Sail_values_Bitvector_a bs = ( byte_chunks ( + (bits_of_method dict_Sail_values_Bitvector_a) bs))" + + +(*val bits_of_bytes : list memory_byte -> list bitU*) +definition bits_of_bytes :: "((bitU)list)list \<Rightarrow>(bitU)list " where + " bits_of_bytes bs = ( List.concat (List.map (\<lambda> v. List.map (\<lambda> b. b) v) bs))" + + +definition mem_bytes_of_bits :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow>(((bitU)list)list)option " where + " mem_bytes_of_bits dict_Sail_values_Bitvector_a bs = ( map_option List.rev (bytes_of_bits + dict_Sail_values_Bitvector_a bs))" + +definition bits_of_mem_bytes :: "((bitU)list)list \<Rightarrow>(bitU)list " where + " bits_of_mem_bytes bs = ( bits_of_bytes (List.rev bs))" + + +(*val bitv_of_byte_lifteds : list Sail_impl_base.byte_lifted -> list bitU +let bitv_of_byte_lifteds v = + foldl (fun x (Byte_lifted y) -> x ++ (List.map bitU_of_bit_lifted y)) [] v + +val bitv_of_bytes : list Sail_impl_base.byte -> list bitU +let bitv_of_bytes v = + foldl (fun x (Byte y) -> x ++ (List.map bitU_of_bit y)) [] v + +val byte_lifteds_of_bitv : list bitU -> list byte_lifted +let byte_lifteds_of_bitv bits = + let bits = List.map bit_lifted_of_bitU bits in + byte_lifteds_of_bit_lifteds bits + +val bytes_of_bitv : list bitU -> list byte +let bytes_of_bitv bits = + let bits = List.map bit_of_bitU bits in + bytes_of_bits bits + +val bit_lifteds_of_bitUs : list bitU -> list bit_lifted +let bit_lifteds_of_bitUs bits = List.map bit_lifted_of_bitU bits + +val bit_lifteds_of_bitv : list bitU -> list bit_lifted +let bit_lifteds_of_bitv v = bit_lifteds_of_bitUs v + + +val address_lifted_of_bitv : list bitU -> address_lifted +let address_lifted_of_bitv v = + let byte_lifteds = byte_lifteds_of_bitv v in + let maybe_address_integer = + match (maybe_all (List.map byte_of_byte_lifted byte_lifteds)) with + | Just bs -> Just (integer_of_byte_list bs) + | _ -> Nothing + end in + Address_lifted byte_lifteds maybe_address_integer + +val bitv_of_address_lifted : address_lifted -> list bitU +let bitv_of_address_lifted (Address_lifted bs _) = bitv_of_byte_lifteds bs + +val address_of_bitv : list bitU -> address +let address_of_bitv v = + let bytes = bytes_of_bitv v in + address_of_byte_list bytes*) + +function (sequential,domintros) reverse_endianness_list :: " 'a list \<Rightarrow> 'a list " where + " reverse_endianness_list bits = ( + if List.length bits \<le>( 8 :: nat) then bits else + reverse_endianness_list (drop_list(( 8 :: int)) bits) @ take_list(( 8 :: int)) bits )" +by pat_completeness auto + + + +(*** Registers *) + +(*type register_field = string +type register_field_index = string * (integer * integer) (* name, start and end *) + +type register = + | Register of string * (* name *) + integer * (* length *) + integer * (* start index *) + bool * (* is increasing *) + list register_field_index + | UndefinedRegister of integer (* length *) + | RegisterPair of register * register*) + +record( 'regstate, 'regval, 'a) register_ref = + + name ::" string " + + (*is_inc : bool;*) + read_from ::" 'regstate \<Rightarrow> 'a " + + write_to ::" 'a \<Rightarrow> 'regstate \<Rightarrow> 'regstate " + + of_regval ::" 'regval \<Rightarrow> 'a option " + + regval_of ::" 'a \<Rightarrow> 'regval " + + +(* Register accessors: pair of functions for reading and writing register values *) +type_synonym( 'regstate, 'regval) register_accessors =" + ((string \<Rightarrow> 'regstate \<Rightarrow> 'regval option) * + (string \<Rightarrow> 'regval \<Rightarrow> 'regstate \<Rightarrow> 'regstate option))" + +record( 'regtype, 'a) field_ref = + + field_name ::" string " + + field_start ::" int " + + field_is_inc ::" bool " + + get_field ::" 'regtype \<Rightarrow> 'a " + + set_field ::" 'regtype \<Rightarrow> 'a \<Rightarrow> 'regtype " + + +(*let name_of_reg = function + | Register name _ _ _ _ -> name + | UndefinedRegister _ -> failwith name_of_reg UndefinedRegister + | RegisterPair _ _ -> failwith name_of_reg RegisterPair +end + +let size_of_reg = function + | Register _ size _ _ _ -> size + | UndefinedRegister size -> size + | RegisterPair _ _ -> failwith size_of_reg RegisterPair +end + +let start_of_reg = function + | Register _ _ start _ _ -> start + | UndefinedRegister _ -> failwith start_of_reg UndefinedRegister + | RegisterPair _ _ -> failwith start_of_reg RegisterPair +end + +let is_inc_of_reg = function + | Register _ _ _ is_inc _ -> is_inc + | UndefinedRegister _ -> failwith is_inc_of_reg UndefinedRegister + | RegisterPair _ _ -> failwith in_inc_of_reg RegisterPair +end + +let dir_of_reg = function + | Register _ _ _ is_inc _ -> dir_of_bool is_inc + | UndefinedRegister _ -> failwith dir_of_reg UndefinedRegister + | RegisterPair _ _ -> failwith dir_of_reg RegisterPair +end + +let size_of_reg_nat reg = natFromInteger (size_of_reg reg) +let start_of_reg_nat reg = natFromInteger (start_of_reg reg) + +val register_field_indices_aux : register -> register_field -> maybe (integer * integer) +let rec register_field_indices_aux register rfield = + match register with + | Register _ _ _ _ rfields -> List.lookup rfield rfields + | RegisterPair r1 r2 -> + let m_indices = register_field_indices_aux r1 rfield in + if isJust m_indices then m_indices else register_field_indices_aux r2 rfield + | UndefinedRegister _ -> Nothing + end + +val register_field_indices : register -> register_field -> integer * integer +let register_field_indices register rfield = + match register_field_indices_aux register rfield with + | Just indices -> indices + | Nothing -> failwith Invalid register/register-field combination + end + +let register_field_indices_nat reg regfield= + let (i,j) = register_field_indices reg regfield in + (natFromInteger i,natFromInteger j)*) + +(*let rec external_reg_value reg_name v = + let (internal_start, external_start, direction) = + match reg_name with + | Reg _ start size dir -> + (start, (if dir = D_increasing then start else (start - (size +1))), dir) + | Reg_slice _ reg_start dir (slice_start, _) -> + ((if dir = D_increasing then slice_start else (reg_start - slice_start)), + slice_start, dir) + | Reg_field _ reg_start dir _ (slice_start, _) -> + ((if dir = D_increasing then slice_start else (reg_start - slice_start)), + slice_start, dir) + | Reg_f_slice _ reg_start dir _ _ (slice_start, _) -> + ((if dir = D_increasing then slice_start else (reg_start - slice_start)), + slice_start, dir) + end in + let bits = bit_lifteds_of_bitv v in + <| rv_bits = bits; + rv_dir = direction; + rv_start = external_start; + rv_start_internal = internal_start |> + +val internal_reg_value : register_value -> list bitU +let internal_reg_value v = + List.map bitU_of_bit_lifted v.rv_bits + (*(integerFromNat v.rv_start_internal) + (v.rv_dir = D_increasing)*) + + +let external_slice (d:direction) (start:nat) ((i,j):(nat*nat)) = + match d with + (*This is the case the thread/concurrecny model expects, so no change needed*) + | D_increasing -> (i,j) + | D_decreasing -> let slice_i = start - i in + let slice_j = (i - j) + slice_i in + (slice_i,slice_j) + end *) + +(* TODO +let external_reg_whole r = + Reg (r.name) (natFromInteger r.start) (natFromInteger r.size) (dir_of_bool r.is_inc) + +let external_reg_slice r (i,j) = + let start = natFromInteger r.start in + let dir = dir_of_bool r.is_inc in + Reg_slice (r.name) start dir (external_slice dir start (i,j)) + +let external_reg_field_whole reg rfield = + let (m,n) = register_field_indices_nat reg rfield in + let start = start_of_reg_nat reg in + let dir = dir_of_reg reg in + Reg_field (name_of_reg reg) start dir rfield (external_slice dir start (m,n)) + +let external_reg_field_slice reg rfield (i,j) = + let (m,n) = register_field_indices_nat reg rfield in + let start = start_of_reg_nat reg in + let dir = dir_of_reg reg in + Reg_f_slice (name_of_reg reg) start dir rfield + (external_slice dir start (m,n)) + (external_slice dir start (i,j))*) + +(*val external_mem_value : list bitU -> memory_value +let external_mem_value v = + byte_lifteds_of_bitv v $> List.reverse + +val internal_mem_value : memory_value -> list bitU +let internal_mem_value bytes = + List.reverse bytes $> bitv_of_byte_lifteds*) + + +(*val foreach : forall 'a 'vars. + (list 'a) -> 'vars -> ('a -> 'vars -> 'vars) -> 'vars*) +fun foreach :: " 'a list \<Rightarrow> 'vars \<Rightarrow>('a \<Rightarrow> 'vars \<Rightarrow> 'vars)\<Rightarrow> 'vars " where + " foreach ([]) vars body = ( vars )" +|" foreach (x # xs) vars body = ( foreach xs (body x vars) body )" + + +(*val index_list : integer -> integer -> integer -> list integer*) +function (sequential,domintros) index_list :: " int \<Rightarrow> int \<Rightarrow> int \<Rightarrow>(int)list " where + " index_list from1 to1 step = ( + if ((step >( 0 :: int)) \<and> (from1 \<le> to1)) \<or> ((step <( 0 :: int)) \<and> (to1 \<le> from1)) then + from1 # index_list (from1 + step) to1 step + else [])" +by pat_completeness auto + + +(*val while : forall 'vars. 'vars -> ('vars -> bool) -> ('vars -> 'vars) -> 'vars*) +function (sequential,domintros) while :: " 'vars \<Rightarrow>('vars \<Rightarrow> bool)\<Rightarrow>('vars \<Rightarrow> 'vars)\<Rightarrow> 'vars " where + " while vars cond body = ( + if cond vars then while (body vars) cond body else vars )" +by pat_completeness auto + + +(*val until : forall 'vars. 'vars -> ('vars -> bool) -> ('vars -> 'vars) -> 'vars*) +function (sequential,domintros) until :: " 'vars \<Rightarrow>('vars \<Rightarrow> bool)\<Rightarrow>('vars \<Rightarrow> 'vars)\<Rightarrow> 'vars " where + " until vars cond body = ( + (let vars = (body vars) in + if cond vars then vars else until (body vars) cond body))" +by pat_completeness auto + + + +(* convert numbers unsafely to naturals *) + +record 'a ToNatural_class= + toNatural_method ::" 'a \<Rightarrow> nat " + +(* eta-expanded for Isabelle output, otherwise it breaks *) +definition instance_Sail_values_ToNatural_Num_integer_dict :: "(int)ToNatural_class " where + " instance_Sail_values_ToNatural_Num_integer_dict = ((| + + toNatural_method = (\<lambda> n . nat (abs n))|) )" + +definition instance_Sail_values_ToNatural_Num_int_dict :: "(int)ToNatural_class " where + " instance_Sail_values_ToNatural_Num_int_dict = ((| + + toNatural_method = (\<lambda> n . (nat (abs n)))|) )" + +definition instance_Sail_values_ToNatural_nat_dict :: "(nat)ToNatural_class " where + " instance_Sail_values_ToNatural_nat_dict = ((| + + toNatural_method = (\<lambda> n . n)|) )" + +definition instance_Sail_values_ToNatural_Num_natural_dict :: "(nat)ToNatural_class " where + " instance_Sail_values_ToNatural_Num_natural_dict = ((| + + toNatural_method = (\<lambda> n . n)|) )" + + +fun toNaturalFiveTup :: " 'a ToNatural_class \<Rightarrow> 'b ToNatural_class \<Rightarrow> 'c ToNatural_class \<Rightarrow> 'd ToNatural_class \<Rightarrow> 'e ToNatural_class \<Rightarrow> 'd*'c*'b*'a*'e \<Rightarrow> nat*nat*nat*nat*nat " where + " toNaturalFiveTup dict_Sail_values_ToNatural_a dict_Sail_values_ToNatural_b dict_Sail_values_ToNatural_c dict_Sail_values_ToNatural_d dict_Sail_values_ToNatural_e (n1,n2,n3,n4,n5) = ( + ((toNatural_method dict_Sail_values_ToNatural_d) n1,(toNatural_method dict_Sail_values_ToNatural_c) n2,(toNatural_method dict_Sail_values_ToNatural_b) n3,(toNatural_method dict_Sail_values_ToNatural_a) n4,(toNatural_method dict_Sail_values_ToNatural_e) n5))" + + +(* Let the following types be generated by Sail per spec, using either bitlists + or machine words as bitvector representation *) +(*type regfp = + | RFull of (string) + | RSlice of (string * integer * integer) + | RSliceBit of (string * integer) + | RField of (string * string) + +type niafp = + | NIAFP_successor + | NIAFP_concrete_address of vector bitU + | NIAFP_indirect_address + +(* only for MIPS *) +type diafp = + | DIAFP_none + | DIAFP_concrete of vector bitU + | DIAFP_reg of regfp + +let regfp_to_reg (reg_info : string -> maybe string -> (nat * nat * direction * (nat * nat))) = function + | RFull name -> + let (start,length,direction,_) = reg_info name Nothing in + Reg name start length direction + | RSlice (name,i,j) -> + let i = natFromInteger i in + let j = natFromInteger j in + let (start,length,direction,_) = reg_info name Nothing in + let slice = external_slice direction start (i,j) in + Reg_slice name start direction slice + | RSliceBit (name,i) -> + let i = natFromInteger i in + let (start,length,direction,_) = reg_info name Nothing in + let slice = external_slice direction start (i,i) in + Reg_slice name start direction slice + | RField (name,field_name) -> + let (start,length,direction,span) = reg_info name (Just field_name) in + let slice = external_slice direction start span in + Reg_field name start direction field_name slice +end + +let niafp_to_nia reginfo = function + | NIAFP_successor -> NIA_successor + | NIAFP_concrete_address v -> NIA_concrete_address (address_of_bitv v) + | NIAFP_indirect_address -> NIA_indirect_address +end + +let diafp_to_dia reginfo = function + | DIAFP_none -> DIA_none + | DIAFP_concrete v -> DIA_concrete_address (address_of_bitv v) + | DIAFP_reg r -> DIA_register (regfp_to_reg reginfo r) +end +*) +end diff --git a/snapshots/isabelle/lib/sail/Sail_values_lemmas.thy b/snapshots/isabelle/lib/sail/Sail_values_lemmas.thy new file mode 100644 index 00000000..dd008695 --- /dev/null +++ b/snapshots/isabelle/lib/sail/Sail_values_lemmas.thy @@ -0,0 +1,206 @@ +theory Sail_values_lemmas + imports Sail_values +begin + +lemma nat_of_int_nat_simps[simp]: "nat_of_int = nat" by (auto simp: nat_of_int_def) + +termination reverse_endianness_list by (lexicographic_order simp add: drop_list_def) + +termination index_list + by (relation "measure (\<lambda>(i, j, step). nat ((j - i + step) * sgn step))") auto + +lemma just_list_map_Some[simp]: "just_list (map Some v) = Some v" by (induction v) auto + +lemma just_list_None_iff[simp]: "just_list xs = None \<longleftrightarrow> None \<in> set xs" + by (induction xs) (auto split: option.splits) + +lemma just_list_Some_iff[simp]: "just_list xs = Some ys \<longleftrightarrow> xs = map Some ys" + by (induction xs arbitrary: ys) (auto split: option.splits) + +lemma just_list_cases: + assumes "just_list xs = y" + obtains (None) "None \<in> set xs" and "y = None" + | (Some) ys where "xs = map Some ys" and "y = Some ys" + using assms by (cases y) auto + +lemma repeat_singleton_replicate[simp]: + "repeat [x] n = replicate (nat n) x" +proof (induction n) + case (nonneg n) + have "nat (1 + int m) = Suc m" for m by auto + then show ?case by (induction n) auto +next + case (neg n) + then show ?case by auto +qed + +lemma bool_of_bitU_simps[simp]: + "bool_of_bitU B0 = Some False" + "bool_of_bitU B1 = Some True" + "bool_of_bitU BU = None" + by (auto simp: bool_of_bitU_def) + +lemma bitops_bitU_of_bool[simp]: + "and_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool (x \<and> y)" + "or_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool (x \<or> y)" + "xor_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool ((x \<or> y) \<and> \<not>(x \<and> y))" + "not_bit (bitU_of_bool x) = bitU_of_bool (\<not>x)" + "not_bit \<circ> bitU_of_bool = bitU_of_bool \<circ> Not" + by (auto simp: bitU_of_bool_def not_bit_def) + +lemma image_bitU_of_bool_B0_B1: "bitU_of_bool ` bs \<subseteq> {B0, B1}" + by (auto simp: bitU_of_bool_def split: if_splits) + +lemma bool_of_bitU_bitU_of_bool[simp]: + "bool_of_bitU \<circ> bitU_of_bool = Some" + "bool_of_bitU \<circ> (bitU_of_bool \<circ> f) = Some \<circ> f" + "bool_of_bitU (bitU_of_bool x) = Some x" + by (intro ext, auto simp: bool_of_bitU_def bitU_of_bool_def)+ + +abbreviation "BC_bitU_list \<equiv> instance_Sail_values_Bitvector_list_dict instance_Sail_values_BitU_Sail_values_bitU_dict" +lemmas BC_bitU_list_def = instance_Sail_values_Bitvector_list_dict_def instance_Sail_values_BitU_Sail_values_bitU_dict_def +abbreviation "BC_mword \<equiv> instance_Sail_values_Bitvector_Machine_word_mword_dict" +lemmas BC_mword_defs = instance_Sail_values_Bitvector_Machine_word_mword_dict_def + access_mword_def access_mword_inc_def access_mword_dec_def + (*update_mword_def update_mword_inc_def update_mword_dec_def*) + subrange_list_def subrange_list_inc_def subrange_list_dec_def + update_subrange_list_def update_subrange_list_inc_def update_subrange_list_dec_def + +declare size_itself_int_def[simp] +declare size_itself_def[simp] +declare word_size[simp] + +lemma int_of_mword_simps[simp]: + "int_of_mword False w = uint w" + "int_of_mword True w = sint w" + "int_of_bv BC_mword False w = Some (uint w)" + "int_of_bv BC_mword True w = Some (sint w)" + by (auto simp: int_of_mword_def int_of_bv_def BC_mword_defs) + +lemma BC_mword_simps[simp]: + "unsigned_method BC_mword a = Some (uint a)" + "signed_method BC_mword a = Some (sint a)" + "length_method BC_mword (a :: ('a :: len) word) = int (LENGTH('a))" + by (auto simp: BC_mword_defs) + +lemma of_bits_mword_of_bl[simp]: + assumes "just_list (map bool_of_bitU bus) = Some bs" + shows "of_bits_method BC_mword bus = Some (of_bl bs)" + and "of_bits_failwith BC_mword bus = of_bl bs" + using assms by (auto simp: BC_mword_defs of_bits_failwith_def maybe_failwith_def) + +lemma nat_of_bits_aux_bl_to_bin_aux: + "nat_of_bools_aux acc bs = nat (bl_to_bin_aux bs (int acc))" + by (induction acc bs rule: nat_of_bools_aux.induct) + (auto simp: Bit_def intro!: arg_cong[where f = nat] arg_cong2[where f = bl_to_bin_aux] split: if_splits) + +lemma nat_of_bits_bl_to_bin[simp]: + "nat_of_bools bs = nat (bl_to_bin bs)" + by (auto simp: nat_of_bools_def bl_to_bin_def nat_of_bits_aux_bl_to_bin_aux) + +lemma unsigned_bits_of_mword[simp]: + "unsigned_method BC_bitU_list (bits_of_method BC_mword a) = Some (uint a)" + by (auto simp: BC_bitU_list_def BC_mword_defs unsigned_of_bits_def unsigned_of_bools_def) + +lemma bits_of_bitU_list[simp]: + "bits_of_method BC_bitU_list v = v" + "of_bits_method BC_bitU_list v = Some v" + by (auto simp: BC_bitU_list_def) + +lemma subrange_list_inc_drop_take: + "subrange_list_inc xs i j = drop (nat i) (take (nat (j + 1)) xs)" + by (auto simp: subrange_list_inc_def split_at_def) + +lemma subrange_list_dec_drop_take: + assumes "i \<ge> 0" and "j \<ge> 0" + shows "subrange_list_dec xs i j = drop (length xs - nat (i + 1)) (take (length xs - nat j) xs)" + using assms unfolding subrange_list_dec_def + by (auto simp: subrange_list_inc_drop_take add.commute diff_diff_add nat_minus_as_int) + +lemma update_subrange_list_inc_drop_take: + assumes "i \<ge> 0" and "j \<ge> i" + shows "update_subrange_list_inc xs i j xs' = take (nat i) xs @ xs' @ drop (nat (j + 1)) xs" + using assms unfolding update_subrange_list_inc_def + by (auto simp: split_at_def min_def) + +lemma update_subrange_list_dec_drop_take: + assumes "j \<ge> 0" and "i \<ge> j" + shows "update_subrange_list_dec xs i j xs' = take (length xs - nat (i + 1)) xs @ xs' @ drop (length xs - nat j) xs" + using assms unfolding update_subrange_list_dec_def update_subrange_list_inc_def + by (auto simp: split_at_def min_def Let_def add.commute diff_diff_add nat_minus_as_int) + +declare access_list_inc_def[simp] + +lemma access_list_dec_rev_nth: + assumes "0 \<le> i" and "nat i < length xs" + shows "access_list_dec xs i = rev xs ! (nat i)" + using assms + by (auto simp: access_list_dec_def rev_nth intro!: arg_cong2[where f = List.nth]) + +lemma access_bv_dec_mword[simp]: + fixes w :: "('a::len) word" + assumes "0 \<le> n" and "nat n < LENGTH('a)" + shows "access_bv_dec BC_mword w n = bitU_of_bool (w !! (nat n))" + using assms unfolding access_bv_dec_def access_list_def + by (auto simp: access_list_dec_rev_nth BC_mword_defs rev_map test_bit_bl) + +lemma access_list_dec_nth[simp]: + assumes "0 \<le> i" + shows "access_list_dec xs i = xs ! (length xs - nat (i + 1))" + using assms + by (auto simp: access_list_dec_def add.commute diff_diff_add nat_minus_as_int) + +lemma update_list_inc_update[simp]: + "update_list_inc xs n x = xs[nat n := x]" + by (auto simp: update_list_inc_def) + +lemma update_list_dec_update[simp]: + "update_list_dec xs n x = xs[length xs - nat (n + 1) := x]" + by (auto simp: update_list_dec_def add.commute diff_diff_add nat_minus_as_int) + +lemma bools_of_nat_aux_simps[simp]: + "\<And>len. len \<le> 0 \<Longrightarrow> bools_of_nat_aux len x acc = acc" + "\<And>len. bools_of_nat_aux (int (Suc len)) x acc = + bools_of_nat_aux (int len) (x div 2) ((if x mod 2 = 1 then True else False) # acc)" + by auto +declare bools_of_nat_aux.simps[simp del] + +lemma bools_of_nat_aux_bin_to_bl_aux: + "bools_of_nat_aux len n acc = bin_to_bl_aux (nat len) (int n) acc" +proof (cases len) + case (nonneg len') + show ?thesis unfolding nonneg + proof (induction len' arbitrary: n acc) + case (Suc len'' n acc) + then show ?case + using zmod_int[of n 2] + by (auto simp del: of_nat_simps simp add: bin_rest_def bin_last_def zdiv_int) + qed auto +qed auto + +lemma bools_of_nat_bin_to_bl[simp]: + "bools_of_nat len n = bin_to_bl (nat len) (int n)" + by (auto simp: bools_of_nat_def bools_of_nat_aux_bin_to_bl_aux) + +lemma add_one_bool_ignore_overflow_aux_rbl_succ[simp]: + "add_one_bool_ignore_overflow_aux xs = rbl_succ xs" + by (induction xs) auto + +lemma add_one_bool_ignore_overflow_rbl_succ[simp]: + "add_one_bool_ignore_overflow xs = rev (rbl_succ (rev xs))" + unfolding add_one_bool_ignore_overflow_def by auto + +lemma map_Not_bin_to_bl: + "map Not (bin_to_bl_aux len n acc) = bin_to_bl_aux len (-n - 1) (map Not acc)" +proof (induction len arbitrary: n acc) + case (Suc len n acc) + moreover have "(- (n div 2) - 1) = ((-n - 1) div 2)" by auto + moreover have "(n mod 2 = 0) = ((- n - 1) mod 2 = 1)" by presburger + ultimately show ?case by (auto simp: bin_rest_def bin_last_def) +qed auto + +lemma bools_of_int_bin_to_bl[simp]: + "bools_of_int (int len) n = bin_to_bl len n" + by (auto simp: bools_of_int_def Let_def map_Not_bin_to_bl rbl_succ[unfolded bin_to_bl_def]) + +end diff --git a/snapshots/isabelle/lib/sail/State.thy b/snapshots/isabelle/lib/sail/State.thy new file mode 100644 index 00000000..9d460e8e --- /dev/null +++ b/snapshots/isabelle/lib/sail/State.thy @@ -0,0 +1,102 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/state.lem.\<close> + +theory "State" + +imports + Main + "Lem_pervasives_extra" + "Sail_values" + "Prompt_monad" + "Prompt" + "State_monad" + "State_monad_lemmas" + +begin + +(*open import Pervasives_extra*) +(*open import Sail_impl_base*) +(*open import Sail_values*) +(*open import Prompt_monad*) +(*open import Prompt*) +(*open import State_monad*) +(*open import {isabelle} `State_monad_lemmas`*) + +(* State monad wrapper around prompt monad *) + +(*val liftState : forall 'regval 'regs 'a 'e. register_accessors 'regs 'regval -> monad 'regval 'a 'e -> monadS 'regs 'a 'e*) +function (sequential,domintros) liftState :: "(string \<Rightarrow> 'regs \<Rightarrow> 'regval option)*(string \<Rightarrow> 'regval \<Rightarrow> 'regs \<Rightarrow> 'regs option)\<Rightarrow>('regval,'a,'e)monad \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " liftState ra (Done a) = ( returnS a )" +|" liftState ra (Read_mem rk a sz k) = ( bindS (read_mem_bytesS + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) rk a sz) (\<lambda> v . liftState ra (k v)))" +|" liftState ra (Read_tag t k) = ( bindS (read_tagS + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) t) (\<lambda> v . liftState ra (k v)))" +|" liftState ra (Write_memv a k) = ( bindS (write_mem_bytesS a) (\<lambda> v . liftState ra (k v)))" +|" liftState ra (Write_tag a t k) = ( bindS (write_tagS + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) a t) (\<lambda> v . liftState ra (k v)))" +|" liftState ra (Read_reg r k) = ( bindS (read_regvalS ra r) (\<lambda> v . liftState ra (k v)))" +|" liftState ra (Excl_res k) = ( bindS (excl_resultS () ) (\<lambda> v . liftState ra (k v)))" +|" liftState ra (Undefined k) = ( bindS (undefined_boolS () ) (\<lambda> v . liftState ra (k v)))" +|" liftState ra (Write_ea wk a sz k) = ( seqS (write_mem_eaS + (instance_Sail_values_Bitvector_list_dict + instance_Sail_values_BitU_Sail_values_bitU_dict) wk a sz) (liftState ra k))" +|" liftState ra (Write_reg r v k) = ( seqS (write_regvalS ra r v) (liftState ra k))" +|" liftState ra (Footprint k) = ( liftState ra k )" +|" liftState ra (Barrier _ k) = ( liftState ra k )" +|" liftState ra (Print _ k) = ( liftState ra k )" +|" liftState ra (Fail descr) = ( failS descr )" +|" liftState ra (Exception e) = ( throwS e )" +by pat_completeness auto + + + +(*val iterS_aux : forall 'rv 'a 'e. integer -> (integer -> 'a -> monadS 'rv unit 'e) -> list 'a -> monadS 'rv unit 'e*) +fun iterS_aux :: " int \<Rightarrow>(int \<Rightarrow> 'a \<Rightarrow> 'rv sequential_state \<Rightarrow>(((unit),'e)result*'rv sequential_state)set)\<Rightarrow> 'a list \<Rightarrow>('rv,(unit),'e)monadS " where + " iterS_aux i f (x # xs) = ( seqS (f i x) (iterS_aux (i +( 1 :: int)) f xs))" +|" iterS_aux i f ([]) = ( returnS () )" + + +(*val iteriS : forall 'rv 'a 'e. (integer -> 'a -> monadS 'rv unit 'e) -> list 'a -> monadS 'rv unit 'e*) +definition iteriS :: "(int \<Rightarrow> 'a \<Rightarrow>('rv,(unit),'e)monadS)\<Rightarrow> 'a list \<Rightarrow> 'rv sequential_state \<Rightarrow>(((unit),'e)result*'rv sequential_state)set " where + " iteriS f xs = ( iterS_aux(( 0 :: int)) f xs )" + + +(*val iterS : forall 'rv 'a 'e. ('a -> monadS 'rv unit 'e) -> list 'a -> monadS 'rv unit 'e*) +definition iterS :: "('a \<Rightarrow> 'rv sequential_state \<Rightarrow>(((unit),'e)result*'rv sequential_state)set)\<Rightarrow> 'a list \<Rightarrow> 'rv sequential_state \<Rightarrow>(((unit),'e)result*'rv sequential_state)set " where + " iterS f xs = ( iteriS ( \<lambda>x . + (case x of _ => \<lambda> x . f x )) xs )" + + +(*val foreachS : forall 'a 'rv 'vars 'e. + list 'a -> 'vars -> ('a -> 'vars -> monadS 'rv 'vars 'e) -> monadS 'rv 'vars 'e*) +fun foreachS :: " 'a list \<Rightarrow> 'vars \<Rightarrow>('a \<Rightarrow> 'vars \<Rightarrow> 'rv sequential_state \<Rightarrow>(('vars,'e)result*'rv sequential_state)set)\<Rightarrow> 'rv sequential_state \<Rightarrow>(('vars,'e)result*'rv sequential_state)set " where + " foreachS ([]) vars body = ( returnS vars )" +|" foreachS (x # xs) vars body = ( bindS + (body x vars) (\<lambda> vars . + foreachS xs vars body))" + + + +(*val whileS : forall 'rv 'vars 'e. 'vars -> ('vars -> monadS 'rv bool 'e) -> + ('vars -> monadS 'rv 'vars 'e) -> monadS 'rv 'vars 'e*) +function (sequential,domintros) whileS :: " 'vars \<Rightarrow>('vars \<Rightarrow> 'rv sequential_state \<Rightarrow>(((bool),'e)result*'rv sequential_state)set)\<Rightarrow>('vars \<Rightarrow> 'rv sequential_state \<Rightarrow>(('vars,'e)result*'rv sequential_state)set)\<Rightarrow> 'rv sequential_state \<Rightarrow>(('vars,'e)result*'rv sequential_state)set " where + " whileS vars cond body s = ( + ( bindS(cond vars) (\<lambda> cond_val s' . + if cond_val then + ( bindS(body vars) (\<lambda> vars s'' . whileS vars cond body s'')) s' + else returnS vars s')) s )" +by pat_completeness auto + + +(*val untilS : forall 'rv 'vars 'e. 'vars -> ('vars -> monadS 'rv bool 'e) -> + ('vars -> monadS 'rv 'vars 'e) -> monadS 'rv 'vars 'e*) +function (sequential,domintros) untilS :: " 'vars \<Rightarrow>('vars \<Rightarrow> 'rv sequential_state \<Rightarrow>(((bool),'e)result*'rv sequential_state)set)\<Rightarrow>('vars \<Rightarrow> 'rv sequential_state \<Rightarrow>(('vars,'e)result*'rv sequential_state)set)\<Rightarrow> 'rv sequential_state \<Rightarrow>(('vars,'e)result*'rv sequential_state)set " where + " untilS vars cond body s = ( + ( bindS(body vars) (\<lambda> vars s' . + ( bindS(cond vars) (\<lambda> cond_val s'' . + if cond_val then returnS vars s'' else untilS vars cond body s'')) s')) s )" +by pat_completeness auto + +end diff --git a/snapshots/isabelle/lib/sail/State_lemmas.thy b/snapshots/isabelle/lib/sail/State_lemmas.thy new file mode 100644 index 00000000..84b08e6c --- /dev/null +++ b/snapshots/isabelle/lib/sail/State_lemmas.thy @@ -0,0 +1,202 @@ +theory State_lemmas + imports State +begin + +lemma All_liftState_dom: "liftState_dom (r, m)" + by (induction m) (auto intro: liftState.domintros) +termination liftState using All_liftState_dom by auto + +lemma liftState_bind[simp]: + "liftState r (bind m f) = bindS (liftState r m) (liftState r \<circ> f)" + by (induction m f rule: bind.induct) auto + +lemma liftState_return[simp]: "liftState r (return a) = returnS a" by (auto simp: return_def) + +lemma Value_liftState_Run: + assumes "(Value a, s') \<in> liftState r m s" + obtains t where "Run m t a" + by (use assms in \<open>induction r m arbitrary: s s' rule: liftState.induct\<close>; + auto simp add: failS_def throwS_def returnS_def simp del: read_regvalS.simps; + blast elim: Value_bindS_elim) + +lemmas liftState_if_distrib[simp] = if_distrib[where f = "liftState ra" for ra] + +lemma liftState_throw[simp]: "liftState r (throw e) = throwS e" by (auto simp: throw_def) +lemma liftState_assert[simp]: "liftState r (assert_exp c msg) = assert_expS c msg" by (auto simp: assert_exp_def assert_expS_def) +lemma liftState_exit[simp]: "liftState r (exit0 ()) = exitS ()" by (auto simp: exit0_def exitS_def) +lemma liftState_exclResult[simp]: "liftState r (excl_result ()) = excl_resultS ()" by (auto simp: excl_result_def) +lemma liftState_barrier[simp]: "liftState r (barrier bk) = returnS ()" by (auto simp: barrier_def) +lemma liftState_footprint[simp]: "liftState r (footprint ()) = returnS ()" by (auto simp: footprint_def) +lemma liftState_undefined[simp]: "liftState r (undefined_bool ()) = undefined_boolS ()" by (auto simp: undefined_bool_def) +lemma liftState_maybe_fail[simp]: "liftState r (maybe_fail msg x) = maybe_failS msg x" + by (auto simp: maybe_fail_def maybe_failS_def split: option.splits) + +lemma liftState_try_catch[simp]: + "liftState r (try_catch m h) = try_catchS (liftState r m) (liftState r \<circ> h)" + by (induction m h rule: try_catch_induct) (auto simp: try_catchS_bindS_no_throw) + +lemma liftState_early_return[simp]: + "liftState r (early_return r) = early_returnS r" + by (auto simp: early_return_def early_returnS_def) + +lemma liftState_catch_early_return[simp]: + "liftState r (catch_early_return m) = catch_early_returnS (liftState r m)" + by (auto simp: catch_early_return_def catch_early_returnS_def sum.case_distrib cong: sum.case_cong) + +lemma liftState_liftR[simp]: + "liftState r (liftR m) = liftSR (liftState r m)" + by (auto simp: liftR_def liftSR_def) + +lemma liftState_try_catchR[simp]: + "liftState r (try_catchR m h) = try_catchSR (liftState r m) (liftState r \<circ> h)" + by (auto simp: try_catchR_def try_catchSR_def sum.case_distrib cong: sum.case_cong) + +lemma liftState_read_mem_BC: + assumes "unsigned_method BC_bitU_list (bits_of_method BCa a) = unsigned_method BCa a" + shows "liftState r (read_mem BCa BCb rk a sz) = read_memS BCa BCb rk a sz" + using assms + by (auto simp: read_mem_def read_mem_bytes_def read_memS_def read_mem_bytesS_def maybe_failS_def split: option.splits) + +lemma liftState_read_mem[simp]: + "\<And>a. liftState r (read_mem BC_mword BC_mword rk a sz) = read_memS BC_mword BC_mword rk a sz" + "\<And>a. liftState r (read_mem BC_bitU_list BC_bitU_list rk a sz) = read_memS BC_bitU_list BC_bitU_list rk a sz" + by (auto simp: liftState_read_mem_BC) + +lemma liftState_write_mem_ea_BC: + assumes "unsigned_method BC_bitU_list (bits_of_method BCa a) = unsigned_method BCa a" + shows "liftState r (write_mem_ea BCa rk a sz) = write_mem_eaS BCa rk a (nat sz)" + using assms by (auto simp: write_mem_ea_def write_mem_eaS_def) + +lemma liftState_write_mem_ea[simp]: + "\<And>a. liftState r (write_mem_ea BC_mword rk a sz) = write_mem_eaS BC_mword rk a (nat sz)" + "\<And>a. liftState r (write_mem_ea BC_bitU_list rk a sz) = write_mem_eaS BC_bitU_list rk a (nat sz)" + by (auto simp: liftState_write_mem_ea_BC) + +lemma liftState_write_mem_val: + "liftState r (write_mem_val BC v) = write_mem_valS BC v" + by (auto simp: write_mem_val_def write_mem_valS_def split: option.splits) + +lemma liftState_read_reg_readS: + assumes "\<And>s. Option.bind (get_regval' (name reg) s) (of_regval reg) = Some (read_from reg s)" + shows "liftState (get_regval', set_regval') (read_reg reg) = readS (read_from reg \<circ> regstate)" +proof + fix s :: "'a sequential_state" + obtain rv v where "get_regval' (name reg) (regstate s) = Some rv" + and "of_regval reg rv \<equiv> Some v" and "read_from reg (regstate s) = v" + using assms unfolding bind_eq_Some_conv by blast + then show "liftState (get_regval', set_regval') (read_reg reg) s = readS (read_from reg \<circ> regstate) s" + by (auto simp: read_reg_def bindS_def returnS_def read_regS_def readS_def) +qed + +lemma liftState_write_reg_updateS: + assumes "\<And>s. set_regval' (name reg) (regval_of reg v) s = Some (write_to reg v s)" + shows "liftState (get_regval', set_regval') (write_reg reg v) = updateS (regstate_update (write_to reg v))" + using assms by (auto simp: write_reg_def updateS_def returnS_def bindS_readS) + +lemma liftState_iter_aux[simp]: + shows "liftState r (iter_aux i f xs) = iterS_aux i (\<lambda>i x. liftState r (f i x)) xs" + by (induction i "\<lambda>i x. liftState r (f i x)" xs rule: iterS_aux.induct) (auto cong: bindS_cong) + +lemma liftState_iteri[simp]: + "liftState r (iteri f xs) = iteriS (\<lambda>i x. liftState r (f i x)) xs" + by (auto simp: iteri_def iteriS_def) + +lemma liftState_iter[simp]: + "liftState r (iter f xs) = iterS (liftState r \<circ> f) xs" + by (auto simp: iter_def iterS_def) + +lemma liftState_foreachM[simp]: + "liftState r (foreachM xs vars body) = foreachS xs vars (\<lambda>x vars. liftState r (body x vars))" + by (induction xs vars "\<lambda>x vars. liftState r (body x vars)" rule: foreachS.induct) + (auto cong: bindS_cong) + +lemma whileS_dom_step: + assumes "whileS_dom (vars, cond, body, s)" + and "(Value True, s') \<in> cond vars s" + and "(Value vars', s'') \<in> body vars s'" + shows "whileS_dom (vars', cond, body, s'')" + by (use assms in \<open>induction vars cond body s arbitrary: vars' s' s'' rule: whileS.pinduct\<close>) + (auto intro: whileS.domintros) + +lemma whileM_dom_step: + assumes "whileM_dom (vars, cond, body)" + and "Run (cond vars) t True" + and "Run (body vars) t' vars'" + shows "whileM_dom (vars', cond, body)" + by (use assms in \<open>induction vars cond body arbitrary: vars' t t' rule: whileM.pinduct\<close>) + (auto intro: whileM.domintros) + +lemma whileM_dom_ex_step: + assumes "whileM_dom (vars, cond, body)" + and "\<exists>t. Run (cond vars) t True" + and "\<exists>t'. Run (body vars) t' vars'" + shows "whileM_dom (vars', cond, body)" + using assms by (blast intro: whileM_dom_step) + +lemmas whileS_pinduct = whileS.pinduct[case_names Step] + +lemma liftState_whileM: + assumes "whileS_dom (vars, liftState r \<circ> cond, liftState r \<circ> body, s)" + and "whileM_dom (vars, cond, body)" + shows "liftState r (whileM vars cond body) s = whileS vars (liftState r \<circ> cond) (liftState r \<circ> body) s" +proof (use assms in \<open>induction vars "liftState r \<circ> cond" "liftState r \<circ> body" s rule: whileS.pinduct\<close>) + case Step: (1 vars s) + note domS = Step(1) and IH = Step(2) and domM = Step(3) + show ?case unfolding whileS.psimps[OF domS] whileM.psimps[OF domM] liftState_bind + proof (intro bindS_ext_cong, goal_cases cond while) + case (while a s') + have "bindS (liftState r (body vars)) (liftState r \<circ> (\<lambda>vars. whileM vars cond body)) s' = + bindS (liftState r (body vars)) (\<lambda>vars. whileS vars (liftState r \<circ> cond) (liftState r \<circ> body)) s'" + if "a" + proof (intro bindS_ext_cong, goal_cases body while') + case (while' vars' s'') + have "whileM_dom (vars', cond, body)" proof (rule whileM_dom_ex_step[OF domM]) + show "\<exists>t. Run (cond vars) t True" using while that by (auto elim: Value_liftState_Run) + show "\<exists>t'. Run (body vars) t' vars'" using while' that by (auto elim: Value_liftState_Run) + qed + then show ?case using while while' that IH by auto + qed auto + then show ?case by auto + qed auto +qed + + +lemma untilM_dom_step: + assumes "untilM_dom (vars, cond, body)" + and "Run (body vars) t vars'" + and "Run (cond vars') t' False" + shows "untilM_dom (vars', cond, body)" + by (use assms in \<open>induction vars cond body arbitrary: vars' t t' rule: untilM.pinduct\<close>) + (auto intro: untilM.domintros) + +lemma untilM_dom_ex_step: + assumes "untilM_dom (vars, cond, body)" + and "\<exists>t. Run (body vars) t vars'" + and "\<exists>t'. Run (cond vars') t' False" + shows "untilM_dom (vars', cond, body)" + using assms by (blast intro: untilM_dom_step) + +lemma liftState_untilM: + assumes "untilS_dom (vars, liftState r \<circ> cond, liftState r \<circ> body, s)" + and "untilM_dom (vars, cond, body)" + shows "liftState r (untilM vars cond body) s = untilS vars (liftState r \<circ> cond) (liftState r \<circ> body) s" +proof (use assms in \<open>induction vars "liftState r \<circ> cond" "liftState r \<circ> body" s rule: untilS.pinduct\<close>) + case Step: (1 vars s) + note domS = Step(1) and IH = Step(2) and domM = Step(3) + show ?case unfolding untilS.psimps[OF domS] untilM.psimps[OF domM] liftState_bind + proof (intro bindS_ext_cong, goal_cases body k) + case (k vars' s') + show ?case unfolding comp_def liftState_bind + proof (intro bindS_ext_cong, goal_cases cond until) + case (until a s'') + have "untilM_dom (vars', cond, body)" if "\<not>a" + proof (rule untilM_dom_ex_step[OF domM]) + show "\<exists>t. Run (body vars) t vars'" using k by (auto elim: Value_liftState_Run) + show "\<exists>t'. Run (cond vars') t' False" using until that by (auto elim: Value_liftState_Run) + qed + then show ?case using k until IH by (auto simp: comp_def) + qed auto + qed auto +qed + +end diff --git a/snapshots/isabelle/lib/sail/State_monad.thy b/snapshots/isabelle/lib/sail/State_monad.thy new file mode 100644 index 00000000..8e19f0b6 --- /dev/null +++ b/snapshots/isabelle/lib/sail/State_monad.thy @@ -0,0 +1,375 @@ +chapter \<open>Generated by Lem from ../../src/gen_lib/state_monad.lem.\<close> + +theory "State_monad" + +imports + Main + "Lem_pervasives_extra" + "Sail_instr_kinds" + "Sail_values" + +begin + +(*open import Pervasives_extra*) +(*open import Sail_instr_kinds*) +(*open import Sail_values*) + +(* 'a is result type *) + +type_synonym memstate =" (int, memory_byte) Map.map " +type_synonym tagstate =" (int, bitU) Map.map " +(* type regstate = map string (vector bitU) *) + +record 'regs sequential_state = + + regstate ::" 'regs " + + memstate ::" memstate " + + tagstate ::" tagstate " + + write_ea ::" (write_kind * int * int)option " + + last_exclusive_operation_was_load ::" bool " + + (* Random bool generator for use as an undefined bit oracle *) + next_bool ::" nat \<Rightarrow> (bool * nat)" + + seed ::" nat " + + +(*val init_state : forall 'regs. 'regs -> (nat -> (bool* nat)) -> nat -> sequential_state 'regs*) +definition init_state :: " 'regs \<Rightarrow>(nat \<Rightarrow> bool*nat)\<Rightarrow> nat \<Rightarrow> 'regs sequential_state " where + " init_state regs o1 s = ( + (| regstate = regs, + memstate = Map.empty, + tagstate = Map.empty, + write_ea = None, + last_exclusive_operation_was_load = False, + next_bool = o1, + seed = s |) )" + + +datatype 'e ex = + Failure " string " + | Throw " 'e " + +datatype( 'a, 'e) result = + Value " 'a " + | Ex " ( 'e ex)" + +(* State, nondeterminism and exception monad with result value type 'a + and exception type 'e. *) +type_synonym( 'regs, 'a, 'e) monadS =" 'regs sequential_state \<Rightarrow> ( ('a, 'e)result * 'regs sequential_state) set " + +(*val returnS : forall 'regs 'a 'e. 'a -> monadS 'regs 'a 'e*) +definition returnS :: " 'a \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " returnS a s = ( {(Value a,s)})" + + +(*val bindS : forall 'regs 'a 'b 'e. monadS 'regs 'a 'e -> ('a -> monadS 'regs 'b 'e) -> monadS 'regs 'b 'e*) +definition bindS :: "('regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set)\<Rightarrow>('a \<Rightarrow> 'regs sequential_state \<Rightarrow>(('b,'e)result*'regs sequential_state)set)\<Rightarrow> 'regs sequential_state \<Rightarrow>(('b,'e)result*'regs sequential_state)set " where + " bindS m f (s :: 'regs sequential_state) = ( + \<Union> (Set.image (\<lambda>x . + (case x of (Value a, s') => f a s' | (Ex e, s') => {(Ex e, s')} )) (m s)))" + + +(*val seqS: forall 'regs 'b 'e. monadS 'regs unit 'e -> monadS 'regs 'b 'e -> monadS 'regs 'b 'e*) +definition seqS :: "('regs sequential_state \<Rightarrow>(((unit),'e)result*'regs sequential_state)set)\<Rightarrow>('regs sequential_state \<Rightarrow>(('b,'e)result*'regs sequential_state)set)\<Rightarrow> 'regs sequential_state \<Rightarrow>(('b,'e)result*'regs sequential_state)set " where + " seqS m n = ( bindS m ( \<lambda>x . + (case x of (_ :: unit) => n )))" + + +(*val chooseS : forall 'regs 'a 'e. SetType 'a => set 'a -> monadS 'regs 'a 'e*) +definition chooseS :: " 'a set \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " chooseS xs s = ( Set.image (\<lambda> x . (Value x, s)) xs )" + + +(*val readS : forall 'regs 'a 'e. (sequential_state 'regs -> 'a) -> monadS 'regs 'a 'e*) +definition readS :: "('regs sequential_state \<Rightarrow> 'a)\<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " readS f = ( (\<lambda> s . returnS (f s) s))" + + +(*val updateS : forall 'regs 'e. (sequential_state 'regs -> sequential_state 'regs) -> monadS 'regs unit 'e*) +definition updateS :: "('regs sequential_state \<Rightarrow> 'regs sequential_state)\<Rightarrow> 'regs sequential_state \<Rightarrow>(((unit),'e)result*'regs sequential_state)set " where + " updateS f = ( (\<lambda> s . returnS () (f s)))" + + +(*val failS : forall 'regs 'a 'e. string -> monadS 'regs 'a 'e*) +definition failS :: " string \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " failS msg s = ( {(Ex (Failure msg), s)})" + + +(*val undefined_boolS : forall 'regval 'regs 'a 'e. unit -> monadS 'regs bool 'e*) +definition undefined_boolS :: " unit \<Rightarrow>('regs,(bool),'e)monadS " where + " undefined_boolS _ = ( bindS + (readS (\<lambda> s . (next_bool s) ((seed s)))) ( \<lambda>x . + (case x of + (b, seed1) => seqS (updateS (\<lambda> s . ( s (| seed := seed1 |)))) + (returnS b) + )))" + + +(*val exitS : forall 'regs 'e 'a. unit -> monadS 'regs 'a 'e*) +definition exitS :: " unit \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " exitS _ = ( failS (''exit''))" + + +(*val throwS : forall 'regs 'a 'e. 'e -> monadS 'regs 'a 'e*) +definition throwS :: " 'e \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " throwS e s = ( {(Ex (Throw e), s)})" + + +(*val try_catchS : forall 'regs 'a 'e1 'e2. monadS 'regs 'a 'e1 -> ('e1 -> monadS 'regs 'a 'e2) -> monadS 'regs 'a 'e2*) +definition try_catchS :: "('regs sequential_state \<Rightarrow>(('a,'e1)result*'regs sequential_state)set)\<Rightarrow>('e1 \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e2)result*'regs sequential_state)set)\<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e2)result*'regs sequential_state)set " where + " try_catchS m h s = ( + \<Union> (Set.image (\<lambda>x . + (case x of + (Value a, s') => returnS a s' + | (Ex (Throw e), s') => h e s' + | (Ex (Failure msg), s') => {(Ex (Failure msg), s')} + )) (m s)))" + + +(*val assert_expS : forall 'regs 'e. bool -> string -> monadS 'regs unit 'e*) +definition assert_expS :: " bool \<Rightarrow> string \<Rightarrow> 'regs sequential_state \<Rightarrow>(((unit),'e)result*'regs sequential_state)set " where + " assert_expS exp msg = ( if exp then returnS () else failS msg )" + + +(* For early return, we abuse exceptions by throwing and catching + the return value. The exception type is either 'r 'e, where Right e + represents a proper exception and Left r an early return of value r. *) +type_synonym( 'regs, 'a, 'r, 'e) monadSR =" ('regs, 'a, ( ('r, 'e)sum)) monadS " + +(*val early_returnS : forall 'regs 'a 'r 'e. 'r -> monadSR 'regs 'a 'r 'e*) +definition early_returnS :: " 'r \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,(('r,'e)sum))result*'regs sequential_state)set " where + " early_returnS r = ( throwS (Inl r))" + + +(*val catch_early_returnS : forall 'regs 'a 'e. monadSR 'regs 'a 'a 'e -> monadS 'regs 'a 'e*) +definition catch_early_returnS :: "('regs sequential_state \<Rightarrow>(('a,(('a,'e)sum))result*'regs sequential_state)set)\<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " catch_early_returnS m = ( + try_catchS m + (\<lambda>x . (case x of Inl a => returnS a | Inr e => throwS e )))" + + +(* Lift to monad with early return by wrapping exceptions *) +(*val liftSR : forall 'a 'r 'regs 'e. monadS 'regs 'a 'e -> monadSR 'regs 'a 'r 'e*) +definition liftSR :: "('regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set)\<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,(('r,'e)sum))result*'regs sequential_state)set " where + " liftSR m = ( try_catchS m (\<lambda> e . throwS (Inr e)))" + + +(* Catch exceptions in the presence of early returns *) +(*val try_catchSR : forall 'regs 'a 'r 'e1 'e2. monadSR 'regs 'a 'r 'e1 -> ('e1 -> monadSR 'regs 'a 'r 'e2) -> monadSR 'regs 'a 'r 'e2*) +definition try_catchSR :: "('regs sequential_state \<Rightarrow>(('a,(('r,'e1)sum))result*'regs sequential_state)set)\<Rightarrow>('e1 \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,(('r,'e2)sum))result*'regs sequential_state)set)\<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,(('r,'e2)sum))result*'regs sequential_state)set " where + " try_catchSR m h = ( + try_catchS m + (\<lambda>x . (case x of Inl r => throwS (Inl r) | Inr e => h e )))" + + +(*val maybe_failS : forall 'regs 'a 'e. string -> maybe 'a -> monadS 'regs 'a 'e*) +definition maybe_failS :: " string \<Rightarrow> 'a option \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " maybe_failS msg = ( \<lambda>x . + (case x of Some a => returnS a | None => failS msg ) )" + + +(*val read_tagS : forall 'regs 'a 'e. Bitvector 'a => 'a -> monadS 'regs bitU 'e*) +definition read_tagS :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow>('regs,(bitU),'e)monadS " where + " read_tagS dict_Sail_values_Bitvector_a addr = ( bindS + (maybe_failS (''unsigned'') ( + (unsigned_method dict_Sail_values_Bitvector_a) addr)) (\<lambda> addr . + readS (\<lambda> s . case_option B0 id ((tagstate s) addr))))" + + +(* Read bytes from memory and return in little endian order *) +(*val read_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => read_kind -> 'a -> nat -> monadS 'regs (list memory_byte) 'e*) +definition read_mem_bytesS :: " 'a Bitvector_class \<Rightarrow> read_kind \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow>('regs,(((bitU)list)list),'e)monadS " where + " read_mem_bytesS dict_Sail_values_Bitvector_a read_kind addr sz = ( bindS + (maybe_failS (''unsigned'') ( + (unsigned_method dict_Sail_values_Bitvector_a) addr)) (\<lambda> addr . + (let sz = (int sz) in + (let addrs = (index_list addr ((addr+sz)-( 1 :: int))(( 1 :: int))) in + (let read_byte = (\<lambda> s addr . (memstate s) addr) in + bindS (readS (\<lambda> s . just_list (List.map (read_byte s) addrs))) + (\<lambda>x . (case x of + Some mem_val => seqS + (updateS + (\<lambda> s . + if read_is_exclusive read_kind + then + ( s (| last_exclusive_operation_was_load := True |)) + else s)) (returnS mem_val) + | None => failS (''read_memS'') + )))))))" + + +(*val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs 'b 'e*) +definition read_memS :: " 'a Bitvector_class \<Rightarrow> 'b Bitvector_class \<Rightarrow> read_kind \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow>('regs,'b,'e)monadS " where + " read_memS dict_Sail_values_Bitvector_a dict_Sail_values_Bitvector_b rk a sz = ( bindS + (read_mem_bytesS dict_Sail_values_Bitvector_a rk a (nat_of_int sz)) (\<lambda> bytes . + maybe_failS (''bits_of_mem_bytes'') ( + (of_bits_method dict_Sail_values_Bitvector_b) (bits_of_mem_bytes bytes))))" + + +(*val excl_resultS : forall 'regs 'e. unit -> monadS 'regs bool 'e*) +definition excl_resultS :: " unit \<Rightarrow>('regs,(bool),'e)monadS " where + " excl_resultS _ = ( bindS + (readS (\<lambda> s . (last_exclusive_operation_was_load s))) (\<lambda> excl_load . seqS + (updateS (\<lambda> s . ( s (| last_exclusive_operation_was_load := False |)))) + (chooseS (if excl_load then {False, True} else {False}))))" + + +(*val write_mem_eaS : forall 'regs 'e 'a. Bitvector 'a => write_kind -> 'a -> nat -> monadS 'regs unit 'e*) +definition write_mem_eaS :: " 'a Bitvector_class \<Rightarrow> write_kind \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow>('regs,(unit),'e)monadS " where + " write_mem_eaS dict_Sail_values_Bitvector_a write_kind addr sz = ( bindS + (maybe_failS (''unsigned'') ( + (unsigned_method dict_Sail_values_Bitvector_a) addr)) (\<lambda> addr . + (let sz = (int sz) in + updateS (\<lambda> s . ( s (| write_ea := (Some (write_kind, addr, sz)) |))))))" + + +(* Write little-endian list of bytes to previously announced address *) +(*val write_mem_bytesS : forall 'regs 'e. list memory_byte -> monadS 'regs bool 'e*) +definition write_mem_bytesS :: "((bitU)list)list \<Rightarrow>('regs,(bool),'e)monadS " where + " write_mem_bytesS v = ( bindS + (readS (\<lambda> s . (write_ea s))) (\<lambda>x . + (case x of + None => failS (''write ea has not been announced yet'') + | Some (_, addr, sz) => + (let addrs = (index_list addr ((addr + sz) - ( 1 :: int)) (( 1 :: int))) in + (*let v = external_mem_value (bits_of v) in*) + (let a_v = (List.zip addrs v) in + (let write_byte = (\<lambda>mem p . (case (mem ,p ) of + ( mem , (addr, v) ) => map_update + addr + v mem + )) in + seqS + (updateS + (\<lambda> s . + ( s (| memstate := (List.foldl write_byte (memstate s) a_v) |)))) + (returnS True)))) + )))" + + +(*val write_mem_valS : forall 'regs 'e 'a. Bitvector 'a => 'a -> monadS 'regs bool 'e*) +definition write_mem_valS :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> 'regs sequential_state \<Rightarrow>(((bool),'e)result*'regs sequential_state)set " where + " write_mem_valS dict_Sail_values_Bitvector_a v = ( (case mem_bytes_of_bits + dict_Sail_values_Bitvector_a v of + Some v => write_mem_bytesS v + | None => failS (''write_mem_val'') +))" + + +(*val write_tagS : forall 'regs 'a 'e. Bitvector 'a => 'a -> bitU -> monadS 'regs bool 'e*) +definition write_tagS :: " 'a Bitvector_class \<Rightarrow> 'a \<Rightarrow> bitU \<Rightarrow>('regs,(bool),'e)monadS " where + " write_tagS dict_Sail_values_Bitvector_a addr t = ( bindS + (maybe_failS (''unsigned'') ( + (unsigned_method dict_Sail_values_Bitvector_a) addr)) (\<lambda> addr . seqS + (updateS (\<lambda> s . ( s (| tagstate := (map_update addr t(tagstate s)) |)))) + (returnS True)))" + + +(*val read_regS : forall 'regs 'rv 'a 'e. register_ref 'regs 'rv 'a -> monadS 'regs 'a 'e*) +definition read_regS :: "('regs,'rv,'a)register_ref \<Rightarrow> 'regs sequential_state \<Rightarrow>(('a,'e)result*'regs sequential_state)set " where + " read_regS reg = ( readS (\<lambda> s . (read_from reg)(regstate s)))" + + +(* TODO +let read_reg_range reg i j state = + let v = slice (get_reg state (name_of_reg reg)) i j in + [(Value (vec_to_bvec v),state)] +let read_reg_bit reg i state = + let v = access (get_reg state (name_of_reg reg)) i in + [(Value v,state)] +let read_reg_field reg regfield = + let (i,j) = register_field_indices reg regfield in + read_reg_range reg i j +let read_reg_bitfield reg regfield = + let (i,_) = register_field_indices reg regfield in + read_reg_bit reg i *) + +(*val read_regvalS : forall 'regs 'rv 'e. + register_accessors 'regs 'rv -> string -> monadS 'regs 'rv 'e*) +fun read_regvalS :: "(string \<Rightarrow> 'regs \<Rightarrow> 'rv option)*(string \<Rightarrow> 'rv \<Rightarrow> 'regs \<Rightarrow> 'regs option)\<Rightarrow> string \<Rightarrow>('regs,'rv,'e)monadS " where + " read_regvalS (read, _) reg = ( bindS + (readS (\<lambda> s . read reg(regstate s))) (\<lambda>x . + (case x of + Some v => returnS v + | None => failS ((''read_regvalS '') @ reg) + )))" + + +(*val write_regvalS : forall 'regs 'rv 'e. + register_accessors 'regs 'rv -> string -> 'rv -> monadS 'regs unit 'e*) +fun write_regvalS :: "(string \<Rightarrow> 'regs \<Rightarrow> 'rv option)*(string \<Rightarrow> 'rv \<Rightarrow> 'regs \<Rightarrow> 'regs option)\<Rightarrow> string \<Rightarrow> 'rv \<Rightarrow>('regs,(unit),'e)monadS " where + " write_regvalS (_, write1) reg v = ( bindS + (readS (\<lambda> s . write1 reg v(regstate s))) (\<lambda>x . + (case x of + Some rs' => updateS (\<lambda> s . ( s (| regstate := rs' |))) + | None => failS ((''write_regvalS '') @ reg) + )))" + + +(*val write_regS : forall 'regs 'rv 'a 'e. register_ref 'regs 'rv 'a -> 'a -> monadS 'regs unit 'e*) +definition write_regS :: "('regs,'rv,'a)register_ref \<Rightarrow> 'a \<Rightarrow> 'regs sequential_state \<Rightarrow>(((unit),'e)result*'regs sequential_state)set " where + " write_regS reg v = ( + updateS (\<lambda> s . ( s (| regstate := ((write_to reg) v(regstate s)) |))))" + + +(* TODO +val update_reg : forall 'regs 'rv 'a 'b 'e. register_ref 'regs 'rv 'a -> ('a -> 'b -> 'a) -> 'b -> monadS 'regs unit 'e +let update_reg reg f v state = + let current_value = get_reg state reg in + let new_value = f current_value v in + [(Value (), set_reg state reg new_value)] + +let write_reg_field reg regfield = update_reg reg regfield.set_field + +val update_reg_range : forall 'regs 'rv 'a 'b. Bitvector 'a, Bitvector 'b => register_ref 'regs 'rv 'a -> integer -> integer -> 'a -> 'b -> 'a +let update_reg_range reg i j reg_val new_val = set_bits (reg.is_inc) reg_val i j (bits_of new_val) +let write_reg_range reg i j = update_reg reg (update_reg_range reg i j) + +let update_reg_pos reg i reg_val x = update_list reg.is_inc reg_val i x +let write_reg_pos reg i = update_reg reg (update_reg_pos reg i) + +let update_reg_bit reg i reg_val bit = set_bit (reg.is_inc) reg_val i (to_bitU bit) +let write_reg_bit reg i = update_reg reg (update_reg_bit reg i) + +let update_reg_field_range regfield i j reg_val new_val = + let current_field_value = regfield.get_field reg_val in + let new_field_value = set_bits (regfield.field_is_inc) current_field_value i j (bits_of new_val) in + regfield.set_field reg_val new_field_value +let write_reg_field_range reg regfield i j = update_reg reg (update_reg_field_range regfield i j) + +let update_reg_field_pos regfield i reg_val x = + let current_field_value = regfield.get_field reg_val in + let new_field_value = update_list regfield.field_is_inc current_field_value i x in + regfield.set_field reg_val new_field_value +let write_reg_field_pos reg regfield i = update_reg reg (update_reg_field_pos regfield i) + +let update_reg_field_bit regfield i reg_val bit = + let current_field_value = regfield.get_field reg_val in + let new_field_value = set_bit (regfield.field_is_inc) current_field_value i (to_bitU bit) in + regfield.set_field reg_val new_field_value +let write_reg_field_bit reg regfield i = update_reg reg (update_reg_field_bit regfield i)*) + +(* TODO Add Show typeclass for value and exception type *) +(*val show_result : forall 'a 'e. result 'a 'e -> string*) +definition show_result :: "('a,'e)result \<Rightarrow> string " where + " show_result = ( \<lambda>x . + (case x of + Value _ => (''Value ()'') + | Ex (Failure msg) => (''Failure '') @ msg + | Ex (Throw _) => (''Throw'') + ) )" + + +(*val prerr_results : forall 'a 'e 's. SetType 's => set (result 'a 'e * 's) -> unit*) +definition prerr_results :: "(('a,'e)result*'s)set \<Rightarrow> unit " where + " prerr_results rs = ( + (let _ = (Set.image ( \<lambda>x . + (case x of (r, _) => (let _ = (prerr_endline (show_result r)) in () ) )) rs) in + () ))" + +end diff --git a/snapshots/isabelle/lib/sail/State_monad_lemmas.thy b/snapshots/isabelle/lib/sail/State_monad_lemmas.thy new file mode 100644 index 00000000..e0d684ba --- /dev/null +++ b/snapshots/isabelle/lib/sail/State_monad_lemmas.thy @@ -0,0 +1,232 @@ +theory State_monad_lemmas + imports + State_monad + Sail_values_lemmas +begin + +(*context + notes returnS_def[simp] and failS_def[simp] and throwS_def[simp] and readS_def[simp] and updateS_def[simp] +begin*) + +lemma bindS_ext_cong[fundef_cong]: + assumes m: "m1 s = m2 s" + and f: "\<And>a s'. (Value a, s') \<in> (m2 s) \<Longrightarrow> f1 a s' = f2 a s'" + shows "bindS m1 f1 s = bindS m2 f2 s" + using assms unfolding bindS_def by (auto split: result.splits) + +lemma bindS_cong[fundef_cong]: + assumes m: "m1 = m2" + and f: "\<And>s a s'. (Value a, s') \<in> (m2 s) \<Longrightarrow> f1 a s' = f2 a s'" + shows "bindS m1 f1 = bindS m2 f2" + using assms by (intro ext bindS_ext_cong; blast) + +lemma bindS_returnS_left[simp]: "bindS (returnS x) f = f x" + by (auto simp add: bindS_def returnS_def) + +lemma bindS_returnS_right[simp]: "bindS m returnS = (m :: ('regs, 'a, 'e) monadS)" + by (intro ext) (auto simp: bindS_def returnS_def split: result.splits) + +lemma bindS_readS: "bindS (readS f) m = (\<lambda>s. m (f s) s)" + by (auto simp: bindS_def readS_def returnS_def) + +lemma bindS_updateS: "bindS (updateS f) m = (\<lambda>s. m () (f s))" + by (auto simp: bindS_def updateS_def returnS_def) + +lemma bindS_assertS_True[simp]: "bindS (assert_expS True msg) f = f ()" + by (auto simp: assert_expS_def) + + +lemma result_cases: + fixes r :: "('a, 'e) result" + obtains (Value) a where "r = Value a" + | (Throw) e where "r = Ex (Throw e)" + | (Failure) msg where "r = Ex (Failure msg)" +proof (cases r) + case (Ex ex) then show ?thesis by (cases ex; auto intro: that) +qed + +lemma result_state_cases: + fixes rs :: "('a, 'e) result \<times> 's" + obtains (Value) a s where "rs = (Value a, s)" + | (Throw) e s where "rs = (Ex (Throw e), s)" + | (Failure) msg s where "rs = (Ex (Failure msg), s)" +proof - + obtain r s where rs: "rs = (r, s)" by (cases rs) + then show thesis by (cases r rule: result_cases) (auto intro: that) +qed + +lemma monadS_ext_eqI: + fixes m m' :: "('regs, 'a, 'e) monadS" + assumes "\<And>a s'. (Value a, s') \<in> m s \<longleftrightarrow> (Value a, s') \<in> m' s" + and "\<And>e s'. (Ex (Throw e), s') \<in> m s \<longleftrightarrow> (Ex (Throw e), s') \<in> m' s" + and "\<And>msg s'. (Ex (Failure msg), s') \<in> m s \<longleftrightarrow> (Ex (Failure msg), s') \<in> m' s" + shows "m s = m' s" +proof (intro set_eqI) + fix x + show "x \<in> m s \<longleftrightarrow> x \<in> m' s" using assms by (cases x rule: result_state_cases) auto +qed + +lemma monadS_eqI: + fixes m m' :: "('regs, 'a, 'e) monadS" + assumes "\<And>s a s'. (Value a, s') \<in> m s \<longleftrightarrow> (Value a, s') \<in> m' s" + and "\<And>s e s'. (Ex (Throw e), s') \<in> m s \<longleftrightarrow> (Ex (Throw e), s') \<in> m' s" + and "\<And>s msg s'. (Ex (Failure msg), s') \<in> m s \<longleftrightarrow> (Ex (Failure msg), s') \<in> m' s" + shows "m = m'" + using assms by (intro ext monadS_ext_eqI) + +lemma bindS_cases: + assumes "(r, s') \<in> bindS m f s" + obtains (Value) a a' s'' where "r = Value a" and "(Value a', s'') \<in> m s" and "(Value a, s') \<in> f a' s''" + | (Ex_Left) e where "r = Ex e" and "(Ex e, s') \<in> m s" + | (Ex_Right) e a s'' where "r = Ex e" and "(Value a, s'') \<in> m s" and "(Ex e, s') \<in> f a s''" + using assms by (cases r; auto simp: bindS_def split: result.splits) + +lemma bindS_intros: + "\<And>m f s a s' a' s''. (Value a', s'') \<in> m s \<Longrightarrow> (Value a, s') \<in> f a' s'' \<Longrightarrow> (Value a, s') \<in> bindS m f s" + "\<And>m f s e s'. (Ex e, s') \<in> m s \<Longrightarrow> (Ex e, s') \<in> bindS m f s" + "\<And>m f s e s' a s''. (Ex e, s') \<in> f a s'' \<Longrightarrow> (Value a, s'') \<in> m s \<Longrightarrow> (Ex e, s') \<in> bindS m f s" + by (auto simp: bindS_def intro: bexI[rotated]) + +lemma bindS_assoc[simp]: "bindS (bindS m f) g = bindS m (\<lambda>x. bindS (f x) g)" + by (auto elim!: bindS_cases intro: bindS_intros monadS_eqI) + +lemma bindS_failS[simp]: "bindS (failS msg) f = failS msg" by (auto simp: bindS_def failS_def) +lemma bindS_throwS[simp]: "bindS (throwS e) f = throwS e" by (auto simp: bindS_def throwS_def) +declare seqS_def[simp] + +lemma Value_bindS_elim: + assumes "(Value a, s') \<in> bindS m f s" + obtains s'' a' where "(Value a', s'') \<in> m s" and "(Value a, s') \<in> f a' s''" + using assms by (auto elim: bindS_cases) + +lemma Ex_bindS_elim: + assumes "(Ex e, s') \<in> bindS m f s" + obtains (Left) "(Ex e, s') \<in> m s" + | (Right) s'' a' where "(Value a', s'') \<in> m s" and "(Ex e, s') \<in> f a' s''" + using assms by (auto elim: bindS_cases) + +lemma try_catchS_returnS[simp]: "try_catchS (returnS a) h = returnS a" + and try_catchS_failS[simp]: "try_catchS (failS msg) h = failS msg" + and try_catchS_throwS[simp]: "try_catchS (throwS e) h = h e" + by (auto simp: try_catchS_def returnS_def failS_def throwS_def) + +lemma try_catchS_cong[cong]: + assumes "\<And>s. m1 s = m2 s" and "\<And>e s. h1 e s = h2 e s" + shows "try_catchS m1 h1 = try_catchS m2 h2" + using assms by (intro arg_cong2[where f = try_catchS] ext) auto + +lemma try_catchS_cases: + assumes "(r, s') \<in> try_catchS m h s" + obtains (Value) a where "r = Value a" and "(Value a, s') \<in> m s" + | (Fail) msg where "r = Ex (Failure msg)" and "(Ex (Failure msg), s') \<in> m s" + | (h) e s'' where "(Ex (Throw e), s'') \<in> m s" and "(r, s') \<in> h e s''" + using assms + by (cases r rule: result_cases) (auto simp: try_catchS_def returnS_def split: result.splits ex.splits) + +lemma try_catchS_intros: + "\<And>m h s a s'. (Value a, s') \<in> m s \<Longrightarrow> (Value a, s') \<in> try_catchS m h s" + "\<And>m h s msg s'. (Ex (Failure msg), s') \<in> m s \<Longrightarrow> (Ex (Failure msg), s') \<in> try_catchS m h s" + "\<And>m h s e s'' r s'. (Ex (Throw e), s'') \<in> m s \<Longrightarrow> (r, s') \<in> h e s'' \<Longrightarrow> (r, s') \<in> try_catchS m h s" + by (auto simp: try_catchS_def returnS_def intro: bexI[rotated]) + +lemma no_Ex_basic_builtins[simp]: + "\<And>s e s' a. (Ex e, s') \<in> returnS a s \<longleftrightarrow> False" + "\<And>s e s' f. (Ex e, s') \<in> readS f s \<longleftrightarrow> False" + "\<And>s e s' f. (Ex e, s') \<in> updateS f s \<longleftrightarrow> False" + "\<And>s e s' xs. (Ex e, s') \<in> chooseS xs s \<longleftrightarrow> False" + by (auto simp: readS_def updateS_def returnS_def chooseS_def) + +fun ignore_throw_aux :: "(('a, 'e1) result \<times> 's) \<Rightarrow> (('a, 'e2) result \<times> 's) set" where + "ignore_throw_aux (Value a, s') = {(Value a, s')}" +| "ignore_throw_aux (Ex (Throw e), s') = {}" +| "ignore_throw_aux (Ex (Failure msg), s') = {(Ex (Failure msg), s')}" +definition "ignore_throw m s \<equiv> \<Union>(ignore_throw_aux ` m s)" + +lemma ignore_throw_cong: + assumes "\<And>s. m1 s = m2 s" + shows "ignore_throw m1 = ignore_throw m2" + using assms by (auto simp: ignore_throw_def) + +lemma ignore_throw_aux_member_simps[simp]: + "(Value a, s') \<in> ignore_throw_aux ms \<longleftrightarrow> ms = (Value a, s')" + "(Ex (Throw e), s') \<in> ignore_throw_aux ms \<longleftrightarrow> False" + "(Ex (Failure msg), s') \<in> ignore_throw_aux ms \<longleftrightarrow> ms = (Ex (Failure msg), s')" + by (cases ms rule: result_state_cases; auto)+ + +lemma ignore_throw_member_simps[simp]: + "(Value a, s') \<in> ignore_throw m s \<longleftrightarrow> (Value a, s') \<in> m s" + "(Value a, s') \<in> ignore_throw m s \<longleftrightarrow> (Value a, s') \<in> m s" + "(Ex (Throw e), s') \<in> ignore_throw m s \<longleftrightarrow> False" + "(Ex (Failure msg), s') \<in> ignore_throw m s \<longleftrightarrow> (Ex (Failure msg), s') \<in> m s" + by (auto simp: ignore_throw_def) + +lemma ignore_throw_cases: + assumes no_throw: "ignore_throw m s = m s" + and r: "(r, s') \<in> m s" + obtains (Value) a where "r = Value a" + | (Failure) msg where "r = Ex (Failure msg)" + using r unfolding no_throw[symmetric] + by (cases r rule: result_cases) (auto simp: ignore_throw_def) + +lemma ignore_throw_bindS[simp]: + "ignore_throw (bindS m f) = bindS (ignore_throw m) (ignore_throw \<circ> f)" + by (intro monadS_eqI) (auto simp: ignore_throw_def elim!: bindS_cases intro: bindS_intros) + +lemma try_catchS_bindS_no_throw: + fixes m1 :: "('r, 'a, 'e1) monadS" and m2 :: "('r, 'a, 'e2) monadS" + assumes m1: "\<And>s. ignore_throw m1 s = m1 s" + and m2: "\<And>s. ignore_throw m1 s = m2 s" + shows "try_catchS (bindS m1 f) h = bindS m2 (\<lambda>a. try_catchS (f a) h)" +proof + fix s + have "try_catchS (bindS m1 f) h s = bindS (ignore_throw m1) (\<lambda>a. try_catchS (f a) h) s" + by (intro monadS_ext_eqI; + auto elim!: bindS_cases try_catchS_cases elim: ignore_throw_cases[OF m1]; + auto simp: ignore_throw_def intro: bindS_intros try_catchS_intros) + also have "\<dots> = bindS m2 (\<lambda>a. try_catchS (f a) h) s" using m2 by (intro bindS_ext_cong) auto + finally show "try_catchS (bindS m1 f) h s = bindS m2 (\<lambda>a. try_catchS (f a) h) s" . +qed + +lemma no_throw_basic_builtins[simp]: + "ignore_throw (returnS a) = returnS a" + "\<And>f. ignore_throw (readS f) = readS f" + "\<And>f. ignore_throw (updateS f) = updateS f" + "ignore_throw (chooseS xs) = chooseS xs" + "ignore_throw (failS msg) = failS msg" + "ignore_throw (maybe_failS msg x) = maybe_failS msg x" + unfolding ignore_throw_def returnS_def chooseS_def maybe_failS_def failS_def readS_def updateS_def + by (intro ext; auto split: option.splits)+ + +lemmas ignore_throw_option_case_distrib = + option.case_distrib[where h = "\<lambda>c. ignore_throw c s" and option = "c s" for c s] + +lemma no_throw_mem_builtins: + "\<And>BC rk a sz s. ignore_throw (read_mem_bytesS BC rk a sz) s = read_mem_bytesS BC rk a sz s" + "\<And>BC a s. ignore_throw (read_tagS BC a) s = read_tagS BC a s" + "\<And>BC wk a sz s. ignore_throw (write_mem_eaS BC wk a sz) s = write_mem_eaS BC wk a sz s" + "\<And>v s. ignore_throw (write_mem_bytesS v) s = write_mem_bytesS v s" + "\<And>BC v s. ignore_throw (write_mem_valS BC v) s = write_mem_valS BC v s" + "\<And>BC a t s. ignore_throw (write_tagS BC a t) s = write_tagS BC a t s" + "\<And>s. ignore_throw (excl_resultS ()) s = excl_resultS () s" + "\<And>s. ignore_throw (undefined_boolS ()) s = undefined_boolS () s" + unfolding read_mem_bytesS_def read_memS_def read_tagS_def write_mem_eaS_def + unfolding write_mem_valS_def write_mem_bytesS_def write_tagS_def + unfolding excl_resultS_def undefined_boolS_def + by (auto cong: bindS_cong bindS_ext_cong ignore_throw_cong option.case_cong + simp: option.case_distrib prod.case_distrib ignore_throw_option_case_distrib comp_def) + +lemma no_throw_read_memS: "ignore_throw (read_memS BCa BCb rk a sz) s = read_memS BCa BCb rk a sz s" + by (auto simp: read_memS_def no_throw_mem_builtins cong: bindS_ext_cong) + +lemma no_throw_read_regvalS: "ignore_throw (read_regvalS r reg_name) s = read_regvalS r reg_name s" + by (cases r) (auto simp: option.case_distrib cong: bindS_cong option.case_cong) + +lemma no_throw_write_regvalS: "ignore_throw (write_regvalS r reg_name v) s = write_regvalS r reg_name v s" + by (cases r) (auto simp: option.case_distrib cong: bindS_cong option.case_cong) + +lemmas no_throw_builtins[simp] = + no_throw_mem_builtins no_throw_read_regvalS no_throw_write_regvalS no_throw_read_memS + +(* end *) + +end |