From: Stefano Zacchiroli Date: Tue, 16 Dec 2003 17:19:48 +0000 (+0000) Subject: removed ancient "interface" dir X-Git-Tag: V_0_5_1_3~71 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=74d9faf4c6bd9abfb84934d6897a1ab98f9027d2;p=helm.git removed ancient "interface" dir --- diff --git a/helm/interface/.cvsignore b/helm/interface/.cvsignore deleted file mode 100644 index 742f6eb37..000000000 --- a/helm/interface/.cvsignore +++ /dev/null @@ -1,27 +0,0 @@ -*.cmo -*.cmx -*.cmi - -experiment -experiment.opt -fix_params -fix_params.opt -mmlinterface -mmlinterface.opt -reduction -reduction.opt -t1lib.log -output.ps -output2.ps - -Makefile -configuration.ml -helm_wget -configure -config.log -config.cache -config.status - -helm_gtk_interface.spec - -gmon.out diff --git a/helm/interface/.depend b/helm/interface/.depend deleted file mode 100644 index 6402ae55b..000000000 --- a/helm/interface/.depend +++ /dev/null @@ -1,94 +0,0 @@ -experiment.cmo: cicCache.cmi cicPp.cmi configuration.cmo getter.cmi \ - uriManager.cmi -experiment.cmx: cicCache.cmx cicPp.cmx configuration.cmx getter.cmx \ - uriManager.cmx -cicCache.cmo: annotationParser.cmo cic.cmo cicParser.cmi cicSubstitution.cmi \ - deannotate.cmo getter.cmi uriManager.cmi cicCache.cmi -cicCache.cmx: annotationParser.cmx cic.cmx cicParser.cmx cicSubstitution.cmx \ - deannotate.cmx getter.cmx uriManager.cmx cicCache.cmi -cicCache.cmi: cic.cmo uriManager.cmi -cicPp.cmo: cic.cmo cicCache.cmi uriManager.cmi cicPp.cmi -cicPp.cmx: cic.cmx cicCache.cmx uriManager.cmx cicPp.cmi -cicPp.cmi: cic.cmo -cicParser.cmo: cicParser2.cmi cicParser3.cmi pxpUriResolver.cmo \ - uriManager.cmi cicParser.cmi -cicParser.cmx: cicParser2.cmx cicParser3.cmx pxpUriResolver.cmx \ - uriManager.cmx cicParser.cmi -cicParser.cmi: cic.cmo uriManager.cmi -cicParser2.cmo: cic.cmo cicParser3.cmi uriManager.cmi cicParser2.cmi -cicParser2.cmx: cic.cmx cicParser3.cmx uriManager.cmx cicParser2.cmi -cicParser2.cmi: cic.cmo cicParser3.cmi -cicParser3.cmo: cic.cmo uriManager.cmi cicParser3.cmi -cicParser3.cmx: cic.cmx uriManager.cmx cicParser3.cmi -cicParser3.cmi: cic.cmo uriManager.cmi -cic.cmo: uriManager.cmi -cic.cmx: uriManager.cmx -getter.cmo: configuration.cmo uriManager.cmi getter.cmi -getter.cmx: configuration.cmx uriManager.cmx getter.cmi -getter.cmi: uriManager.cmi -cicReduction.cmo: cic.cmo cicCache.cmi cicPp.cmi cicSubstitution.cmi \ - uriManager.cmi cicReduction.cmi -cicReduction.cmx: cic.cmx cicCache.cmx cicPp.cmx cicSubstitution.cmx \ - uriManager.cmx cicReduction.cmi -cicReduction.cmi: cic.cmo -cicTypeChecker.cmo: cic.cmo cicCache.cmi cicPp.cmi cicReduction.cmi \ - cicSubstitution.cmi uriManager.cmi cicTypeChecker.cmi -cicTypeChecker.cmx: cic.cmx cicCache.cmx cicPp.cmx cicReduction.cmx \ - cicSubstitution.cmx uriManager.cmx cicTypeChecker.cmi -cicTypeChecker.cmi: uriManager.cmi -reduction.cmo: cic.cmo cicCache.cmi cicPp.cmi cicReduction.cmi \ - cicTypeChecker.cmi configuration.cmo getter.cmi uriManager.cmi -reduction.cmx: cic.cmx cicCache.cmx cicPp.cmx cicReduction.cmx \ - cicTypeChecker.cmx configuration.cmx getter.cmx uriManager.cmx -theoryParser.cmo: pxpUriResolver.cmo theoryParser2.cmo -theoryParser.cmx: pxpUriResolver.cmx theoryParser2.cmx -theoryParser2.cmo: theory.cmo -theoryParser2.cmx: theory.cmx -theoryTypeChecker.cmo: cicCache.cmi cicTypeChecker.cmi theory.cmo \ - theoryCache.cmo uriManager.cmi -theoryTypeChecker.cmx: cicCache.cmx cicTypeChecker.cmx theory.cmx \ - theoryCache.cmx uriManager.cmx -cicCooking.cmo: cic.cmo cicCache.cmi uriManager.cmi cicCooking.cmi -cicCooking.cmx: cic.cmx cicCache.cmx uriManager.cmx cicCooking.cmi -cicCooking.cmi: cic.cmo uriManager.cmi -cicFindParameters.cmo: cic.cmo cic2Xml.cmo cicCache.cmi configuration.cmo \ - uriManager.cmi xml.cmi -cicFindParameters.cmx: cic.cmx cic2Xml.cmx cicCache.cmx configuration.cmx \ - uriManager.cmx xml.cmx -theoryCache.cmo: getter.cmi theoryParser.cmo -theoryCache.cmx: getter.cmx theoryParser.cmx -fix_params.cmo: cicFindParameters.cmo configuration.cmo deannotate.cmo \ - getter.cmi uriManager.cmi -fix_params.cmx: cicFindParameters.cmx configuration.cmx deannotate.cmx \ - getter.cmx uriManager.cmx -cic2Xml.cmo: cic.cmo uriManager.cmi xml.cmi -cic2Xml.cmx: cic.cmx uriManager.cmx xml.cmx -xml.cmo: xml.cmi -xml.cmx: xml.cmi -uriManager.cmo: uriManager.cmi -uriManager.cmx: uriManager.cmi -cicSubstitution.cmo: cic.cmo cicSubstitution.cmi -cicSubstitution.cmx: cic.cmx cicSubstitution.cmi -cicSubstitution.cmi: cic.cmo uriManager.cmi -mmlinterface.cmo: annotation2Xml.cmo cicAnnotationHinter.cmo cicCache.cmi \ - cicTypeChecker.cmi cicXPath.cmo configuration.cmo getter.cmi \ - theoryTypeChecker.cmo uriManager.cmi xml.cmi xsltProcessor.cmo -mmlinterface.cmx: annotation2Xml.cmx cicAnnotationHinter.cmx cicCache.cmx \ - cicTypeChecker.cmx cicXPath.cmx configuration.cmx getter.cmx \ - theoryTypeChecker.cmx uriManager.cmx xml.cmx xsltProcessor.cmx -xsltProcessor.cmo: configuration.cmo uriManager.cmi -xsltProcessor.cmx: configuration.cmx uriManager.cmx -deannotate.cmo: cic.cmo -deannotate.cmx: cic.cmx -cicXPath.cmo: cic.cmo -cicXPath.cmx: cic.cmx -pxpUriResolver.cmo: configuration.cmo -pxpUriResolver.cmx: configuration.cmx -annotationParser.cmo: annotationParser2.cmo pxpUriResolver.cmo -annotationParser.cmx: annotationParser2.cmx pxpUriResolver.cmx -annotationParser2.cmo: cic.cmo -annotationParser2.cmx: cic.cmx -annotation2Xml.cmo: cic.cmo uriManager.cmi xml.cmi -annotation2Xml.cmx: cic.cmx uriManager.cmx xml.cmx -cicAnnotationHinter.cmo: cic.cmo -cicAnnotationHinter.cmx: cic.cmx diff --git a/helm/interface/AUTHORS b/helm/interface/AUTHORS deleted file mode 100644 index 153b3df9c..000000000 --- a/helm/interface/AUTHORS +++ /dev/null @@ -1,3 +0,0 @@ -Andrea Asperti -Luca Padovani -Claudio Sacerdoti Coen diff --git a/helm/interface/COPYING b/helm/interface/COPYING deleted file mode 100644 index d60c31a97..000000000 --- a/helm/interface/COPYING +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 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. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, 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 software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, 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 redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -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 give any other recipients of the Program a copy of this License -along with the Program. - -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 Program or any portion -of it, thus forming a work based on the Program, 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) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -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 Program, 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 Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) 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; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, 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 executable. 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. - -If distribution of executable or 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 counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program 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. - - 5. 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 Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program 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. - - 7. 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 Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program 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 Program. - -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. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program 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. - - 9. The Free Software Foundation may publish revised and/or new versions -of the 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 Program -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 Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, 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 - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "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 PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. 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 PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. 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. - - - Copyright (C) - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/helm/interface/ChangeLog b/helm/interface/ChangeLog deleted file mode 100644 index 20c36b475..000000000 --- a/helm/interface/ChangeLog +++ /dev/null @@ -1 +0,0 @@ -28/12/2000: First alpha release diff --git a/helm/interface/Makefile.in b/helm/interface/Makefile.in deleted file mode 100644 index 1fe157016..000000000 --- a/helm/interface/Makefile.in +++ /dev/null @@ -1,204 +0,0 @@ -OCAML_ROOT = @OCAML_ROOT@ -BIN_DIR = @BIN_DIR@ -LABLGTK_DIR = @LABLGTK_LIB_DIR@ -LABLGTKMATHVIEW_DIR = @LABLGTKMATHVIEW_LIB_DIR@ -MINIDOM_DIR = @MLMINIDOM_LIB_DIR@ - -PXP_DIR = $(OCAML_ROOT)/site-lib/pxp -NETSTRING_DIR = $(OCAML_ROOT)/site-lib/netstring -XSTR_DIR = $(OCAML_ROOT)/site-lib/xstr -NETCLIENT_DIR = $(OCAML_ROOT)/site-lib/netclient - -#OCAMLC = ocamlc -I $(LABLGTK_DIR) -I $(LABLGTKMATHVIEW_DIR) -I $(PXP_DIR) -I $(NETSTRING_DIR) -I $(MINIDOM_DIR) -I mlmathview -#OCAMLOPT = ocamlopt -I $(LABLGTK_DIR) -I $(LABLGTKMATHVIEW_DIR) -I mlgtk_devel -I $(PXP_DIR) -I $(NETSTRING_DIR) -I $(MINIDOM_DIR) -I mlmathview -OCAMLC = ocamlc -I $(LABLGTK_DIR) -I $(LABLGTKMATHVIEW_DIR) -I $(PXP_DIR) -I $(NETSTRING_DIR) -I $(MINIDOM_DIR) -I $(XSTR_DIR) -I $(NETCLIENT_DIR) -OCAMLOPT = ocamlopt -I $(LABLGTK_DIR) -I $(LABLGTKMATHVIEW_DIR) -I $(PXP_DIR) -I $(NETSTRING_DIR) -I $(MINIDOM_DIR) -I $(XSTR_DIR) -I $(NETCLIENT_DIR) -OCAMLDEP = ocamldep - -all: experiment reduction fix_params mmlinterface -opt: experiment.opt reduction.opt fix_params.opt mmlinterface.opt - -PXPLIBS = netstring.cma netmappings_iso.cmo netmappings_other.cmo \ - pxp_types.cma \ - pxp_lex_iso88591.cma pxp_lex_utf8.cma pxp_engine.cma \ - pxp_utf8.cmo - -PXPLIBSOPT = netstring.cmxa netmappings_iso.cmx netmappings_other.cmx \ - pxp_types.cmxa \ - pxp_lex_iso88591.cmxa pxp_lex_utf8.cmxa pxp_engine.cmxa \ - pxp_utf8.cmx - -XSTRLIBS = xstr.cma - -XSTRLIBSOPT = xstr.cmxa - -NETCLIENTLIBS = netclient.cma - -NETCLIENTLIBSOPT = netclient.cmxa - -DEPOBJS = experiment.ml cicCache.ml cicCache.mli cicPp.ml cicPp.mli \ - cicParser.ml cicParser.mli cicParser2.ml cicParser2.mli \ - cicParser3.ml cicParser3.mli cic.ml clientHTTP.ml getter.ml getter.mli \ - gtkInterface.ml cicReduction.ml cicReduction.mli cicTypeChecker.ml \ - cicTypeChecker.mli reduction.ml tgtkInterface.ml theory.ml \ - theoryParser.ml theoryParser2.ml theoryPp.ml theoryTypeChecker.ml \ - cicCooking.ml cicCooking.mli cicFindParameters.ml theoryCache.ml \ - fix_params.ml cic2Xml.ml xml.ml uriManager.ml uriManager.mli \ - cicSubstitution.ml cicSubstitution.mli \ - mmlinterface.ml configuration.ml styleConfiguration.ml \ - xsltProcessorHTTP.ml xsltProcessor.ml deannotate.ml cicXPath.ml pxpUriResolver.ml \ - annotationParser.ml annotationParser2.ml annotation2Xml.ml \ - cicAnnotationHinter.ml - -MMLINTERFACEOBJS = configuration.cmo uriManager.cmo clientHTTP.cmo getter.cmo cic.cmo \ - pxpUriResolver.cmo styleConfiguration.cmo \ - cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ - cicSubstitution.cmo annotationParser2.cmo \ - annotationParser.cmo cicCache.cmo cicCooking.cmo cicPp.cmo \ - cicReduction.cmo cicTypeChecker.cmo \ - xml.cmo \ - xsltProcessorHTTP.cmo xsltProcessor.cmo cic2Xml.cmo annotation2Xml.cmo \ - cicXPath.cmo theory.cmo theoryParser2.cmo theoryParser.cmo \ - theoryCache.cmo theoryTypeChecker.cmo \ - cicAnnotationHinter.cmo mmlinterface.cmo - -MMLINTERFACEOPTOBJS = configuration.cmx uriManager.cmx clientHTTP.cmx getter.cmx cic.cmx \ - pxpUriResolver.cmx styleConfiguration.cmx \ - cicParser3.cmx cicParser2.cmx cicParser.cmx \ - deannotate.cmx cicSubstitution.cmx annotationParser2.cmx \ - annotationParser.cmx cicCache.cmx \ - cicCooking.cmx cicPp.cmx cicReduction.cmx \ - cicTypeChecker.cmx \ - xml.cmx xsltProcessorHTTP.cmx xsltProcessor.cmx \ - cic2Xml.cmx annotation2Xml.cmx cicXPath.cmx \ - theory.cmx theoryParser2.cmx theoryParser.cmx \ - theoryCache.cmx theoryTypeChecker.cmx \ - cicAnnotationHinter.cmx mmlinterface.cmx - -FIX_PARAMSOBJS = configuration.cmo uriManager.cmo clientHTTP.cmo getter.cmo cic.cmo \ - pxpUriResolver.cmo styleConfiguration.cmo \ - cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ - cicSubstitution.cmo annotationParser2.cmo \ - annotationParser.cmo cicCache.cmo cicPp.cmo xml.cmo \ - cic2Xml.cmo cicFindParameters.cmo fix_params.cmo - -FIX_PARAMSOPTOBJS = configuration.cmx uriManager.cmx clientHTTP.cmx getter.cmx cic.cmx \ - pxpUriResolver.cmx styleConfiguration.cmx \ - cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \ - cicSubstitution.cmx annotationParser2.cmx \ - annotationParser.cmx cicCache.cmx cicPp.cmx xml.cmx \ - cic2Xml.cmx cicFindParameters.cmx fix_params.cmx - -REDUCTIONOBJS = configuration.cmo uriManager.cmo clientHTTP.cmo getter.cmo cic.cmo \ - pxpUriResolver.cmo styleConfiguration.cmo \ - cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ - cicSubstitution.cmo annotationParser2.cmo annotationParser.cmo \ - cicCache.cmo cicPp.cmo cicCooking.cmo \ - cicReduction.cmo cicTypeChecker.cmo reduction.cmo - -REDUCTIONOPTOBJS = configuration.cmx uriManager.cmx clientHTTP.cmx getter.cmx cic.cmx \ - pxpUriResolver.cmx styleConfiguration.cmx \ - cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \ - cicSubstitution.cmx annotationParser2.cmx \ - annotationParser.cmx cicCache.cmx cicPp.cmx cicCooking.cmx \ - cicReduction.cmx cicTypeChecker.cmx reduction.cmx - -EXPERIMENTOBJS = configuration.cmo uriManager.cmo clientHTTP.cmo getter.cmo cic.cmo \ - pxpUriResolver.cmo styleConfiguration.cmo \ - cicParser3.cmo cicParser2.cmo cicParser.cmo deannotate.cmo \ - cicSubstitution.cmo annotationParser2.cmo \ - annotationParser.cmo cicCache.cmo cicPp.cmo experiment.cmo - -EXPERIMENTOPTOBJS = configuration.cmx uriManager.cmx clientHTTP.cmx getter.cmx cic.cmx \ - pxpUriResolver.cmx styleConfiguration.cmx \ - cicParser3.cmx cicParser2.cmx cicParser.cmx deannotate.cmx \ - cicSubstitution.cmx annotationParser2.cmx \ - annotationParser.cmx cicCache.cmx cicPp.cmx experiment.cmx - -depend: - $(OCAMLDEP) $(DEPOBJS) > .depend - -mmlinterface: $(MMLINTERFACEOBJS) - $(OCAMLC) -custom -o mmlinterface str.cma unix.cma $(PXPLIBS) $(XSTRLIBS) $(NETCLIENTLIBS) dbm.cma \ - lablgtk.cma gtkInit.cmo \ - $(MINIDOM_DIR)/minidom.cmo \ - $(MINIDOM_DIR)/ominidom.cmo \ - $(LABLGTKMATHVIEW_DIR)/lablgtkmathview.cma \ - $(MMLINTERFACEOBJS) \ - -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ - -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ - -lunix `gtkmathview-config --libs` \ - $(LABLGTKMATHVIEW_DIR)/ml_gtk_mathview.o \ - $(MINIDOM_DIR)/ml_minidom.o" \ - -cclib -lmldbm -cclib -lndbm - -mmlinterface.opt: $(MMLINTERFACEOPTOBJS) - $(OCAMLOPT) -o mmlinterface.opt str.cmxa unix.cmxa $(PXPLIBSOPT) $(XSTRLIBSOPT) $(NETCLIENTLIBSOPT) unix.cmxa \ - dbm.cmxa lablgtk.cmxa gtkInit.cmx \ - $(MINIDOM_DIR)/minidom.cmx \ - $(MINIDOM_DIR)/ominidom.cmx \ - $(LABLGTKMATHVIEW_DIR)/lablgtkmathview.cmxa \ - $(MMLINTERFACEOPTOBJS) \ - -cclib "-lstr -L/usr/lib -L/usr/X11R6/lib -lgtk -lgdk \ - -rdynamic -lgmodule -lglib -ldl -lXi -lXext -lX11 -lm \ - -lunix `gtkmathview-config --libs` \ - $(LABLGTKMATHVIEW_DIR)/ml_gtk_mathview.o \ - $(MINIDOM_DIR)/ml_minidom.o" \ - -cclib -lmldbm -cclib -lndbm - -fix_params: $(FIX_PARAMSOBJS) - $(OCAMLC) -custom -o fix_params str.cma unix.cma $(PXPLIBS) $(XSTRLIBS) $(NETCLIENTLIBS) dbm.cma \ - $(FIX_PARAMSOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm - -fix_params.opt: $(FIX_PARAMSOPTOBJS) - $(OCAMLOPT) -o fix_params.opt str.cmxa unix.cmxa $(PXPLIBSOPT) $(XSTRLIBSOPT) $(NETCLIENTLIBSOPT) dbm.cmxa \ - $(FIX_PARAMSOPTOBJS) -cclib -lstr -cclib -lmldbm \ - -cclib -lndbm - -reduction: $(REDUCTIONOBJS) - $(OCAMLC) -custom -o reduction str.cma unix.cma $(PXPLIBS) $(XSTRLIBS) $(NETCLIENTLIBS) dbm.cma \ - $(REDUCTIONOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm - -reduction.opt: $(REDUCTIONOPTOBJS) - $(OCAMLOPT) -o reduction.opt str.cmxa unix.cmxa $(PXPLIBSOPT) $(XSTRLIBSOPT) $(NETCLIENTLIBSOPT) dbm.cmxa \ - $(REDUCTIONOPTOBJS) -cclib -lstr -cclib -lmldbm \ - -cclib -lndbm - -experiment: $(EXPERIMENTOBJS) - $(OCAMLC) -custom -o experiment str.cma unix.cma $(PXPLIBS) $(XSTRLIBS) $(NETCLIENTLIBS) dbm.cma \ - $(EXPERIMENTOBJS) -cclib -lstr -cclib -lmldbm -cclib -lndbm - -experiment.opt: $(EXPERIMENTOPTOBJS) - $(OCAMLOPT) -o experiment.opt str.cmxa unix.cmxa $(PXPLIBSOPT) $(XSTRLIBSOPT) $(NETCLIENTLIBSOPT) dbm.cmxa \ - $(EXPERIMENTOPTOBJS) -cclib -lstr -cclib -lmldbm \ - -cclib -lndbm - -.SUFFIXES: .ml .mli .cmo .cmi .cmx -.ml.cmo: - $(OCAMLC) -c $< -.mli.cmi: - $(OCAMLC) -c $< -.ml.cmx: - $(OCAMLOPT) -c $< - -clean: - rm -f *.cm[iox] *.o experiment experiment.opt reduction \ - reduction.opt fix_params fix_params.opt mmlinterface \ - mmlinterface.opt mmlinterface2 mmlinterface2.opt - -install: - cp mmlinterface mmlinterface.opt helm_wget $(BIN_DIR) - -distclean: clean - rm -f Makefile configuration.ml helm_wget configure config.log \ - config.cache config.status - -dist: clean - rm -rf ../@PACKAGE@-@VERSION@ - mkdir ../@PACKAGE@-@VERSION@ - cp -r * .depend ../@PACKAGE@-@VERSION@ - (cd .. ; tar cvfz @PACKAGE@-@VERSION@.tar.gz @PACKAGE@-@VERSION@ ; rm -rf @PACKAGE@-@VERSION@) - -.PHONY: install distclean clean - -include .depend diff --git a/helm/interface/NEWS b/helm/interface/NEWS deleted file mode 100644 index 20c36b475..000000000 --- a/helm/interface/NEWS +++ /dev/null @@ -1 +0,0 @@ -28/12/2000: First alpha release diff --git a/helm/interface/README b/helm/interface/README deleted file mode 100644 index 63d2c2ac8..000000000 --- a/helm/interface/README +++ /dev/null @@ -1,8 +0,0 @@ -NOTE: This is the first alpha release of project HELM. - -HELM (Hypertextual Electronic Library of Mathematics) is a project aimed -at the creation of tools for the development and exploitation of a huge -distributed library of formal mathematical knowledge. This package holds -a gtk interface to the library. - -For more information see http://www.cs.unibo.it/helm diff --git a/helm/interface/TEMPI b/helm/interface/TEMPI deleted file mode 100644 index dc2bc8522..000000000 --- a/helm/interface/TEMPI +++ /dev/null @@ -1,214 +0,0 @@ -prima di UriManager.ml: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m50.266s - user 0m44.160s - sys 0m0.700s - -dopo UriManager.ml, ma prima di passare da = a ==: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m51.388s - user 0m45.430s - sys 0m0.530s - -dopo UriManager.ml e popo il passaggio (parziale?) da = a ==: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m50.767s - user 0m44.750s - sys 0m0.510s - -dopo il passaggio alla cache che usa ancora =: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m50.646s - user 0m44.680s - sys 0m0.530s - -dopo il passaggio alla cache con utilizzo di ==: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m50.861s - user 0m45.030s - sys 0m0.500s - -con funzione di hashing costante ;-( - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m51.442s - user 0m45.440s - sys 0m0.530s - -con implementazione isomorfa all'albero delle uri: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m54.081s - user 0m47.590s - sys 0m0.780s - -con implementazione con doppio RB-albero: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m52.504s - user 0m46.120s - sys 0m0.720s - -con implementazione semplice, gestite anche le uri delle var: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m51.850s - user 0m46.060s - sys 0m0.530s - -con implementazione con doppio RB-albero, gestite anche le uri delle var: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m51.495s - user 0m45.660s - sys 0m0.540s - -========================================================= - -con implementazione con doppio RB-albero, gestite anche le uri delle var -e spostata nell'uri-manager is_prefix: - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m50.465s - user 0m45.710s - sys 0m0.590s - -con implementazione semplice (e tutto il resto): - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m49.710s - user 0m43.850s - sys 0m0.500s - -con implementazione banale (e tutto il resto): - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m49.289s - user 0m44.840s - sys 0m0.570s - -con implementazione banale SOLO PARSING ;-) - - [ABCI]* (terza passata, uguale alla seconda): - - real 0m48.395s - user 0m42.830s - sys 0m0.850s - -========================================================= - -con implementazione con doppio RB-albero, gestite anche le uri delle var -e spostata nell'uri-manager is_prefix: - - REAL (prima passata, dopo un sync): - - real 10m58.033s - user 10m37.690s - sys 0m2.570s - -con implementazione semplice (e tutto il resto): - - REAL (prima passata, dopo un sync): - - real 10m31.035s - user 10m9.350s - sys 0m3.230s - -con implementazione banale (e tutto il resto): - - REAL (prima passata, dopo un sync): - - real 11m4.026s - user 10m43.930s - sys 0m3.070s - -================================================= - -con implementazione banale, SOLO PARSING di tutto: - - real 6m54.336s - user 6m13.850s - sys 0m6.580s - -con implementazione banale, anche typechecking di tutto: - - real 20m17.739s - user 19m14.740s - sys 0m8.550s - -con implementazione semplice, anche typechecking di tutto: - - real 19m36.079s - user 18m36.480s - sys 0m7.760s - -con implementazione con doppio RB-albero, anche typechecking di tutto: - - real 17m30.423s - user 16m30.840s - sys 0m6.170s - -*************************************************************************** - APPLICATA EURISTICA -*************************************************************************** - -con implementazione con doppio RB-albero, anche typechecking di tutto -(universita') ????????: - -real 5m37.805s -user 5m1.640s -sys 0m5.010s - -tutto (ma a casa): - -real 7m36.663s -user 6m52.220s -sys 0m5.860s - - -solo REAL: - -real 2m52.860s -user 2m41.050s -sys 0m2.820s - -========================================================================== - -tutto (ma a casa) dopo eliminazione buri: - -real 7m52.773s -user 6m52.110s -sys 0m7.130s - -"solo parsing" di tutto dopo eliminazione buri: - -real 7m8.379s -user 6m15.250s -sys 0m6.700s - -=========================================================================== - -TUTTO ALL'UNIVERSITA' CON EURISTICA MA SENZA UNIVERSI: - -real 5m47.920s -user 5m14.600s -sys 0m5.010s - diff --git a/helm/interface/WGET b/helm/interface/WGET deleted file mode 100644 index f1cca6c37..000000000 --- a/helm/interface/WGET +++ /dev/null @@ -1,3 +0,0 @@ --P directory di destinazione --q no output (quiet mode) --c continue retrieving (no uri.1, uri.2, ...) diff --git a/helm/interface/annotation2Xml.ml b/helm/interface/annotation2Xml.ml deleted file mode 100644 index b75f2bc29..000000000 --- a/helm/interface/annotation2Xml.ml +++ /dev/null @@ -1,228 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(*CSC codice cut & paste da cicPp e xmlcommand *) - -exception ImpossiblePossible;; -exception NotImplemented;; -exception BinderNotSpecified;; - -let dtdname = "http://localhost:8081/getdtd?url=annotations.dtd";; - -(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *) -let print_term = - let rec aux = - let module C = Cic in - let module X = Xml in - let module U = UriManager in - function - C.ARel (id,ann,_,_) -> - (match !ann with - None -> [<>] - | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) - | C.AVar (id,ann,_) -> - (match !ann with - None -> [<>] - | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) - | C.AMeta (id,ann,_) -> - (match !ann with - None -> [<>] - | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) - | C.ASort (id,ann,_) -> - (match !ann with - None -> [<>] - | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) - | C.AImplicit _ -> raise NotImplemented - | C.AProd (id,ann,_,s,t) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - aux s ; - aux t - >] - | C.ACast (id,ann,v,t) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - aux v ; - aux t - >] - | C.ALambda (id,ann,_,s,t) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - aux s ; - aux t - >] - | C.ALetIn (id,ann,_,s,t) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - aux s ; - aux t - >] - | C.AAppl (id,ann,li) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>] - >] - | C.AConst (id,ann,_,_) -> - (match !ann with - None -> [<>] - | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) - | C.AAbst (id,ann,_) -> raise NotImplemented - | C.AMutInd (id,ann,_,_,_) -> - (match !ann with - None -> [<>] - | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) - | C.AMutConstruct (id,ann,_,_,_,_) -> - (match !ann with - None -> [<>] - | Some ann -> (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) - | C.AMutCase (id,ann,_,_,_,ty,te,patterns) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - aux ty ; - aux te ; - List.fold_right - (fun x i -> [< aux x ; i>]) - patterns [<>] - >] - | C.AFix (id, ann, _, funs) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - List.fold_right - (fun (_,_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>] - >] - | C.ACoFix (id, ann,no,funs) -> - [< (match !ann with - None -> [<>] - | Some ann -> - (X.xml_nempty "Annotation" ["of", id] (X.xml_cdata ann)) - ) ; - List.fold_right - (fun (_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>] - >] - in - aux -;; - -let print_mutual_inductive_type (_,_,arity,constructors) = - [< print_term arity ; - List.fold_right - (fun (name,ty,_) i -> [< print_term ty ; i >]) constructors [<>] - >] -;; - -let target_uri_of_annotation_uri uri = - Str.replace_first (Str.regexp "\.ann$") "" (UriManager.string_of_uri uri) -;; - -let pp_annotation obj curi = - let module C = Cic in - let module X = Xml in - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n\n") ; - X.xml_nempty "Annotations" ["of", target_uri_of_annotation_uri curi] - begin - match obj with - C.ADefinition (xid, ann, _, te, ty, _) -> - [< (match !ann with - None -> [<>] - | Some ann -> - X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) - ) ; - print_term te ; - print_term ty - >] - | C.AAxiom (xid, ann, _, ty, _) -> - [< (match !ann with - None -> [<>] - | Some ann -> - X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) - ) ; - print_term ty - >] - | C.AVariable (xid, ann, _, bo, ty) -> - [< (match !ann with - None -> [<>] - | Some ann -> - X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) - ) ; - (match bo with - None -> [<>] - | Some bo -> print_term bo - ) ; - print_term ty - >] - | C.ACurrentProof (xid, ann, _, conjs, bo, ty) -> - [< (match !ann with - None -> [<>] - | Some ann -> - X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) - ) ; - List.fold_right - (fun (_,t) i -> [< print_term t ; i >]) - conjs [<>] ; - print_term bo ; - print_term ty - >] - | C.AInductiveDefinition (xid, ann, tys, params, paramsno) -> - [< (match !ann with - None -> [<>] - | Some ann -> - X.xml_nempty "Annotation" ["of", xid] (X.xml_cdata ann) - ) ; - List.fold_right - (fun x i -> [< print_mutual_inductive_type x ; i >]) - tys [< >] - >] - end - >] -;; diff --git a/helm/interface/annotationParser.ml b/helm/interface/annotationParser.ml deleted file mode 100644 index ffd76c922..000000000 --- a/helm/interface/annotationParser.ml +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception Warnings;; - -class warner = - object - method warn w = - print_endline ("WARNING: " ^ w) ; - (raise Warnings : unit) - end -;; - -exception EmptyUri;; - -let annotate filename ids_to_targets = - let module Y = Pxp_yacc in - try - let d = - let config = {Y.default_config with Y.warner = new warner} in - Y.parse_document_entity config -(*PXP (Y.ExtID (Pxp_types.System filename, - new Pxp_reader.resolve_as_file ~url_of_id ())) -*) (PxpUriResolver.from_file filename) - Y.default_spec - - in - AnnotationParser2.annotate ids_to_targets d#root - with - e -> - print_endline (Pxp_types.string_of_exn e) ; - raise e -;; diff --git a/helm/interface/annotationParser2.ml b/helm/interface/annotationParser2.ml deleted file mode 100644 index 58edc4ca8..000000000 --- a/helm/interface/annotationParser2.ml +++ /dev/null @@ -1,129 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception IllFormedXml of int;; - -(* Utility functions that transform a Pxp attribute into something useful *) - -let string_of_attr a = - let module T = Pxp_types in - match a with - T.Value s -> s - | _ -> raise (IllFormedXml 0) -;; - -exception DontKnowWhatToDo;; - -let rec string_of_annotations n = - let module D = Pxp_document in - let module T = Pxp_types in - match n#node_type with - D.T_element s -> - "<" ^ s ^ - List.fold_right - (fun att i -> - match n#attribute att with - T.Value s -> " " ^ att ^ "=\"" ^ s ^ "\"" ^ i - | T.Implied_value -> i - | T.Valuelist l -> " " ^ att ^ "=\"" ^ String.concat " " l ^ "\"" ^ i - ) (n#attribute_names) "" ^ - (match n#sub_nodes with - [] -> "/>" - | l -> - ">" ^ - String.concat "" (List.map string_of_annotations l) ^ - "" - ) - | D.T_data -> n#data - | _ -> raise DontKnowWhatToDo -;; - -let get_annotation n = - String.concat "" (List.map string_of_annotations (n#sub_nodes)) -;; - -let annotate_object ann obj = - let module C = Cic in - let rann = - match obj with - C.ADefinition (_, rann, _, _, _, _) -> rann - | C.AAxiom (_, rann, _, _, _) -> rann - | C.AVariable (_, rann, _, _, _) -> rann - | C.ACurrentProof (_, rann, _, _, _, _) -> rann - | C.AInductiveDefinition (_, rann, _, _, _) -> rann - in - rann := Some ann -;; - -let annotate_term ann term = - let module C = Cic in - let rann = - match term with - C.ARel (_, rann, _, _) -> rann - | C.AVar (_, rann, _) -> rann - | C.AMeta (_, rann, _) -> rann - | C.ASort (_, rann, _) -> rann - | C.AImplicit (_, rann) -> rann - | C.ACast (_, rann, _, _) -> rann - | C.AProd (_, rann, _, _, _) -> rann - | C.ALambda (_, rann, _, _, _) -> rann - | C.ALetIn (_, rann, _, _, _) -> rann - | C.AAppl (_, rann, _) -> rann - | C.AConst (_, rann, _, _) -> rann - | C.AAbst (_, rann, _) -> rann - | C.AMutInd (_, rann, _, _, _) -> rann - | C.AMutConstruct (_, rann, _, _, _, _) -> rann - | C.AMutCase (_, rann, _, _, _, _, _, _) -> rann - | C.AFix (_, rann, _, _) -> rann - | C.ACoFix (_, rann, _, _) -> rann - in - rann := Some ann -;; - -let annotate ids_to_targets n = - let module D = Pxp_document in - let module C = Cic in - let annotate_elem n = - let ntype = n # node_type in - match ntype with - D.T_element "Annotation" -> - let of_uri = string_of_attr (n # attribute "of") in - begin - try - match Hashtbl.find ids_to_targets of_uri with - C.Object o -> annotate_object (get_annotation n) o - | C.Term t -> annotate_term (get_annotation n) t - with - Not_found -> assert false - end - | D.T_element _ | D.T_data -> - raise (IllFormedXml 1) - | _ -> raise DontKnowWhatToDo - in - match n # node_type with - D.T_element "Annotations" -> - List.iter annotate_elem (n # sub_nodes) - | _ -> raise (IllFormedXml 2) -;; diff --git a/helm/interface/cic.ml b/helm/interface/cic.ml deleted file mode 100644 index 8c08b0075..000000000 --- a/helm/interface/cic.ml +++ /dev/null @@ -1,162 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 14/06/2000 *) -(* *) -(* This module defines the internal representation of the objects (variables, *) -(* blocks of (co)inductive definitions and constants) and the terms of cic *) -(* *) -(******************************************************************************) - -(* STUFF TO MANAGE IDENTIFIERS *) -type id = string (* the abstract type of the (annotated) node identifiers *) -type anntarget = - Object of annobj - | Term of annterm - -(* INTERNAL REPRESENTATION OF CIC OBJECTS AND TERMS *) -and sort = - Prop - | Set - | Type -and name = - Name of string - | Anonimous -and term = - Rel of int (* DeBrujin index *) - | Var of UriManager.uri (* uri *) - | Meta of int (* numeric id *) - | Sort of sort (* sort *) - | Implicit (* *) - | Cast of term * term (* value, type *) - | Prod of name * term * term (* binder, source, target *) - | Lambda of name * term * term (* binder, source, target *) - | LetIn of name * term * term (* binder, term, target *) - | Appl of term list (* arguments *) - | Const of UriManager.uri * int (* uri, number of cookings*) - | Abst of UriManager.uri (* uri *) - | MutInd of UriManager.uri * int * int (* uri, cookingsno, typeno*) - | MutConstruct of UriManager.uri * int * (* uri, cookingsno, *) - int * int (* typeno, consno *) - (*CSC: serve cookingsno?*) - | MutCase of UriManager.uri * int * (* ind. uri, cookingsno, *) - int * (* ind. typeno, *) - term * term * (* outtype, ind. term *) - term list (* patterns *) - | Fix of int * inductiveFun list (* funno, functions *) - | CoFix of int * coInductiveFun list (* funno, functions *) -and obj = - Definition of string * term * term * (* id, value, type, *) - (int * UriManager.uri list) list (* parameters *) - | Axiom of string * term * - (int * UriManager.uri list) list (* id, type, parameters *) - | Variable of string * term option * term (* name, body, type *) - | CurrentProof of string * (int * term) list * (* name, conjectures, *) - term * term (* value, type *) - | InductiveDefinition of inductiveType list * (* inductive types, *) - (int * UriManager.uri list) list * int (* parameters, n ind. pars *) -and inductiveType = - string * bool * term * (* typename, inductive, arity *) - constructor list (* constructors *) -and constructor = - string * term * bool list option ref (* id, type, really recursive *) -and inductiveFun = - string * int * term * term (* name, ind. index, type, body *) -and coInductiveFun = - string * term * term (* name, type, body *) - -and annterm = - ARel of id * annotation option ref * - int * string option (* DeBrujin index, binder *) - | AVar of id * annotation option ref * - UriManager.uri (* uri *) - | AMeta of id * annotation option ref * int (* numeric id *) - | ASort of id * annotation option ref * sort (* sort *) - | AImplicit of id * annotation option ref (* *) - | ACast of id * annotation option ref * - annterm * annterm (* value, type *) - | AProd of id * annotation option ref * - name * annterm * annterm (* binder, source, target *) - | ALambda of id * annotation option ref * - name * annterm * annterm (* binder, source, target *) - | ALetIn of id * annotation option ref * - name * annterm * annterm (* binder, term, target *) - | AAppl of id * annotation option ref * - annterm list (* arguments *) - | AConst of id * annotation option ref * - UriManager.uri * int (* uri, number of cookings*) - | AAbst of id * annotation option ref * - UriManager.uri (* uri *) - | AMutInd of id * annotation option ref * - UriManager.uri * int * int (* uri, cookingsno, typeno*) - | AMutConstruct of id * annotation option ref * - UriManager.uri * int * (* uri, cookingsno, *) - int * int (* typeno, consno *) - (*CSC: serve cookingsno?*) - | AMutCase of id * annotation option ref * - UriManager.uri * int * (* ind. uri, cookingsno *) - int * (* ind. typeno, *) - annterm * annterm * (* outtype, ind. term *) - annterm list (* patterns *) - | AFix of id * annotation option ref * - int * anninductiveFun list (* funno, functions *) - | ACoFix of id * annotation option ref * - int * anncoInductiveFun list (* funno, functions *) -and annobj = - ADefinition of id * annotation option ref * - string * (* id, *) - annterm * annterm * (* value, type, *) - (int * UriManager.uri list) list exactness (* parameters *) - | AAxiom of id * annotation option ref * - string * annterm * (* id, type *) - (int * UriManager.uri list) list (* parameters *) - | AVariable of id * annotation option ref * - string * annterm option * annterm (* name, body, type *) - | ACurrentProof of id * annotation option ref * - string * (int * annterm) list * (* name, conjectures, *) - annterm * annterm (* value, type *) - | AInductiveDefinition of id * - annotation option ref * anninductiveType list * (* inductive types , *) - (int * UriManager.uri list) list * int (* parameters,n ind. pars*) -and anninductiveType = - string * bool * annterm * (* typename, inductive, arity *) - annconstructor list (* constructors *) -and annconstructor = - string * annterm * bool list option ref (* id, type, really recursive *) -and anninductiveFun = - string * int * annterm * annterm (* name, ind. index, type, body *) -and anncoInductiveFun = - string * annterm * annterm (* name, type, body *) -and annotation = - string -and 'a exactness = - Possible of 'a (* an approximation to something *) - | Actual of 'a (* something *) -;; diff --git a/helm/interface/cic2Xml.ml b/helm/interface/cic2Xml.ml deleted file mode 100644 index 58f35bb6f..000000000 --- a/helm/interface/cic2Xml.ml +++ /dev/null @@ -1,255 +0,0 @@ - -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(*CSC codice cut & paste da cicPp e xmlcommand *) - -exception ImpossiblePossible;; -exception NotImplemented;; -exception BinderNotSpecified;; - -let dtdname = "http://localhost:8081/getdtd?url=cic.dtd";; - -(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *) -let print_term curi = - let rec aux = - let module C = Cic in - let module X = Xml in - let module U = UriManager in - function - C.ARel (id,_,n,Some b) -> - X.xml_empty "REL" ["value",(string_of_int n);"binder",b;"id",id] - | C.ARel _ -> raise BinderNotSpecified - | C.AVar (id,_,uri) -> - let vdepth = U.depth_of_uri uri - and cdepth = U.depth_of_uri curi in - X.xml_empty "VAR" - ["relUri",(string_of_int (cdepth - vdepth)) ^ "," ^ - (U.name_of_uri uri) ; - "id",id] - | C.AMeta (id,_,n) -> - X.xml_empty "META" ["no",(string_of_int n) ; "id",id] - | C.ASort (id,_,s) -> - let string_of_sort = - function - C.Prop -> "Prop" - | C.Set -> "Set" - | C.Type -> "Type" - in - X.xml_empty "SORT" ["value",(string_of_sort s) ; "id",id] - | C.AImplicit _ -> raise NotImplemented - | C.AProd (id,_,C.Anonimous,s,t) -> - X.xml_nempty "PROD" ["id",id] - [< X.xml_nempty "source" [] (aux s) ; - X.xml_nempty "target" [] (aux t) - >] - | C.AProd (xid,_,C.Name id,s,t) -> - X.xml_nempty "PROD" ["id",xid] - [< X.xml_nempty "source" [] (aux s) ; - X.xml_nempty "target" ["binder",id] (aux t) - >] - | C.ACast (id,_,v,t) -> - X.xml_nempty "CAST" ["id",id] - [< X.xml_nempty "term" [] (aux v) ; - X.xml_nempty "type" [] (aux t) - >] - | C.ALambda (id,_,C.Anonimous,s,t) -> - X.xml_nempty "LAMBDA" ["id",id] - [< X.xml_nempty "source" [] (aux s) ; - X.xml_nempty "target" [] (aux t) - >] - | C.ALambda (xid,_,C.Name id,s,t) -> - X.xml_nempty "LAMBDA" ["id",xid] - [< X.xml_nempty "source" [] (aux s) ; - X.xml_nempty "target" ["binder",id] (aux t) - >] - | C.ALetIn (xid,_,C.Anonimous,s,t) -> - assert false (*CSC: significa che e' sbagliato il tipo di LetIn!!!*) - | C.ALetIn (xid,_,C.Name id,s,t) -> - X.xml_nempty "LETIN" ["id",xid] - [< X.xml_nempty "term" [] (aux s) ; - X.xml_nempty "letintarget" ["binder",id] (aux t) - >] - | C.AAppl (id,_,li) -> - X.xml_nempty "APPLY" ["id",id] - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>]) - >] - | C.AConst (id,_,uri,_) -> - X.xml_empty "CONST" ["uri", (U.string_of_uri uri) ; "id",id] - | C.AAbst (id,_,uri) -> raise NotImplemented - | C.AMutInd (id,_,uri,_,i) -> - X.xml_empty "MUTIND" - ["uri", (U.string_of_uri uri) ; - "noType",(string_of_int i) ; - "id",id] - | C.AMutConstruct (id,_,uri,_,i,j) -> - X.xml_empty "MUTCONSTRUCT" - ["uri", (U.string_of_uri uri) ; - "noType",(string_of_int i) ; "noConstr",(string_of_int j) ; - "id",id] - | C.AMutCase (id,_,uri,_,typeno,ty,te,patterns) -> - X.xml_nempty "MUTCASE" - ["uriType",(U.string_of_uri uri) ; - "noType", (string_of_int typeno) ; - "id", id] - [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; - X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; - List.fold_right - (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>]) - patterns [<>] - >] - | C.AFix (id, _, no, funs) -> - X.xml_nempty "FIX" ["noFun", (string_of_int no) ; "id",id] - [< List.fold_right - (fun (fi,ai,ti,bi) i -> - [< X.xml_nempty "FixFunction" - ["name", fi; "recIndex", (string_of_int ai)] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] ; - i - >] - ) funs [<>] - >] - | C.ACoFix (id,_,no,funs) -> - X.xml_nempty "COFIX" ["noFun", (string_of_int no) ; "id",id] - [< List.fold_right - (fun (fi,ti,bi) i -> - [< X.xml_nempty "CofixFunction" ["name", fi] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] ; - i - >] - ) funs [<>] - >] - in - aux -;; - -let encode params = - List.fold_right - (fun (n,l) i -> - match l with - [] -> i - | _ -> - string_of_int n ^ ": " ^ - String.concat " " (List.map UriManager.name_of_uri l) ^ - i - ) params "" -;; - -let print_mutual_inductive_type curi (typename,inductive,arity,constructors) = - let module C = Cic in - let module X = Xml in - [< X.xml_nempty "InductiveType" - ["name",typename ; - "inductive",(string_of_bool inductive) - ] - [< X.xml_nempty "arity" [] (print_term curi arity) ; - (List.fold_right - (fun (name,ty,_) i -> - [< X.xml_nempty "Constructor" ["name",name] - (print_term curi ty) ; - i - >]) - constructors - [<>] - ) - >] - >] -;; - -let pp obj curi = - let module C = Cic in - let module X = Xml in - match obj with - C.ADefinition (xid, _, id, te, ty, params) -> - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n\n") ; - X.xml_nempty "Definition" - (["name", id ; "id",xid] @ - match params with - C.Possible _ -> raise ImpossiblePossible - (*CSC params are kept in inverted order in the internal *) - (* representation (the order of application) *) - | C.Actual fv' -> ["params",(encode (List.rev fv'))]) - [< X.xml_nempty "body" [] (print_term curi te) ; - X.xml_nempty "type" [] (print_term curi ty) >] - >] - | C.AAxiom (xid, _, id, ty, params) -> - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n\n") ; - X.xml_nempty "Axiom" - (*CSC params are kept in inverted order in the internal *) - (* representation (the order of application) *) - ["name",id ; "params",(encode (List.rev params)) ; "id",xid] - [< X.xml_nempty "type" [] (print_term curi ty) >] - >] - | C.AVariable (xid, _, name, bo, ty) -> - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n\n") ; - X.xml_nempty "Variable" ["name",name ; "id",xid] - [< (match bo with - None -> [<>] - | Some bo -> X.xml_nempty "body" [] (print_term curi bo) - ) ; - X.xml_nempty "type" [] (print_term curi ty) - >] - >] - | C.ACurrentProof (xid, _, name, conjs, bo, ty) -> - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n\n"); - X.xml_nempty "CurrentProof" ["name",name ; "id",xid] - [< List.fold_right - (fun (j,t) i -> - [< X.xml_nempty "Conjecture" ["no",(string_of_int j)] - [< print_term curi t >] ; i >]) - conjs [<>] ; - X.xml_nempty "body" [] [< print_term curi bo >] ; - X.xml_nempty "type" [] [< print_term curi ty >] - >] - >] - | C.AInductiveDefinition (xid, _, tys, params, paramsno) -> - let names = - List.map - (fun (typename,_,_,_) -> typename) - tys - in - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n\n") ; - X.xml_nempty "InductiveDefinition" - (*CSC params are kept in inverted order in the internal *) - (* representation (the order of application) *) - ["noParams",string_of_int paramsno ; - "params",(encode (List.rev params)) ; - "id",xid] - [< List.fold_right - (fun x i -> [< print_mutual_inductive_type curi x ; i >]) - tys [< >] - >] - >] -;; diff --git a/helm/interface/cicAnnotationHinter.ml b/helm/interface/cicAnnotationHinter.ml deleted file mode 100644 index 86bcb4588..000000000 --- a/helm/interface/cicAnnotationHinter.ml +++ /dev/null @@ -1,381 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 14/06/2000 *) -(* *) -(* *) -(******************************************************************************) - -let deactivate_hints_from annotation_window n = - let annotation_hints = annotation_window#annotation_hints in - for i = n to Array.length annotation_hints - 1 do - annotation_hints.(i)#misc#hide () - done -;; - -(* CSC: orripilante *) -(* the list of the signal ids *) -let sig_ids = ref ([] : GtkSignal.id list);; - -let disconnect_hint annotation_window buttonno = - match !sig_ids with - id::ids -> - annotation_window#annotation_hints.(buttonno)#misc#disconnect id ; - sig_ids := ids - | _ -> assert false -;; - -(* link_hint annotation_window n label hint *) -(* set the label of the nth hint button of annotation_window to label *) -(* and the correspondent hint to hint *) -let link_hint annotation_window buttonno label hint = - let button = annotation_window#annotation_hints.(buttonno) in - sig_ids := - (button#connect#clicked - (fun () -> (annotation_window#annotation : GEdit.text)#insert hint) - ) :: !sig_ids ; - button#misc#show () ; - match button#children with - [labelw] -> (GMisc.label_cast labelw)#set_text label - | _ -> assert false -;; - -exception TooManyHints;; - -let link_hints annotation_window a = - if Array.length a > Array.length annotation_window#annotation_hints then - raise TooManyHints ; - for i = List.length !sig_ids - 1 downto 0 do - disconnect_hint annotation_window i - done ; - Array.iteri - (fun i (label,hint) -> link_hint annotation_window i label hint) a ; - deactivate_hints_from annotation_window (Array.length a) -;; - -let list_mapi f = - let rec aux n = - function - [] -> [] - | he::tl -> (f n he)::(aux (n + 1) tl) - in - aux 0 -;; - -let get_id annterm = - let module C = Cic in - match annterm with - C.ARel (id,_,_,_) -> id - | C.AVar (id,_,_) -> id - | C.AMeta (id,_,_) -> id - | C.ASort (id,_,_) -> id - | C.AImplicit (id,_) -> id - | C.ACast (id,_,_,_) -> id - | C.AProd (id,_,_,_,_) -> id - | C.ALambda (id,_,_,_,_) -> id - | C.ALetIn (id,_,_,_,_) -> id - | C.AAppl (id,_,_) -> id - | C.AConst (id,_,_,_) -> id - | C.AAbst (id,_,_) -> id - | C.AMutInd (id,_,_,_,_) -> id - | C.AMutConstruct (id,_,_,_,_,_)-> id - | C.AMutCase (id,_,_,_,_,_,_,_) -> id - | C.AFix (id,_,_,_) -> id - | C.ACoFix (id,_,_,_) -> id -;; - -let create_hint_from_term annotation_window annterm = - let module C = Cic in - match annterm with - C.ARel (id,_,_,_) -> - link_hints annotation_window - [| "Binder", "" |] - | C.AVar (id,_,_) -> - link_hints annotation_window - [| "relURI???", "" |] - | C.AMeta (id,_,_) -> - link_hints annotation_window - [| "Number", "" |] - | C.ASort (id,_,_) -> - link_hints annotation_window - [| "Value", "" |] - | C.AImplicit (id,_) -> - link_hints annotation_window [| |] - | C.ACast (id,_,bo,ty) -> - let boid = get_id bo - and tyid = get_id ty in - link_hints annotation_window - [| "Body", "" ; - "Type", "" - |] - | C.AProd (id,_,_,ty,bo) -> - let boid = get_id bo - and tyid = get_id ty in - link_hints annotation_window - [| "Binder", - "" ; - "Body", "" ; - "Type", "" - |] - | C.ALambda (id,_,_,ty,bo) -> - let boid = get_id bo - and tyid = get_id ty in - link_hints annotation_window - [| "Binder", - "" ; - "Body", "" ; - "Type", "" - |] - | C.ALetIn (id,_,_,ty,bo) -> - let boid = get_id bo - and tyid = get_id ty in - link_hints annotation_window - [| "Binder", - "" ; - "Term", "" ; - "Target", "" - |] - | C.AAppl (id,_,args) -> - let argsid = - Array.mapi - (fun i te -> "Argument " ^ string_of_int i, "") - (Array.of_list args) - in - link_hints annotation_window argsid - | C.AConst (id,_,_,_) -> - link_hints annotation_window - [| "Uri???", "" |] - | C.AAbst (id,_,_) -> - link_hints annotation_window - [| "Uri???", "" |] - | C.AMutInd (id,_,_,_,_) -> - link_hints annotation_window - [| "Uri???", "" |] - | C.AMutConstruct (id,_,_,_,_,_) -> - link_hints annotation_window - [| "Uri???", "" |] - | C.AMutCase (id,_,_,_,_,outty,te,pl) -> - let outtyid = get_id outty - and teid = get_id te - and plid = - Array.mapi - (fun i te -> "Pattern " ^ string_of_int i, "") - (Array.of_list pl) - in - link_hints annotation_window - (Array.append - [| "Uri???", "" ; - "Case Type", "" ; - "Term", "" ; - |] - plid) - | C.AFix (id,_,_,funl) -> - let funtylid = - Array.mapi - (fun i (_,_,ty,_) -> - "Type " ^ string_of_int i, "") - (Array.of_list funl) - and funbolid = - Array.mapi - (fun i (_,_,_,bo) -> - "Body " ^ string_of_int i, "") - (Array.of_list funl) - and funnamel = - Array.mapi - (fun i (_,_,_,_) -> - "Name " ^ string_of_int i, "") - (Array.of_list funl) - and funrecindexl = - Array.mapi - (fun i (_,_,_,_) -> - "Recursive Index??? " ^ string_of_int i, "") - (Array.of_list funl) - in - link_hints annotation_window - (Array.concat - [ funtylid ; - funbolid ; - funnamel ; - funrecindexl ; - [| "NoFun???", "" |] - ] - ) - | C.ACoFix (id,_,_,funl) -> - let funtylid = - Array.mapi - (fun i (_,ty,_) -> - "Type " ^ string_of_int i, "") - (Array.of_list funl) - and funbolid = - Array.mapi - (fun i (_,_,bo) -> - "Body " ^ string_of_int i, "") - (Array.of_list funl) - and funnamel = - Array.mapi - (fun i (_,_,_) -> - "Name " ^ string_of_int i, "") - (Array.of_list funl) - in - link_hints annotation_window - (Array.concat - [ funtylid ; - funbolid ; - funnamel ; - [| "NoFun???", "" |] - ] - ) -;; - -(*CSC: da riscrivere completamente eliminando il paciugo degli array - liste *) -let create_hint_from_obj annotation_window annobj = - let module C = Cic in - match annobj with - C.ADefinition (id,_,_,bo,ty,_) -> - let boid = get_id bo - and tyid = get_id ty in - link_hints annotation_window - [| "Name", "" ; - "Ingredients", "" ; - "Body", "" ; - "Type", "" - |] - | C.AAxiom (id,_,_,ty,_) -> - let tyid = get_id ty in - link_hints annotation_window - [| "Name", "" ; - "Ingredients", "" ; - "Type", "" - |] - | C.AVariable (id,_,_,bo,ty) -> - let tyid = get_id ty in - link_hints annotation_window - (match bo with - None -> - [| "Name", "" ; - "Type", "" - |] - | Some bo -> - let boid = get_id bo in - [| "Name", "" ; - "Body", "" ; - "Type", "" - |] - ) - | C.ACurrentProof (id,_,_,conjs,bo,ty) -> - let boid = get_id bo - and tyid = get_id ty - and conjsid = List.map (fun (_,te) -> get_id te) conjs in - link_hints annotation_window - (Array.append - [| "Name", "" ; - "Ingredients", "" ; - "Body", "" ; - "Type", "" - |] - (Array.mapi - (fun i id -> - "Conjecture " ^ string_of_int i, "" - ) (Array.of_list conjsid) - ) - ) - | C.AInductiveDefinition (id,_,itl,_,_) -> - let itlids = - List.map - (fun (_,_,arity,cons) -> - get_id arity, - List.map (fun (_,ty,_) -> get_id ty) cons - ) itl - in - link_hints annotation_window - (Array.concat - [ - [| "Ingredients","" |]; - (Array.mapi - (fun i _ -> - "Type Name " ^ string_of_int i, - "" - ) (Array.of_list itlids) - ) ; - (Array.mapi - (fun i (id,_) -> - "Type " ^ string_of_int i, "" - ) (Array.of_list itlids) - ) ; - (Array.concat - (list_mapi - (fun i (_,consid) -> - (Array.mapi - (fun j _ -> - "Constructor Name " ^ string_of_int i ^ " " ^ string_of_int j, - "" - ) (Array.of_list consid) - ) ; - ) itlids - ) - ) ; - (Array.concat - (list_mapi - (fun i (_,consid) -> - (Array.mapi - (fun j id -> - "Constructor " ^ string_of_int i ^ " " ^ string_of_int j, - "" - ) (Array.of_list consid) - ) ; - ) itlids - ) - ) - ] - ) -;; - -exception IdUnknown of string;; - -let create_hints annotation_window (annobj,ids_to_targets) xpath = - try - match Hashtbl.find ids_to_targets xpath with - Cic.Object annobj -> create_hint_from_obj annotation_window annobj - | Cic.Term annterm -> create_hint_from_term annotation_window annterm - with - Not_found -> raise (IdUnknown xpath) -;; diff --git a/helm/interface/cicCache.ml b/helm/interface/cicCache.ml deleted file mode 100644 index 6ae536caf..000000000 --- a/helm/interface/cicCache.ml +++ /dev/null @@ -1,212 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a trival cache system (an hash-table) for cic *) -(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) -(* *) -(******************************************************************************) - -let raise e = print_endline "***" ; flush stdout ; print_endline (Printexc.to_string e) ; flush stdout ; raise e;; - -(*CSC: forse i due seguenti tipi sono da unificare? *) -type cooked_obj = - Cooked of Cic.obj - | Frozen of Cic.obj - | Unchecked of Cic.obj -type type_checked_obj = - CheckedObj of Cic.obj (* cooked obj *) - | UncheckedObj of Cic.obj (* uncooked obj *) -;; - -exception NoFunctionProvided;; - -(* CSC: da sostituire con un (...) option ref *) -let cook_obj = ref (fun obj uri -> raise NoFunctionProvided);; - -exception CircularDependency of string;; -exception CouldNotUnfreeze of string;; -exception Impossible;; -exception UncookedObj;; - -module HashedType = - struct - type t = UriManager.uri * int (* uri, livello di cottura *) - let equal (u1,n1) (u2,n2) = UriManager.eq u1 u2 && n1 = n2 - let hash = Hashtbl.hash - end -;; - -(* Hashtable that uses == instead of = for testing equality *) -module HashTable = Hashtbl.Make(HashedType);; - -let hashtable = HashTable.create 271;; - -(* n is the number of time that the object must be cooked *) -let get_obj_and_type_checking_info uri n = - try - HashTable.find hashtable (uri,n) - with - Not_found -> - try - match HashTable.find hashtable (uri,0) with - Cooked _ - | Frozen _ -> raise Impossible - | Unchecked _ as t -> t - with - Not_found -> - let filename = Getter.get uri in - let (annobj,_) = CicParser.term_of_xml filename uri false in - let obj = Deannotate.deannotate_obj annobj in - let output = Unchecked obj in - HashTable.add hashtable (uri,0) output ; - output -;; - -(* DANGEROUS!!! *) -(* USEFUL ONLY DURING THE FIXING OF THE FILES *) -(* change_obj uri (Some newobj) *) -(* maps uri to newobj in cache. *) -(* change_obj uri None *) -(* maps uri to a freeze dummy-object. *) -let change_obj uri newobj = - let newobj = - match newobj with - Some newobj' -> Unchecked newobj' - | None -> Frozen (Cic.Variable ("frozen-dummy", None, Cic.Implicit)) - in - HashTable.remove hashtable (uri,0) ; - HashTable.add hashtable (uri,0) newobj -;; - -let is_annotation_uri uri = - Str.string_match (Str.regexp ".*\.ann$") (UriManager.string_of_uri uri) 0 -;; - -(* returns both the annotated and deannotated uncooked forms (plus the *) -(* map from ids to annotation targets) *) -let get_annobj_and_type_checking_info uri = - let filename = Getter.get uri in - match CicParser.term_of_xml filename uri true with - (_, None) -> raise Impossible - | (annobj, Some ids_to_targets) -> - (* If uri is the uri of an annotation, let's use the annotation file *) - if is_annotation_uri uri then - AnnotationParser.annotate (Getter.get_ann uri) ids_to_targets ; - try - (annobj, ids_to_targets, HashTable.find hashtable (uri,0)) - with - Not_found -> - let obj = Deannotate.deannotate_obj annobj in - let output = Unchecked obj in - HashTable.add hashtable (uri,0) output ; - (annobj, ids_to_targets, output) -;; - - -(* get_obj uri *) -(* returns the cic object whose uri is uri. If the term is not just in cache, *) -(* then it is parsed via CicParser.term_of_xml from the file whose name is *) -(* the result of Getter.get uri *) -let get_obj uri = - match get_obj_and_type_checking_info uri 0 with - Unchecked obj -> obj - | Frozen obj -> obj - | Cooked obj -> obj -;; - -(* get_annobj uri *) -(* returns the cic object whose uri is uri either in annotated and *) -(* deannotated form. The term is put into the cache if it's not there yet. *) -let get_annobj uri = - let (ann, ids_to_targets, deann) = get_annobj_and_type_checking_info uri in - let deannobj = - match deann with - Unchecked obj -> obj - | Frozen _ -> raise (CircularDependency (UriManager.string_of_uri uri)) - | Cooked obj -> obj - in - (ann, ids_to_targets, deannobj) -;; - -(*CSC Commento falso *) -(* get_obj uri *) -(* returns the cooked cic object whose uri is uri. The term must be present *) -(* and cooked in cache *) -let rec get_cooked_obj uri cookingsno = - match get_obj_and_type_checking_info uri cookingsno with - Unchecked _ - | Frozen _ -> raise UncookedObj - | Cooked obj -> obj -;; - -(* is_type_checked uri *) -(* CSC: commento falso ed obsoleto *) -(* returns true if the term has been type-checked *) -(* otherwise it returns false and freeze the term for type-checking *) -(* set_type_checking_info must be called to unfreeze the term *) -let is_type_checked uri cookingsno = - match get_obj_and_type_checking_info uri cookingsno with - Cooked obj -> CheckedObj obj - | Unchecked obj -> - HashTable.remove hashtable (uri,0) ; - HashTable.add hashtable (uri,0) (Frozen obj) ; - UncheckedObj obj - | Frozen _ -> raise (CircularDependency (UriManager.string_of_uri uri)) -;; - -(* set_type_checking_info uri *) -(* must be called once the type-checking of uri is finished *) -(* The object whose uri is uri is unfreezed *) -let set_type_checking_info uri = - match HashTable.find hashtable (uri,0) with - Frozen obj -> - (* let's cook the object at every level *) - HashTable.remove hashtable (uri,0) ; - let obj' = CicSubstitution.undebrujin_inductive_def uri obj in - HashTable.add hashtable (uri,0) (Cooked obj') ; - let cooked_objs = !cook_obj obj' uri in - let last_cooked_level = ref 0 in - let last_cooked_obj = ref obj' in - List.iter - (fun (n,cobj) -> - for i = !last_cooked_level + 1 to n do - HashTable.add hashtable (uri,i) (Cooked !last_cooked_obj) - done ; - HashTable.add hashtable (uri,n + 1) (Cooked cobj) ; - last_cooked_level := n + 1 ; - last_cooked_obj := cobj - ) cooked_objs ; - for i = !last_cooked_level + 1 to UriManager.depth_of_uri uri + 1 do - HashTable.add hashtable (uri,i) (Cooked !last_cooked_obj) - done - | _ -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri)) -;; diff --git a/helm/interface/cicCache.mli b/helm/interface/cicCache.mli deleted file mode 100644 index 3f5fd0003..000000000 --- a/helm/interface/cicCache.mli +++ /dev/null @@ -1,81 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a trival cache system (an hash-table) for cic *)(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *)(* *) -(******************************************************************************) - -exception CircularDependency of string;; - -(* get_obj uri *) -(* returns the cic object whose uri is uri. If the term is not just in cache, *) -(* then it is parsed via CicParser.term_of_xml from the file whose name is *) -(* the result of Getter.get uri *) -val get_obj : UriManager.uri -> Cic.obj - -(* get_annobj uri *) -(* returns the cic object whose uri is uri either in annotated and in *) -(* deannotated form. It returns also the map from ids to annotation targets. *) -(* The term is put in cache if it's not there yet. *) -(* The functions raise CircularDependency if asked to retrieve a Frozen object*) -val get_annobj : - UriManager.uri -> Cic.annobj * (Cic.id, Cic.anntarget) Hashtbl.t * Cic.obj - -(* DANGEROUS!!! *) -(* USEFUL ONLY DURING THE FIXING OF THE FILES *) -(* change_obj uri (Some newobj) *) -(* maps uri to newobj in cache. *) -(* change_obj uri None *) -(* maps uri to a freeze dummy-object. *) -val change_obj : UriManager.uri -> Cic.obj option -> unit - -type type_checked_obj = - CheckedObj of Cic.obj (* cooked obj *) - | UncheckedObj of Cic.obj (* uncooked obj *) - -(* is_type_checked uri cookingsno *) -(*CSC commento falso ed obsoleto *) -(* returns (true,object) if the object has been type-checked *) -(* otherwise it returns (false,object) and freeze the object for *) -(* type-checking *) -(* set_type_checking_info must be called to unfreeze the object *) -val is_type_checked : UriManager.uri -> int -> type_checked_obj - -(* set_type_checking_info uri *) -(* must be called once the type-checking of uri is finished *) -(* The object whose uri is uri is unfreezed and won't be type-checked *) -(* again in the future (is_type_checked will return true) *) -val set_type_checking_info : UriManager.uri -> unit - -(* get_cooked_obj uri cookingsno *) -val get_cooked_obj : UriManager.uri -> int -> Cic.obj - -val cook_obj : (Cic.obj -> UriManager.uri -> (int * Cic.obj) list) ref diff --git a/helm/interface/cicCooking.ml b/helm/interface/cicCooking.ml deleted file mode 100644 index fcd67bd95..000000000 --- a/helm/interface/cicCooking.ml +++ /dev/null @@ -1,217 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception Impossible;; -exception NotImplemented of int * string;; -exception WrongUriToConstant;; -exception WrongUriToVariable of string;; -exception WrongUriToInductiveDefinition;; - -(* mem x lol is true if x is a member of one *) -(* of the lists of the list of (int * list) lol *) -let mem x lol = - List.fold_right (fun (_,l) i -> i || List.mem x l) lol false -;; - -(* cook var term *) -let cook curi cookingsno var = - let rec aux k = - let module C = Cic in - function - C.Rel n as t -> - (match n with - n when n >= k -> C.Rel (n + 1) - | _ -> C.Rel n - ) - | C.Var uri as t -> - if UriManager.eq uri var then - C.Rel k - else - t - | C.Meta _ as t -> t - | C.Sort _ as t -> t - | C.Implicit as t -> t - | C.Cast (te, ty) -> C.Cast (aux k te, aux k ty) - | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k + 1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t) - | C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k + 1) t) - | C.Appl (he::tl) -> - (* Get rid of C.Appl (C.Appl l1) l2 *) - let newtl = List.map (aux k) tl in - (match aux k he with - C.Appl (he'::tl') -> C.Appl (he'::(tl'@newtl)) - | t -> C.Appl (t::newtl) - ) - | C.Appl [] -> raise Impossible - | C.Const (uri,_) -> - if match CicCache.get_obj uri with - C.Definition (_,_,_,params) when mem var params -> true - | C.Definition _ -> false - | C.Axiom (_,_,params) when mem var params -> true - | C.Axiom _ -> false - | C.CurrentProof _ -> - raise (NotImplemented (2,(UriManager.string_of_uri uri))) - | _ -> raise WrongUriToConstant - then - C.Appl - ((C.Const (uri,UriManager.relative_depth curi uri cookingsno)):: - [C.Rel k]) - else - C.Const (uri,UriManager.relative_depth curi uri cookingsno) - | C.Abst _ as t -> t - | C.MutInd (uri,_,i) -> - if match CicCache.get_obj uri with - C.InductiveDefinition (_,params,_) when mem var params -> true - | C.InductiveDefinition _ -> false - | _ -> raise WrongUriToInductiveDefinition - then - C.Appl ((C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i))::[C.Rel k]) - else - C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i) - | C.MutConstruct (uri,_,i,j) -> - if match CicCache.get_obj uri with - C.InductiveDefinition (_,params,_) when mem var params -> true - | C.InductiveDefinition _ -> false - | _ -> raise WrongUriToInductiveDefinition - then - C.Appl ((C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j))::[C.Rel k]) - else - C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j) - | C.MutCase (uri,_,i,outt,term,pl) -> - let substitutedfl = - List.map (aux k) pl - in - C.MutCase (uri,UriManager.relative_depth curi uri cookingsno,i, - aux k outt,aux k term, substitutedfl) - | C.Fix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> (name,i,aux k ty, aux (k+len) bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name,aux k ty, aux (k+len) bo)) - fl - in - C.CoFix (i, substitutedfl) - in - aux 1 -;; - -let cook_gen add_binder curi cookingsno ty vars = - let module C = Cic in - let module U = UriManager in - let rec cookrec ty = - function - var::tl -> - let (varname, varbody, vartype) = - match CicCache.get_obj var with - C.Variable (varname, varbody, vartype) -> (varname, varbody, vartype) - | _ -> raise (WrongUriToVariable (U.string_of_uri var)) - in - cookrec (add_binder (C.Name varname) varbody vartype - (cook curi cookingsno var ty)) tl - | _ -> ty - in - cookrec ty vars -;; - -let cook_prod = - cook_gen (fun n b s t -> - match b with - None -> Cic.Prod (n,s,t) - | Some b -> Cic.LetIn (n,b,t) - ) -and cook_lambda = - cook_gen (fun n b s t -> - match b with - None -> Cic.Lambda (n,s,t) - | Some b -> Cic.LetIn (n,b,t) - ) -;; - -(*CSC: sbagliato da rifare e completare *) -let cook_one_level obj curi cookingsno vars = - let module C = Cic in - match obj with - C.Definition (id,te,ty,params) -> - let ty' = cook_prod curi cookingsno ty vars in - let te' = cook_lambda curi cookingsno te vars in - C.Definition (id,te',ty',params) - | C.Axiom (id,ty,parameters) -> - let ty' = cook_prod curi cookingsno ty vars in - C.Axiom (id,ty',parameters) - | C.Variable _ as obj -> obj - | C.CurrentProof (id,conjs,te,ty) -> - let ty' = cook_prod curi cookingsno ty vars in - let te' = cook_lambda curi cookingsno te vars in - C.CurrentProof (id,conjs,te',ty') - | C.InductiveDefinition (dl, params, n_ind_params) -> - let dl' = - List.map - (fun (name,inductive,arity,constructors) -> - let constructors' = - List.map - (fun (name,ty,r) -> - let r' = - match !r with - None -> raise Impossible - | Some r -> List.map (fun _ -> false) vars @ r - in - (name,cook_prod curi cookingsno ty vars,ref (Some r')) - ) constructors - in - (name,inductive,cook_prod curi cookingsno arity vars,constructors') - ) dl - in - C.InductiveDefinition (dl', params, n_ind_params + List.length vars) -;; - -let cook_obj obj uri = - let module C = Cic in - let params = - match obj with - C.Definition (_,_,_,params) -> params - | C.Axiom (_,_,params) -> params - | C.Variable _ -> [] - | C.CurrentProof _ -> [] - | C.InductiveDefinition (_,params,_) -> params - in - let rec cook_all_levels obj = - function - [] -> [] - | (n,vars)::tl -> - let cooked_obj = cook_one_level obj uri (n + 1) (List.rev vars) in - (n,cooked_obj)::(cook_all_levels cooked_obj tl) - in - cook_all_levels obj (List.rev params) -;; - -CicCache.cook_obj := cook_obj;; diff --git a/helm/interface/cicCooking.mli b/helm/interface/cicCooking.mli deleted file mode 100644 index 203bf6c33..000000000 --- a/helm/interface/cicCooking.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception Impossible -exception NotImplemented of int * string -exception WrongUriToConstant -exception WrongUriToVariable of string -exception WrongUriToInductiveDefinition -val cook_obj : Cic.obj -> UriManager.uri -> (int * Cic.obj) list diff --git a/helm/interface/cicFindParameters.ml b/helm/interface/cicFindParameters.ml deleted file mode 100644 index dbc1483d1..000000000 --- a/helm/interface/cicFindParameters.ml +++ /dev/null @@ -1,162 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception WrongUriToConstant;; -exception WrongUriToInductiveDefinition;; -exception CircularDependency of string;; - -module OrderedUris = - struct - type t = UriManager.uri - let compare (s1 : t) (s2 : t) = - (* library function for = *) - compare s1 s2 - (*if s1 = s2 then 0 else if s1 < s2 then (-1) else 1*) - end -;; - -let filename_of_uri uri = - let uri' = UriManager.string_of_uri uri in - let fn = Str.replace_first (Str.regexp "cic:") Configuration.helm_dir uri' in - fn ^ ".xml" -;; - -(* quite inefficient coding of a set of strings: the only operations *) -(* performed are mem O(log n), and union O(n * log n?) *) -(* Perhaps a better implementation would be an array of bits or a map *) -(* from uri to booleans *) -module SetOfUris = Set.Make(OrderedUris);; - -let (@@) = SetOfUris.union;; - -let rec parameters_of te ty pparams= - let module S = SetOfUris in - let module C = Cic in - let rec aux = - function - C.Rel _ -> S.empty - | C.Var uri -> S.singleton uri - | C.Meta _ -> S.empty - | C.Sort _ -> S.empty - | C.Implicit -> S.empty - | C.Cast (te, ty) -> aux te @@ aux ty - | C.Prod (_, s, t) -> aux s @@ aux t - | C.Lambda (_, s, t) -> aux s @@ aux t - | C.Appl l -> List.fold_right (fun x i -> aux x @@ i) l S.empty - | C.Const (uri,_) -> - (* the parameters could be not exact but only possible *) - fix_params uri (Some (filename_of_uri uri)) ; - (* now the parameters are surely possible *) - (match CicCache.get_obj uri with - C.Definition (_, _, _, params) -> - List.fold_right - (fun (_,l) i -> - List.fold_right - (fun x i -> S.singleton x @@ i) l i - ) params S.empty - | C.Axiom (_, _, params) -> - List.fold_right - (fun (_,l) i -> - List.fold_right - (fun x i -> S.singleton x @@ i) l i - ) params S.empty - | C.CurrentProof _ -> S.empty (*CSC wrong *) - | _ -> raise WrongUriToConstant - ) - | C.Abst _ -> S.empty - | C.MutInd (uri,_,_) -> - (match CicCache.get_obj uri with - C.InductiveDefinition (_, params, _) -> - List.fold_right - (fun (_,l) i -> - List.fold_right - (fun x i -> S.singleton x @@ i) l i - ) params S.empty - | _ -> raise WrongUriToInductiveDefinition - ) - | C.MutConstruct (uri,_,_,_) -> - (match CicCache.get_obj uri with - C.InductiveDefinition (_, params, _) -> - List.fold_right - (fun (_,l) i -> - List.fold_right - (fun x i -> S.singleton x @@ i) l i - ) params S.empty - | _ -> raise WrongUriToInductiveDefinition - ) - | C.MutCase (uri,_,_,outtype,term,patterns) -> - (*CSC cosa basta? Ci vuole anche uri? *) - (match CicCache.get_obj uri with - C.InductiveDefinition (_, params, _) -> - List.fold_right - (fun (_,l) i -> - List.fold_right - (fun x i -> S.singleton x @@ i) l i - ) params S.empty - | _ -> raise WrongUriToInductiveDefinition - ) @@ aux outtype @@ aux term @@ - List.fold_right (fun x i -> aux x @@ i) patterns S.empty - | C.Fix (_,fl) -> - List.fold_right - (fun (_,_,ty,bo) i -> aux ty @@ aux bo @@ i) - fl S.empty - | C.CoFix (_,fl) -> - List.fold_right - (fun (_,ty,bo) i -> aux ty @@ aux bo @@ i) - fl S.empty - in - let actual_params = aux te @@ aux ty in - (* sort_actual_params wants in input the ordered list of possible params *) - let rec sort_actual_params2 = - function - [] -> [] - | he::tl when S.mem he actual_params -> he::(sort_actual_params2 tl) - | _::tl -> sort_actual_params2 tl - in - let rec sort_actual_params = - function - [] -> [] - | (n,l)::tl -> (n, sort_actual_params2 l)::(sort_actual_params tl) - in - sort_actual_params pparams - -and fix_params uri filename = - let module C = Cic in - let (ann, _, deann) = CicCache.get_annobj uri in - match ann, deann with - (C.ADefinition (xid, ann, id, te, ty, C.Possible pparams), - C.Definition (id', te', ty', _)) -> - (* let's freeze the object to avoid circular dependencies *) - CicCache.change_obj uri None ; - let real_params = parameters_of te' ty' pparams in - let fixed = - C.ADefinition (xid,ann,id,te,ty,C.Actual real_params) - in - Xml.pp (Cic2Xml.pp fixed uri) filename ; - (* unfreeze and fix the object *) - CicCache.change_obj uri - (Some (C.Definition (id', te', ty', real_params))) - | _ -> () -;; diff --git a/helm/interface/cicParser.ml b/helm/interface/cicParser.ml deleted file mode 100644 index bf75243ec..000000000 --- a/helm/interface/cicParser.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This is the main (top level) module of a parser for cic objects from xml *) -(* files to the internal representation. It uses the modules cicParser2 *) -(* (objects level) and cicParser3 (terms level) *) -(* *) -(******************************************************************************) - -exception Warnings;; - -class warner = - object - method warn w = - print_endline ("WARNING: " ^ w) ; - (raise Warnings : unit) - end -;; - -exception EmptyUri;; - -(* given an uri u it returns the list of tokens of the base uri of u *) -(* e.g.: token_of_uri "cic:/a/b/c/d.xml" returns ["a" ; "b" ; "c"] *) -let tokens_of_uri uri = - let uri' = UriManager.string_of_uri uri in - let rec chop_list = - function - [] -> raise EmptyUri - | he::[fn] -> [he] - | he::tl -> he::(chop_list tl) - in - let trimmed_uri = Str.replace_first (Str.regexp "cic:") "" uri' in - let list_of_tokens = Str.split (Str.regexp "/") trimmed_uri in - chop_list list_of_tokens -;; - -(* given the filename of an xml file of a cic object it returns its internal *) -(* representation. process_annotations is true if the annotations do really *) -(* matter *) -let term_of_xml filename uri process_annotations = - let module Y = Pxp_yacc in - try - let d = - (* sets the current base uri to resolve relative URIs *) - CicParser3.current_sp := tokens_of_uri uri ; - CicParser3.current_uri := uri ; - CicParser3.process_annotations := process_annotations ; - CicParser3.ids_to_targets := - if process_annotations then Some (Hashtbl.create 500) else None ; - let config = {Y.default_config with Y.warner = new warner} in - Y.parse_document_entity config -(*PXP (Y.ExtID (Pxp_types.System filename, - new Pxp_reader.resolve_as_file ~url_of_id ())) -*) (PxpUriResolver.from_file filename) - CicParser3.domspec - in - let ids_to_targets = !CicParser3.ids_to_targets in - let res = (CicParser2.get_term d#root, ids_to_targets) in - CicParser3.ids_to_targets := None ; (* let's help the GC *) - res - with - e -> - print_endline ("Filename: " ^ filename ^ "\nException: ") ; - print_endline (Pxp_types.string_of_exn e) ; - raise e -;; diff --git a/helm/interface/cicParser.mli b/helm/interface/cicParser.mli deleted file mode 100644 index 0078f6f33..000000000 --- a/helm/interface/cicParser.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 22/03/2000 *) -(* *) -(* This is the main (top level) module of a parser for cic objects from xml *) -(* files to the internal representation. It uses the modules cicParser2 *) -(* (objects level) and cicParser3 (terms level) *) -(* *) -(******************************************************************************) - -(* given the filename of an xml file of a cic object and it's uri, it returns *) -(* its internal annotated representation. The boolean is set to true if the *) -(* annotations do really matter *) -val term_of_xml : - string -> UriManager.uri -> bool -> - Cic.annobj * (Cic.id, Cic.anntarget) Hashtbl.t option diff --git a/helm/interface/cicParser2.ml b/helm/interface/cicParser2.ml deleted file mode 100644 index 562f79bba..000000000 --- a/helm/interface/cicParser2.ml +++ /dev/null @@ -1,289 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module is the objects level of a parser for cic objects from xml *) -(* files to the internal representation. It uses the module cicParser3 *) -(* cicParser3 (terms level) and it is used only through cicParser2 (top *) -(* level). *) -(* *) -(******************************************************************************) - -exception IllFormedXml of int;; -exception NotImplemented;; - -(* Utility functions that transform a Pxp attribute into something useful *) - -(* mk_absolute_uris "n1: v1 ... vn n2 : u1 ... un ...." *) -(* returns [(n1,[absolute_uri_for_v1 ; ... ; absolute_uri_for_vn]) ; (n2,...) *) -let mk_absolute_uris s = - let l = (Str.split (Str.regexp ":") s) in - let absolute_of_relative n v = - let module P3 = CicParser3 in - let rec mkburi = - function - (0,_) -> "/" - | (n,he::tl) when n > 0 -> - "/" ^ he ^ mkburi (n - 1, tl) - | _ -> raise (IllFormedXml 12) - in - let m = List.length !P3.current_sp - (int_of_string n) in - let buri = mkburi (m, !P3.current_sp) in - UriManager.uri_of_string ("cic:" ^ buri ^ v ^ ".var") - in - let rec absolutize = - function - [] -> [] - | [no ; vs] -> - let vars = (Str.split (Str.regexp " ") vs) in - [(int_of_string no, List.map (absolute_of_relative no) vars)] - | no::vs::tl -> - let vars = (Str.split (Str.regexp " ") vs) in - let rec add_prefix = - function - [no2] -> ([], no2) - | he::tl -> - let (pvars, no2) = add_prefix tl in - ((absolute_of_relative no he)::pvars, no2) - | _ -> raise (IllFormedXml 11) - in - let (pvars, no2) = add_prefix vars in - (int_of_string no, pvars)::(absolutize (no2::tl)) - | _ -> raise (IllFormedXml 10) - in - (* last parameter must be applied first *) - absolutize l -;; - -let option_uri_list_of_attr a1 a2 = - let module T = Pxp_types in - let parameters = - match a1 with - T.Value s -> mk_absolute_uris s - | _ -> raise (IllFormedXml 0) - in - match a2 with - T.Value "POSSIBLE" -> Cic.Possible parameters - | T.Implied_value -> Cic.Actual parameters - | _ -> raise (IllFormedXml 0) -;; - -let uri_list_of_attr a = - let module T = Pxp_types in - match a with - T.Value s -> mk_absolute_uris s - | _ -> raise (IllFormedXml 0) -;; - -let string_of_attr a = - let module T = Pxp_types in - match a with - T.Value s -> s - | _ -> raise (IllFormedXml 0) -;; - -let int_of_attr a = - int_of_string (string_of_attr a) -;; - -let bool_of_attr a = - bool_of_string (string_of_attr a) -;; - -(* Other utility functions *) - -let get_content n = - match n#sub_nodes with - [ t ] -> t - | _ -> raise (IllFormedXml 1) -;; - -let register_id id node = - if !CicParser3.process_annotations then - match !CicParser3.ids_to_targets with - None -> assert false - | Some ids_to_targets -> - Hashtbl.add ids_to_targets id (Cic.Object node) -;; - -(* Functions that, given the list of sons of a node of the cic dom (objects *) -(* level), retrieve the internal representation associated to the node. *) -(* Everytime a cic term subtree is found, it is translated to the internal *) -(* representation using the method to_cic_term defined in cicParser3. *) -(* Each function raise IllFormedXml if something goes wrong, but this should *) -(* be impossible due to the presence of the dtd *) -(* The functions should really be obvious looking at their name and the cic *) -(* dtd *) - -(* called when a CurrentProof is found *) -let get_conjs_value_type l = - let rec rget (c, v, t) l = - let module D = Pxp_document in - match l with - [] -> (c, v, t) - | conj::tl when conj#node_type = D.T_element "Conjecture" -> - let no = int_of_attr (conj#attribute "no") - and typ = (get_content conj)#extension#to_cic_term in - rget ((no, typ)::c, v, t) tl - | value::tl when value#node_type = D.T_element "body" -> - let v' = (get_content value)#extension#to_cic_term in - (match v with - None -> rget (c, Some v', t) tl - | _ -> raise (IllFormedXml 2) - ) - | typ::tl when typ#node_type = D.T_element "type" -> - let t' = (get_content typ)#extension#to_cic_term in - (match t with - None -> rget (c, v, Some t') tl - | _ -> raise (IllFormedXml 3) - ) - | _ -> raise (IllFormedXml 4) - in - match rget ([], None, None) l with - (c, Some v, Some t) -> (c, v, t) - | _ -> raise (IllFormedXml 5) -;; - -(* used only by get_inductive_types; called one time for each inductive *) -(* definitions in a block of inductive definitions *) -let get_names_arity_constructors l = - let rec rget (a,c) l = - let module D = Pxp_document in - match l with - [] -> (a, c) - | arity::tl when arity#node_type = D.T_element "arity" -> - let a' = (get_content arity)#extension#to_cic_term in - rget (Some a',c) tl - | con::tl when con#node_type = D.T_element "Constructor" -> - let id = string_of_attr (con#attribute "name") - and ty = (get_content con)#extension#to_cic_term in - rget (a,(id,ty,ref None)::c) tl - | _ -> raise (IllFormedXml 9) - in - match rget (None,[]) l with - (Some a, c) -> (a, List.rev c) - | _ -> raise (IllFormedXml 8) -;; - -(* called when an InductiveDefinition is found *) -let rec get_inductive_types = - function - [] -> [] - | he::tl -> - let tyname = string_of_attr (he#attribute "name") - and inductive = bool_of_attr (he#attribute "inductive") - and (arity,cons) = - get_names_arity_constructors (he#sub_nodes) - in - (tyname,inductive,arity,cons)::(get_inductive_types tl) (*CSC 0 a caso *) -;; - -(* This is the main function and also the only one used directly from *) -(* cicParser. Given the root of the dom tree, it returns the internal *) -(* representation of the cic object described in the tree *) -(* It uses the previous functions and the to_cic_term method defined *) -(* in cicParser3 (used for subtrees that encode cic terms) *) -let rec get_term n = - let module D = Pxp_document in - let module C = Cic in - let ntype = n # node_type in - match ntype with - D.T_element "Definition" -> - let id = string_of_attr (n # attribute "name") - and params = - option_uri_list_of_attr (n#attribute "params") (n#attribute "paramMode") - and (value, typ) = - let sons = n#sub_nodes in - match sons with - [v ; t] when - v#node_type = D.T_element "body" && - t#node_type = D.T_element "type" -> - let v' = get_content v - and t' = get_content t in - (v'#extension#to_cic_term, t'#extension#to_cic_term) - | _ -> raise (IllFormedXml 6) - and xid = string_of_attr (n#attribute "id") in - let res = C.ADefinition (xid, ref None, id, value, typ, params) in - register_id xid res ; - res - | D.T_element "Axiom" -> - let id = string_of_attr (n # attribute "name") - and params = uri_list_of_attr (n # attribute "params") - and typ = - (get_content (get_content n))#extension#to_cic_term - and xid = string_of_attr (n#attribute "id") in - let res = C.AAxiom (xid, ref None, id, typ, params) in - register_id xid res ; - res - | D.T_element "CurrentProof" -> - let name = string_of_attr (n#attribute "name") - and xid = string_of_attr (n#attribute "id") in - let sons = n#sub_nodes in - let (conjs, value, typ) = get_conjs_value_type sons in - let res = C.ACurrentProof (xid, ref None, name, conjs, value, typ) in - register_id xid res ; - res - | D.T_element "InductiveDefinition" -> - let sons = n#sub_nodes - and xid = string_of_attr (n#attribute "id") in - let inductiveTypes = get_inductive_types sons - and params = uri_list_of_attr (n#attribute "params") - and nparams = int_of_attr (n#attribute "noParams") in - let res = - C.AInductiveDefinition (xid, ref None, inductiveTypes, params, nparams) - in - register_id xid res ; - res - | D.T_element "Variable" -> - let name = string_of_attr (n#attribute "name") - and xid = string_of_attr (n#attribute "id") - and (body, typ) = - let sons = n#sub_nodes in - match sons with - [b ; t] when - b#node_type = D.T_element "body" && - t#node_type = D.T_element "type" -> - let b' = get_content b - and t' = get_content t in - (Some (b'#extension#to_cic_term), t'#extension#to_cic_term) - | [t] when t#node_type = D.T_element "type" -> - let t' = get_content t in - (None, t'#extension#to_cic_term) - | _ -> raise (IllFormedXml 6) - in - let res = C.AVariable (xid,ref None,name,body,typ) in - register_id xid res ; - res - | D.T_element _ - | D.T_data - | _ -> - raise (IllFormedXml 7) -;; diff --git a/helm/interface/cicParser2.mli b/helm/interface/cicParser2.mli deleted file mode 100644 index be0a00054..000000000 --- a/helm/interface/cicParser2.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module is the objects level of a parser for cic objects from xml *) -(* files to the internal representation. It uses the module cicParser3 *) -(* cicParser3 (terms level) and it is used only through cicParser2 (top *) -(* level). *) -(* *) -(******************************************************************************) - -exception IllFormedXml of int -exception NotImplemented - -(* This is the main function and also the only one used directly from *) -(* cicParser. Given the root of the dom tree, it returns the internal *) -(* representation of the cic object described in the tree *) -(* It uses the previous functions and the to_cic_term method defined *) -(* in cicParser3 (used for subtrees that encode cic terms) *) -val get_term : - < attribute : string -> Pxp_types.att_value; - node_type : Pxp_document.node_type; - sub_nodes : < attribute : string -> Pxp_types.att_value; - node_type : Pxp_document.node_type; - sub_nodes : CicParser3.cic_term Pxp_document.node list; - .. > - list; - .. > -> - Cic.annobj diff --git a/helm/interface/cicParser3.ml b/helm/interface/cicParser3.ml deleted file mode 100644 index 54b417fa1..000000000 --- a/helm/interface/cicParser3.ml +++ /dev/null @@ -1,564 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module is the terms level of a parser for cic objects from xml *) -(* files to the internal representation. It is used by the module cicParser2 *) -(* (objects level). It defines an extension of the standard dom using the *) -(* object-oriented extension machinery of markup: an object with a method *) -(* to_cic_term that returns the internal representation of the subtree is *) -(* added to each node of the dom tree *) -(* *) -(******************************************************************************) - -exception IllFormedXml of int;; - -(* The hashtable from the current identifiers to the object or the terms *) -let ids_to_targets = ref None;; - -(* The list of tokens of the current section path. *) -(* Used to resolve relative URIs *) -let current_sp = ref [];; - -(* The uri of the object been parsed *) -let current_uri = ref (UriManager.uri_of_string "cic:/.xml");; - -(* True if annotation really matter *) -let process_annotations = ref false;; - -(* Utility functions to map a markup attribute to something useful *) - -let cic_attr_of_xml_attr = - function - Pxp_types.Value s -> Cic.Name s - | Pxp_types.Implied_value -> Cic.Anonimous - | _ -> raise (IllFormedXml 1) - -let cic_sort_of_xml_attr = - function - Pxp_types.Value "Prop" -> Cic.Prop - | Pxp_types.Value "Set" -> Cic.Set - | Pxp_types.Value "Type" -> Cic.Type - | _ -> raise (IllFormedXml 2) - -let int_of_xml_attr = - function - Pxp_types.Value n -> int_of_string n - | _ -> raise (IllFormedXml 3) - -let uri_of_xml_attr = - function - Pxp_types.Value s -> UriManager.uri_of_string s - | _ -> raise (IllFormedXml 4) - -let string_of_xml_attr = - function - Pxp_types.Value s -> s - | _ -> raise (IllFormedXml 5) - -let binder_of_xml_attr = - function - Pxp_types.Value s -> if !process_annotations then Some s else None - | _ -> raise (IllFormedXml 17) -;; - -let register_id id node = - if !process_annotations then - match !ids_to_targets with - None -> assert false - | Some ids_to_targets -> - Hashtbl.add ids_to_targets id (Cic.Term node) -;; - -(* the "interface" of the class linked to each node of the dom tree *) - -class virtual cic_term = - object (self) - - (* fields and methods ever required by markup *) - val mutable node = (None : cic_term Pxp_document.node option) - - method clone = {< >} - method node = - match node with - None -> - assert false - | Some n -> n - method set_node n = - node <- Some n - - (* a method that returns the internal representation of the tree (term) *) - (* rooted in this node *) - method virtual to_cic_term : Cic.annterm - end -;; - -(* the class of the objects linked to nodes that are not roots of cic terms *) -class eltype_not_of_cic = - object (self) - - inherit cic_term - - method to_cic_term = raise (IllFormedXml 6) - end -;; - -(* the class of the objects linked to nodes whose content is a cic term *) -(* (syntactic sugar xml entities) e.g. ... *) -class eltype_transparent = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - match n#sub_nodes with - [ t ] -> t#extension#to_cic_term - | _ -> raise (IllFormedXml 7) - end -;; - -(* A class for each cic node type *) - -class eltype_fix = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let nofun = int_of_xml_attr (n#attribute "noFun") - and id = string_of_xml_attr (n#attribute "id") - and functions = - let sons = n#sub_nodes in - List.map - (function - f when f#node_type = Pxp_document.T_element "FixFunction" -> - let name = string_of_xml_attr (f#attribute "name") - and recindex = int_of_xml_attr (f#attribute "recIndex") - and (ty, body) = - match f#sub_nodes with - [t ; b] when - t#node_type = Pxp_document.T_element "type" && - b#node_type = Pxp_document.T_element "body" -> - (t#extension#to_cic_term, b#extension#to_cic_term) - | _ -> raise (IllFormedXml 14) - in - (name, recindex, ty, body) - | _ -> raise (IllFormedXml 13) - ) sons - in - let res = Cic.AFix (id, ref None, nofun, functions) in - register_id id res ; - res - end -;; - -class eltype_cofix = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let nofun = int_of_xml_attr (n#attribute "noFun") - and id = string_of_xml_attr (n#attribute "id") - and functions = - let sons = n#sub_nodes in - List.map - (function - f when f#node_type = Pxp_document.T_element "CofixFunction" -> - let name = string_of_xml_attr (f#attribute "name") - and (ty, body) = - match f#sub_nodes with - [t ; b] when - t#node_type = Pxp_document.T_element "type" && - b#node_type = Pxp_document.T_element "body" -> - (t#extension#to_cic_term, b#extension#to_cic_term) - | _ -> raise (IllFormedXml 16) - in - (name, ty, body) - | _ -> raise (IllFormedXml 15) - ) sons - in - let res = Cic.ACoFix (id, ref None, nofun, functions) in - register_id id res ; - res - end -;; - -class eltype_implicit = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let id = string_of_xml_attr (n#attribute "id") in - let res = Cic.AImplicit (id, ref None) in - register_id id res ; - res - end -;; - -class eltype_rel = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let value = int_of_xml_attr (n#attribute "value") - and binder = binder_of_xml_attr (n#attribute "binder") - and id = string_of_xml_attr (n#attribute "id") in - let res = Cic.ARel (id,ref None,value,binder) in - register_id id res ; - res - end -;; - -class eltype_meta = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let value = int_of_xml_attr (n#attribute "no") - and id = string_of_xml_attr (n#attribute "id") in - let res = Cic.AMeta (id,ref None,value) in - register_id id res ; - res - end -;; - -class eltype_var = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let name = string_of_xml_attr (n#attribute "relUri") - and xid = string_of_xml_attr (n#attribute "id") in - match Str.split (Str.regexp ",") name with - [index; id] -> - let get_prefix n = - let rec aux = - function - (0,_) -> "/" - | (n,he::tl) when n > 0 -> "/" ^ he ^ aux (n - 1, tl) - | _ -> raise (IllFormedXml 19) - in - aux (List.length !current_sp - n,!current_sp) - in - let res = - Cic.AVar - (xid,ref None, - (UriManager.uri_of_string - ("cic:" ^ get_prefix (int_of_string index) ^ id ^ ".var")) - ) - in - register_id id res ; - res - | _ -> raise (IllFormedXml 18) - end -;; - -class eltype_apply = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let children = n#sub_nodes - and id = string_of_xml_attr (n#attribute "id") in - if List.length children < 2 then raise (IllFormedXml 8) - else - let res = - Cic.AAppl - (id,ref None,List.map (fun x -> x#extension#to_cic_term) children) - in - register_id id res ; - res - end -;; - -class eltype_cast = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let sons = n#sub_nodes - and id = string_of_xml_attr (n#attribute "id") in - match sons with - [te ; ty] when - te#node_type = Pxp_document.T_element "term" && - ty#node_type = Pxp_document.T_element "type" -> - let term = te#extension#to_cic_term - and typ = ty#extension#to_cic_term in - let res = Cic.ACast (id,ref None,term,typ) in - register_id id res ; - res - | _ -> raise (IllFormedXml 9) - end -;; - -class eltype_sort = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let sort = cic_sort_of_xml_attr (n#attribute "value") - and id = string_of_xml_attr (n#attribute "id") in - let res = Cic.ASort (id,ref None,sort) in - register_id id res ; - res - end -;; - -class eltype_abst = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let value = uri_of_xml_attr (n#attribute "uri") - and id = string_of_xml_attr (n#attribute "id") in - let res = Cic.AAbst (id,ref None,value) in - register_id id res ; - res - end -;; - -class eltype_const = - object (self) - - inherit cic_term - - method to_cic_term = - let module U = UriManager in - let n = self#node in - let value = uri_of_xml_attr (n#attribute "uri") - and id = string_of_xml_attr (n#attribute "id") in - let res = - Cic.AConst (id,ref None,value, U.relative_depth !current_uri value 0) - in - register_id id res ; - res - end -;; - -class eltype_mutind = - object (self) - - inherit cic_term - - method to_cic_term = - let module U = UriManager in - let n = self#node in - let name = uri_of_xml_attr (n#attribute "uri") - and noType = int_of_xml_attr (n#attribute "noType") - and id = string_of_xml_attr (n#attribute "id") in - let res = - Cic.AMutInd - (id,ref None,name, U.relative_depth !current_uri name 0, noType) - in - register_id id res ; - res - end -;; - -class eltype_mutconstruct = - object (self) - - inherit cic_term - - method to_cic_term = - let module U = UriManager in - let n = self#node in - let name = uri_of_xml_attr (n#attribute "uri") - and noType = int_of_xml_attr (n#attribute "noType") - and noConstr = int_of_xml_attr (n#attribute "noConstr") - and id = string_of_xml_attr (n#attribute "id") in - let res = - Cic.AMutConstruct - (id, ref None, name, U.relative_depth !current_uri name 0, - noType, noConstr) - in - register_id id res ; - res - end -;; - -class eltype_prod = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let sons = n#sub_nodes - and id = string_of_xml_attr (n#attribute "id") in - match sons with - [s ; t] when - s#node_type = Pxp_document.T_element "source" && - t#node_type = Pxp_document.T_element "target" -> - let name = cic_attr_of_xml_attr (t#attribute "binder") - and source = s#extension#to_cic_term - and target = t#extension#to_cic_term in - let res = Cic.AProd (id,ref None,name,source,target) in - register_id id res ; - res - | _ -> raise (IllFormedXml 10) - end -;; - -class eltype_mutcase = - object (self) - - inherit cic_term - - method to_cic_term = - let module U = UriManager in - let n = self#node in - let sons = n#sub_nodes - and id = string_of_xml_attr (n#attribute "id") in - match sons with - ty::te::patterns when - ty#node_type = Pxp_document.T_element "patternsType" && - te#node_type = Pxp_document.T_element "inductiveTerm" -> - let ci = uri_of_xml_attr (n#attribute "uriType") - and typeno = int_of_xml_attr (n#attribute "noType") - and inductiveType = ty#extension#to_cic_term - and inductiveTerm = te#extension#to_cic_term - and lpattern= List.map (fun x -> x#extension#to_cic_term) patterns - in - let res = - Cic.AMutCase (id,ref None,ci,U.relative_depth !current_uri ci 0, - typeno,inductiveType,inductiveTerm,lpattern) - in - register_id id res ; - res - | _ -> raise (IllFormedXml 11) - end -;; - -class eltype_lambda = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let sons = n#sub_nodes - and id = string_of_xml_attr (n#attribute "id") in - match sons with - [s ; t] when - s#node_type = Pxp_document.T_element "source" && - t#node_type = Pxp_document.T_element "target" -> - let name = cic_attr_of_xml_attr (t#attribute "binder") - and source = s#extension#to_cic_term - and target = t#extension#to_cic_term in - let res = Cic.ALambda (id,ref None,name,source,target) in - register_id id res ; - res - | _ -> raise (IllFormedXml 12) - end -;; - -class eltype_letin = - object (self) - - inherit cic_term - - method to_cic_term = - let n = self#node in - let sons = n#sub_nodes - and id = string_of_xml_attr (n#attribute "id") in - match sons with - [s ; t] when - s#node_type = Pxp_document.T_element "term" && - t#node_type = Pxp_document.T_element "letintarget" -> - let name = cic_attr_of_xml_attr (t#attribute "binder") - and source = s#extension#to_cic_term - and target = t#extension#to_cic_term in - let res = Cic.ALetIn (id,ref None,name,source,target) in - register_id id res ; - res - | _ -> raise (IllFormedXml 12) - end -;; - -(* The definition of domspec, an hashtable that maps each node type to the *) -(* object that must be linked to it. Used by markup. *) - -let domspec = - let module D = Pxp_document in - D.make_spec_from_alist - ~data_exemplar: (new D.data_impl (new eltype_not_of_cic)) - ~default_element_exemplar: (new D.element_impl (new eltype_not_of_cic)) - ~element_alist: - [ "REL", (new D.element_impl (new eltype_rel)) ; - "VAR", (new D.element_impl (new eltype_var)) ; - "META", (new D.element_impl (new eltype_meta)) ; - "SORT", (new D.element_impl (new eltype_sort)) ; - "IMPLICIT", (new D.element_impl (new eltype_implicit)) ; - "CAST", (new D.element_impl (new eltype_cast)) ; - "PROD", (new D.element_impl (new eltype_prod)) ; - "LAMBDA", (new D.element_impl (new eltype_lambda)) ; - "LETIN", (new D.element_impl (new eltype_letin)) ; - "APPLY", (new D.element_impl (new eltype_apply)) ; - "CONST", (new D.element_impl (new eltype_const)) ; - "ABST", (new D.element_impl (new eltype_abst)) ; - "MUTIND", (new D.element_impl (new eltype_mutind)) ; - "MUTCONSTRUCT", (new D.element_impl (new eltype_mutconstruct)) ; - "MUTCASE", (new D.element_impl (new eltype_mutcase)) ; - "FIX", (new D.element_impl (new eltype_fix)) ; - "COFIX", (new D.element_impl (new eltype_cofix)) ; - "arity", (new D.element_impl (new eltype_transparent)) ; - "term", (new D.element_impl (new eltype_transparent)) ; - "type", (new D.element_impl (new eltype_transparent)) ; - "body", (new D.element_impl (new eltype_transparent)) ; - "source", (new D.element_impl (new eltype_transparent)) ; - "target", (new D.element_impl (new eltype_transparent)) ; - "patternsType", (new D.element_impl (new eltype_transparent)) ; - "inductiveTerm", (new D.element_impl (new eltype_transparent)) ; - "pattern", (new D.element_impl (new eltype_transparent)) - ] - () -;; diff --git a/helm/interface/cicParser3.mli b/helm/interface/cicParser3.mli deleted file mode 100644 index ada1b2e81..000000000 --- a/helm/interface/cicParser3.mli +++ /dev/null @@ -1,67 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module is the terms level of a parser for cic objects from xml *) -(* files to the internal representation. It is used by the module cicParser2 *) -(* (objects level). It defines an extension of the standard dom using the *) -(* object-oriented extension machinery of markup: an object with a method *) -(* to_cic_term that returns the internal representation of the subtree is *) -(* added to each node of the dom tree *) -(* *) -(******************************************************************************) - -exception IllFormedXml of int - -val ids_to_targets : (Cic.id, Cic.anntarget) Hashtbl.t option ref -val current_sp : string list ref -val current_uri : UriManager.uri ref -val process_annotations : bool ref - -(* the "interface" of the class linked to each node of the dom tree *) -class virtual cic_term : - object ('a) - - (* fields and methods ever required by markup *) - val mutable node : cic_term Pxp_document.node option - method clone : 'a - method node : cic_term Pxp_document.node - method set_node : cic_term Pxp_document.node -> unit - - (* a method that returns the internal representation of the tree (term) *) - (* rooted in this node *) - method virtual to_cic_term : Cic.annterm - - end - -(* The definition of domspec, an hashtable that maps each node type to the *) -(* object that must be linked to it. Used by markup. *) -val domspec : cic_term Pxp_document.spec diff --git a/helm/interface/cicPp.ml b/helm/interface/cicPp.ml deleted file mode 100644 index 0270f9919..000000000 --- a/helm/interface/cicPp.ml +++ /dev/null @@ -1,211 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a very simple Coq-like pretty printer that, given *) -(* an object of cic (internal representation) returns a string describing the *) -(* object in a syntax similar to that of coq *) -(* *) -(******************************************************************************) - -exception CicPpInternalError;; - -(* Utility functions *) - -let string_of_name = - function - Cic.Name s -> s - | Cic.Anonimous -> "_" -;; - -(* get_nth l n returns the nth element of the list l if it exists or raise *) -(* a CicPpInternalError if l has less than n elements or n < 1 *) -let rec get_nth l n = - match (n,l) with - (1, he::_) -> he - | (n, he::tail) when n > 1 -> get_nth tail (n-1) - | (_,_) -> raise CicPpInternalError -;; - -(* pp t l *) -(* pretty-prints a term t of cic in an environment l where l is a list of *) -(* identifier names used to resolve DeBrujin indexes. The head of l is the *) -(* name associated to the greatest DeBrujin index in t *) -let rec pp t l = - let module C = Cic in - match t with - C.Rel n -> - (match get_nth l n with - C.Name s -> s - | _ -> raise CicPpInternalError - ) - | C.Var uri -> UriManager.name_of_uri uri - | C.Meta n -> "?" ^ (string_of_int n) - | C.Sort s -> - (match s with - C.Prop -> "Prop" - | C.Set -> "Set" - | C.Type -> "Type" - ) - | C.Implicit -> "?" - | C.Prod (b,s,t) -> - (match b with - C.Name n -> "(" ^ n ^ ":" ^ pp s l ^ ")" ^ pp t (b::l) - | C.Anonimous -> "(" ^ pp s l ^ "->" ^ pp t (b::l) ^ ")" - ) - | C.Cast (v,t) -> pp v l - | C.Lambda (b,s,t) -> - "[" ^ string_of_name b ^ ":" ^ pp s l ^ "]" ^ pp t (b::l) - | C.LetIn (b,s,t) -> - "[" ^ string_of_name b ^ ":=" ^ pp s l ^ "]" ^ pp t (b::l) - | C.Appl li -> - "(" ^ - (List.fold_right - (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i) - li "" - ) ^ ")" - | C.Const (uri,_) -> UriManager.name_of_uri uri - | C.Abst uri -> UriManager.name_of_uri uri - | C.MutInd (uri,_,n) -> - (match CicCache.get_obj uri with - C.InductiveDefinition (dl,_,_) -> - let (name,_,_,_) = get_nth dl (n+1) in - name - | _ -> raise CicPpInternalError - ) - | C.MutConstruct (uri,_,n1,n2) -> - (match CicCache.get_obj uri with - C.InductiveDefinition (dl,_,_) -> - let (_,_,_,cons) = get_nth dl (n1+1) in - let (id,_,_) = get_nth cons n2 in - id - | _ -> raise CicPpInternalError - ) - | C.MutCase (uri,_,n1,ty,te,patterns) -> - let connames = - (match CicCache.get_obj uri with - C.InductiveDefinition (dl,_,_) -> - let (_,_,_,cons) = get_nth dl (n1+1) in - List.map (fun (id,_,_) -> id) cons - | _ -> raise CicPpInternalError - ) - in - "\n<" ^ pp ty l ^ ">Cases " ^ pp te l ^ " of " ^ - List.fold_right (fun (x,y) i -> "\n " ^ x ^ " => " ^ pp y l ^ i) - (List.combine connames patterns) "" ^ - "\nend" - | C.Fix (no, funs) -> - let snames = List.map (fun (name,_,_,_) -> name) funs in - let names = List.rev (List.map (function name -> C.Name name) snames) in - "\nFix " ^ get_nth snames (no + 1) ^ " {" ^ - List.fold_right - (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^ - " : " ^ pp ty l ^ " := \n" ^ - pp bo (names@l) ^ i) - funs "" ^ - "}\n" - | C.CoFix (no,funs) -> - let snames = List.map (fun (name,_,_) -> name) funs in - let names = List.rev (List.map (function name -> C.Name name) snames) in - "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^ - List.fold_right - (fun (name,ty,bo) i -> "\n" ^ name ^ - " : " ^ pp ty l ^ " := \n" ^ - pp bo (names@l) ^ i) - funs "" ^ - "}\n" -;; - -(* ppinductiveType (typename, inductive, arity, cons) names *) -(* pretty-prints a single inductive definition (typename, inductive, arity, *) -(* cons) where the cic terms in the inductive definition need to be *) -(* evaluated in the environment names that is the list of typenames of the *) -(* mutual inductive definitions defined in the block of mutual inductive *) -(* definitions to which this one belongs to *) -let ppinductiveType (typename, inductive, arity, cons) names = - (if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^ - (*CSC: bug found: was pp arity names ^ " =\n " ^*) - pp arity [] ^ " =\n " ^ - List.fold_right - (fun (id,ty,_) i -> id ^ " : " ^ pp ty names ^ - (if i = "" then "\n" else "\n | ") ^ i) - cons "" -;; - -(* ppobj obj returns a string with describing the cic object obj in a syntax *) -(* similar to the one used by Coq *) -let ppobj obj = - let module C = Cic in - let module U = UriManager in - match obj with - C.Definition (id, t1, t2, params) -> - "Definition of " ^ id ^ - "(" ^ - List.fold_right - (fun (_,x) i -> - List.fold_right - (fun x i -> - U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i' - ) x "" ^ match i with "" -> "" | i' -> " " ^ i' - ) params "" ^ ")" ^ - ":\n" ^ pp t1 [] ^ " : " ^ pp t2 [] - | C.Axiom (id, ty, params) -> - "Axiom " ^ id ^ "(" ^ - List.fold_right - (fun (_,x) i -> - List.fold_right - (fun x i -> - U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i' - ) x "" ^ match i with "" -> "" | i' -> " " ^ i' - ) params "" ^ - "):\n" ^ pp ty [] - | C.Variable (name, bo, ty) -> - "Variable " ^ name ^ ":\n" ^ pp ty [] ^ "\n" ^ - (match bo with None -> "" | Some bo -> ":= " ^ pp bo []) - | C.CurrentProof (name, conjectures, value, ty) -> - "Current Proof:\n" ^ - List.fold_right - (fun (n, t) i -> "?" ^ (string_of_int n) ^ ": " ^ pp t [] ^ "\n" ^ i) - conjectures "" ^ - "\n" ^ pp value [] ^ " : " ^ pp ty [] - | C.InductiveDefinition (l, params, nparams) -> - "Parameters = " ^ - List.fold_right - (fun (_,x) i -> - List.fold_right - (fun x i -> - U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i' - ) x "" ^ match i with "" -> "" | i' -> " " ^ i' - ) params "" ^ "\n" ^ - "NParams = " ^ string_of_int nparams ^ "\n" ^ - let names = List.rev (List.map (fun (n,_,_,_) -> C.Name n) l) in - List.fold_right (fun x i -> ppinductiveType x names ^ i) l "" -;; diff --git a/helm/interface/cicPp.mli b/helm/interface/cicPp.mli deleted file mode 100644 index 99757d186..000000000 --- a/helm/interface/cicPp.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a very simple Coq-like pretty printer that, given *) -(* an object of cic (internal representation) returns a string describing the *) -(* object in a syntax similar to that of coq *) -(* *) -(******************************************************************************) - -(* ppobj obj returns a string with describing the cic object obj in a syntax *) -(* similar to the one used by Coq *) -val ppobj : Cic.obj -> string diff --git a/helm/interface/cicReduction.ml b/helm/interface/cicReduction.ml deleted file mode 100644 index 65e2f71b8..000000000 --- a/helm/interface/cicReduction.ml +++ /dev/null @@ -1,278 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception CicReductionInternalError;; -exception WrongUriToInductiveDefinition;; - -let fdebug = ref 1;; -let debug t env s = - let rec debug_aux t i = - let module C = Cic in - let module U = UriManager in - CicPp.ppobj (C.Variable ("DEBUG", None, - C.Prod (C.Name "-9", C.Const (U.uri_of_string "cic:/dummy-9",0), - C.Prod (C.Name "-8", C.Const (U.uri_of_string "cic:/dummy-8",0), - C.Prod (C.Name "-7", C.Const (U.uri_of_string "cic:/dummy-7",0), - C.Prod (C.Name "-6", C.Const (U.uri_of_string "cic:/dummy-6",0), - C.Prod (C.Name "-5", C.Const (U.uri_of_string "cic:/dummy-5",0), - C.Prod (C.Name "-4", C.Const (U.uri_of_string "cic:/dummy-4",0), - C.Prod (C.Name "-3", C.Const (U.uri_of_string "cic:/dummy-3",0), - C.Prod (C.Name "-2", C.Const (U.uri_of_string "cic:/dummy-2",0), - C.Prod (C.Name "-1", C.Const (U.uri_of_string "cic:/dummy-1",0), - t - ) - ) - ) - ) - ) - ) - ) - ) - ) - )) ^ "\n" ^ i - in - if !fdebug = 0 then - begin - print_endline (s ^ "\n" ^ List.fold_right debug_aux (t::env) "") ; - flush stdout - end -;; - -exception Impossible of int;; -exception ReferenceToDefinition;; -exception ReferenceToAxiom;; -exception ReferenceToVariable;; -exception ReferenceToCurrentProof;; -exception ReferenceToInductiveDefinition;; - -(* takes a well-typed term *) -let whd = - let rec whdaux l = - let module C = Cic in - let module S = CicSubstitution in - function - C.Rel _ as t -> if l = [] then t else C.Appl (t::l) - | C.Var _ as t -> if l = [] then t else C.Appl (t::l) - | C.Meta _ as t -> if l = [] then t else C.Appl (t::l) - | C.Sort _ as t -> t (* l should be empty *) - | C.Implicit as t -> t - | C.Cast (te,ty) -> whdaux l te (*CSC E' GIUSTO BUTTARE IL CAST? *) - | C.Prod _ as t -> t (* l should be empty *) - | C.Lambda (name,s,t) as t' -> - (match l with - [] -> t' - | he::tl -> whdaux tl (S.subst he t) - (* when name is Anonimous the substitution should be superfluous *) - ) - | C.Appl (he::tl) -> whdaux (tl@l) he - | C.Appl [] -> raise (Impossible 1) - | C.Const (uri,cookingsno) as t -> - (match CicCache.get_cooked_obj uri cookingsno with - C.Definition (_,body,_,_) -> whdaux l body - | C.Axiom _ -> if l = [] then t else C.Appl (t::l) - (*CSC: Prossima riga sbagliata: Var punta alle variabili, non Const *) - | C.Variable _ -> if l = [] then t else C.Appl (t::l) - | C.CurrentProof (_,_,body,_) -> whdaux l body - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - | C.Abst _ as t -> t (*CSC l should be empty ????? *) - | C.MutInd (uri,_,_) as t -> if l = [] then t else C.Appl (t::l) - | C.MutConstruct (uri,_,_,_) as t -> if l = [] then t else C.Appl (t::l) - | C.MutCase (mutind,cookingsno,i,_,term,pl) as t -> - let decofix = - function - C.CoFix (i,fl) as t -> - let (_,_,body) = List.nth fl i in - let body' = - let counter = ref (List.length fl) in - List.fold_right - (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) - fl - body - in - whdaux [] body' - | C.Appl (C.CoFix (i,fl) :: tl) -> - let (_,_,body) = List.nth fl i in - let body' = - let counter = ref (List.length fl) in - List.fold_right - (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) - fl - body - in - whdaux tl body' - | t -> t - in - (match decofix (whdaux [] term) with - C.MutConstruct (_,_,_,j) -> whdaux l (List.nth pl (j-1)) - | C.Appl (C.MutConstruct (_,_,_,j) :: tl) -> - let (arity, r, num_ingredients) = - match CicCache.get_obj mutind with - C.InductiveDefinition (tl,ingredients,r) -> - let (_,_,arity,_) = List.nth tl i - and num_ingredients = - List.fold_right - (fun (k,l) i -> - if k < cookingsno then i + List.length l else i - ) ingredients 0 - in - (arity,r,num_ingredients) - | _ -> raise WrongUriToInductiveDefinition - in - let ts = - let num_to_eat = r + num_ingredients in - let rec eat_first = - function - (0,l) -> l - | (n,he::tl) when n > 0 -> eat_first (n - 1, tl) - | _ -> raise (Impossible 5) - in - eat_first (num_to_eat,tl) - in - whdaux (ts@l) (List.nth pl (j-1)) - | C.Abst _| C.Cast _ | C.Implicit -> - raise (Impossible 2) (* we don't trust our whd ;-) *) - | _ -> t - ) - | C.Fix (i,fl) as t -> - let (_,recindex,_,body) = List.nth fl i in - let recparam = - try - Some (List.nth l recindex) - with - _ -> None - in - (match recparam with - Some recparam -> - (match whdaux [] recparam with - C.MutConstruct _ - | C.Appl ((C.MutConstruct _)::_) -> - let body' = - let counter = ref (List.length fl) in - List.fold_right - (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl))) - fl - body - in - (* Possible optimization: substituting whd recparam in l *) - whdaux l body' - | _ -> if l = [] then t else C.Appl (t::l) - ) - | None -> if l = [] then t else C.Appl (t::l) - ) - | C.CoFix (i,fl) as t -> - (*CSC vecchio codice - let (_,_,body) = List.nth fl i in - let body' = - let counter = ref (List.length fl) in - List.fold_right - (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) - fl - body - in - whdaux l body' - *) - if l = [] then t else C.Appl (t::l) - in - whdaux [] -;; - -(* t1, t2 must be well-typed *) -let are_convertible t1 t2 = - let module U = UriManager in - let rec aux t1 t2 = - debug t1 [t2] "PREWHD"; - (* this trivial euristic cuts down the total time of about five times ;-) *) - (* this because most of the time t1 and t2 are "sintactically" the same *) - if t1 = t2 then - true - else - begin - let module C = Cic in - let t1' = whd t1 - and t2' = whd t2 in - debug t1' [t2'] "POSTWHD"; - (*if !fdebug = 0 then ignore(Unix.system "read" );*) - match (t1',t2') with - (C.Rel n1, C.Rel n2) -> n1 = n2 - | (C.Var uri1, C.Var uri2) -> U.eq uri1 uri2 - | (C.Meta n1, C.Meta n2) -> n1 = n2 - | (C.Sort s1, C.Sort s2) -> true (*CSC da finire con gli universi *) - | (C.Prod (_,s1,t1), C.Prod(_,s2,t2)) -> - aux s1 s2 && aux t1 t2 - | (C.Lambda (_,s1,t1), C.Lambda(_,s2,t2)) -> - aux s1 s2 && aux t1 t2 - | (C.Appl l1, C.Appl l2) -> - (try - List.fold_right2 (fun x y b -> aux x y && b) l1 l2 true - with - Invalid_argument _ -> false - ) - | (C.Const (uri1,_), C.Const (uri2,_)) -> - (*CSC: questo commento e' chiaro o delirante? Io lo sto scrivendo *) - (*CSC: mentre sono delirante, quindi ... *) - (* WARNING: it is really important that the two cookingsno are not *) - (* checked for equality. This allows not to cook an object with no *) - (* ingredients only to update the cookingsno. E.g: if a term t has *) - (* a reference to a term t1 which does not depend on any variable *) - (* and t1 depends on a term t2 (that can't depend on any variable *) - (* because of t1), then t1 cooked at every level could be the same *) - (* as t1 cooked at level 0. Doing so, t2 will be extended in t *) - (* with cookingsno 0 and not 2. But this will not cause any trouble*) - (* if here we don't check that the two cookingsno are equal. *) - U.eq uri1 uri2 - | (C.MutInd (uri1,k1,i1), C.MutInd (uri2,k2,i2)) -> - (* WARNIG: see the previous warning *) - U.eq uri1 uri2 && i1 = i2 - | (C.MutConstruct (uri1,_,i1,j1), C.MutConstruct (uri2,_,i2,j2)) -> - (* WARNIG: see the previous warning *) - U.eq uri1 uri2 && i1 = i2 && j1 = j2 - | (C.MutCase (uri1,_,i1,outtype1,term1,pl1), - C.MutCase (uri2,_,i2,outtype2,term2,pl2)) -> - (* WARNIG: see the previous warning *) - (* aux outtype1 outtype2 should be true if aux pl1 pl2 *) - U.eq uri1 uri2 && i1 = i2 && aux outtype1 outtype2 && - aux term1 term2 && - List.fold_right2 (fun x y b -> b && aux x y) pl1 pl2 true - | (C.Fix (i1,fl1), C.Fix (i2,fl2)) -> - i1 = i2 && - List.fold_right2 - (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) b -> - b && recindex1 = recindex2 && aux ty1 ty2 && aux bo1 bo2) - fl1 fl2 true - | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) -> - i1 = i2 && - List.fold_right2 - (fun (_,ty1,bo1) (_,ty2,bo2) b -> - b && aux ty1 ty2 && aux bo1 bo2) - fl1 fl2 true - | (C.Abst _, _) | (_, C.Abst _) | (C.Cast _, _) | (_, C.Cast _) - | (C.Implicit, _) | (_, C.Implicit) -> - raise (Impossible 3) (* we don't trust our whd ;-) *) - | (_,_) -> false - end - in - aux t1 t2 -;; diff --git a/helm/interface/cicReduction.mli b/helm/interface/cicReduction.mli deleted file mode 100644 index d61bc7251..000000000 --- a/helm/interface/cicReduction.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception WrongUriToInductiveDefinition -exception ReferenceToDefinition -exception ReferenceToAxiom -exception ReferenceToVariable -exception ReferenceToCurrentProof -exception ReferenceToInductiveDefinition -val fdebug : int ref -val whd : Cic.term -> Cic.term -val are_convertible : Cic.term -> Cic.term -> bool diff --git a/helm/interface/cicSubstitution.ml b/helm/interface/cicSubstitution.ml deleted file mode 100644 index 434e67025..000000000 --- a/helm/interface/cicSubstitution.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -let lift n = - let rec liftaux k = - let module C = Cic in - function - C.Rel m -> - if m < k then - C.Rel m - else - C.Rel (m + n) - | C.Var _ as t -> t - | C.Meta _ as t -> t - | C.Sort _ as t -> t - | C.Implicit as t -> t - | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty) - | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t) - | C.Appl l -> C.Appl (List.map (liftaux k) l) - | C.Const _ as t -> t - | C.Abst _ as t -> t - | C.MutInd _ as t -> t - | C.MutConstruct _ as t -> t - | C.MutCase (sp,cookingsno,i,outty,t,pl) -> - C.MutCase (sp, cookingsno, i, liftaux k outty, liftaux k t, - List.map (liftaux k) pl) - | C.Fix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (k+len) bo)) - fl - in - C.Fix (i, liftedfl) - | C.CoFix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, ty, bo) -> (name, liftaux k ty, liftaux (k+len) bo)) - fl - in - C.CoFix (i, liftedfl) - in - liftaux 1 -;; - -let subst arg = - let rec substaux k = - let module C = Cic in - function - C.Rel n as t -> - (match n with - n when n = k -> lift (k - 1) arg - | n when n < k -> t - | _ -> C.Rel (n - 1) - ) - | C.Var _ as t -> t - | C.Meta _ as t -> t - | C.Sort _ as t -> t - | C.Implicit as t -> t - | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty) (*CSC ??? *) - | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t) - | C.Appl l -> C.Appl (List.map (substaux k) l) - | C.Const _ as t -> t - | C.Abst _ as t -> t - | C.MutInd _ as t -> t - | C.MutConstruct _ as t -> t - | C.MutCase (sp,cookingsno,i,outt,t,pl) -> - C.MutCase (sp,cookingsno,i,substaux k outt, substaux k t, - List.map (substaux k) pl) - | C.Fix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo)) - fl - in - C.CoFix (i, substitutedfl) - in - substaux 1 -;; - -let undebrujin_inductive_def uri = - function - Cic.InductiveDefinition (dl,params,n_ind_params) -> - let dl' = - List.map - (fun (name,inductive,arity,constructors) -> - let constructors' = - List.map - (fun (name,ty,r) -> - let ty' = - let counter = ref (List.length dl) in - List.fold_right - (fun _ -> - decr counter ; - subst (Cic.MutInd (uri,0,!counter)) - ) dl ty - in - (name,ty',r) - ) constructors - in - (name,inductive,arity,constructors') - ) dl - in - Cic.InductiveDefinition (dl', params, n_ind_params) - | obj -> obj -;; diff --git a/helm/interface/cicSubstitution.mli b/helm/interface/cicSubstitution.mli deleted file mode 100644 index 72e9a32c2..000000000 --- a/helm/interface/cicSubstitution.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val lift : int -> Cic.term -> Cic.term -val subst : Cic.term -> Cic.term -> Cic.term -val undebrujin_inductive_def : UriManager.uri -> Cic.obj -> Cic.obj diff --git a/helm/interface/cicTypeChecker.ml b/helm/interface/cicTypeChecker.ml deleted file mode 100644 index ea1c28ca2..000000000 --- a/helm/interface/cicTypeChecker.ml +++ /dev/null @@ -1,1255 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception NotImplemented;; -exception Impossible;; -exception NotWellTyped of string;; -exception WrongUriToConstant of string;; -exception WrongUriToVariable of string;; -exception WrongUriToMutualInductiveDefinitions of string;; -exception ListTooShort;; -exception NotPositiveOccurrences of string;; -exception NotWellFormedTypeOfInductiveConstructor of string;; -exception WrongRequiredArgument of string;; - -let fdebug = ref 0;; -let debug t env = - let rec debug_aux t i = - let module C = Cic in - let module U = UriManager in - CicPp.ppobj (C.Variable ("DEBUG", None, - C.Prod (C.Name "-15", C.Const (U.uri_of_string "cic:/dummy-15",0), - C.Prod (C.Name "-14", C.Const (U.uri_of_string "cic:/dummy-14",0), - C.Prod (C.Name "-13", C.Const (U.uri_of_string "cic:/dummy-13",0), - C.Prod (C.Name "-12", C.Const (U.uri_of_string "cic:/dummy-12",0), - C.Prod (C.Name "-11", C.Const (U.uri_of_string "cic:/dummy-11",0), - C.Prod (C.Name "-10", C.Const (U.uri_of_string "cic:/dummy-10",0), - C.Prod (C.Name "-9", C.Const (U.uri_of_string "cic:/dummy-9",0), - C.Prod (C.Name "-8", C.Const (U.uri_of_string "cic:/dummy-8",0), - C.Prod (C.Name "-7", C.Const (U.uri_of_string "cic:/dummy-7",0), - C.Prod (C.Name "-6", C.Const (U.uri_of_string "cic:/dummy-6",0), - C.Prod (C.Name "-5", C.Const (U.uri_of_string "cic:/dummy-5",0), - C.Prod (C.Name "-4", C.Const (U.uri_of_string "cic:/dummy-4",0), - C.Prod (C.Name "-3", C.Const (U.uri_of_string "cic:/dummy-3",0), - C.Prod (C.Name "-2", C.Const (U.uri_of_string "cic:/dummy-2",0), - C.Prod (C.Name "-1", C.Const (U.uri_of_string "cic:/dummy-1",0), - t - ) - ) - ) - ) - ) - ) - ) - ) - ))))))) - )) ^ "\n" ^ i - in - if !fdebug = 0 then - raise (NotWellTyped ("\n" ^ List.fold_right debug_aux (t::env) "")) - (*print_endline ("\n" ^ List.fold_right debug_aux (t::env) "") ; flush stdout*) -;; - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> raise ListTooShort -;; - -exception CicCacheError;; - -let rec cooked_type_of_constant uri cookingsno = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj = - match CicCache.is_type_checked uri cookingsno with - CicCache.CheckedObj cobj -> cobj - | CicCache.UncheckedObj uobj -> - (* let's typecheck the uncooked obj *) - (match uobj with - C.Definition (_,te,ty,_) -> - let _ = type_of ty in - if not (R.are_convertible (type_of te) ty) then - raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri))) - | C.Axiom (_,ty,_) -> - (* only to check that ty is well-typed *) - let _ = type_of ty in () - | C.CurrentProof (_,_,te,ty) -> - let _ = type_of ty in - if not (R.are_convertible (type_of te) ty) then - raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri))) - | _ -> raise (WrongUriToConstant (U.string_of_uri uri)) - ) ; - CicCache.set_type_checking_info uri ; - match CicCache.is_type_checked uri cookingsno with - CicCache.CheckedObj cobj -> cobj - | CicCache.UncheckedObj _ -> raise CicCacheError - in - match cobj with - C.Definition (_,_,ty,_) -> ty - | C.Axiom (_,ty,_) -> ty - | C.CurrentProof (_,_,_,ty) -> ty - | _ -> raise (WrongUriToConstant (U.string_of_uri uri)) - -and type_of_variable uri = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - (* 0 because a variable is never cooked => no partial cooking at one level *) - match CicCache.is_type_checked uri 0 with - CicCache.CheckedObj (C.Variable (_,_,ty)) -> ty - | CicCache.UncheckedObj (C.Variable (_,bo,ty)) -> - (* only to check that ty is well-typed *) - let _ = type_of ty in - (match bo with - None -> () - | Some bo -> - if not (R.are_convertible (type_of bo) ty) then - raise (NotWellTyped ("Variable " ^ (U.string_of_uri uri))) - ) ; - CicCache.set_type_checking_info uri ; - ty - | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri)) - -and does_not_occur n nn te = - let module C = Cic in - (*CSC: whd sembra essere superflua perche' un caso in cui l'occorrenza *) - (*CSC: venga mangiata durante la whd sembra presentare problemi di *) - (*CSC: universi *) - match CicReduction.whd te with - C.Rel m when m > n && m <= nn -> false - | C.Rel _ - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit -> true - | C.Cast (te,ty) -> does_not_occur n nn te && does_not_occur n nn ty - | C.Prod (_,so,dest) -> - does_not_occur n nn so && does_not_occur (n + 1) (nn + 1) dest - | C.Lambda (_,so,dest) -> - does_not_occur n nn so && does_not_occur (n + 1) (nn + 1) dest - | C.LetIn (_,so,dest) -> - does_not_occur n nn so && does_not_occur (n + 1) (nn + 1) dest - | C.Appl l -> - List.fold_right (fun x i -> i && does_not_occur n nn x) l true - | C.Const _ - | C.Abst _ - | C.MutInd _ - | C.MutConstruct _ -> true - | C.MutCase (_,_,_,out,te,pl) -> - does_not_occur n nn out && does_not_occur n nn te && - List.fold_right (fun x i -> i && does_not_occur n nn x) pl true - | C.Fix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - let nn_plus_len = nn + len in - List.fold_right - (fun (_,_,ty,bo) i -> - i && does_not_occur n_plus_len nn_plus_len ty && - does_not_occur n_plus_len nn_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - let nn_plus_len = nn + len in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur n_plus_len nn_plus_len ty && - does_not_occur n_plus_len nn_plus_len bo - ) fl true - -(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *) -(*CSC questa funzione e' simile alla are_all_occurrences_positive, ma fa *) -(*CSC dei controlli leggermente diversi. Viene invocata solamente dalla *) -(*CSC strictly_positive *) -(*CSC definizione (giusta???) tratta dalla mail di Hugo ;-) *) -and weakly_positive n nn uri te = - let module C = Cic in - (*CSC mettere in cicSubstitution *) - let rec subst_inductive_type_with_dummy_rel = - function - C.MutInd (uri',_,0) when UriManager.eq uri' uri -> - C.Rel 0 (* dummy rel *) - | C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri -> - C.Rel 0 (* dummy rel *) - | C.Cast (te,ty) -> subst_inductive_type_with_dummy_rel te - | C.Prod (name,so,ta) -> - C.Prod (name, subst_inductive_type_with_dummy_rel so, - subst_inductive_type_with_dummy_rel ta) - | C.Lambda (name,so,ta) -> - C.Lambda (name, subst_inductive_type_with_dummy_rel so, - subst_inductive_type_with_dummy_rel ta) - | C.Appl tl -> - C.Appl (List.map subst_inductive_type_with_dummy_rel tl) - | C.MutCase (uri,cookingsno,i,outtype,term,pl) -> - C.MutCase (uri,cookingsno,i, - subst_inductive_type_with_dummy_rel outtype, - subst_inductive_type_with_dummy_rel term, - List.map subst_inductive_type_with_dummy_rel pl) - | C.Fix (i,fl) -> - C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i, - subst_inductive_type_with_dummy_rel ty, - subst_inductive_type_with_dummy_rel bo)) fl) - | C.CoFix (i,fl) -> - C.CoFix (i,List.map (fun (name,ty,bo) -> (name, - subst_inductive_type_with_dummy_rel ty, - subst_inductive_type_with_dummy_rel bo)) fl) - | t -> t - in - match CicReduction.whd te with - C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri -> true - | C.MutInd (uri',_,0) when UriManager.eq uri' uri -> true - | C.Prod (C.Anonimous,source,dest) -> - strictly_positive n nn (subst_inductive_type_with_dummy_rel source) && - weakly_positive (n + 1) (nn + 1) uri dest - | C.Prod (name,source,dest) when does_not_occur 0 n dest -> - (* dummy abstraction, so we behave as in the anonimous case *) - strictly_positive n nn (subst_inductive_type_with_dummy_rel source) && - weakly_positive (n + 1) (nn + 1) uri dest - | C.Prod (_,source,dest) -> - does_not_occur n nn (subst_inductive_type_with_dummy_rel source) && - weakly_positive (n + 1) (nn + 1) uri dest - | _ -> raise (NotWellFormedTypeOfInductiveConstructor ("Guess where the error is ;-)")) - -(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *) -(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *) -and instantiate_parameters params c = - let module C = Cic in - match (c,params) with - (c,[]) -> c - | (C.Prod (_,_,ta), he::tl) -> - instantiate_parameters tl - (CicSubstitution.subst he ta) - | (C.Cast (te,_), _) -> instantiate_parameters params te - | (t,l) -> raise Impossible - -and strictly_positive n nn te = - let module C = Cic in - let module U = UriManager in - match CicReduction.whd te with - C.Rel _ -> true - | C.Cast (te,ty) -> - (*CSC: bisogna controllare ty????*) - strictly_positive n nn te - | C.Prod (_,so,ta) -> - does_not_occur n nn so && - strictly_positive (n+1) (nn+1) ta - | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> - List.fold_right (fun x i -> i && does_not_occur n nn x) tl true - | C.Appl ((C.MutInd (uri,_,i))::tl) -> - let (ok,paramsno,cl) = - match CicCache.get_obj uri with - C.InductiveDefinition (tl,_,paramsno) -> - let (_,_,_,cl) = List.nth tl i in - (List.length tl = 1, paramsno, cl) - | _ -> raise(WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) - in - let (params,arguments) = split tl paramsno in - let lifted_params = List.map (CicSubstitution.lift 1) params in - let cl' = - List.map (fun (_,te,_) -> instantiate_parameters lifted_params te) cl - in - ok && - List.fold_right - (fun x i -> i && does_not_occur n nn x) - arguments true && - (*CSC: MEGAPATCH3 (sara' quella giusta?)*) - List.fold_right - (fun x i -> - i && - weakly_positive (n+1) (nn+1) uri x - ) cl' true - | C.MutInd (uri,_,i) -> - (match CicCache.get_obj uri with - C.InductiveDefinition (tl,_,_) -> - List.length tl = 1 - | _ -> raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) - ) - | t -> does_not_occur n nn t - -(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *) -and are_all_occurrences_positive uri indparamsno i n nn te = - let module C = Cic in - match CicReduction.whd te with - C.Appl ((C.Rel m)::tl) when m = i -> - (*CSC: riscrivere fermandosi a 0 *) - (* let's check if the inductive type is applied at least to *) - (* indparamsno parameters *) - let last = - List.fold_left - (fun k x -> - if k = 0 then 0 - else - match CicReduction.whd x with - C.Rel m when m = n - (indparamsno - k) -> k - 1 - | _ -> raise (WrongRequiredArgument (UriManager.string_of_uri uri)) - ) indparamsno tl - in - if last = 0 then - List.fold_right (fun x i -> i && does_not_occur n nn x) tl true - else - raise (WrongRequiredArgument (UriManager.string_of_uri uri)) - | C.Rel m when m = i -> - if indparamsno = 0 then - true - else - raise (WrongRequiredArgument (UriManager.string_of_uri uri)) - | C.Prod (C.Anonimous,source,dest) -> - strictly_positive n nn source && - are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest - | C.Prod (name,source,dest) when does_not_occur 0 n dest -> - (* dummy abstraction, so we behave as in the anonimous case *) - strictly_positive n nn source && - are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest - | C.Prod (_,source,dest) -> - does_not_occur n nn source && - are_all_occurrences_positive uri indparamsno (i+1) (n + 1) (nn + 1) dest - | _ -> raise (NotWellFormedTypeOfInductiveConstructor (UriManager.string_of_uri uri)) - -(*CSC: cambiare il nome, torna unit! *) -and cooked_mutual_inductive_defs uri = - let module U = UriManager in - function - Cic.InductiveDefinition (itl, _, indparamsno) -> - (* let's check if the arity of the inductive types are well *) - (* formed *) - List.iter (fun (_,_,x,_) -> let _ = type_of x in ()) itl ; - - (* let's check if the types of the inductive constructors *) - (* are well formed. *) - (* In order not to use type_of_aux we put the types of the *) - (* mutual inductive types at the head of the types of the *) - (* constructors using Prods *) - (*CSC: piccola??? inefficienza *) - let len = List.length itl in - let _ = - List.fold_right - (fun (_,_,_,cl) i -> - List.iter - (fun (name,te,r) -> - let augmented_term = - List.fold_right - (fun (name,_,ty,_) i -> Cic.Prod (Cic.Name name, ty, i)) - itl te - in - let _ = type_of augmented_term in - (* let's check also the positivity conditions *) - if not (are_all_occurrences_positive uri indparamsno i 0 len te) - then - raise (NotPositiveOccurrences (U.string_of_uri uri)) - else - match !r with - Some _ -> raise Impossible - | None -> r := Some (recursive_args 0 len te) - ) cl ; - (i + 1) - ) itl 1 - in - () - | _ -> - raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - -and cooked_type_of_mutual_inductive_defs uri cookingsno i = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj = - match CicCache.is_type_checked uri cookingsno with - CicCache.CheckedObj cobj -> cobj - | CicCache.UncheckedObj uobj -> - cooked_mutual_inductive_defs uri uobj ; - CicCache.set_type_checking_info uri ; - (match CicCache.is_type_checked uri cookingsno with - CicCache.CheckedObj cobj -> cobj - | CicCache.UncheckedObj _ -> raise CicCacheError - ) - in - match cobj with - C.InductiveDefinition (dl,_,_) -> - let (_,_,arity,_) = List.nth dl i in - arity - | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - -and cooked_type_of_mutual_inductive_constr uri cookingsno i j = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj = - match CicCache.is_type_checked uri cookingsno with - CicCache.CheckedObj cobj -> cobj - | CicCache.UncheckedObj uobj -> - cooked_mutual_inductive_defs uri uobj ; - CicCache.set_type_checking_info uri ; - (match CicCache.is_type_checked uri cookingsno with - CicCache.CheckedObj cobj -> cobj - | CicCache.UncheckedObj _ -> raise CicCacheError - ) - in - match cobj with - C.InductiveDefinition (dl,_,_) -> - let (_,_,_,cl) = List.nth dl i in - let (_,ty,_) = List.nth cl (j-1) in - ty - | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - -and recursive_args n nn te = - let module C = Cic in - match CicReduction.whd te with - C.Rel _ -> [] - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit - | C.Cast _ (*CSC ??? *) -> raise Impossible (* due to type-checking *) - | C.Prod (_,so,de) -> - (not (does_not_occur n nn so))::(recursive_args (n+1) (nn + 1) de) - | C.Lambda _ -> raise Impossible (* due to type-checking *) - | C.LetIn _ -> raise NotImplemented - | C.Appl _ -> [] - | C.Const _ - | C.Abst _ -> raise Impossible - | C.MutInd _ - | C.MutConstruct _ - | C.MutCase _ - | C.Fix _ - | C.CoFix _ -> raise Impossible (* due to type-checking *) - -and get_new_safes p c rl safes n nn x = - let module C = Cic in - let module U = UriManager in - let module R = CicReduction in - match (R.whd c, R.whd p, rl) with - (C.Prod (_,_,ta1), C.Lambda (_,_,ta2), b::tl) -> - (* we are sure that the two sources are convertible because we *) - (* have just checked this. So let's go along ... *) - let safes' = - List.map (fun x -> x + 1) safes - in - let safes'' = - if b then 1::safes' else safes' - in - get_new_safes ta2 ta1 tl safes'' (n+1) (nn+1) (x+1) - | (C.MutInd _, e, []) -> (e,safes,n,nn,x) - | (C.Appl _, e, []) -> (e,safes,n,nn,x) - | (_,_,_) -> raise Impossible - -and eat_prods n te = - let module C = Cic in - let module R = CicReduction in - match (n, R.whd te) with - (0, _) -> te - | (n, C.Prod (_,_,ta)) when n > 0 -> eat_prods (n - 1) ta - | (_, _) -> raise Impossible - -and eat_lambdas n te = - let module C = Cic in - let module R = CicReduction in - match (n, R.whd te) with - (0, _) -> (te, 0) - | (n, C.Lambda (_,_,ta)) when n > 0 -> - let (te, k) = eat_lambdas (n - 1) ta in - (te, k + 1) - | (_, _) -> raise Impossible - -(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *) -and check_is_really_smaller_arg n nn kl x safes te = - (*CSC: forse la whd si puo' fare solo quando serve veramente. *) - (*CSC: cfr guarded_by_destructors *) - let module C = Cic in - let module U = UriManager in - match CicReduction.whd te with - C.Rel m when List.mem m safes -> true - | C.Rel _ -> false - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit - | C.Cast _ -(* | C.Cast (te,ty) -> - check_is_really_smaller_arg n nn kl x safes te && - check_is_really_smaller_arg n nn kl x safes ty*) -(* | C.Prod (_,so,ta) -> - check_is_really_smaller_arg n nn kl x safes so && - check_is_really_smaller_arg (n+1) (nn+1) kl (x+1) - (List.map (fun x -> x + 1) safes) ta*) - | C.Prod _ -> raise Impossible - | C.Lambda (_,so,ta) -> - check_is_really_smaller_arg n nn kl x safes so && - check_is_really_smaller_arg (n+1) (nn+1) kl (x+1) - (List.map (fun x -> x + 1) safes) ta - | C.LetIn (_,so,ta) -> - check_is_really_smaller_arg n nn kl x safes so && - check_is_really_smaller_arg (n+1) (nn+1) kl (x+1) - (List.map (fun x -> x + 1) safes) ta - | C.Appl (he::_) -> - (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *) - (*CSC: solo perche' non abbiamo trovato controesempi *) - check_is_really_smaller_arg n nn kl x safes he - | C.Appl [] -> raise Impossible - | C.Const _ - | C.Abst _ - | C.MutInd _ -> raise Impossible - | C.MutConstruct _ -> false - | C.MutCase (uri,_,i,outtype,term,pl) -> - (match term with - C.Rel m when List.mem m safes || m = x -> - let (isinductive,paramsno,cl) = - match CicCache.get_obj uri with - C.InductiveDefinition (tl,_,paramsno) -> - let (_,isinductive,_,cl) = List.nth tl i in - let cl' = - List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl - in - (isinductive,paramsno,cl') - | _ -> - raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) - in - if not isinductive then - List.fold_right - (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p) - pl true - else - List.fold_right - (fun (p,(_,c,rl)) i -> - let rl' = - match !rl with - Some rl' -> - let (_,rl'') = split rl' paramsno in - rl'' - | None -> raise Impossible - in - let (e,safes',n',nn',x') = - get_new_safes p c rl' safes n nn x - in - i && - check_is_really_smaller_arg n' nn' kl x' safes' e - ) (List.combine pl cl) true - | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> - let (isinductive,paramsno,cl) = - match CicCache.get_obj uri with - C.InductiveDefinition (tl,_,paramsno) -> - let (_,isinductive,_,cl) = List.nth tl i in - let cl' = - List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl - in - (isinductive,paramsno,cl') - | _ -> - raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) - in - if not isinductive then - List.fold_right - (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p) - pl true - else - (*CSC: supponiamo come prima che nessun controllo sia necessario*) - (*CSC: sugli argomenti di una applicazione *) - List.fold_right - (fun (p,(_,c,rl)) i -> - let rl' = - match !rl with - Some rl' -> - let (_,rl'') = split rl' paramsno in - rl'' - | None -> raise Impossible - in - let (e, safes',n',nn',x') = - get_new_safes p c rl' safes n nn x - in - i && - check_is_really_smaller_arg n' nn' kl x' safes' e - ) (List.combine pl cl) true - | _ -> - List.fold_right - (fun p i -> i && check_is_really_smaller_arg n nn kl x safes p) - pl true - ) - | C.Fix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,_,ty,bo) i -> - i && - check_is_really_smaller_arg n_plus_len nn_plus_len kl x_plus_len - safes' bo - ) fl true - | C.CoFix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,ty,bo) i -> - i && - check_is_really_smaller_arg n_plus_len nn_plus_len kl x_plus_len - safes' bo - ) fl true - -and guarded_by_destructors n nn kl x safes = - let module C = Cic in - let module U = UriManager in - function - C.Rel m when m > n && m <= nn -> false - | C.Rel _ - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit -> true - | C.Cast (te,ty) -> - guarded_by_destructors n nn kl x safes te && - guarded_by_destructors n nn kl x safes ty - | C.Prod (_,so,ta) -> - guarded_by_destructors n nn kl x safes so && - guarded_by_destructors (n+1) (nn+1) kl (x+1) - (List.map (fun x -> x + 1) safes) ta - | C.Lambda (_,so,ta) -> - guarded_by_destructors n nn kl x safes so && - guarded_by_destructors (n+1) (nn+1) kl (x+1) - (List.map (fun x -> x + 1) safes) ta - | C.LetIn (_,so,ta) -> - guarded_by_destructors n nn kl x safes so && - guarded_by_destructors (n+1) (nn+1) kl (x+1) - (List.map (fun x -> x + 1) safes) ta - | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> - let k = List.nth kl (m - n - 1) in - if not (List.length tl > k) then false - else - List.fold_right - (fun param i -> - i && guarded_by_destructors n nn kl x safes param - ) tl true && - check_is_really_smaller_arg n nn kl x safes (List.nth tl k) - | C.Appl tl -> - List.fold_right (fun t i -> i && guarded_by_destructors n nn kl x safes t) - tl true - | C.Const _ - | C.Abst _ - | C.MutInd _ - | C.MutConstruct _ -> true - | C.MutCase (uri,_,i,outtype,term,pl) -> - (match term with - C.Rel m when List.mem m safes || m = x -> - let (isinductive,paramsno,cl) = - match CicCache.get_obj uri with - C.InductiveDefinition (tl,_,paramsno) -> - let (_,isinductive,_,cl) = List.nth tl i in - let cl' = - List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl - in - (isinductive,paramsno,cl') - | _ -> - raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) - in - if not isinductive then - guarded_by_destructors n nn kl x safes outtype && - guarded_by_destructors n nn kl x safes term && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun p i -> i && guarded_by_destructors n nn kl x safes p) - pl true - else - guarded_by_destructors n nn kl x safes outtype && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun (p,(_,c,rl)) i -> - let rl' = - match !rl with - Some rl' -> - let (_,rl'') = split rl' paramsno in - rl'' - | None -> raise Impossible - in - let (e,safes',n',nn',x') = - get_new_safes p c rl' safes n nn x - in - i && - guarded_by_destructors n' nn' kl x' safes' e - ) (List.combine pl cl) true - | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> - let (isinductive,paramsno,cl) = - match CicCache.get_obj uri with - C.InductiveDefinition (tl,_,paramsno) -> - let (_,isinductive,_,cl) = List.nth tl i in - let cl' = - List.map (fun (id,ty,r) -> (id, eat_prods paramsno ty, r)) cl - in - (isinductive,paramsno,cl') - | _ -> - raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)) - in - if not isinductive then - guarded_by_destructors n nn kl x safes outtype && - guarded_by_destructors n nn kl x safes term && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun p i -> i && guarded_by_destructors n nn kl x safes p) - pl true - else - guarded_by_destructors n nn kl x safes outtype && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun t i -> i && guarded_by_destructors n nn kl x safes t) - tl true && - List.fold_right - (fun (p,(_,c,rl)) i -> - let rl' = - match !rl with - Some rl' -> - let (_,rl'') = split rl' paramsno in - rl'' - | None -> raise Impossible - in - let (e, safes',n',nn',x') = - get_new_safes p c rl' safes n nn x - in - i && - guarded_by_destructors n' nn' kl x' safes' e - ) (List.combine pl cl) true - | _ -> - guarded_by_destructors n nn kl x safes outtype && - guarded_by_destructors n nn kl x safes term && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun p i -> i && guarded_by_destructors n nn kl x safes p) - pl true - ) - | C.Fix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,_,ty,bo) i -> - i && guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len - safes' ty && - guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len - safes' bo - ) fl true - | C.CoFix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,ty,bo) i -> - i && guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len - safes' ty && - guarded_by_destructors n_plus_len nn_plus_len kl x_plus_len safes' - bo - ) fl true - -(*CSC h = 0 significa non ancora protetto *) -and guarded_by_constructors n nn h = - let module C = Cic in - function - C.Rel m when m > n && m <= nn -> h = 1 - | C.Rel _ - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit -> true (*CSC: ma alcuni sono impossibili!!!! vedi Prod *) - | C.Cast (te,ty) -> - guarded_by_constructors n nn h te && - guarded_by_constructors n nn h ty - | C.Prod (_,so,de) -> - raise Impossible (* the term has just been type-checked *) - | C.Lambda (_,so,de) -> - does_not_occur n nn so && - guarded_by_constructors (n + 1) (nn + 1) h de - | C.LetIn (_,so,de) -> - does_not_occur n nn so && - guarded_by_constructors (n + 1) (nn + 1) h de - | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> - h = 1 && - List.fold_right (fun x i -> i && does_not_occur n nn x) tl true - | C.Appl ((C.MutConstruct (uri,cookingsno,i,j))::tl) -> - let (is_coinductive, rl) = - match CicCache.get_cooked_obj uri cookingsno with - C.InductiveDefinition (itl,_,_) -> - let (_,is_inductive,_,cl) = List.nth itl i in - let (_,cons,rrec_args) = List.nth cl (j - 1) in - (match !rrec_args with - None -> raise Impossible - | Some rec_args -> (not is_inductive, rec_args) - ) - | _ -> - raise (WrongUriToMutualInductiveDefinitions - (UriManager.string_of_uri uri)) - in - is_coinductive && - List.fold_right - (fun (x,r) i -> - i && - if r then - guarded_by_constructors n nn 1 x - else - does_not_occur n nn x - ) (List.combine tl rl) true - | C.Appl l -> - List.fold_right (fun x i -> i && does_not_occur n nn x) l true - | C.Const _ - | C.Abst _ - | C.MutInd _ - | C.MutConstruct _ -> true (*CSC: ma alcuni sono impossibili!!!! vedi Prod *) - | C.MutCase (_,_,_,out,te,pl) -> - let rec returns_a_coinductive = - function - (*CSC: per le regole di tipaggio, la chiamata ricorsiva verra' *) - (*CSC: effettata solo una volta, per mangiarsi l'astrazione *) - (*CSC: non dummy *) - C.Lambda (_,_,de) -> returns_a_coinductive de - | C.MutInd (uri,_,i) -> - (*CSC: definire una funzioncina per questo codice sempre replicato *) - (match CicCache.get_obj uri with - C.InductiveDefinition (itl,_,_) -> - let (_,is_inductive,_,_) = List.nth itl i in - not is_inductive - | _ -> - raise (WrongUriToMutualInductiveDefinitions - (UriManager.string_of_uri uri)) - ) - (*CSC: bug nella prossima riga (manca la whd) *) - | C.Appl ((C.MutInd (uri,_,i))::_) -> - (match CicCache.get_obj uri with - C.InductiveDefinition (itl,_,_) -> - let (_,is_inductive,_,_) = List.nth itl i in - not is_inductive - | _ -> - raise (WrongUriToMutualInductiveDefinitions - (UriManager.string_of_uri uri)) - ) - | _ -> false - in - does_not_occur n nn out && - does_not_occur n nn te && - if returns_a_coinductive out then - List.fold_right - (fun x i -> i && guarded_by_constructors n nn h x) pl true - else - List.fold_right (fun x i -> i && does_not_occur n nn x) pl true - | C.Fix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len in - List.fold_right - (fun (_,_,ty,bo) i -> - i && does_not_occur n_plus_len nn_plus_len ty && - does_not_occur n_plus_len nn_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur n_plus_len nn_plus_len ty && - does_not_occur n_plus_len nn_plus_len bo - ) fl true - -and check_allowed_sort_elimination uri i need_dummy ind arity1 arity2 = - let module C = Cic in - let module U = UriManager in - match (CicReduction.whd arity1, CicReduction.whd arity2) with - (C.Prod (_,so1,de1), C.Prod (_,so2,de2)) - when CicReduction.are_convertible so1 so2 -> - check_allowed_sort_elimination uri i need_dummy - (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2 - | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true - | (C.Sort C.Prop, C.Sort C.Set) when need_dummy -> - (match CicCache.get_obj uri with - C.InductiveDefinition (itl,_,_) -> - let (_,_,_,cl) = List.nth itl i in - (* is a singleton definition? *) - List.length cl = 1 - | _ -> - raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - ) - | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true - | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true - | (C.Sort C.Set, C.Sort C.Type) when need_dummy -> - (match CicCache.get_obj uri with - C.InductiveDefinition (itl,_,_) -> - let (_,_,_,cl) = List.nth itl i in - (* is a small inductive type? *) - (*CSC: ottimizzare calcolando staticamente *) - let rec is_small = - function - C.Prod (_,so,de) -> - let s = type_of so in - (s = C.Sort C.Prop || s = C.Sort C.Set) && - is_small de - | _ -> true (*CSC: we trust the type-checker *) - in - List.fold_right (fun (_,x,_) i -> i && is_small x) cl true - | _ -> - raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - ) - | (C.Sort C.Type, C.Sort _) when need_dummy -> true - | (C.Sort C.Prop, C.Prod (_,so,ta)) when not need_dummy -> - let res = CicReduction.are_convertible so ind - in - res && - (match CicReduction.whd ta with - C.Sort C.Prop -> true - | C.Sort C.Set -> - (match CicCache.get_obj uri with - C.InductiveDefinition (itl,_,_) -> - let (_,_,_,cl) = List.nth itl i in - (* is a singleton definition? *) - List.length cl = 1 - | _ -> - raise (WrongUriToMutualInductiveDefinitions - (U.string_of_uri uri)) - ) - | _ -> false - ) - | (C.Sort C.Set, C.Prod (_,so,ta)) when not need_dummy -> - let res = CicReduction.are_convertible so ind - in - res && - (match CicReduction.whd ta with - C.Sort C.Prop - | C.Sort C.Set -> true - | C.Sort C.Type -> - (match CicCache.get_obj uri with - C.InductiveDefinition (itl,_,_) -> - let (_,_,_,cl) = List.nth itl i in - (* is a small inductive type? *) - let rec is_small = - function - C.Prod (_,so,de) -> - let s = type_of so in - (s = C.Sort C.Prop || s = C.Sort C.Set) && - is_small de - | _ -> true (*CSC: we trust the type-checker *) - in - List.fold_right (fun (_,x,_) i -> i && is_small x) cl true - | _ -> - raise (WrongUriToMutualInductiveDefinitions - (U.string_of_uri uri)) - ) - | _ -> raise Impossible - ) - | (C.Sort C.Type, C.Prod (_,so,_)) when not need_dummy -> - CicReduction.are_convertible so ind - | (_,_) -> false - -and type_of_branch argsno need_dummy outtype term constype = - let module C = Cic in - let module R = CicReduction in - match R.whd constype with - C.MutInd (_,_,_) -> - if need_dummy then - outtype - else - C.Appl [outtype ; term] - | C.Appl (C.MutInd (_,_,_)::tl) -> - let (_,arguments) = split tl argsno - in - if need_dummy && arguments = [] then - outtype - else - C.Appl (outtype::arguments@(if need_dummy then [] else [term])) - | C.Prod (name,so,de) -> - C.Prod (C.Name "pippo",so,type_of_branch argsno need_dummy - (CicSubstitution.lift 1 outtype) - (C.Appl [CicSubstitution.lift 1 term ; C.Rel 1]) de) - | _ -> raise Impossible - - -and type_of t = - let rec type_of_aux env = - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module U = UriManager in - function - C.Rel n -> S.lift n (List.nth env (n - 1)) - | C.Var uri -> - incr fdebug ; - let ty = type_of_variable uri in - decr fdebug ; - ty - | C.Meta n -> raise NotImplemented - | C.Sort s -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *) - | C.Implicit -> raise Impossible - | C.Cast (te,ty) -> - let _ = type_of ty in - if R.are_convertible (type_of_aux env te) ty then ty - else raise (NotWellTyped "Cast") - | C.Prod (_,s,t) -> - let sort1 = type_of_aux env s - and sort2 = type_of_aux (s::env) t in - sort_of_prod (sort1,sort2) - | C.Lambda (n,s,t) -> - let sort1 = type_of_aux env s - and type2 = type_of_aux (s::env) t in - let sort2 = type_of_aux (s::env) type2 in - (* only to check if the product is well-typed *) - let _ = sort_of_prod (sort1,sort2) in - C.Prod (n,s,type2) - | C.LetIn (n,s,t) -> - let type1 = type_of_aux env s in - let type2 = type_of_aux (type1::env) t in - type2 - | C.Appl (he::tl) when List.length tl > 0 -> - let hetype = type_of_aux env he - and tlbody_and_type = List.map (fun x -> (x, type_of_aux env x)) tl in - (try - eat_prods hetype tlbody_and_type - with _ -> debug (C.Appl (he::tl)) env ; C.Implicit) - | C.Appl _ -> raise (NotWellTyped "Appl: no arguments") - | C.Const (uri,cookingsno) -> - incr fdebug ; - let cty = cooked_type_of_constant uri cookingsno in - decr fdebug ; - cty - | C.Abst _ -> raise Impossible - | C.MutInd (uri,cookingsno,i) -> - incr fdebug ; - let cty = cooked_type_of_mutual_inductive_defs uri cookingsno i in - decr fdebug ; - cty - | C.MutConstruct (uri,cookingsno,i,j) -> - let cty = cooked_type_of_mutual_inductive_constr uri cookingsno i j - in - cty - | C.MutCase (uri,cookingsno,i,outtype,term,pl) -> - let outsort = type_of_aux env outtype in - let (need_dummy, k) = - let rec guess_args t = - match decast t with - C.Sort _ -> (true, 0) - | C.Prod (_, s, t) -> - let (b, n) = guess_args t in - if n = 0 then - (* last prod before sort *) - match CicReduction.whd s with - (*CSC vedi nota delirante su cookingsno in cicReduction.ml *) - C.MutInd (uri',_,i') when U.eq uri' uri && i' = i -> (false, 1) - | C.Appl ((C.MutInd (uri',_,i')) :: _) - when U.eq uri' uri && i' = i -> (false, 1) - | _ -> (true, 1) - else - (b, n + 1) - | _ -> raise (NotWellTyped "MutCase: outtype ill-formed") - in - (*CSC whd non serve dopo type_of_aux ? *) - let (b, k) = guess_args outsort in - if not b then (b, k - 1) else (b, k) - in - let (parameters, arguments) = - match R.whd (type_of_aux env term) with - (*CSC manca il caso dei CAST *) - C.MutInd (uri',_,i') -> - (*CSC vedi nota delirante sui cookingsno in cicReduction.ml*) - if U.eq uri uri' && i = i' then ([],[]) - else raise (NotWellTyped ("MutCase: the term is of type " ^ - (U.string_of_uri uri') ^ "," ^ string_of_int i' ^ - " instead of type " ^ (U.string_of_uri uri') ^ "," ^ - string_of_int i)) - | C.Appl (C.MutInd (uri',_,i') :: tl) -> - if U.eq uri uri' && i = i' then split tl (List.length tl - k) - else raise (NotWellTyped ("MutCase: the term is of type " ^ - (U.string_of_uri uri') ^ "," ^ string_of_int i' ^ - " instead of type " ^ (U.string_of_uri uri) ^ "," ^ - string_of_int i)) - | _ -> raise (NotWellTyped "MutCase: the term is not an inductive one") - in - (* let's control if the sort elimination is allowed: [(I q1 ... qr)|B] *) - let sort_of_ind_type = - if parameters = [] then - C.MutInd (uri,cookingsno,i) - else - C.Appl ((C.MutInd (uri,cookingsno,i))::parameters) - in - if not (check_allowed_sort_elimination uri i need_dummy - sort_of_ind_type (type_of_aux env sort_of_ind_type) outsort) - then - raise (NotWellTyped "MutCase: not allowed sort elimination") ; - - (* let's check if the type of branches are right *) - let (cl,parsno) = - match CicCache.get_cooked_obj uri cookingsno with - C.InductiveDefinition (tl,_,parsno) -> - let (_,_,_,cl) = List.nth tl i in (cl,parsno) - | _ -> - raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - in - let (_,branches_ok) = - List.fold_left - (fun (j,b) (p,(_,c,_)) -> - let cons = - if parameters = [] then - (C.MutConstruct (uri,cookingsno,i,j)) - else - (C.Appl (C.MutConstruct (uri,cookingsno,i,j)::parameters)) - in - (j + 1, b && - R.are_convertible (type_of_aux env p) - (type_of_branch parsno need_dummy outtype cons - (type_of_aux env cons)) - ) - ) (1,true) (List.combine pl cl) - in - if not branches_ok then - raise (NotWellTyped "MutCase: wrong type of a branch") ; - - if not need_dummy then - C.Appl ((outtype::arguments)@[term]) - else if arguments = [] then - outtype - else - C.Appl (outtype::arguments) - | C.Fix (i,fl) -> - let types_times_kl = - List.rev - (List.map (fun (_,k,ty,_) -> let _ = type_of_aux env ty in (ty,k)) fl) - in - let (types,kl) = List.split types_times_kl in - let len = List.length types in - List.iter - (fun (name,x,ty,bo) -> - if (R.are_convertible (type_of_aux (types @ env) bo) - (CicSubstitution.lift len ty)) - then - begin - let (m, eaten) = eat_lambdas (x + 1) bo in - (*let's control the guarded by destructors conditions D{f,k,x,M}*) - if not (guarded_by_destructors eaten (len + eaten) kl 1 [] m) then - raise (NotWellTyped "Fix: not guarded by destructors") - end - else - raise (NotWellTyped "Fix: ill-typed bodies") - ) fl ; - - (*CSC: controlli mancanti solo su D{f,k,x,M} *) - let (_,_,ty,_) = List.nth fl i in - ty - | C.CoFix (i,fl) -> - let types = - List.rev (List.map (fun (_,ty,_) -> let _ = type_of_aux env ty in ty) fl) - in - let len = List.length types in - List.iter - (fun (_,ty,bo) -> - if (R.are_convertible (type_of_aux (types @ env) bo) - (CicSubstitution.lift len ty)) - then - begin - (* let's control the guarded by constructors conditions C{f,M} *) - if not (guarded_by_constructors 0 len 0 bo) then - raise (NotWellTyped "CoFix: not guarded by constructors") - end - else - raise (NotWellTyped "CoFix: ill-typed bodies") - ) fl ; - - let (_,ty,_) = List.nth fl i in - ty - - and decast = - let module C = Cic in - function - C.Cast (t,_) -> t - | t -> t - - and sort_of_prod (t1, t2) = - let module C = Cic in - match (decast t1, decast t2) with - (C.Sort s1, C.Sort s2) - when (s2 = C.Prop or s2 = C.Set) -> (* different from Coq manual!!! *) - C.Sort s2 - | (C.Sort s1, C.Sort s2) -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *) - | (_,_) -> raise (NotWellTyped "Prod") - - and eat_prods hetype = - (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *) - (*CSC: cucinati *) - function - [] -> hetype - | (hete, hety)::tl -> - (match (CicReduction.whd hetype) with - Cic.Prod (n,s,t) -> - if CicReduction.are_convertible s hety then - (CicReduction.fdebug := -1 ; - eat_prods (CicSubstitution.subst hete t) tl - ) - else - ( - CicReduction.fdebug := 0 ; - let _ = CicReduction.are_convertible s hety in - debug hete [hety ; s] ; - raise (NotWellTyped "Appl: wrong parameter-type") -) - | _ -> raise (NotWellTyped "Appl: wrong Prod-type") - ) - in - type_of_aux [] t -;; - -let typecheck uri = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - match CicCache.is_type_checked uri 0 with - CicCache.CheckedObj _ -> () - | CicCache.UncheckedObj uobj -> - (* let's typecheck the uncooked object *) - (match uobj with - C.Definition (_,te,ty,_) -> - let _ = type_of ty in - if not (R.are_convertible (type_of te ) ty) then - raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri))) - | C.Axiom (_,ty,_) -> - (* only to check that ty is well-typed *) - let _ = type_of ty in () - | C.CurrentProof (_,_,te,ty) -> - (*CSC [] wrong *) - let _ = type_of ty in - debug (type_of te) [] ; - if not (R.are_convertible (type_of te) ty) then - raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri))) - | C.Variable (_,bo,ty) -> - (* only to check that ty is well-typed *) - let _ = type_of ty in - (match bo with - None -> () - | Some bo -> - if not (R.are_convertible (type_of bo) ty) then - raise (NotWellTyped ("Variable" ^ (U.string_of_uri uri))) - ) - | C.InductiveDefinition _ -> - cooked_mutual_inductive_defs uri uobj - ) ; - CicCache.set_type_checking_info uri -;; diff --git a/helm/interface/cicTypeChecker.mli b/helm/interface/cicTypeChecker.mli deleted file mode 100644 index 72dd63c57..000000000 --- a/helm/interface/cicTypeChecker.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception NotWellTyped of string -exception WrongUriToConstant of string -exception WrongUriToVariable of string -exception WrongUriToMutualInductiveDefinitions of string -exception ListTooShort -exception NotPositiveOccurrences of string -exception NotWellFormedTypeOfInductiveConstructor of string -exception WrongRequiredArgument of string -val typecheck : UriManager.uri -> unit diff --git a/helm/interface/cicXPath.ml b/helm/interface/cicXPath.ml deleted file mode 100644 index 776d229af..000000000 --- a/helm/interface/cicXPath.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 14/06/2000 *) -(* *) -(* *) -(******************************************************************************) - -let get_annotation_from_term annterm = - let module C = Cic in - match annterm with - C.ARel (_,ann,_,_) -> ann - | C.AVar (_,ann,_) -> ann - | C.AMeta (_,ann,_) -> ann - | C.ASort (_,ann,_) -> ann - | C.AImplicit (_,ann) -> ann - | C.ACast (_,ann,_,_) -> ann - | C.AProd (_,ann,_,_,_) -> ann - | C.ALambda (_,ann,_,_,_) -> ann - | C.ALetIn (_,ann,_,_,_) -> ann - | C.AAppl (_,ann,_) -> ann - | C.AConst (_,ann,_,_) -> ann - | C.AAbst (_,ann,_) -> ann - | C.AMutInd (_,ann,_,_,_) -> ann - | C.AMutConstruct (_,ann,_,_,_,_)-> ann - | C.AMutCase (_,ann,_,_,_,_,_,_) -> ann - | C.AFix (_,ann,_,_) -> ann - | C.ACoFix (_,ann,_,_) -> ann -;; - -let get_annotation_from_obj annobj = - let module C = Cic in - match annobj with - C.ADefinition (_,ann,_,_,_,_) -> ann - | C.AAxiom (_,ann,_,_,_) -> ann - | C.AVariable (_,ann,_,_,_) -> ann - | C.ACurrentProof (_,ann,_,_,_,_) -> ann - | C.AInductiveDefinition (_,ann,_,_,_) -> ann -;; - -exception IdUnknown of string;; - -let get_annotation (annobj,ids_to_targets) xpath = - try - match Hashtbl.find ids_to_targets xpath with - Cic.Object annobj -> get_annotation_from_obj annobj - | Cic.Term annterm -> get_annotation_from_term annterm - with - Not_found -> raise (IdUnknown xpath) -;; diff --git a/helm/interface/clientHTTP.ml b/helm/interface/clientHTTP.ml deleted file mode 100644 index 9086d8207..000000000 --- a/helm/interface/clientHTTP.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -let send cmd = - ignore (Http_client.Convenience.http_get cmd) - -let get uri = - Http_client.Convenience.http_get uri - -let get_and_save uri dest_filename = - let reply = get uri - and out_channel = open_out dest_filename in - output_string out_channel reply ; - close_out out_channel - -let get_and_save_to_tmp uri = - let flat_string s s' c = - let cs = String.copy s in - for i = 0 to (String.length s) - 1 do - if String.contains s' s.[i] then cs.[i] <- c - done ; - cs - in - let tmp_file = Configuration.tmp_dir ^ "/" ^ (flat_string uri ".-=:;!?/&" '_') in - get_and_save uri tmp_file ; - tmp_file - diff --git a/helm/interface/config.cache.pkg b/helm/interface/config.cache.pkg deleted file mode 100644 index fe72875bb..000000000 --- a/helm/interface/config.cache.pkg +++ /dev/null @@ -1,4 +0,0 @@ -# This is the config.cache that holds the ``standard'' path for the -# HELM library. It is supposed to be used when creating packages - -helm_cv_HELM_DEFAULT_CONFIGURATION_DIR=${helm_cv_HELM_DEFAULT_CONFIGURATION_DIR='$RESOLVED_PREFIX/etc/helm'} diff --git a/helm/interface/configuration.ml.in b/helm/interface/configuration.ml.in deleted file mode 100644 index d20a3c0c0..000000000 --- a/helm/interface/configuration.ml.in +++ /dev/null @@ -1,117 +0,0 @@ -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 28/12/2000 *) -(* *) -(* This is the parser that reads the configuration file of helm *) -(* *) -(******************************************************************************) - -exception MalformedDir of string - -(* this should be the only hard coded constant *) -let filename = - let prefix = - try - Sys.getenv "HELM_CONFIGURATION_DIR" - with - Not_found -> "@HELM_CONFIGURATION_DIR@" - in - if prefix.[(String.length prefix) - 1] = '/' then - raise (MalformedDir prefix) ; - prefix ^ "/configuration.xml";; - -exception Warnings;; - -class warner = - object - method warn w = - print_endline ("WARNING: " ^ w) ; - (raise Warnings : unit) - end -;; - -let xml_document () = - let module Y = Pxp_yacc in - try - let config = {Y.default_config with Y.warner = new warner} in - Y.parse_document_entity config (Y.from_file filename) Y.default_spec - with - e -> - print_endline (Pxp_types.string_of_exn e) ; - raise e -;; - -exception Impossible;; - -let vars = Hashtbl.create 14;; - -(* resolve tags and returns the string values of the variable tags *) -let rec resolve = - let module D = Pxp_document in - function - [] -> "" - | he::tl when he#node_type = D.T_element "value-of" -> - (match he#attribute "var" with - Pxp_types.Value var -> Hashtbl.find vars var - | _ -> raise Impossible - ) ^ resolve tl - | he::tl when he#node_type = D.T_data -> - he#data ^ resolve tl - | _ -> raise Impossible -;; - -(* we trust the xml file to be valid because of the validating xml parser *) -let _ = - List.iter - (function - n -> - match n#node_type with - Pxp_document.T_element var -> - Hashtbl.add vars var (resolve (n#sub_nodes)) - | _ -> raise Impossible - ) - ((xml_document ())#root#sub_nodes) -;; - -(* try to read a configuration variable, given its name into the - * configuration.xml file and its name into the shell environment. - * The shell variable, if present, has precedence over configuration.xml - *) -let read_configuration_var_env xml_name env_name = - try - try - Sys.getenv env_name - with - Not_found -> Hashtbl.find vars xml_name - with - Not_found -> - Printf.printf "Sorry, cannot find variable `%s', please check your configuration\n" xml_name ; - flush stdout ; - raise Not_found - -let read_configuration_var xml_name = - try - Hashtbl.find vars xml_name - with - Not_found -> - Printf.printf "Sorry, cannot find variable `%s', please check your configuration\n" xml_name ; - flush stdout ; - raise Not_found - -let helm_dir = read_configuration_var "helm_dir";; -let dtd_dir = read_configuration_var "dtd_dir";; -let style_dir = read_configuration_var_env "style_dir" "HELM_STYLE_DIR";; -let servers_file = read_configuration_var "servers_file";; -let uris_dbm = read_configuration_var "uris_dbm";; -let dest = read_configuration_var "dest";; -let indexname = read_configuration_var "indexname";; -let tmp_dir = read_configuration_var "tmp_dir" -let helm_dir = read_configuration_var "helm_dir";; -let getter_url = read_configuration_var_env "getter_url" "HELM_GETTER_URL";; -let processor_url = read_configuration_var_env "processor_url" "HELM_PROCESSOR_URL";; - -let _ = Hashtbl.clear vars;; - diff --git a/helm/interface/configure.in b/helm/interface/configure.in deleted file mode 100644 index 4dc7a6fec..000000000 --- a/helm/interface/configure.in +++ /dev/null @@ -1,206 +0,0 @@ -AC_INIT(configuration.ml.in) - -PACKAGE=helm_gtk_interface -MAJOR_VERSION=0 -MINOR_VERSION=0 -MICRO_VERSION=2 -VERSION=$MAJOR_VERSION.$MINOR_VERSION.$MICRO_VERSION - -DEFAULT_HELM_CONFIGURATION_DIR=/usr/local/etc/helm - -AC_ARG_ENABLE( - defaults, - [ --enable-defaults[=ARG] if yes then use defaults (don't ask user) [default=auto]], - USE_DEFAULTS=$enableval, - USE_DEFAULTS=auto -) - -if test "x$prefix" != xNONE; then - RESOLVED_PREFIX=$prefix -else - RESOLVED_PREFIX=$ac_default_prefix -fi - -if test "x$exec_prefix" != xNONE; then - RESOLVED_EXEC_PREFIX=$exec_prefix -else - RESOLVED_EXEC_PREFIX=$RESOLVED_PREFIX -fi - -dnl The following is the directory where the binary will be installed -BIN_DIR=$RESOLVED_EXEC_PREFIX/bin - -AC_PATH_PROG(WGET_BINARY,wget,no) -if test $WGET_BINARY = no; then - AC_MSG_WARN(wget is required to update the database) -fi - -AC_PATH_PROG(PERL_BINARY,perl,no) -if test $PERL_BINARY = no ; then - AC_MSG_ERROR(Could not find perl) -fi - -dnl MISSING CHECKS: -dnl ocaml-findlib, ocaml-netstring, ocaml-pxp, ocaml-netclient - -dnl Check for Ocaml -AC_CHECK_PROG(HAVE_OCAMLC, ocamlc, yes, no) -if test $HAVE_OCAMLC = "no"; then - AC_MSG_ERROR(could not find ocamlc in PATH, please make sure ocaml is installed) -fi - -dnl Check for the Ocaml library dir -AC_MSG_CHECKING(for the ocaml library dir) -OCAML_ROOT=`ocamlc -v | grep "^Standard" | sed 's/^.*: *//'` -AC_MSG_RESULT($OCAML_ROOT) - -DEFAULT_MLMINIDOM_LIB_DIR=$OCAML_ROOT/mlminidom -DEFAULT_LABLGTK_LIB_DIR=$OCAML_ROOT/lablgtk -DEFAULT_LABLGTKMATHVIEW_LIB_DIR=$OCAML_ROOT/lablgtkmathview - -dnl Check for mlminidom -DEFAULTS=$USE_DEFAULTS -if test $DEFAULTS = auto; then - if test -f $DEFAULT_MLMINIDOM_LIB_DIR/minidom.mli; then - MLMINIDOM_LIB_DIR=$DEFAULT_MLMINIDOM_LIB_DIR - else - DEFAULTS=no - fi -fi - -if test $DEFAULTS = no; then - echo - echo "Where can I find the mlminidom library?" - echo - echo -n "[[$DEFAULT_MLMINIDOM_LIB_DIR]] ? " - echo - read MLMINIDOM_LIB_DIR - if test "x$MLMINIDOM_LIB_DIR" = x; then - MLMINIDOM_LIB_DIR=$DEFAULT_MLMINIDOM_LIB_DIR - fi -elif test $DEFAULTS = yes; then - MLMINIDOM_LIB_DIR=$DEFAULT_MLMINIDOM_LIB_DIR -fi - -AC_MSG_CHECKING(for $MLMINIDOM_LIB_DIR/minidom.mli) -if test ! -f $MLMINIDOM_LIB_DIR/minidom.mli; then - AC_MSG_RESULT(no) - AC_MSG_ERROR(please check your installation) -fi -AC_MSG_RESULT(ok) - -dnl Check for lablgtk -DEFAULTS=$USE_DEFAULTS -if test $DEFAULTS = auto; then - if test -f $DEFAULT_LABLGTK_LIB_DIR/gtk.ml; then - LABLGTK_LIB_DIR=$DEFAULT_LABLGTK_LIB_DIR - else - DEFAULTS=no - fi -fi - -if test $DEFAULTS = no; then - echo - echo "Where can I find the lablgtk library?" - echo - echo -n "[[$DEFAULT_LABLGTK_LIB_DIR]] ? " - read LABLGTK_LIB_DIR - echo - if test "x$LABLGTK_LIB_DIR" = x; then - LABLGTK_LIB_DIR=$DEFAULT_LABLGTK_LIB_DIR - fi -elif test $DEFAULTS = yes; then - LABLGTK_LIB_DIR=$DEFAULT_LABLGTK_LIB_DIR -fi - -AC_MSG_CHECKING(for $LABLGTK_LIB_DIR/gtk.ml) -if test ! -f $LABLGTK_LIB_DIR/gtk.ml; then - AC_MSG_RESULT(no) - AC_MSG_ERROR(please check your installation) -fi -AC_MSG_RESULT(ok) - -dnl Check for lablgtkmathview -DEFAULTS=$USE_DEFAULTS -if test $DEFAULTS = auto; then - if test -f $DEFAULT_LABLGTKMATHVIEW_LIB_DIR/gMathView.ml; then - LABLGTKMATHVIEW_LIB_DIR=$DEFAULT_LABLGTKMATHVIEW_LIB_DIR - else - DEFAULTS=no - fi -fi - -if test $DEFAULTS = no; then - echo - echo "Where can I find the lablgtkmathview library?" - echo - echo -n "[[$DEFAULT_LABLGTKMATHVIEW_LIB_DIR]] ? " - read LABLGTKMATHVIEW_LIB_DIR - echo - if test "x$LABLGTKMATHVIEW_LIB_DIR" = x; then - LABLGTKMATHVIEW_LIB_DIR=$DEFAULT_LABLGTKMATHVIEW_LIB_DIR - fi -elif test $DEFAULTS = yes; then - LABLGTKMATHVIEW_LIB_DIR=$DEFAULT_LABLGTKMATHVIEW_LIB_DIR -fi - -AC_MSG_CHECKING(for $LABLGTKMATHVIEW_LIB_DIR/gMathView.ml) -if test ! -f $LABLGTKMATHVIEW_LIB_DIR/gMathView.ml; then - AC_MSG_RESULT(no) - AC_MSG_ERROR(please check your installation) -fi -AC_MSG_RESULT(ok) - -dnl Check for HELM -DEFAULTS=$USE_DEFAULTS -if test $DEFAULTS = auto; then - AC_CHECK_PROG(HAVE_HELM_CONFIG, helm-config, yes, no) - if test $HAVE_HELM_CONFIG = yes; then - HELM_CONFIGURATION_DIR=`helm-config --etc-dir` - else - DEFAULTS=no - fi -fi - -if test $DEFAULTS = no; then - echo - echo "\`helm-config' is not installed (or I can't find it in your path)." - echo "Please, insert the directory where I can find the configuration" - echo "files for HELM (configuration.xml in particular)..." - echo - echo -n "[[$DEFAULT_HELM_CONFIGURATION_DIR]] ? " - read HELM_CONFIGURATION_DIR - echo - if test "x$HELM_CONFIGURATION_DIR" = "x"; then - HELM_CONFIGURATION_DIR=$DEFAULT_HELM_CONFIGURATION_DIR - fi -elif test $DEFAULTS = yes; then - HELM_CONFIGURATION_DIR=$DEFAULT_HELM_CONFIGURATION_DIR -fi - -AC_MSG_CHECKING(for configuration.xml) -if test -f $HELM_CONFIGURATION_DIR/configuration.xml; then - AC_MSG_RESULT(ok) -else - AC_MSG_RESULT(no) - AC_MSG_ERROR(please check your installation) -fi - -AC_SUBST(PACKAGE) -AC_SUBST(VERSION) -AC_SUBST(OCAML_ROOT) -AC_SUBST(MLMINIDOM_LIB_DIR) -AC_SUBST(LABLGTK_LIB_DIR) -AC_SUBST(LABLGTKMATHVIEW_LIB_DIR) -AC_SUBST(BIN_DIR) -AC_SUBST(HELM_CONFIGURATION_DIR) -AC_SUBST(PERL_BINARY) - -AC_OUTPUT([ - Makefile - configuration.ml - helm_wget - helm_gtk_interface.spec -], - chmod +x helm_wget -) diff --git a/helm/interface/deannotate.ml b/helm/interface/deannotate.ml deleted file mode 100644 index 00d4854db..000000000 --- a/helm/interface/deannotate.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -let expect_possible_parameters = ref false;; - -exception NotExpectingPossibleParameters;; - -let rec deannotate_term = - let module C = Cic in - function - C.ARel (_,_,n,_) -> C.Rel n - | C.AVar (_,_,uri) -> C.Var uri - | C.AMeta (_,_,n) -> C.Meta n - | C.ASort (_,_,s) -> C.Sort s - | C.AImplicit _ -> C.Implicit - | C.ACast (_,_,va,ty) -> C.Cast (deannotate_term va, deannotate_term ty) - | C.AProd (_,_,name,so,ta) -> - C.Prod (name, deannotate_term so, deannotate_term ta) - | C.ALambda (_,_,name,so,ta) -> - C.Lambda (name, deannotate_term so, deannotate_term ta) - | C.ALetIn (_,_,name,so,ta) -> - C.LetIn (name, deannotate_term so, deannotate_term ta) - | C.AAppl (_,_,l) -> C.Appl (List.map deannotate_term l) - | C.AConst (_,_,uri, cookingsno) -> C.Const (uri, cookingsno) - | C.AAbst (_,_,uri) -> C.Abst uri - | C.AMutInd (_,_,uri,cookingsno,i) -> C.MutInd (uri,cookingsno,i) - | C.AMutConstruct (_,_,uri,cookingsno,i,j) -> - C.MutConstruct (uri,cookingsno,i,j) - | C.AMutCase (_,_,uri,cookingsno,i,outtype,te,pl) -> - C.MutCase (uri,cookingsno,i,deannotate_term outtype, - deannotate_term te, List.map deannotate_term pl) - | C.AFix (_,_,funno,ifl) -> - C.Fix (funno, List.map deannotate_inductiveFun ifl) - | C.ACoFix (_,_,funno,ifl) -> - C.CoFix (funno, List.map deannotate_coinductiveFun ifl) - -and deannotate_inductiveFun (name,index,ty,bo) = - (name, index, deannotate_term ty, deannotate_term bo) - -and deannotate_coinductiveFun (name,ty,bo) = - (name, deannotate_term ty, deannotate_term bo) -;; - -let deannotate_inductiveType (name, isinductive, arity, cons) = - (name, isinductive, deannotate_term arity, - List.map (fun (id,ty,recs) -> (id,deannotate_term ty, recs)) cons) -;; - -let deannotate_obj = - let module C = Cic in - function - C.ADefinition (_, _, id, bo, ty, params) -> - (match params with - C.Possible params -> - if !expect_possible_parameters then - C.Definition (id, deannotate_term bo, deannotate_term ty, params) - else - raise NotExpectingPossibleParameters - | C.Actual params -> - C.Definition (id, deannotate_term bo, deannotate_term ty, params) - ) - | C.AAxiom (_, _, id, ty, params) -> - C.Axiom (id, deannotate_term ty, params) - | C.AVariable (_, _, name, bo, ty) -> - C.Variable (name, - (match bo with None -> None | Some bo -> Some (deannotate_term bo)), - deannotate_term ty) - | C.ACurrentProof (_, _, name, conjs, bo, ty) -> - C.CurrentProof ( - name, List.map (fun (id,con) -> (id,deannotate_term con)) conjs, - deannotate_term bo, deannotate_term ty - ) - | C.AInductiveDefinition (_, _, tys, params, parno) -> - C.InductiveDefinition ( List.map deannotate_inductiveType tys, - params, parno) -;; diff --git a/helm/interface/experiment.ml b/helm/interface/experiment.ml deleted file mode 100644 index 7d06b4d23..000000000 --- a/helm/interface/experiment.ml +++ /dev/null @@ -1,109 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This is a textual interface to the Coq-like pretty printer cicPp for cic *) -(* terms exported in xml. It uses directly the modules cicPp and cache and *) -(* indirectly all the other modules (cicParser, cicParser2, cicParser3, *) -(* getter). The syntax is "experiment[.opt] filename1 ... filenamen" where *) -(* filenamei is the path-name of an xml file describing a cic term. On stdout *) -(* are pretty-printed all the n terms *) -(* *) -(******************************************************************************) - -let pretty_print = ref true;; -let read_from_stdin = ref false;; -let uris_in_input = ref false;; - -let parse uri = - if !pretty_print then - begin - print_endline ("^^^" ^ uri ^ "^^^") ; - print_string (CicPp.ppobj (CicCache.get_obj (UriManager.uri_of_string uri))); - print_endline ("\n$$$" ^ uri ^ "$$$\n") - end - else - begin - print_string uri ; - let _ = CicCache.get_obj (UriManager.uri_of_string uri) in - print_endline " OK!" ; - flush stdout - end -;; - -let uri_of_filename fn = - if !uris_in_input then fn - else - let uri = - Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn - in - let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in - uri' -;; - -let read_filenames_from_stdin () = - let files = ref [] in - try - while true do - let l = Str.split (Str.regexp " ") (read_line ()) in - List.iter (fun x -> files := (uri_of_filename x) :: !files) l - done - with - End_of_file -> - files := List.rev !files ; - List.iter parse !files -;; - -(* filenames are read from command line and converted to uris via *) -(* uri_of_filenames; then the cic terms are load in cache via *) -(* CicCache.get_obj and then pretty printed via CicPp.ppobj *) - -let main() = - let files = ref [] in - Arg.parse - ["-nopp", Arg.Clear pretty_print, "Do not pretty print, parse only" ; - "-stdin", Arg.Set read_from_stdin, "Read from stdin" ; - "-uris", Arg.Set uris_in_input, "Read uris, not filenames" ; - "-update", Arg.Unit Getter.update, "Update the getter view of the world"] - (fun x -> files := (uri_of_filename x) :: !files) - " -usage: experiment file ... - -List of options:"; - if !read_from_stdin then read_filenames_from_stdin () - else - begin - files := List.rev !files; - List.iter parse !files - end -;; - -main();; diff --git a/helm/interface/fix_params.ml b/helm/interface/fix_params.ml deleted file mode 100644 index f1edf091a..000000000 --- a/helm/interface/fix_params.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -let read_from_stdin = ref false;; - -let uri_of_filename fn = - let uri = - Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn - in - let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in - UriManager.uri_of_string uri' -;; - -let main() = - Deannotate.expect_possible_parameters := true ; - let files = ref [] in - Arg.parse - ["-stdin", Arg.Set read_from_stdin, "Read from stdin"] - (fun x -> files := (x, uri_of_filename x) :: !files) - " -usage: experiment file ... - -List of options:"; - if !read_from_stdin then - begin - try - while true do - let l = Str.split (Str.regexp " ") (read_line ()) in - List.iter (fun x -> files := (x, uri_of_filename x) :: !files) l - done - with - End_of_file -> () - end ; - files := List.rev !files; - Getter.update () ; - print_endline "ATTENTION: have you changed servers.txt so that you'll try \ - to repair your own objs instead of others'?" ; - flush stdout ; - List.iter - (function (fn, uri) -> - print_string (UriManager.string_of_uri uri) ; - flush stdout ; - (try - CicFindParameters.fix_params uri (Some fn) - with - e -> print_newline () ; flush stdout ; raise e ) ; - print_endline " OK!" ; - flush stdout - ) !files -;; - -main();; diff --git a/helm/interface/getter.ml b/helm/interface/getter.ml deleted file mode 100644 index 5b973f2ef..000000000 --- a/helm/interface/getter.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(******************************************************************************) - - -(*CSC: il getter _DEVE_ diventare un semplice "binding" a quello in Perl *) - -let update () = -(* deliver update request to http_getter *) - ClientHTTP.send (Configuration.getter_url ^ "update") -;; - -(* url_of_uri : uri -> url *) -let url_of_uri uri = - let dbm = Dbm.opendbm Configuration.uris_dbm [Dbm.Dbm_rdonly] 0o660 in - let url = Dbm.find dbm (UriManager.string_of_uri uri) in - Dbm.close dbm ; - url -;; - -let filedir_of_uri uri = - let fn = UriManager.buri_of_uri uri in - let fn' = Str.replace_first (Str.regexp ".*:") Configuration.dest fn in - fn' -;; - -let name_and_ext_of_uri uri = - let str = UriManager.string_of_uri uri in - Str.replace_first (Str.regexp ".*/") "" str -;; - -let raw_get = ClientHTTP.get_and_save - -(* get_file : uri -> filename *) -let get_file uri = - let dir = filedir_of_uri uri in - let fn = dir ^ "/" ^ name_and_ext_of_uri uri ^ ".xml" in - if not (Sys.file_exists fn) then - begin - let url = url_of_uri uri in - raw_get - (Configuration.getter_url ^ "getxml?uri=" ^ - UriManager.string_of_uri uri ^ "&format=normal&patch_dtd=no" - ) fn - end ; - fn -;; - -(* get : uri -> filename *) -(* If uri is the URI of an annotation, the annotated object is processed *) -let get uri = - let module U = UriManager in - get_file - (U.uri_of_string - (Str.replace_first (Str.regexp "\.types$") "" - (Str.replace_first (Str.regexp "\.ann$") "" (U.string_of_uri uri)))) -;; - -(* get_ann : uri -> filename *) -(* If uri is the URI of an annotation, the annotation file is processed *) -let get_ann = get_file;; - -(* get_ann_file_name_and_uri : uri -> filename * annuri *) -(* If given an URI, it returns the name of the corresponding *) -(* annotation file and the annotation uri *) -let get_ann_file_name_and_uri uri = - let module U = UriManager in - let uri = U.string_of_uri uri in - let annuri = - U.uri_of_string ( - if Str.string_match (Str.regexp ".*\.ann$") uri 0 then - uri - else - uri ^ ".ann" - ) - in - let dir = filedir_of_uri annuri in - let fn = dir ^ "/" ^ name_and_ext_of_uri annuri ^ ".xml" in - (fn, annuri) -;; diff --git a/helm/interface/getter.mli b/helm/interface/getter.mli deleted file mode 100644 index 0c7401cbc..000000000 --- a/helm/interface/getter.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* *) -(******************************************************************************) - -(* raw_get : uri -> dest_file -> () *) -val raw_get : string -> string -> unit - -(* get : uri -> filename *) -(* If uri is the URI of an annotation, the annotated object is processed *) -val get : UriManager.uri -> string - -(* get_ann : uri -> filename *) -(* If uri is the URI of an annotation, the annotation file is processed *) -val get_ann : UriManager.uri -> string - -(* get_ann_file_name_and_uri : uri -> filename * annuri *) -(* If given an URI, it returns the name of the corresponding *) -(* annotation file and the annotation uri *) -val get_ann_file_name_and_uri : UriManager.uri -> string * UriManager.uri - -(* synchronize with the servers *) -val update : unit -> unit diff --git a/helm/interface/helm_gtk_interface.spec.in b/helm/interface/helm_gtk_interface.spec.in deleted file mode 100644 index 0e567ae14..000000000 --- a/helm/interface/helm_gtk_interface.spec.in +++ /dev/null @@ -1,32 +0,0 @@ -Summary: The gtk interface for the library of project HELM -Name: @PACKAGE@ -Version: @VERSION@ -Release: 1 -Copyright: GPL -URL: http://www.cs.unibo.it/helm -Packager: Claudio Sacerdoti Coen -Requires: helm_configuration >= 0.0.2, helm_data >= 0.0.2, helm_http_getter >= 0.0.2, helm_uwobo >= 0.0.2, ocaml >= 3.00, ocaml-findlib, ocaml-netstring, ocaml-pxp, lablgtk, lablgtkmathview >= 0.0.2 -Group: Applications/Publishing -Source: www.cs.unibo.it:/helm/@PACKAGE@-@VERSION@.tar.gz -%description -HELM (Hypertextual Electronic Library of Mathematics) is a project aimed -at the creation of tools for the development and exploitation of a huge -distributed library of formal mathematical knowledge. This package holds -a gtk interface to the library. -For more information see http://www.cs.unibo.it/helm - -%prep -%setup - -%build -./configure --enable-defaults -make -make opt - -%install -make install - -%files -%doc AUTHORS COPYING ChangeLog NEWS README -%attr(755,root,root) /usr/local/bin/mmlinterface -%attr(755,root,root) /usr/local/bin/mmlinterface.opt diff --git a/helm/interface/helm_wget.in b/helm/interface/helm_wget.in deleted file mode 100755 index 8aa0260cb..000000000 --- a/helm/interface/helm_wget.in +++ /dev/null @@ -1,19 +0,0 @@ -#!@PERL_BINARY@ - -if ($#ARGV != 1) { - print STDERR "Usage: helm_wget prefix URL\n"; - exit -1; -} - -my ($prefix,$URL) = @ARGV; -if ($URL =~ /^file:\//) { - $URL =~ s/^file:\///; - my $command = "mkdir -p $prefix ; cp $URL $prefix"; - print "$command\n"; - system($command) == 0 - or die "\"$command\" error"; -} else { - my $command = "wget -c -P $prefix $URL"; - system($command) == 0 - or die "\"$command\" error"; -} diff --git a/helm/interface/mmlinterface.ml b/helm/interface/mmlinterface.ml deleted file mode 100755 index 68c4134d1..000000000 --- a/helm/interface/mmlinterface.ml +++ /dev/null @@ -1,518 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 03/04/2001 *) -(* *) -(* This is a simple gtk interface to the Coq-like pretty printer cicPp for *) -(* cic terms exported in xml. It uses directly the modules cicPp and *) -(* cicCcache and indirectly all the other modules (cicParser, cicParser2, *) -(* cicParser3, getter). *) -(* The syntax is "gtkInterface[.opt] filename1 ... filenamen" where *) -(* filenamei is the path-name of an xml file describing a cic term. *) -(* The terms are loaded in cache and then pretty-printed one at a time and *) -(* only once, when the user wants to look at it: if the user wants to look at *) -(* a term again, then the pretty-printed term is showed again, but not *) -(* recomputed *) -(* *) -(******************************************************************************) - -(* GLOBAL REFERENCES (USED BY CALLBACKS) *) - -let annotated_obj = ref None;; (* reference to a couple option where *) - (* the first component is the current *) - (* annotated object and the second is *) - (* the map from ids to annotated targets *) -let ann = ref (ref None);; (* current annotation *) -let radio_some_status = ref false;; (* is the radio_some button selected? *) -let current_url = ref "";; - -(* MISC FUNCTIONS *) - -let pathname_of_annuri uristring = - Configuration.annotations_dir ^ - Str.replace_first (Str.regexp "^cic:") "" uristring -;; - -let make_dirs dirpath = - ignore (Unix.system ("mkdir -p " ^ dirpath)) -;; - -exception No_param_dot_CICURI_or_param_dot_annotations_found_in of string;; -exception Bad_formed_url of string;; - -let uri_from_url url = - let module N = Neturl in - let founduri = ref None in - let foundann = ref None in - let rec find_uri = - function - [] -> raise (No_param_dot_CICURI_or_param_dot_annotations_found_in url) - | he::tl -> - match Str.split (Str.regexp "=") he with - ["param.CICURI";uri] -> - if !founduri <> None then - raise (Bad_formed_url url) - else - begin - founduri := Some uri ; - if !foundann = None then - find_uri tl - end - | ["param.annotations";ann] -> - if !foundann <> None then - raise (Bad_formed_url url) - else - begin - foundann := - Some - (match ann with - "yes" -> ".ann" - | "NO" -> "" - | _ -> raise (Bad_formed_url url) - ) ; - if !founduri = None then - find_uri tl - end - | _ -> find_uri tl - in - find_uri - (Str.split (Str.regexp "&") - (N.url_query ~encoded:true (N.url_of_string N.ip_url_syntax url))) ; - match !founduri,!foundann with - (Some uri),(Some ann) -> uri ^ ann - | _ , _ -> - raise (No_param_dot_CICURI_or_param_dot_annotations_found_in url) -;; - -let get_current_uri () = - UriManager.uri_of_string (uri_from_url !current_url) -;; - -(* CALLBACKS *) - -let get_annotated_obj () = - match !annotated_obj with - None -> - let annobj = - (CicCache.get_annobj (get_current_uri ())) - in - annotated_obj := Some annobj ; - annobj - | Some annobj -> annobj -;; - -let update_output rendering_window url = - rendering_window#label#set_text (uri_from_url url) ; - rendering_window#output#load url -;; - -(* called when an hyperlink is clicked *) -let jump rendering_window (node : Ominidom.o_mDOMNode) = - let module O = Ominidom in - let module U = Unix in - match (node#get_attribute (O.o_mDOMString_of_string "href")) with - Some str -> - let frameseturl = str#get_string in - let devnull = U.openfile "/dev/null" [U.O_RDWR] 0o600 in - ignore - (U.create_process "netscape-remote" - [|"netscape-remote" ; "-noraise" ; "-remote" ; - "openURL(" ^ frameseturl ^ ",cic)" - |] devnull devnull devnull) - | None -> assert false -;; - -(* called by the remote control *) -let remotejump rendering_window url = - current_url := url ; - update_output rendering_window url -;; - -let choose_selection rendering_window (node : Ominidom.o_mDOMNode option) = - let module O = Ominidom in - let rec aux node = - match node#get_attribute (O.o_mDOMString_of_string "xref") with - Some _ -> rendering_window#output#set_selection (Some node) - | None -> aux (node#get_parent) - in - match node with - Some x -> aux x - | None -> rendering_window#output#set_selection None -;; - -let annotateb_pressed rendering_window annotation_window () = - let module O = Ominidom in - match rendering_window#output#get_selection with - Some node -> - begin - match (node#get_attribute (O.o_mDOMString_of_string "xref")) with - Some xpath -> - let annobj = get_annotated_obj () - and annotation = (annotation_window#annotation : GEdit.text) in - ann := CicXPath.get_annotation annobj (xpath#get_string) ; - CicAnnotationHinter.create_hints annotation_window annobj - (xpath#get_string) ; - annotation#delete_text 0 annotation#length ; - begin - match !(!ann) with - None -> - annotation#misc#set_sensitive false ; - annotation_window#radio_none#set_active true ; - radio_some_status := false - | Some ann' -> - annotation#insert ann' ; - annotation#misc#set_sensitive true ; - annotation_window#radio_some#set_active true ; - radio_some_status := true - end ; - GMain.Grab.add (annotation_window#window_to_annotate#coerce) ; - annotation_window#show () ; - | None -> rendering_window#label#set_text ("ERROR: No xref found!!!\n") - end - | None -> rendering_window#label#set_text ("ERROR: No selection!!!\n") -;; - -(* called when the annotation is confirmed *) -let save_annotation annotation = - let module S = Str in - let module U = UriManager in - if !radio_some_status then - !ann := Some (annotation#get_chars 0 annotation#length) - else - !ann := None ; - match !annotated_obj with - None -> assert false - | Some (annobj,_) -> - let uri = get_current_uri () in - let annxml = Annotation2Xml.pp_annotation annobj uri in - make_dirs - (pathname_of_annuri (U.buri_of_uri uri)) ; - Xml.pp ~quiet:true annxml - (Some - (pathname_of_annuri (U.string_of_uri (U.annuri_of_uri uri)) ^ - ".xml" - ) - ) -;; - -(* STUFF TO BUILD THE GTK INTERFACE *) - -(* Stuff for the widget settings *) - -let export_to_postscript (output : GMathView.math_view) () = - output#export_to_postscript ~filename:"output.ps" (); -;; - -let activate_t1 output button_set_anti_aliasing button_set_kerning - button_export_to_postscript button_t1 () -= - let is_set = button_t1#active in - output#set_font_manager_type - (if is_set then `font_manager_t1 else `font_manager_gtk) ; - if is_set then - begin - button_set_anti_aliasing#misc#set_sensitive true ; - button_set_kerning#misc#set_sensitive true ; - button_export_to_postscript#misc#set_sensitive true ; - end - else - begin - button_set_anti_aliasing#misc#set_sensitive false ; - button_set_kerning#misc#set_sensitive false ; - button_export_to_postscript#misc#set_sensitive false ; - end -;; - -let set_anti_aliasing output button_set_anti_aliasing () = - output#set_anti_aliasing button_set_anti_aliasing#active -;; - -let set_kerning output button_set_kerning () = - output#set_kerning button_set_kerning#active -;; - -let changefont output font_size_spinb () = - output#set_font_size font_size_spinb#value_as_int -;; - -let set_log_verbosity output log_verbosity_spinb () = - output#set_log_verbosity log_verbosity_spinb#value_as_int -;; - -class settings_window output sw button_export_to_postscript jump_callback - selection_changed_callback -= - let settings_window = GWindow.window ~title:"GtkMathView settings" () in - let vbox = - GPack.vbox ~packing:settings_window#add () in - let table = - GPack.table - ~rows:1 ~columns:3 ~homogeneous:false ~row_spacings:5 ~col_spacings:5 - ~border_width:5 ~packing:vbox#add () in - let button_t1 = - GButton.toggle_button ~label:"activate t1 fonts" - ~packing:(table#attach ~left:0 ~top:0) () in - let button_set_anti_aliasing = - GButton.toggle_button ~label:"set_anti_aliasing" - ~packing:(table#attach ~left:1 ~top:0) () in - let button_set_kerning = - GButton.toggle_button ~label:"set_kerning" - ~packing:(table#attach ~left:2 ~top:0) () in - let table = - GPack.table - ~rows:2 ~columns:2 ~homogeneous:false ~row_spacings:5 ~col_spacings:5 - ~border_width:5 ~packing:vbox#add () in - let font_size_label = - GMisc.label ~text:"font size:" - ~packing:(table#attach ~left:0 ~top:0 ~expand:`NONE) () in - let font_size_spinb = - let sadj = - GData.adjustment ~value:14.0 ~lower:5.0 ~upper:50.0 ~step_incr:1.0 () - in - GEdit.spin_button - ~adjustment:sadj ~packing:(table#attach ~left:1 ~top:0 ~fill:`NONE) () in - let log_verbosity_label = - GMisc.label ~text:"log verbosity:" - ~packing:(table#attach ~left:0 ~top:1) () in - let log_verbosity_spinb = - let sadj = - GData.adjustment ~value:0.0 ~lower:0.0 ~upper:3.0 ~step_incr:1.0 () - in - GEdit.spin_button - ~adjustment:sadj ~packing:(table#attach ~left:1 ~top:1) () in - let hbox = - GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in - let closeb = - GButton.button ~label:"Close" - ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in -object(self) - method show = settings_window#show - initializer - button_set_anti_aliasing#misc#set_sensitive false ; - button_set_kerning#misc#set_sensitive false ; - (* Signals connection *) - ignore(button_t1#connect#clicked - (activate_t1 output button_set_anti_aliasing button_set_kerning - button_export_to_postscript button_t1)) ; - ignore(font_size_spinb#connect#changed (changefont output font_size_spinb)) ; - ignore(button_set_anti_aliasing#connect#toggled - (set_anti_aliasing output button_set_anti_aliasing)); - ignore(button_set_kerning#connect#toggled - (set_kerning output button_set_kerning)) ; - ignore(log_verbosity_spinb#connect#changed - (set_log_verbosity output log_verbosity_spinb)) ; - ignore(closeb#connect#clicked settings_window#misc#hide) -end;; - -(* Main windows *) - -class annotation_window output label = - let window_to_annotate = - GWindow.window ~title:"Annotating environment" ~border_width:2 () in - let hbox1 = - GPack.hbox ~packing:window_to_annotate#add () in - let vbox1 = - GPack.vbox ~packing:(hbox1#pack ~padding:5) () in - let hbox2 = - GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in - let radio_some = GButton.radio_button ~label:"Annotation below" - ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in - let radio_none = GButton.radio_button ~label:"No annotation" - ~group:radio_some#group - ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) - ~active:true () in - let annotation = GEdit.text ~editable:true ~width:400 ~height:180 - ~packing:(vbox1#pack ~padding:5) () in - let table = - GPack.table ~rows:3 ~columns:3 ~packing:(vbox1#pack ~padding:5) () in - let annotation_hints = - Array.init 9 - (function i -> - GButton.button ~label:("Hint " ^ string_of_int i) - ~packing:(table#attach ~left:(i mod 3) ~top:(i / 3)) () - ) in - let vbox2 = - GPack.vbox ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let confirmb = - GButton.button ~label:"O.K." - ~packing:(vbox2#pack ~expand:false ~fill:false ~padding:5) () in - let abortb = - GButton.button ~label:"Abort" - ~packing:(vbox2#pack ~expand:false ~fill:false ~padding:5) () in -object (self) - method window_to_annotate = window_to_annotate - method annotation = annotation - method radio_some = radio_some - method radio_none = radio_none - method annotation_hints = annotation_hints - method output = (output : GMathView.math_view) - method show () = window_to_annotate#show () - initializer - (* signal handlers here *) - ignore (window_to_annotate#event#connect#delete - (fun _ -> - window_to_annotate#misc#hide () ; - GMain.Grab.remove (window_to_annotate#coerce) ; - true - )) ; - ignore (confirmb#connect#clicked - (fun () -> - window_to_annotate#misc#hide () ; - save_annotation annotation ; - GMain.Grab.remove (window_to_annotate#coerce) ; - let new_current_uri = UriManager.annuri_of_uri (get_current_uri ()) in - Getter.register new_current_uri - (Configuration.annotations_url ^ - Str.replace_first (Str.regexp "^cic:") "" - (UriManager.string_of_uri new_current_uri) ^ ".xml" - ) ; -(*CSC: corretto, up to XsltProcessor.url_of_uri - let new_current_url = XsltProcessor.url_of_uri new_current_uri in - current_url := new_current_url ; - label#set_text (UriManager.string_of_uri new_current_uri) ; - output#load new_current_url -*) () - )) ; - ignore (abortb#connect#clicked - (fun () -> - window_to_annotate#misc#hide () ; - GMain.Grab.remove (window_to_annotate#coerce) - )); - ignore (radio_some#connect#clicked - (fun () -> annotation#misc#set_sensitive true ; radio_some_status := true)) ; - ignore (radio_none #connect#clicked - (fun () -> - annotation#misc#set_sensitive false; - radio_some_status := false) - ) -end;; - -class rendering_window annotation_window output (label : GMisc.label) = - let window = - GWindow.window ~title:"MathML viewer" ~border_width:2 () in - let vbox = - GPack.vbox ~packing:window#add () in - let _ = vbox#pack ~expand:false ~fill:false ~padding:5 label#coerce in - let scrolled_window0 = - GBin.scrolled_window ~border_width:10 - ~packing:(vbox#pack ~expand:true ~padding:5) () in - let _ = scrolled_window0#add output#coerce in - let hbox = - GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in - let annotateb = - GButton.button ~label:"Annotate" - ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in - let settingsb = - GButton.button ~label:"Settings" - ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in - let button_export_to_postscript = - GButton.button ~label:"export_to_postscript" - ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in - let closeb = - GButton.button ~label:"Close" - ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in -object(self) - method label = label - method output = (output : GMathView.math_view) - method show () = window#show () - initializer - button_export_to_postscript#misc#set_sensitive false ; - - (* signal handlers here *) - ignore(output#connect#jump (jump self)) ; - ignore(output#connect#selection_changed (choose_selection self)) ; - ignore(closeb#connect#clicked (fun _ -> GMain.Main.quit ())) ; - ignore(annotateb#connect#clicked (annotateb_pressed self annotation_window)) ; - let settings_window = new settings_window output scrolled_window0 - button_export_to_postscript (jump self) (choose_selection self) in - ignore(settingsb#connect#clicked settings_window#show) ; - ignore(button_export_to_postscript#connect#clicked (export_to_postscript output)) ; - ignore(window#event#connect#delete (fun _ -> GMain.Main.quit () ; true )) -end;; - -(* MAIN *) - -let initialize_everything tmpfile url = - let module U = Unix in - (* Let's be ready to be remotely controlled *) - let socket = U.socket ~domain:U.PF_INET ~kind:U.SOCK_DGRAM ~protocol:0 in - let address = U.ADDR_INET (U.inet_addr_of_string "127.000.000.001", 8778) in - let buffersize = 2048 in (* are 2048 chars enough? *) - let buffer = String.create buffersize in - try - U.bind socket address ; - U.set_nonblock socket ; - let output = GMathView.math_view ~width:400 ~height:380 () - and label = GMisc.label ~text:"???" () in - let annotation_window = new annotation_window output label in - let rendering_window = - new rendering_window annotation_window output label - in - let exec_remote_request () = - try - remotejump rendering_window - (String.sub buffer 0 (U.recv socket buffer 0 buffersize [])) - with - U.Unix_error (U.EAGAIN,_,_) - | U.Unix_error (U.EWOULDBLOCK,_,_) -> () - in - ignore (GMain.Timeout.add ~ms:500 - ~callback:(fun () -> exec_remote_request () ; true)) ; - rendering_window#show () ; - rendering_window#label#set_text (uri_from_url url) ; - rendering_window#output#load tmpfile ; - GMain.Main.main () - with - U.Unix_error (_,"bind",_) -> - (* Another copy is already under execution ==> I am a remote control *) - ignore (U.sendto socket url 0 (String.length url) [] address) -;; - -let _ = - let filename = ref "" in - let usage_msg = - "\nusage: mmlinterface[.opt] file url\n\n List of options:" - in - Arg.parse [] - (fun x -> - if x = "" then raise (Arg.Bad "Empty filename or URL not allowed") ; - if !filename = "" then - filename := x - else if !current_url = "" then - current_url := x - else - begin - prerr_string "More than two arguments provided\n" ; - Arg.usage [] usage_msg ; - exit (-1) - end - ) usage_msg ; - initialize_everything !filename !current_url -;; diff --git a/helm/interface/pxpUriResolver.ml b/helm/interface/pxpUriResolver.ml deleted file mode 100644 index 7ca78aa93..000000000 --- a/helm/interface/pxpUriResolver.ml +++ /dev/null @@ -1,128 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 11/10/2000 *) -(* *) -(* *) -(******************************************************************************) - -let resolve s = - let starts_with s s' = - if String.length s < String.length s' then - false - else - (String.sub s 0 (String.length s')) = s' - in - if starts_with s "http:" then - ClientHTTP.get_and_save_to_tmp s - else - s -;; - -let url_syntax = - let enable_if = - function - `Not_recognized -> Neturl.Url_part_not_recognized - | `Allowed -> Neturl.Url_part_allowed - | `Required -> Neturl.Url_part_required - in - { Neturl.null_url_syntax with - Neturl.url_enable_scheme = enable_if `Allowed; - Neturl.url_enable_host = enable_if `Allowed; - Neturl.url_enable_path = Neturl.Url_part_required; - Neturl.url_accepts_8bits = true; - } -;; - -let file_url_of_id xid = - let file_url_of_sysname sysname = - (* By convention, we can assume that sysname is a URL conforming - * to RFC 1738 with the exception that it may contain non-ASCII - * UTF-8 characters. - *) - try - Neturl.url_of_string url_syntax sysname - (* may raise Malformed_URL *) - with - Neturl.Malformed_URL -> raise Pxp_reader.Not_competent - in - let url = - match xid with - Pxp_types.Anonymous -> raise Pxp_reader.Not_competent - | Pxp_types.Public (_,sysname) -> - let sysname = resolve sysname in - if sysname <> "" then file_url_of_sysname sysname - else raise Pxp_reader.Not_competent - | Pxp_types.System sysname -> - let sysname = resolve sysname in - file_url_of_sysname sysname - in - let scheme = - try Neturl.url_scheme url with Not_found -> "file" in - let host = - try Neturl.url_host url with Not_found -> "" in - - if scheme <> "file" then raise Pxp_reader.Not_competent; - if host <> "" && host <> "localhost" then raise Pxp_reader.Not_competent; - - url -;; - -let from_file ?system_encoding utf8_filename = - - let r = - new Pxp_reader.resolve_as_file - ?system_encoding:system_encoding - ~url_of_id:file_url_of_id - () - in - - let utf8_abs_filename = - if utf8_filename <> "" && utf8_filename.[0] = '/' then - utf8_filename - else - Sys.getcwd() ^ "/" ^ utf8_filename - in - - let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in - let url = Neturl.make_url - ~scheme:"file" - ~host:"localhost" - ~path:(Neturl.split_path utf8_abs_filename) - syntax - in - - let xid = Pxp_types.System (Neturl.string_of_url url) in - - - Pxp_yacc.ExtID(xid, r) -;; - - diff --git a/helm/interface/reduction.ml b/helm/interface/reduction.ml deleted file mode 100644 index 558822b2d..000000000 --- a/helm/interface/reduction.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -let read_from_stdin = ref false;; -let uris_in_input = ref false;; -let reduction_only = ref false;; - -let parse uri = - print_endline ("^^^" ^ uri ^ "^^^") ; - print_string (CicPp.ppobj (CicCache.get_obj (UriManager.uri_of_string uri))) ; - print_endline ("\n$$$" ^ uri ^ "$$$\n") -;; - -let uri_of_filename fn = - if !uris_in_input then fn - else - let uri = - Str.replace_first (Str.regexp (Str.quote Configuration.helm_dir)) "cic:" fn - in - let uri' = Str.replace_first (Str.regexp "\.xml$") "" uri in - uri' -;; - -(* filenames are read from command line and converted to uris via *) -(* uri_of_filenames; then the cic terms are load in cache via *) -(* CicCache.get_obj and then pretty printed via CicPp.ppobj *) - -exception NotADefinition;; - -let main () = - let files = ref [] in - Arg.parse - ["-stdin", Arg.Set read_from_stdin, "Read from stdin" ; - "-uris", Arg.Set uris_in_input, "Read uris, not filenames" ; - "-update", Arg.Unit Getter.update, "Update the getter view of the world" ; - "-reduction", Arg.Set reduction_only, "Do reduction instead of tyepchecking"] - (fun x -> files := (uri_of_filename x) :: !files) - " -usage: experiment file ... - -List of options:"; - if !read_from_stdin then - begin - try - while true do - let l = Str.split (Str.regexp " ") (read_line ()) in - List.iter (fun x -> files := (uri_of_filename x) :: !files) l - done - with - End_of_file -> () - end ; - files := List.rev !files; - List.iter - (function x -> - print_string x ; - flush stdout ; - (try - if !reduction_only then - match CicCache.get_obj (UriManager.uri_of_string x) with - Cic.Definition (_,bo,_,_) -> - CicTypeChecker.typecheck (UriManager.uri_of_string x) ; - ignore (CicReduction.whd bo) - | _ -> raise NotADefinition - else - CicTypeChecker.typecheck (UriManager.uri_of_string x) - with - e -> print_newline () ; flush stdout ; raise e ) ; - print_endline " OK!" ; - flush stdout - ) !files -;; - -main ();; diff --git a/helm/interface/styleConfiguration.ml b/helm/interface/styleConfiguration.ml deleted file mode 100644 index ff85de718..000000000 --- a/helm/interface/styleConfiguration.ml +++ /dev/null @@ -1,95 +0,0 @@ -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 28/12/2000 *) -(* *) -(* This is the parser that reads the configuration file of helm *) -(* *) -(******************************************************************************) - -let filename = - try - Sys.getenv "HELM_STYLECONFIGURATION_PATH" - with - Not_found -> - let xml = "style-configuration.xml" in - let tmp_xml = Configuration.tmp_dir ^ "/" ^ xml in - let request_xml = Configuration.getter_url ^ "getstyleconf?uri=" ^ xml in - ClientHTTP.get_and_save request_xml tmp_xml ; - tmp_xml - -exception Warnings;; - -class warner = - object - method warn w = - print_endline ("WARNING: " ^ w) ; - (raise Warnings : unit) - end -;; - -let xml_document () = - let module Y = Pxp_yacc in - try - let config = {Y.default_config with Y.warner = new warner} in - Y.parse_document_entity config (PxpUriResolver.from_file filename) Y.default_spec - with - e -> - print_endline (Pxp_types.string_of_exn e) ; - raise e -;; - -exception Impossible;; - -let styles = Hashtbl.create 13;; -let applies = Hashtbl.create 13;; - -(* we trust the xml file to be valid because of the validating xml parser *) -let _ = - List.iter - (function - n -> - match n#node_type with - Pxp_document.T_element "style" -> - let key = - try - match n#attribute "key" with - Pxp_types.Value s -> s - | _ -> raise Impossible - with - Not_found -> n#data - in - Hashtbl.add styles key n#data - | Pxp_document.T_element "apply" -> - let keys = List.map - (function n -> - match n#node_type with - Pxp_document.T_element "style-ref" -> - begin - match n#attribute "key" with - Pxp_types.Value s -> s - | _ -> raise Impossible - end - | _ -> raise Impossible - ) - n#sub_nodes - in - let apply_name = - match n#attribute "name" with - Pxp_types.Value s -> s - | _ -> raise Impossible - in Hashtbl.add applies apply_name keys - | _ -> raise Impossible - ) - ((xml_document ())#root#sub_nodes) -;; - -let style_of_key key = - Hashtbl.find styles key - -let key_list_of_mode_name name = - Hashtbl.find applies name -;; - diff --git a/helm/interface/theory.ml b/helm/interface/theory.ml deleted file mode 100644 index 10ef1144b..000000000 --- a/helm/interface/theory.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type theory_elem = - Theorem of string (* uri *) - | Definition of string (* uri *) - | Axiom of string (* uri *) - | Variable of string (* uri *) - | Section of string * theory_elem list (* uri, subtheory *) -and theory = - string * theory_elem list (* uri, subtheory *) -;; diff --git a/helm/interface/theoryCache.ml b/helm/interface/theoryCache.ml deleted file mode 100644 index c7f6a3f9f..000000000 --- a/helm/interface/theoryCache.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type check_status = Checked | Unchecked;; - -let hashtable = Hashtbl.create 17;; - -let get_term_and_type_checking_info uri = - try - Hashtbl.find hashtable uri - with - Not_found -> - let filename = Getter.get uri in - let term = TheoryParser.theory_of_xml filename in - Hashtbl.add hashtable uri (term, Unchecked) ; - (term, Unchecked) -;; - - -let get_theory uri = - fst (get_term_and_type_checking_info uri) -;; - -let is_type_checked uri = - match snd (get_term_and_type_checking_info uri) with - Checked -> true - | Unchecked -> false -;; - -let set_type_checking_info uri = - match Hashtbl.find hashtable uri with - (term, _) -> - Hashtbl.remove hashtable uri ; - Hashtbl.add hashtable uri (term, Checked) -;; diff --git a/helm/interface/theoryParser.ml b/helm/interface/theoryParser.ml deleted file mode 100644 index 5ce9fff6c..000000000 --- a/helm/interface/theoryParser.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception Warnings;; - -class warner = - object - method warn w = - print_endline ("WARNING: " ^ w) ; - (raise Warnings : unit) - end -;; - -exception EmptyUri;; - -let theory_of_xml filename = - let module Y = Pxp_yacc in - try - let d = - let config = {Y.default_config with Y.warner = new warner} in - Y.parse_document_entity config -(*PXP (Y.ExtID (Pxp_types.System filename, - new Pxp_reader.resolve_as_file ~url_of_id ())) -*) (PxpUriResolver.from_file filename) - Y.default_spec - in - TheoryParser2.get_theory d#root - with - e -> - print_endline (Pxp_types.string_of_exn e) ; - raise e -;; diff --git a/helm/interface/theoryParser2.ml b/helm/interface/theoryParser2.ml deleted file mode 100644 index 4304ecc2b..000000000 --- a/helm/interface/theoryParser2.ml +++ /dev/null @@ -1,66 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception IllFormedXml of int;; - -(* Utility functions that transform a Pxp attribute into something useful *) - -let string_of_attr a = - let module T = Pxp_types in - match a with - T.Value s -> s - | _ -> raise (IllFormedXml 0) - -let get_theory n = - let module D = Pxp_document in - let module T = Theory in - let rec get_theory_elem n = - let ntype = n # node_type in - match ntype with - D.T_element "THEOREM" -> - let uri = string_of_attr (n # attribute "uri") in - T.Theorem uri - | D.T_element "DEFINITION" -> - let uri = string_of_attr (n # attribute "uri") in - T.Definition uri - | D.T_element "AXIOM" -> - let uri = string_of_attr (n # attribute "uri") in - T.Axiom uri - | D.T_element "VARIABLE" -> - let uri = string_of_attr (n # attribute "uri") in - T.Variable uri - | D.T_element "SECTION" -> - let uri = string_of_attr (n # attribute "uri") - and subtheory = List.map get_theory_elem (n # sub_nodes) in - T.Section (uri, subtheory) - | D.T_element _ | D.T_data | _ -> - raise (IllFormedXml 1) - in - match n # node_type with - D.T_element "Theory" -> - let uri = string_of_attr (n # attribute "uri") in - (uri, List.map get_theory_elem (n # sub_nodes)) - | _ -> raise (IllFormedXml 2) -;; diff --git a/helm/interface/theoryTypeChecker.ml b/helm/interface/theoryTypeChecker.ml deleted file mode 100644 index 7ebbf190b..000000000 --- a/helm/interface/theoryTypeChecker.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception NotWellTyped of string;; - -let typecheck uri = - let rec typecheck_term curi t = - let module T = Theory in - let module P = CicTypeChecker in - let module C = CicCache in - let module U = UriManager in - let obj_typecheck uri = - try - P.typecheck (U.uri_of_string uri) - with - P.NotWellTyped s -> - raise (NotWellTyped - ("Type Checking was NOT successfull due to an error during " ^ - "type-checking of term " ^ uri ^ ":\n\n" ^ s)) - in - match t with - T.Theorem uri -> obj_typecheck (curi ^ "/" ^ uri) - | T.Definition uri -> obj_typecheck (curi ^ "/" ^ uri) - | T.Axiom uri -> obj_typecheck (curi ^ "/" ^ uri) - | T.Variable uri -> obj_typecheck (curi ^ "/" ^ uri) - | T.Section (uri,l) -> typecheck_theory l (curi ^ "/" ^ uri) - and typecheck_theory l curi = - List.iter (typecheck_term curi) l - in - let (uri, l) = TheoryCache.get_theory uri in - typecheck_theory l uri -;; diff --git a/helm/interface/toglie_helm_xref.pl b/helm/interface/toglie_helm_xref.pl deleted file mode 100755 index 13c9739ab..000000000 --- a/helm/interface/toglie_helm_xref.pl +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/perl - -while() -{ - s/helm:xref="[^"]*"//g; - s/helm:xref='[^']*'//g; - print; -} diff --git a/helm/interface/toglie_helm_xref.sh b/helm/interface/toglie_helm_xref.sh deleted file mode 100755 index b3cb4e0d4..000000000 --- a/helm/interface/toglie_helm_xref.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/bash - -echo "****" $1 -cp $1 /tmp/pippo -cat /tmp/pippo | ./toglie_helm_xref.pl > $1 diff --git a/helm/interface/uriManager.ml b/helm/interface/uriManager.ml deleted file mode 100644 index 52c7f3426..000000000 --- a/helm/interface/uriManager.ml +++ /dev/null @@ -1,111 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* "cic:/a/b/c.con" => [| "cic:/a" ; "cic:/a/b" ; "cic:/a/b/c.con" ; "c" |] *) -type uri = string array;; - -let eq uri1 uri2 = - uri1 == uri2 -;; - -let string_of_uri uri = uri.(Array.length uri - 2);; -let name_of_uri uri = uri.(Array.length uri - 1);; -let buri_of_uri uri = uri.(Array.length uri - 3);; -let depth_of_uri uri = Array.length uri - 2;; - -(*CSC: ora e' diventato poco efficiente, migliorare *) -let relative_depth curi uri cookingsno = - let rec length_of_current_prefix l1 l2 = - match (l1, l2) with - (he1::tl1, he2::tl2) when he1 == he2 -> - 1 + length_of_current_prefix tl1 tl2 - | (_,_) -> 0 - in - depth_of_uri uri - - length_of_current_prefix - (Array.to_list (Array.sub curi 0 (Array.length curi - (2 + cookingsno)))) - (Array.to_list (Array.sub uri 0 (Array.length uri - 2))) - (*CSC: vecchio codice da eliminare - if eq curi uri then 0 - else - depth_of_uri uri - - length_of_current_prefix (Array.to_list curi) (Array.to_list uri) - *) -;; - -module OrderedStrings = - struct - type t = string - let compare (s1 : t) (s2 : t) = compare s1 s2 - end -;; - -module SetOfStrings = Map.Make(OrderedStrings);; - -(*CSC: commento obsoleto ed errato *) -(* Invariant: the map is the identity function, *) -(* i.e. (SetOfStrings.find str !set_of_uri) == str *) -let set_of_uri = ref SetOfStrings.empty;; -let set_of_prefixes = ref SetOfStrings.empty;; - -(* similar to uri_of_string, but used for prefixes of uris *) -let normalize prefix = - try - SetOfStrings.find prefix !set_of_prefixes - with - Not_found -> - set_of_prefixes := SetOfStrings.add prefix prefix !set_of_prefixes ; - prefix -;; - -exception IllFormedUri of string;; - -let mk_prefixes str = - let rec aux curi = - function - [he] -> - let prefix_uri = curi ^ "/" ^ he - and name = List.hd (Str.split (Str.regexp "\.") he) in - [ normalize prefix_uri ; name ] - | he::tl -> - let prefix_uri = curi ^ "/" ^ he in - (normalize prefix_uri)::(aux prefix_uri tl) - | _ -> raise (IllFormedUri str) - in - let tokens = (Str.split (Str.regexp "/") str) in - (* ty = "cic:" *) - let (ty, sp) = (List.hd tokens, List.tl tokens) in - aux ty sp -;; - -let uri_of_string str = - try - SetOfStrings.find str !set_of_uri - with - Not_found -> - let uri = Array.of_list (mk_prefixes str) in - set_of_uri := SetOfStrings.add str uri !set_of_uri ; - uri -;; diff --git a/helm/interface/uriManager.ml.implementazione_banale b/helm/interface/uriManager.ml.implementazione_banale deleted file mode 100644 index cd0d71f71..000000000 --- a/helm/interface/uriManager.ml.implementazione_banale +++ /dev/null @@ -1,18 +0,0 @@ -type uri = string;; - -let eq uri1 uri2 = - uri1 = uri2 -;; - -let string_of_uri uri = uri;; -let uri_of_string str = str;; - -let name_of_uri uri = - let l = Str.split (Str.regexp "/") uri in - let name_suf = List.nth l (List.length l - 1) in - List.hd (Str.split (Str.regexp "\.") name_suf) -;; - -let depth_of_uri uri = - List.length (Str.split (Str.regexp "/") uri) - 2 -;; diff --git a/helm/interface/uriManager.ml.implementazione_doppia b/helm/interface/uriManager.ml.implementazione_doppia deleted file mode 100644 index d03d9970f..000000000 --- a/helm/interface/uriManager.ml.implementazione_doppia +++ /dev/null @@ -1,86 +0,0 @@ -(* "cic:/a/b/c.con" => [| "cic:/a" ; "cic:/a/b" ; "cic:/a/b/c.con" ; "c" |] *) -type uri = string array;; - -let eq uri1 uri2 = - uri1 == uri2 -;; - -let string_of_uri uri = uri.(Array.length uri - 2);; -let name_of_uri uri = uri.(Array.length uri - 1);; -let buri_of_uri uri = uri.(Array.length uri - 3);; -let depth_of_uri uri = Array.length uri - 2;; - -(*CSC: ora e' diventato poco efficiente, migliorare *) -let relative_depth curi uri cookingsno = - let rec length_of_current_prefix l1 l2 = - match (l1, l2) with - (he1::tl1, he2::tl2) when he1 == he2 -> - 1 + length_of_current_prefix tl1 tl2 - | (_,_) -> 0 - in - depth_of_uri uri - - length_of_current_prefix - (Array.to_list (Array.sub curi 0 (Array.length curi - (2 + cookingsno)))) - (Array.to_list (Array.sub uri 0 (Array.length uri - 2))) - (*CSC: vecchio codice da eliminare - if eq curi uri then 0 - else - depth_of_uri uri - - length_of_current_prefix (Array.to_list curi) (Array.to_list uri) - *) -;; - -module OrderedStrings = - struct - type t = string - let compare (s1 : t) (s2 : t) = compare s1 s2 - end -;; - -module SetOfStrings = Map.Make(OrderedStrings);; - -(*CSC: commento obsoleto ed errato *) -(* Invariant: the map is the identity function, *) -(* i.e. (SetOfStrings.find str !set_of_uri) == str *) -let set_of_uri = ref SetOfStrings.empty;; -let set_of_prefixes = ref SetOfStrings.empty;; - -(* similar to uri_of_string, but used for prefixes of uris *) -let normalize prefix = - try - SetOfStrings.find prefix !set_of_prefixes - with - Not_found -> - set_of_prefixes := SetOfStrings.add prefix prefix !set_of_prefixes ; - prefix -;; - -exception IllFormedUri of string;; - -let mk_prefixes str = - let rec aux curi = - function - [he] -> - let prefix_uri = curi ^ "/" ^ he - and name = List.hd (Str.split (Str.regexp "\.") he) in - [ normalize prefix_uri ; name ] - | he::tl -> - let prefix_uri = curi ^ "/" ^ he in - (normalize prefix_uri)::(aux prefix_uri tl) - | _ -> raise (IllFormedUri str) - in - let tokens = (Str.split (Str.regexp "/") str) in - (* ty = "cic:" *) - let (ty, sp) = (List.hd tokens, List.tl tokens) in - aux ty sp -;; - -let uri_of_string str = - try - SetOfStrings.find str !set_of_uri - with - Not_found -> - let uri = Array.of_list (mk_prefixes str) in - set_of_uri := SetOfStrings.add str uri !set_of_uri ; - uri -;; diff --git a/helm/interface/uriManager.ml.implementazione_semplice b/helm/interface/uriManager.ml.implementazione_semplice deleted file mode 100644 index 8b8921b3e..000000000 --- a/helm/interface/uriManager.ml.implementazione_semplice +++ /dev/null @@ -1,39 +0,0 @@ -type uri = string;; - -let eq uri1 uri2 = - uri1 == uri2 -;; - -let string_of_uri uri = uri;; - -let name_of_uri uri = - let l = Str.split (Str.regexp "/") uri in - let name_suf = List.nth l (List.length l - 1) in - List.hd (Str.split (Str.regexp "\.") name_suf) -;; - -let depth_of_uri uri = - List.length (Str.split (Str.regexp "/") uri) - 2 -;; - -module OrderedStrings = - struct - type t = string - let compare (s1 : t) (s2 : t) = compare s1 s2 - end -;; - -module SetOfStrings = Map.Make(OrderedStrings);; - -(* Invariant: the map is the identity function, *) -(* i.e. (SetOfStrings.find str !set_of_uri) == str *) -let set_of_uri = ref SetOfStrings.empty;; - -let uri_of_string str = - try - SetOfStrings.find str !set_of_uri - with - Not_found -> - set_of_uri := SetOfStrings.add str str !set_of_uri ; - str -;; diff --git a/helm/interface/uriManager.mli b/helm/interface/uriManager.mli deleted file mode 100644 index 9bd6210d9..000000000 --- a/helm/interface/uriManager.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type uri - -val eq : uri -> uri -> bool - -val uri_of_string : string -> uri - -val string_of_uri : uri -> string (* complete uri *) -val name_of_uri : uri -> string (* name only (without extension)*) -val buri_of_uri : uri -> string (* base uri only *) -val depth_of_uri : uri -> int (* length of the path *) - -(* relative_depth curi uri cookingsno *) -(* is the number of times to cook uri to use it when the current uri is curi *) -(* cooked cookingsno times *) -val relative_depth : uri -> uri -> int -> int diff --git a/helm/interface/uris_of_filenames.pl b/helm/interface/uris_of_filenames.pl deleted file mode 100755 index 019730bee..000000000 --- a/helm/interface/uris_of_filenames.pl +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/perl - -while() { - chomp; - split / /; - for (@_) { - $GZSUFF = ""; - if (/.gz$/) - { s/.gz$//; $GZSUFF = " gz" if ($ARGV[0] == "-gz"); } - if (/.*\.(con|var|ind)(\.types)?\.xml/) - { s/\./cic:/; } - elsif (/.*\.theory\.xml/) - { s/\./theory:/; } - s/\.xml//; - print $_.$GZSUFF."\n"; - } -} diff --git a/helm/interface/xml.ml b/helm/interface/xml.ml deleted file mode 100644 index 5926b48eb..000000000 --- a/helm/interface/xml.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* A tactic to print Coq objects in XML *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 18/10/2000 *) -(* *) -(* This module defines a pretty-printer and the stream of commands to the pp *) -(* *) -(******************************************************************************) - - -(* the type token for XML cdata, empty elements and not-empty elements *) -(* Usage: *) -(* Str cdata *) -(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) -(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) -(* content *) -type token = Str of string - | Empty of string * (string * string) list - | NEmpty of string * (string * string) list * token Stream.t -;; - -(* currified versions of the constructors make the code more readable *) -let xml_empty name attrs = [< 'Empty(name,attrs) >] -let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >] -let xml_cdata str = [< 'Str str >] - -(* Usage: *) -(* pp tokens None pretty prints the output on stdout *) -(* pp tokens (Some filename) pretty prints the output on the file filename *) -let pp strm fn = - let channel = ref stdout in - let rec pp_r m = - parser - [< 'Str a ; s >] -> - print_spaces m ; - fprint_string (a ^ "\n") ; - pp_r m s - | [< 'Empty(n,l) ; s >] -> - print_spaces m ; - fprint_string ("<" ^ n) ; - List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; - fprint_string "/>\n" ; - pp_r m s - | [< 'NEmpty(n,l,c) ; s >] -> - print_spaces m ; - fprint_string ("<" ^ n) ; - List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; - fprint_string ">\n" ; - pp_r (m+1) c ; - print_spaces m ; - fprint_string ("\n") ; - pp_r m s - | [< >] -> () - and print_spaces m = - for i = 1 to m do fprint_string " " done - and fprint_string str = - output_string !channel str - in - match fn with - Some filename -> - channel := open_out filename ; - pp_r 0 strm ; - close_out !channel ; - print_string ("\nWriting on file \"" ^ filename ^ "\" was succesfull\n"); - flush stdout - | None -> - pp_r 0 strm -;; diff --git a/helm/interface/xml.mli b/helm/interface/xml.mli deleted file mode 100644 index 2e0c7c72a..000000000 --- a/helm/interface/xml.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* A tactic to print Coq objects in XML *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 18/10/2000 *) -(* *) -(* This module defines a pretty-printer and the stream of commands to the pp *) -(* *) -(******************************************************************************) - -(* Tokens for XML cdata, empty elements and not-empty elements *) -(* Usage: *) -(* Str cdata *) -(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) -(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) -(* content *) -type token = - | Str of string - | Empty of string * (string * string) list - | NEmpty of string * (string * string) list * token Stream.t - -(* currified versions of the token constructors make the code more readable *) -val xml_empty : string -> (string * string) list -> token Stream.t -val xml_nempty : - string -> (string * string) list -> token Stream.t -> token Stream.t -val xml_cdata : string -> token Stream.t - -(* The pretty printer for streams of token *) -(* Usage: *) -(* pp tokens None pretty prints the output on stdout *) -(* pp tokens (Some filename) pretty prints the output on the file filename *) -val pp : token Stream.t -> string option -> unit diff --git a/helm/interface/xsltProcessor.ml b/helm/interface/xsltProcessor.ml deleted file mode 100644 index 95f1c70d5..000000000 --- a/helm/interface/xsltProcessor.ml +++ /dev/null @@ -1,79 +0,0 @@ -(* Copyright (C) 2000, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -let initialize () = - Printf.printf "Initializing the UWOBO servlet, please wait" ; flush stdout ; - Hashtbl.iter - (fun key uri -> - let string_to_send = (Configuration.processor_url ^ "add?xsluri=" ^ Configuration.getter_url ^ "getxslt?uri=" ^ uri ^ "&key=" ^ key) - in - print_char '.' ; flush stdout ; - ClientHTTP.send string_to_send - ) - StyleConfiguration.styles ; - Printf.printf " ok\n" ; flush stdout -;; - -(* CSC: esempio per vedere se veniva calcolata bene. Rimuovere pure il commento -http://phd.cs.unibo.it:8080/helm/servlet/uwobo/apply?xmluri=http%3A//phd.cs.unibo.it%3A8081/getxml%3Furi%3Dcic%3A/Coq/Init/Datatypes/nat_ind.con&keys=C1,C2,L¶m.processorURL=http%3A//phd.cs.unibo.it%3A8080/helm/servlet/uwobo/¶m.getterURL=http%3A//phd.cs.unibo.it%3A8081/&prop.doctype-public=&prop.encoding=&prop.media-type=text/xml¶m.doctype-public=¶m.encoding=¶m.media-type=text/xml¶m.keys=C1%2CC2%2CL¶m.CICURI=cic:/Coq/Init/Datatypes/nat_ind.con¶m.naturalLanguage=yes¶m.annotations=NO - - -&keys=C1,C2,L -*) - -let process uri usecache mode naturalLanguage annotations = - let uri = UriManager.string_of_uri uri in - let url = Configuration.getter_url ^ "getxml?uri=" ^ uri in - let keys = - match StyleConfiguration.key_list_of_mode_name mode with - first_key::key_list -> - first_key ^ - (List.fold_right - (fun key cmd -> "," ^ key ^ cmd) - key_list - "" - ) - | _ -> prerr_string "Warning: the list of keys for UWOBO is empty\n"; "" - in - let string_to_send = - Configuration.processor_url ^ "apply?xmluri=" ^ url ^ - "¶m.processorURL=" ^ Configuration.processor_url ^ - "¶m.getterURL=" ^ Configuration.getter_url ^ - "&prop.doctype-public=&prop.encoding=&prop.media-type=text/xml" ^ - "&keys=" ^ keys ^ - "¶m.keys=" ^ keys ^ - "¶m.CICURI=" ^ uri ^ - "¶m.naturalLanguage=" ^ naturalLanguage ^ - "¶m.annotations=" ^ annotations ^ - "¶m.doctype-public=¶m.encoding=¶m.media-type=text/xml" - in - string_to_send -;; - -(*CSC: ma questa funzione ha senso? Se si', in quale modulo?*) -(*CSC: tutti i parametri passati alla process sono quasi a caso!!! *) -let url_of_uri uri = - process uri true "cic" "yes" "YES" -;;