real: remove `rx`
authorMichal Terepeta <michal.terepeta@gmail.com>
Mon, 13 Mar 2017 22:33:19 +0000 (18:33 -0400)
committerBen Gamari <ben@smart-cactus.org>
Mon, 13 Mar 2017 23:44:06 +0000 (19:44 -0400)
The benchmark doesn't compile, but even when fixed, it doesn't seem
very useful - it runs in mere ~100ms and there aren't easy knobs to
make it run for longer. Considering that this hasn't been used for
some time, it seems ok to simply remove it.

Also, removing it will make the initial version of Shake-based build
system easier.

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>
Test Plan: compile & run nofib

Reviewers: goldfire, bgamari

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D3159

83 files changed:
real/Makefile
real/rx/CHANGELOG [deleted file]
real/rx/Makefile [deleted file]
real/rx/TODO [deleted file]
real/rx/copying.html [deleted file]
real/rx/copyright.html [deleted file]
real/rx/doc/Makefile [deleted file]
real/rx/doc/rxdoc.lit [deleted file]
real/rx/doc/rxuser.lit [deleted file]
real/rx/examples/Makefile [deleted file]
real/rx/examples/basic.lit [deleted file]
real/rx/examples/check.lit [deleted file]
real/rx/index.html [deleted file]
real/rx/link.html [deleted file]
real/rx/online.html [deleted file]
real/rx/rx-MAIL [deleted file]
real/rx/src/BackwardS.hs [deleted file]
real/rx/src/CBackwardS.hs [deleted file]
real/rx/src/CForwardS.hs [deleted file]
real/rx/src/CharSeq.hs [deleted file]
real/rx/src/Command.hs [deleted file]
real/rx/src/Cross.hs [deleted file]
real/rx/src/Defaults.hs [deleted file]
real/rx/src/Exp2FA.hs [deleted file]
real/rx/src/ExpParse.hs [deleted file]
real/rx/src/FA.hs [deleted file]
real/rx/src/FA2Exp.hs [deleted file]
real/rx/src/FAcheat.hs [deleted file]
real/rx/src/FAcmpct.hs [deleted file]
real/rx/src/FAcon.hs [deleted file]
real/rx/src/FAconv.hs [deleted file]
real/rx/src/FAdet.hs [deleted file]
real/rx/src/FAhom.hs [deleted file]
real/rx/src/FAintersect.hs [deleted file]
real/rx/src/FAkeepcons.hs [deleted file]
real/rx/src/FAkeepst.hs [deleted file]
real/rx/src/FAlquotient.hs [deleted file]
real/rx/src/FAmap.hs [deleted file]
real/rx/src/FAmin.hs [deleted file]
real/rx/src/FAminus.hs [deleted file]
real/rx/src/FAneg.hs [deleted file]
real/rx/src/FArquotient.hs [deleted file]
real/rx/src/FAstar.hs [deleted file]
real/rx/src/FAsubtrans.hs [deleted file]
real/rx/src/FAtimes.hs [deleted file]
real/rx/src/FAtypes.hs [deleted file]
real/rx/src/FAunify.hs [deleted file]
real/rx/src/FAunion.hs [deleted file]
real/rx/src/FAuseful.hs [deleted file]
real/rx/src/FiniteMap.hs [deleted file]
real/rx/src/ForwardS.hs [deleted file]
real/rx/src/Gen.hs [deleted file]
real/rx/src/Gram2FA.hs [deleted file]
real/rx/src/Grammar.hs [deleted file]
real/rx/src/Heave.hs [deleted file]
real/rx/src/Heuristic.hs [deleted file]
real/rx/src/IdStack.hs [deleted file]
real/rx/src/Ids.hs [deleted file]
real/rx/src/Instance.hs [deleted file]
real/rx/src/Lex.hs [deleted file]
real/rx/src/Loop.hs [deleted file]
real/rx/src/Makefile [deleted file]
real/rx/src/Maybes.hs [deleted file]
real/rx/src/Options.hs [deleted file]
real/rx/src/PI.hs [deleted file]
real/rx/src/Parse.hs [deleted file]
real/rx/src/Prec.hs [deleted file]
real/rx/src/Pretty.hs [deleted file]
real/rx/src/PrettyClass.hs [deleted file]
real/rx/src/RX.hs [deleted file]
real/rx/src/Reader.hs [deleted file]
real/rx/src/Reuse.hs [deleted file]
real/rx/src/SaturnS.hs [deleted file]
real/rx/src/Semantik.hs [deleted file]
real/rx/src/Set.hs [deleted file]
real/rx/src/Sorters.hs [deleted file]
real/rx/src/State.hs [deleted file]
real/rx/src/Stuff.hs [deleted file]
real/rx/src/Syntax.hs [deleted file]
real/rx/src/TA.hs [deleted file]
real/rx/src/Trace.hs [deleted file]
real/rx/src/WrapSubtrans.hs [deleted file]
real/rx/template.html [deleted file]

index 11e98aa..891c41d 100644 (file)
@@ -5,7 +5,7 @@ SUBDIRS = anna bspt cacheprof compress compress2 fem fluid fulsom gamteb gg \
           grep hidden hpg infer lift linear maillist mkhprog parser pic prolog \
           reptile rsa scs symalg veritas
 
-OTHER_SUBDIRS = PolyGP rx
+OTHER_SUBDIRS = PolyGP
 
 include $(TOP)/mk/target.mk
 
diff --git a/real/rx/CHANGELOG b/real/rx/CHANGELOG
deleted file mode 100644 (file)
index e36a660..0000000
+++ /dev/null
@@ -1,16 +0,0 @@
-rx-2.0.2 (18-sep-98)
-
-       fixed a nice bug in FAunion.hs
-
-       slight rearrangements to allow other haskell programs
-       to link with RX
-
-       recast documentation into html
-
-rx-2.0.1 (5-nov-97)
-
-       fixed export lists to make rx compile with hbc
-
-rx-2.0.0 (1-nov-97) 
-
-       basic release   
\ No newline at end of file
diff --git a/real/rx/Makefile b/real/rx/Makefile
deleted file mode 100644 (file)
index b24a9e7..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-SUBDIRS=src examples
-include $(TOP)/mk/target.mk
-
diff --git a/real/rx/TODO b/real/rx/TODO
deleted file mode 100644 (file)
index 8878c94..0000000
+++ /dev/null
@@ -1,20 +0,0 @@
-a few things to add to RX
-
-- a proper type system. 
-  at the moment, everything is a rational language.
-  we would need (at least) terms, numbers, sets, lists, tuples
-
-
-- a proper module system:
-
-       - non-flat namespace
-       - import/export declarations
-       
-- modules are compiled, resulting in
-       
-       - object files (containing variable bindings,
-         like normal forms of automata)
-       - text files (containing typeset output)
-         these should be \includeonly-able
-
-- all of this gets us dangerously close to a full Haskell.
diff --git a/real/rx/copying.html b/real/rx/copying.html
deleted file mode 100644 (file)
index 5efe998..0000000
+++ /dev/null
@@ -1,341 +0,0 @@
-<PRE>
-                   GNU GENERAL PUBLIC LICENSE
-                      Version 2, June 1991
-
- Copyright (C) 1989, 1991 Free Software Foundation, Inc.
-                          675 Mass Ave, Cambridge, MA 02139, 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.
-\f
-                   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.)
-\f
-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.
-\f
-  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.
-\f
-  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
-\f
-           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.
-
-    (one line to give the program's name and a brief idea of what it does.)
-    Copyright (C) 19yy  (name of author)
-
-    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., 675 Mass Ave, Cambridge, MA 02139, 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) 19yy 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.
-
-  (signature of Ty Coon), 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.
-</PRE>
diff --git a/real/rx/copyright.html b/real/rx/copyright.html
deleted file mode 100644 (file)
index 98dbb12..0000000
+++ /dev/null
@@ -1,53 +0,0 @@
-<HTML>
-
-<HEAD>
-<TITLE>RX Copyright</TITLE>
-<LINK REV="made" HREF="mailto:joe@informatik.uni-leipzig.de">
-</HEAD>
-
-<BODY> 
-<HR>
-<H2>RX Copyright</H2>
-
-<HR>
-
-RX: An Interpreter for Rational Tree Languages
-Copyright (C) 1998 Johannes Waldmann
-<P>
-   The files Maybes.hs, FiniteMap.hs, Set.hs, Pretty.hs, CharSeq.hs,
-   Parse.hs are originally taken from libraries 
-   provided with the Glasgow Haskell Compiler,
-   and/or the Chalmers Haskell Compiler, (C) 1997 The GHC Team
-   and/or Lennart Augustsson.
-<P>
-    RX 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.
-<P>
-    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
-    <A HREF="copying.html">GNU General Public Licence</A>
-    for more details.
-<P>
-    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., 675 Mass Ave, Cambridge, MA 02139, USA.
-<P>
-
-
-<HR>
-
-<ADDRESS>
-<A HREF="http://www.informatik.uni-leipzig.de/~joe/">
-<TT>http://www.informatik.uni-leipzig.de/~joe/</TT></A>
-<A HREF="mailto:joe@informatik.uni-leipzig.de">
-<TT>mailto:joe@informatik.uni-leipzig.de</TT></A>
-</ADDRESS>
-
-</BODY>
-</HTML>
-
-
-
diff --git a/real/rx/doc/Makefile b/real/rx/doc/Makefile
deleted file mode 100644 (file)
index 4c4fc45..0000000
+++ /dev/null
@@ -1,33 +0,0 @@
-MAIN = rxdoc
-
-
-RX = ../src/RX
-
-RX_OPTS = 
-
-RTS_OPTS = +RTS -H50M -K10M -RTS
-
-WWW = $(HOME)/.www/rx
-
-###########################################################################
-
-all : $(MAIN).tex $(MAIN).dvi $(MAIN).ps $(MAIN).dvi.gz $(MAIN).ps.gz
-
-clean :
-       rm -f *~ *.tex *.dvi *.aux *.toc *.log *.ps
-
-%.gz : %
-       gzip -v -9 $<
-
-# latex stuff ##############################################################
-
-
-%.tex : %.lit 
-       $(RX) $(RTS_OPTS) $(RX_OPTS) current=text code=latex $< |tee $@
-
-%.dvi : %.tex
-       - latex "\\nonstopmode\\input $<"
-
-%.ps : %.dvi
-       dvips -t a4 $< -o $@
-
diff --git a/real/rx/doc/rxdoc.lit b/real/rx/doc/rxdoc.lit
deleted file mode 100644 (file)
index df77e40..0000000
+++ /dev/null
@@ -1,26 +0,0 @@
-.set (current=text,text=latex,eval=off)
-
-\documentclass[11pt,a4paper]{report}
-\pagestyle{headings}
-
-\setlength{\hoffset}{-0.5in}
-\addtolength{\textwidth}{1.5in}
-\addtolength{\evensidemargin}{-0.8in}
-\addtolength{\oddsidemargin}{0.3in}
-
-\setlength{\voffset}{-0.8in}
-\addtolength{\textheight}{1.5in}
-
-\parskip 2mm
-\parindent 0mm
-\renewcommand{\baselinestretch}{1.1}
-
-
-.begin(current=code,output=off)
-form RX = "\texttt{RX}"
-.end
-
-\begin{document}
-\appendix
-.import "rxuser.lit"
-\end{document}
diff --git a/real/rx/doc/rxuser.lit b/real/rx/doc/rxuser.lit
deleted file mode 100644 (file)
index f8a62d3..0000000
+++ /dev/null
@@ -1,611 +0,0 @@
-\chapter{$RX$ User Manual} %%%%%%%%%%%%%%%%%%%%%%%%%%
-\label{chapter:rxuser}
-\label{chap:rxuser}
-
-\section{Introduction}
-This chapter describes the program $RX$, 
-written within the framework of this thesis.
-$RX$ handles rational tree languages in term algebras with
-arbitrary signatures. $RX$ performs the usual operations on
-rational languages. 
-
-$RX$ has been used to guess, and later verify,
-a lot of the relations between languages that are used in the
-decision procedure for $CL S$,
-and the grammar for normalizing terms,
-given in chapters \ref{chapter:termin} and \ref{chap:predN}
-of this thesis.
-
-Furthermore, $RX$'s input and output behaviour can be customized so
-that it integrates smoothly with a typesetting system, much in the
-spirit of a \emph{literate programming} tool.  $RX$ input may be
-contained in a text document, and $RX$ output may be embedded in such
-a document.  Additionally, $RX$ output can contain formatting
-instructions to the typesetter.  In fact $RX$ is used to format the
-very thesis you are now reading.
-
-\newpage
-\section{$RX$ internals} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-$RX$ internally represents rational tree languages by
-finite tree automata. They can be non-deterministic
-(bottom-up or top-down) or deterministic (bottom-up).
-
-For details of the underlying theory, see chapter \ref{chapter:rxtheory}.
-
-The external form, used for input and output,
-is a non-deterministic top-down automaton
-that could also be called a rational grammar.
-
-
-%% \section{$RX$ implementation} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\medskip
-
-$RX$ is written entirely in the pure, lazy functional programming
-language Haskell. It uses Haskell-1.3 features. $RX$ is known to
-work with these compilers/interpreters: hugs, ghc-2.02, hbc-0.9999.4.
-It does not depend on compiler-specific extensions or libraries.
-
-$RX$ uses publically available libraries for
-\begin{enumerate}
-\item Finite Maps and Sets
-\item Parsing
-\item Pretty Printing
-\end{enumerate}
-(Copies of these are included with the $RX$ source code distribution.)
-These libraries helped me a lot when programming $RX$,
-as they provide tried and tested and optimized solutions for standard tasks,
-and allowed me to focus on finite automata programming.
-
-%% \section{$RX$ availability} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-\medskip
-
-The source code of $RX$, and some additional information,
-is available under terms of the GNU public license
-\index{GNU}
-from \verb+http://www5.informatik.uni-jena.de/~joe/rx/+.
-
-
-\newpage
-\section{$RX$ syntax} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-$RX$ lexically and syntactically borrows 
-from the Haskell programming language.
-
-\subsection*{$RX$ lexic}
-
-$RX$ code consists of lines of characters.
-
-The input may contain comments. A comment extends from 
-\verb+--+ to the end of the line, or it is enclosed in
-between \verb+{-+ and \verb+-}+.
-
-$RX$ has these lexical tokens:
-\begin{enumerate}
-\item number (a sequence of digits)
-\item name (an alphabetic character, 
-  followed by a sequence of alphanumeric characters)
-\item operator (a sequence of non-alphanumeric non-blank characters)
-\item string (enclosed in double quotes)
-\item group symbols 
-  \verb+(+, \verb+)+, \verb+[+, \verb+]+, \verb+{+, \verb+}+
-\item group separator \verb+,+ (comma).
-  Note that \verb+;+ (semi-colon) is not a separator but an operator.
-\end{enumerate}
-The names \verb+arity+ and \verb+form+ are reserved.
-
-A name may contain characters \verb+"_"+, \verb+"^"+, and \verb+"'"+,
-and they'll have their expected interpretation when
-the output is embedded in a \LaTeX\ document.
-
-Names and operators together are called \emph{identifiers}.
-
-A name enclosed in back-quotes behaves as if it were an operator.
-From now on, \emph{operator} encompasses that meaning.
-
-An operator enclosed in parentheses behaves as if it were a name.
-From now on, \emph{name} encompasses that meaning.
-
-%%% \newpage
-\subsection*{$RX$ syntax}
-
-$RX$ code is a sequence of \emph{declarations} and \emph{expressions}.
-
-A \emph{declaration} declares one of these things:
-\begin{enumerate}
-\item
-  the form of an identifier (see below),
-\item
-  the arity (number of required arguments) of names.
-
-  Example: \verb+arity 2 power, times+
-\item
-  the precedence and associativity of operators.
-  
-  Example:
-\begin{verbatim}
-infixl 7 *
-infixl 5 +
-\end{verbatim}
-\end{enumerate}
-
-An \emph{expression} is a sequence of \emph{clauses}
-separated by operators.
-
-A \emph{clause} is a name followed by a sequence of \emph{atoms}.
-
-An \emph{atom} is a name or a \emph{group}.
-
-A \emph{group} is a sequence of expressions,
-separated by group separators, enclosed in group symbols.
-The group \verb+(x)+, where \verb+x+ is an expression,
-is semantically equivalent to \verb+x+ alone.
-
-\subsection*{$RX$ special syntax}
-
-In $RX$, there is no partial application and there are no
-higher order functions. In a function application, the function
-must get exactly the number of arguments that its arity requires.
-
-Arities that have not been explicitly declared (see above)
-are implicitly set to 0 for names and 2 for operators.
-
-This is more restrictive that Haskell but it allows for 
-a nice shorthand notation: the operator \verb+@+ (called \emph{apply})
-is implicitly inserted whenever a function has \emph{more}
-arguments than necessary. Let \verb+f+ have arity 2,
-then \verb+f x y b c+ is parsed as \verb+((f x y) @ b) @ c+.
-This corresponds to the convention used in combinatory logic 
-and lambda calculus.
-
-This behavior can be controlled 
-by the switch \verb+implicit+ and by the option \verb+apply+.
-If \verb+implicit+ is \verb+on+,
-then the binary operator that is the value of the option \verb+apply+
-is inserted. Normally, this is \verb+@+.
-
-
-\newpage
-\section{$RX$ semantics}
-
-In $RX$, the semantics of each identifier is a function from
-state \(\times\) sequences of values to 
-state \(\times\) values. The length of the sequence
-is the arity of the identifier. 
-
-Currently, the values are finite tree automata,
-but this could be extended to a wider range of types.
-
-The state is just the mapping
-from identifiers to their meaning (semantics).
-The pair (identifier, meaning) is called binding.
-
-The state map can be extended by new bindings, 
-but existing meanings cannot be overridden.
-
-The operator \verb+=+ adds a new binding.
-Examples:
-\begin{verbatim}
-q = 0
-f a b = a + b * b
-\end{verbatim}
-If the arity of the bound identifier is 0 (a constant declaration), 
-then the value of the whole expression is that of the right hand side.
-If the arity is more than 0 (a function definition),
-then the value of the whole expression is undefined.
-
-The operator \verb+;+ combines the evaluation of two expressions
-sequentially.
-In \verb+a; b+, first \verb+a+ is evaluated, 
-then \verb+b+ is evaluated in the state that resulted from the
-evaluation of \verb+a+. The value of \verb+b+ is the
-final result.
-
-\subsection*{$RX$ special semantics}
-
-So far, the description does not contain any hint on the range of values
-that $RX$ operates on. This modularity is intentional, and could
-be explored when extending $RX$ or re-using parts of it for other
-purposes.
-
-But we are going to use $RX$ for tree automata. The will be input and
-output as rational tree grammars. 
-
-First we need to specify the term algebra we're working in.
-This happens implicitly.
-
-Each expression has a term algebra associated with it
-that consists of the \emph{constructors} that happen to be contained
-in the expression's value. 
-
-A \emph{constructor} is an identifier that is not bound.
-
-Example:
-\begin{verbatim}
-arity 0 S
-infixl 60 @
-\end{verbatim}
-This declares two constructors, one nullary, one binary.
-
-
-A grammar is built by the
-name \verb+grammar+ that gets two arguments: a start expression and
-a set of rules. Example:
-
-\begin{verbatim}
-grammar x { x -> S, x -> S x + S x x }
-\end{verbatim}
-Remember that this is in fact \verb,x -> S @ x + (S @ x) @ x,
-by the rule of implicit application.
-
-Each rule has a variable on the left 
-and an \emph{rule expression} on the right.
-The start expression of the grammar also is an \emph{rule expression}.
-
-A \emph{rule expression} looks like an expression (see above) but
-there are restrictions on where grammar variables might occur:
-Starting from the top of the syntax tree of a rule expression, on the
-path to any grammar variable contained therein, only constructors and
-\verb-++- operators are allowed. In branches of rule expressions where
-no grammar variables occur, arbitrary expressions are permitted.
-
-Note that \verb+grammar+ does not evaluate its arguments.
-Rather, it behaves like a LISP special form that gets to see
-the syntax tree of its argument.
-
-\subsection*{$RX$ predefined identifiers}
-
-There are predefined operators for rational languages:
-\begin{enumerate}
-\item \verb,++, union
-\item \verb,\\, difference
-\item \verb,&, intersection
-\end{enumerate}
-
-and predefined functions that only transform a language's representation,
-but keep its meaning (the set of its words).
-\begin{enumerate}
-\item \verb,unify,:
-  unify seemingly identical states in the automaton
-\item \verb,useful,
-  only keep reachable and productive states
-\item \verb,det,
-  make automaton deterministic
-\item \verb,min,
-  make automaton deterministic and then minimal
-\end{enumerate}
-
-\subsection*{Evaluation of expressions} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-If the switch \verb,eval, is \verb,on,, each expression is
-evaluated and the evaluation may result in state changes
-(because new bindings were added).
-
-However, if evaluating an inline expression changes the current $RX$ state,
-this change is not promoted to other code blocks or snippets.
-
-That is, assignments cannot be hidden inside the text.
-Rather, they must be made visible in code blocks.
-(You can still cheat there, by turning the output off, see below.)
-
-If the switch \verb,exp, is \verb,on,, the input expression is printed.
-For normal typesetting, you would 
-\begin{verbatim}
- .set (eval=off,exp=on)
-\end{verbatim}
-
-If the switch \verb,res, is \verb,on,, the result of
-evaluating the input is printed. (If evaluation took place at all.)
-
-\subsection*{Preprocessing} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-The switches \verb+unify,useful,det,min+ tell whether the so named
-functions should be automatically inserted on top of all expressions
-that are being evaluated. In bindings, this refers to expressions
-right of the \verb,=,.
-
-The switch \verb,expand, tells whether the input expansion
-is shown or hidden.
-
-
-\subsection*{Postprocessing} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-The result of an evaluation is a finite tree automaton.
-It is shown as a rational grammar. There are switches that
-control the appearance of that grammar.
-\begin{enumerate}
-\item \verb,foldconst,
-  rules \verb,x -> e, where \verb,e, does not contain grammar
-  variables, are applied to all other rules, and the deleted.
-\item \verb,foldnonrec,
-  rules \verb,x -> e, where \verb,e, does not contain \verb,x,,
-  are applied to all other rules, and the deleted.
-\item \verb,hidegrammar,
-  if the rule set is empty, don't say \verb,grammar x {},.
-  Rather, use \verb,x, instead.
-\end{enumerate}
-
-
-\newpage
-\section{Controlling $RX$'s behaviour} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-In addition to the core language, $RX$ has means for preprocessing
-its input, and specifying aspects of its behaviour.
-
-\subsection*{Options}
-
-While processing input, $RX$ keeps a set of \emph{options}.
-
-An \emph{option set} is a mapping from strings to strings.
-It maps \emph{options} to \emph{values}.
-
-A \emph{switch} is an option that only takes on values 
-of \verb+on+ or \verb+off+.
-
-Options can be set by \emph{directives}, or on the
-command line when invoking $RX$.
-
-A \emph{directive} starts with a dot as the very first character in a line.
-
-Options can be set globally by
-\begin{verbatim}
- .set (opt1=val1, opt2=val2, ...)
-\end{verbatim}
-A \verb+.set+ is effective from where it stands to the end of
-the file it is located in.
-
-Option names and values can be given as $RX$ names or strings.
-
-A value can also refer to another option's value by prepending
-a dollar sign to it, as in 
-.begin(keepsep="/")
-\verb+.set (foo=$bar)+.
-.end
-
-Options can be set locally by
-\begin{verbatim}
- .begin (opt1=val1,...)
-    ...
- .end
-\end{verbatim}
-The new option set is effective only in between \verb+.begin+
-and \verb+.end+.
-
-\subsection*{Default values for options}
-
-The file \verb,Defaults.hs, from the $RX$ source distribution
-contains the option set that is compiled in. All of those
-options can be changed, however.
-
-\subsection*{Importing files}
-
-$RX$ input can be split over several files. The \verb+.import+
-directive includes the contents of a file into the input stream.
-\begin{verbatim}
- .import file
-\end{verbatim}
-\verb+file+ must be the file's complete name as an $RX$ string.
-
-The string \verb+"-"+, when used as a file name,
-means the standard input stream. This is only really useful
-on the command line, see below.
-
-It is possible to set some options that are only in effect while
-the imported file is processed
-\begin{verbatim}
- .import (opt1=val1,...) file
-\end{verbatim}
-
-In any case, none of the possible \verb+.set+ commands in the
-\emph{imported} file has an effect on the options in the \emph{importing} 
-file.
-
-\subsection*{$RX$ command line invocation}
-
-When the $RX$ executable is invoked, it analyzes its command line,
-takes appropriate actions, and writes its output to the standard
-output stream, from where it may be redirected by other means.
-
-On the command line, you may specify option values
-and files to read. 
-
-Example:
-\begin{verbatim}
-RX opt1=val1 opt2=val2 filea opt3=val3 fileb filec -
-\end{verbatim}
-is handled as
-\begin{verbatim}
- .set (opt1=val1)
- .set (opt2=val2)
- .import "filea"
- .set (opt3=val3)
- .import "fileb"
- .import "filec"
- .import "-"
-\end{verbatim}
-Note that the last line means ``read standard input''.
-
-Additionally, $RX$ might understand options for its underlying runtime system.
-They depend on the compiler that had been used when building $RX$.
-A common idiom is
-\begin{verbatim}
-RX +RTS -H50M -RTS opt1=val1 ...
-\end{verbatim}
-telling the system to use lots of heap space.
-
-
-\newpage
-\section{Literate Programming} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-A literate document contains text and code.
-From this, $RX$ generates a text document
-that has  code expressions and possibly their values converted to
-formatted text.
-
-The switch \verb,output, says whether to generate any
-output at all. Beware that even if this is off, 
-imports, sets, and evaluations may take place.
-
-$RX$ knows whether it is currently looking at text or code
-by looking up the value of the option \verb,current,. So a typical
-code block is
-\begin{verbatim}
- .begin(current=code)
-    ...
- .end
-\end{verbatim}
-The physical lines inside such a block are glued together to
-form logical lines that are fed into the $RX$ evaluator one by one.
-
-A \emph{logical line} consists of one or more \emph{physical lines}.
-Each physical line that starts with a non-blank character
-begins a new logical line. Physical lines that start with a blank
-character are called \emph{continuation lines}. They are appended
-to the most recent logical line.
-
-Each logical line must be a syntactically valid $RX$ expression.
-
-Apart from code blocks, there may be code snippets contained
-inside lines of text.
-
-Example:
-.begin(keepsep="/")
-\begin{verbatim}
-  ... the expression $S Q1 Q0$ denotes ...
-\end{verbatim}
-.end
-
-Such inline code must be a valid expression.
-It is also sent to the $RX$ evaluator.
-
-There are two variations of inline code. They differ in
-whether the separator is omitted or kept.
-Per default,
-.begin(keepsep="/",omitsep="/")
-\begin{verbatim}
- .set (keepsep="$",omitsep="|")
-\end{verbatim}
-and \verb,$x$, will result in \verb,$y$,,
-while \verb,|x|, will result in \verb,y,,
-.end
-where \verb,y, denotes the result of typesetting \verb,x,.
-
-The default setting should prove reasonable,
-and in fact $RX$ inline code mode can be seen 
-as a replacement for \LaTeX's math mode.
-
-
-
-
-\subsection*{Typesetting customization} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-$RX$ has two styles for typesetting its output:
-\verb,plain, and \verb,latex,.
-
-Both can be assigned independently to the options \verb,code,
-and \verb,text,.
-
-Example:
-\begin{verbatim}
- .set (text=latex,code=plain)
-\end{verbatim}
-tells $RX$ to use \verb+\verb+ for inline code
-and the \verb+{verbatim}+ environment for code blocks.
-
-You can assign a special \LaTeX\ expansion to $RX$ identifiers.
-This will be used when \verb,code=latex,. It is achieved by
-form declarations, of which there are two kinds:
-
-A \emph{passive form} is just a string that gets printed instead
-of the identifier's name. Example:
-\begin{verbatim}
- .begin(current=code,output=off)
- form S = "\textbf{S}"
- form (+) = "\cup"
- .end
-\end{verbatim}
-Note that form declarations happen inside code, not text.
-
-An \emph{active} form is a formatting macro that takes arguments.
-Example:
-\begin{verbatim}
- .begin(current=code,output=off)
- form (/) 2 = "\frac#1#2"
- .end
-\end{verbatim}
-
-In the arguments of the operators, parentheses are inserted
-so that the output is correctly parseable with the given operator 
-precedences and associativities. 
-This remains unaffected when a passive form is used for an operator.
-
-When an active form is in effect, its arguments are typeset
-for a very low precedence. So, there will be no outer parentheses,
-because it is assumed that the form takes care of visual grouping.
-For instance, \verb,4 / (1 + 3), will come out as \verb,\frac{4}{1 + 3},,
-given the above declaration.
-
-(As an aside, this idea of omitting some parentheses was already present
-in the \texttt{smugweb} system \cite{waldmann:smugweb}.)
-
-\subsection*{Typesetting trees}
-
-As seen in this thesis, $RX$ can be conveniently used to read and
-typeset trees. Reading is eased by the \emph{implicit apply} convention which
-inserts \verb+@+ nodes.  These nodes can be visually typeset by giving
-\verb+@+ an active form. In this paper we use \verb+tree.sty+
-written by  Edward M. Reingold and Nachum Dershowitz
-which in turn uses \PiCTeX.
-
-
-
-\newpage
-\section{$RX$ example} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\label{sec:rxexample}
-
-.set (code=plain,res=on)
-
-.begin (current=code,output=off)
-local contains, all, redex, normal, normal', t, x, y
-arity 0 all, redex, normal, normal', t, x, y
-arity 1 contains
-.end
-
-Here is some input that is used in the thesis itself.
-
-First, describe the set of all $S$-terms.
-.begin(current=code,eval=on)
-all = grammar t { t -> S ++ t t }
-.end
-So $all$ is a constant whose value is an automaton that accepts
-(produces) the set of all terms.
-
-The set of all redexes obviously is
-.begin(current=code,eval=on)
-redex = S all all all
-.end
-
-Now we define a function with one argument.
-.begin(current=code,eval=on)
-contains x = grammar y { y -> x, y -> y all ++ all y }
-.end
-
-
-The argument is any language $x$, and the result 
-is the language of all terms $y$ that contain $x$ as a subterm.
-
-This allows to compute the set of normal forms.
-.begin(current=code,eval=on)
-normal = all \\ contains redex
-.end
-
-Finally, this could be compared to the representation
-.begin(current=code,eval=on)
-normal' = grammar t { t -> S, t -> S t, t -> S t t }
-.end
-
-
-.begin (current=code,output=off)
-unlocal
-.end
diff --git a/real/rx/examples/Makefile b/real/rx/examples/Makefile
deleted file mode 100644 (file)
index 3d5c31d..0000000
+++ /dev/null
@@ -1,35 +0,0 @@
-TOP = ../../..
-include $(TOP)/mk/boilerplate.mk
-
-SRC_RUNTEST_OPTS += +RTS -H50M -K10M -RTS basic.lit check.lit -o1 rx.stdout
-
-# compiled version
-NOFIB_PROG= ../src/rx
-
-# interpreted version
-# RX = runhugs -h1m -l ../src/RX.hs
-
-all :: runtests
-
-###########################################################################
-
-clean ::
-       rm *~ 
-
-# latex stuff ##############################################################
-
-
-%.tex : %.lit 
-       $(RX) $(RTS_OPTS) $(RX_OPTS) current=text code=latex $< |tee $@
-
-%.out : %.in
-       $(RX) $(RTS_OPTS) $(RX_OPTS) current=code code=plain $< |tee $@
-
-%.dvi : %.tex
-       - latex "\\nonstopmode\\input $<"
-
-%.ps : %.dvi
-       dvips -t a4 $< -o $@
-
-
-include $(TOP)/mk/target.mk
diff --git a/real/rx/examples/basic.lit b/real/rx/examples/basic.lit
deleted file mode 100644 (file)
index 04395ec..0000000
+++ /dev/null
@@ -1,72 +0,0 @@
-.set (current=code,eval=on)
-
--- defines basic expressions and constructions
--- formatting things are omitted
-
-
-infixl 60 @    -- binary constructor (is default)
-
-.set (implicit = on, apply = "@")
-
-T = S S
-A = T S
-
-M = grammar t { t -> S ++ t t }
-N = grammar n { n -> S ++ S n ++ S n n }
-
------------------------------------------------------
-
-tri x = grammar t { t -> x ++ S t M ++ S M t }
-
-infixr 50 /, \
-
-X / Y = grammar g { g -> Y ++ X g }
-X \ Y = grammar g { g -> X ++ g Y }
-
---------------------------------------------------------
-
-
-
-M0 = M
-M1 = M0 M
-M2 = M1 M
-M3 = M2 M
-M4 = M3 M
-
------------------------------------------------------
-
-
-
-P = grammar p { p -> S ++ S p }
-P0 = N \\ N
-P1 = S ++ S P0
-P2 = S ++ S P1
-P3 = S ++ S P2
-P4 = S ++ S P3
-
------------------------------------------------------
-
-Q = M \\ P
-Q0 = M \\ P0
-Q1 = M \\ P1
-Q2 = M \\ P2
-Q3 = M \\ P3
-Q4 = M \\ P4
-
------------------------------------------------------
-
-N0 = T / (S ++ S N)
-N01 = S P2 / (S ++ S N ++ S (S T) P2)
-
-N1 = N01 \\ N0
-N2 = N \\ N01
-
-Bm = T / S (S P2) S
-Lm = T / S T (S P2)
-
-L = N1 \\ Bm
-Lp = L \\ Lm
-
------------------------------------------------------
-
-
diff --git a/real/rx/examples/check.lit b/real/rx/examples/check.lit
deleted file mode 100644 (file)
index 5b62910..0000000
+++ /dev/null
@@ -1,12 +0,0 @@
-.set (current=code)
-
-F = tri (Q2 Q1)
-
--- all of these should return empty sets
-
-Q1 F \\ F
-
-N2 \\ ( tri (Q3 Q2 ++ S Q3 Q0) )
-
-Lp \\ ( T / (S (S T) T ++ S T Q3) )
-
diff --git a/real/rx/index.html b/real/rx/index.html
deleted file mode 100644 (file)
index d6d4fa2..0000000
+++ /dev/null
@@ -1,81 +0,0 @@
-<HTML>
-
-<HEAD>
-<TITLE>RX: Rational Tree Languages</TITLE>
-<LINK REV="made" HREF="mailto:joe@informatik.uni-leipzig.de">
-</HEAD>
-
-<BODY>
-<HR>
-
-<H2>RX: an interpreter for Rational Tree Languages</H2>
-
-<HR>
-
-RX is a system that knows about regular tree grammars,
-finite tree automata, and rational tree expressions.
-<P>
-You may feed some regular tree grammars to my RX interpreter
-and do some computations. 
-See the 
-<A HREF="online.html">online examples</A>, 
-and edit them to taste.
-
-<HR>
-
-If you want to use RX for real work, please get the latest
-<A HREF="release/">source release</A>
-and install it on your system. The sources are written
-in the pure lazy functional programming language
-<A HREF="http://www.haskell.org/">Haskell</A>
-and can be compiled with 
-<A HREF="http://www.dcs.gla.ac.uk/fp/software/ghc/">ghc</A>
-or 
-<A HREF="http://www.cs.chalmers.se/~augustss/hbc/hbc.html">hbc</A>,
-or interpreted under 
-<A HREF="http://haskell.systemsz.cs.yale.edu/hugs/">hugs</A>.
-<P>
-Please tell me if you built RX, and have any comments
-or if you just want to be informed on further releases.
-
-<HR>
-
-<UL>
-
-
-<LI><A HREF="copyright.html">Copyright notice</A>
-<LI><A HREF="release/">packaged releases</A>
-<LI><A HREF="online.html">online examples</A>
-<LI>RX user manual (sort of) 
-    (<A HREF="doc/rxdoc.dvi.gz">dvi</A>|<A HREF="doc/rxdoc.ps.gz">ps</A>)
-<LI><A HREF="link.html">link your programs with RX</A>
-<LI><A HREF="CHANGELOG">changelog</A>
-<LI><A HREF="TODO">todo</A>
-
-</UL>
-
-
-<HR>
-<P ALIGN="CENTER">
-<A HREF="http://www.anybrowser.org/campaign/"><IMG 
-SRC="http://www.informatik.uni-leipzig.de/~joe/anybrowsernow.gif" 
-ALT="best viewed with any browser"></A>
-</P>
-
-
-
-<HR>
-<ADDRESS>
-<A HREF="http://www.informatik.uni-leipzig.de/~joe/">
-<TT>http://www.informatik.uni-leipzig.de/~joe/</TT></A>
-<A HREF="mailto:joe@informatik.uni-leipzig.de">
-<TT>mailto:joe@informatik.uni-leipzig.de</TT></A>
-</ADDRESS>
-
-</BODY>
-</HTML>
-
-
-
-
-
diff --git a/real/rx/link.html b/real/rx/link.html
deleted file mode 100644 (file)
index 2a2cf36..0000000
+++ /dev/null
@@ -1,49 +0,0 @@
-<HTML>
-
-<HEAD>
-<TITLE>RX: link with it</TITLE>
-<LINK REV="made" HREF="mailto:joe@informatik.uni-leipzig.de">
-</HEAD>
-
-<BODY>
-<HR>
-
-<H3>How to link RX code to your Haskell program</H3>
-
-<HR>
-
-You might want to use RX's functionality (computation with finite
-tree automata, also their input and output) from within another program.
-<P>
-The Haskell module
-<A HREF="src/Reader.hs">Reader</A>
-gives you access to the input routine.
-
-
-
-
-
-<HR>
-<P ALIGN="CENTER">
-<A HREF="http://www.anybrowser.org/campaign/"><IMG 
-SRC="http://www.informatik.uni-leipzig.de/~joe/anybrowsernow.gif" 
-ALT="best viewed with any browser"></A>
-</P>
-
-
-
-<HR>
-<ADDRESS>
-<A HREF="http://www.informatik.uni-leipzig.de/~joe/">
-<TT>http://www.informatik.uni-leipzig.de/~joe/</TT></A>
-<A HREF="mailto:joe@informatik.uni-leipzig.de">
-<TT>mailto:joe@informatik.uni-leipzig.de</TT></A>
-</ADDRESS>
-
-</BODY>
-</HTML>
-
-
-
-
-
diff --git a/real/rx/online.html b/real/rx/online.html
deleted file mode 100644 (file)
index 9110479..0000000
+++ /dev/null
@@ -1,169 +0,0 @@
-<HTML>
-<HEAD>
-<TITLE>RX Online Examples</TITLE>
-<LINK REV="made" HREF="mailto:joe@informatik.uni-leipzig.de">
-</HEAD>
-
-<BODY>
-<HR>
-
-<H2>RX Online Examples</H2>
-
-<HR>
-
-Please understand that this RX is run with low priority and
-small stack and heap space to reduce system load on our server.
-
-<P>
-
-Beware: the examples are run on a host at
-my previous workplace. This is bound to break somewhere in the near future.
-So I'm bound to move the system over here completely -
-but not this week (I hope).
-
-<P>
-
-Your inputs (and RX's output) will be logged. 
-(Your name will not.)
-
-<HR>
-
-<H3>RX example: words over single letter alphabet</H3>
-This shows the grammar syntax. All output grammars are in fact
-deterministic bottom up tree automata. Their states are denoted
-by naturals. Beware of higher arities. They work, in theory,
-but in practice, they need their time.
-<FORM METHOD="POST" 
-      ACTION="http://www.minet.uni-jena.de/cgi-bin/user/joe/RX.pl">
-<TEXTAREA NAME="RX_INPUT" ROWS=8 COLS=60>arity 0 zero -- constructor
-arity 1 succ -- constructor
-nats = grammar n { n -> zero ++ succ n }
-evens = grammar e { e -> zero ++ succ (succ e) }
--- some trivial operations
-nats \\ evens -- set difference
-evens ++ nats -- set union
-evens & nats -- set intersection
-</TEXTAREA>
-<P>
-<INPUT TYPE="submit" VALUE="submit">
-<INPUT TYPE="reset"  VALUE="reset" >
-</FORM>
-<HR>
-
-<H3>RX example: binary trees</H3>
-This is what I use in CL(S). 
-<FORM METHOD="POST" 
-      ACTION="http://www.minet.uni-jena.de/cgi-bin/user/joe/RX.pl">
-<TEXTAREA NAME="RX_INPUT" ROWS=10 COLS=60>arity 0 S  
-.set (implicit=on, apply = "@")
-all = grammar m { m -> S ++ m m }
--- expression in normal form
-norm = grammar n { n -> S ++ S n ++ S n n }
--- expressions with redexes
-unnorm = all \\ norm
--- sanity check
-norm & unnorm
-</TEXTAREA>
-<P>
-<INPUT TYPE="submit" VALUE="submit">
-<INPUT TYPE="reset"  VALUE="reset" >
-</FORM>
-<HR>
-
-<H3>RX examples from my RTA98 paper</H3>
-You'll have to read the paper 
-<STRONG>Normalization of S-Terms is Decidable</STRONG>
-to understand what's going on.
-The point is that all of the checks below 
-should return the empty set.
-<FORM METHOD="POST" 
-      ACTION="http://www.minet.uni-jena.de/cgi-bin/user/joe/RX.pl">
-<TEXTAREA NAME="RX_INPUT" ROWS=60 COLS=60>arity 0 S -- nullary constructor  
-infixl 60 @ -- binary application operator
-.set (implicit=on, apply = "@") -- is implicitly used
-.set (det=on,min=on) -- make all automata deterministic
-
--- section 2: Notations and Preliminaries
--- definition 3:
-T = S S
-A = S S S
--- definition 4:
-M = grammar m { m -> S ++ m m }
-N = grammar n { n -> S ++ S n ++ S n n }
--- definition 6 (just some of them):
-Q0 = M
-P1 = S        
-Q1 = M \\ P1
-P2 = S ++ S P1
-Q2 = M \\ P2
-P3 = S ++ S P2
-Q3 = M \\ P3
--- check lemma 7 (trivial):
-P2 \\ P3
-Q3 \\ Q2
--- definition 9 (director):
-dir y = grammar d { d -> y, d -> S d M ++ S M d }
--- definition 11:
-infixr 55 /
-x / y = grammar d { d -> y, d -> x d }
-
--- section 3: Examples of Infinite Reductions
--- definition 14:
-F = dir (Q2 Q1)
--- check lemma 15 (nearly trivial):
-Q1 F \\ F
-
--- section 4: The decision Procedure
--- subsection 4.2: The case N N
--- definition 20:
-N0 = T / (S ++ S N)
--- definition 25:
-N01 = (S P2) / (S ++ S N ++ S (S T) P2)
--- definition 30:
-N1 = N01 \\ N0
-N2 = N \\ N01
--- check proof of proposition 31 (substantial):
-N2 \\ (dir (Q3 Q2) ++ dir (S Q3 Q0))
-
--- subsection 4.2: The case N1 N1
--- definition 33:
-L0 = T / S (S P2) S
--- definition 36:
-L1 = T / S T (S P2)
--- definition 39:
-L12 = N1 \\ L0
-L2 = L12 \\ L1
--- check proof of proposition 40 (substantial):
-L12 \\ dir (Q2 Q1)
--- check proof of proposition 41 (substantial):
-L2 \\ (T / (S (S T) T ++ S T Q3))
-</TEXTAREA>
-<P>
-(Running the examples takes some time on our server.
-Be prepared to wait, or download the RX source
-and run them at your site.)
-</P>
-<P>
-<INPUT TYPE="submit" VALUE="submit">
-<INPUT TYPE="reset"  VALUE="reset" >
-</FORM>
-<HR>
-
-<P ALIGN="CENTER">
-<A HREF="http://www.anybrowser.org/campaign/"><IMG SRC="http://www.informatik.un
-i-leipzig.de/~joe/anybrowsernow.gif" ALT="best viewed with any browser"></A>
-</P>
-
-
-
-<HR>
-<ADDRESS>
-<A HREF="http://www.informatik.uni-leipzig.de/~joe/">
-<TT>http://www.informatik.uni-leipzig.de/~joe/</TT></A>
-<A HREF="mailto:joe@informatik.uni-leipzig.de">
-<TT>mailto:joe@informatik.uni-leipzig.de</TT></A>
-</ADDRESS>
-
-</BODY>
-</HTML>
-
diff --git a/real/rx/rx-MAIL b/real/rx/rx-MAIL
deleted file mode 100644 (file)
index a3ed9ba..0000000
+++ /dev/null
@@ -1,30 +0,0 @@
-From: joe@informatik.uni-leipzig.de <joe@informatik.uni-leipzig.de>
-Sent: Friday, October 09, 1998 8:52 AM
-To: Simon Peyton Jones
-Subject: Re: GHC library licensing
-
-
-> Can we include RX in the nofib suite? 
-
-yes sure. after `make' in src/, there's `make check' in examples/
-that keeps the system busy for a while.
-
-i used RX to check parts of a proof of a main result
-of my PhD thesis. (that's exactly what `make check' does).
-and i used lots of other haskell programs to generate
-examples and conjectures - so ghc/hbc/hugs were (are) 
-crucial tools for my research.
-
-the RX code is not optimized too much, i'm afraid.
-however i hope that ghc is able to specialize away
-most of the overloaded functions. can this be done automatically?
-i'm too lazy to insert all those pragmas.
-
-by the way, executables compiled with ghc -O2 
-give me bus errors on sparc-sunos5 (ghc-2.10 is all i have. -O works.)
-
-
--- 
-Dr. Johannes Waldmann     Institut fur Informatik    Universitat Leipzig
-joe@informatik.uni-leipzig.de http://www.informatik.uni-leipzig.de/~joe/
-Augustusplatz, D-04109 Leipzig, Germany, Tel/Fax (+49) 341 97 32 204/209
diff --git a/real/rx/src/BackwardS.hs b/real/rx/src/BackwardS.hs
deleted file mode 100644 (file)
index 3f040b3..0000000
+++ /dev/null
@@ -1,121 +0,0 @@
-module BackwardS
-
-( backwardS
-, backwardSpublic
-)
-
--- implements thomas genet's algorithm
--- for approximating term replacement in a finite automaton
-
--- we're looking at the reversed system   x z (y z) -> S x y z
-
--- this implementation is ugly ugly ugly
--- w.r.t. the rest of the system
--- the reduction rule of S is hardwired
--- as are the names of the constructors (S and @)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import Reuse
-
-sons :: TNFA Int -> Int -> [(Int, Int)]
-sons (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "BackwardS.sons.ts") p
-       lrs =   [ (l, r) 
-               | t <- setToList ts
-               , tconname (stcon t) == "@"
-               , let [l, r] = stargs t
-               ]
-    in
-       lrs
-
-
-backwardS :: Opts -> TNFA Int -> TNFA Int
--- look for all matches of x z (y z) 
--- add new states from that to S x y z
-backwardS opts a @ (TNFA cons all starts moves) =
-    let        
-       quads = [ (t, (ll, rl, rr))
-               | t <- setToList all
-               , (l, r) <- sons a t
-               , (ll, lr) <- sons a l
-               , (rl, rr) <- sons a r
-               , lr == rr      -- these are the two z's
-               ]
-
-       -- next free state
-       next = 1 + maximum (setToList all)
-
-       -- write new top state numbers to quads
-       -- warnig: the number 3 depends on the states used in "new" below
-       iquads = zip [next, next + 3 .. ] quads
-
-       -- this is a bit ugly
-       -- need to find the complete id information for the constructors
-       -- we hope they are there
-       ap = head [ con | con <- setToList cons, tconname con == "@" ]
-       s  = head [ con | con <- setToList cons, tconname con == "S" ]
-       
-       -- generate new states per quad
-
-       movesr = invert moves
-
-       new (i, (t, (x, y, z))) = 
-               [ (t    , mksterm ap [i + 0, z] )
-               , (i + 0, mksterm ap [i + 1, y] )
-               , (i + 1, mksterm ap [i + 2, x] )
-               , (i + 2, mksterm s  []         )
-               ]
-
-       newsl = [ p | iq <- iquads, p <- new iq ]
-       news = listToFM [ (a, unitSet t) | (a, t) <- newsl ]
-       moves' = moves `mergeFM` news
-       all' = all `unionSet` mkSet (keysFM moves')
-
-       r = TNFA cons all' starts moves'
-
-
-       addons = [ a | a <- keysFM news, a >= next ]
-       r' = reuse opts r addons
-
-       r'' = chose opts "reuse" r' r
-
-    in
-
-       trinfo opts "backwardS" r'' $
-
-       r''
-
-
-
-
-backwardSpublic :: Opts -> [ TNFA Int ] -> TNFA Int
-
-backwardSpublic opts args =
-    if length args /= 1 
-    then error "backwardSpublic.args"
-    else 
-       let [arg1] = args
-       in  backwardS opts arg1
-
-
-
--- later:
-
--- iterate the backwardS operation
--- making the automaton deterministic and minimal
--- before and after each step
--- until process converges
-
--- making determin. should ensure that the two z's really "are the same"
diff --git a/real/rx/src/CBackwardS.hs b/real/rx/src/CBackwardS.hs
deleted file mode 100644 (file)
index 66aad8c..0000000
+++ /dev/null
@@ -1,189 +0,0 @@
-module CBackwardS
-
-( cbackwardS
-, cbackwardSpublic
-)
-
--- checks whether a given grammar
--- is backward closed under reduction
--- in the system   S x y z   ->   x z (y z)
-
--- this implementation is ugly ugly ugly
--- w.r.t. the rest of the system
--- the reduction rule of S is hardwired
--- as are the names of the constructors (S and @)
-
-where
-
-import Trace
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAmin
-import FAuseful
-
-import FAneg
-import FAintersect
-import FAunion
-
--- import Reuse
-
-sons :: TNFA Int -> Int -> [(Int, Int)]
-sons (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "CBackwardS.sons.ts") p
-       lrs =   [ (l, r) 
-               | t <- setToList ts
-               , tconname (stcon t) == "@"
-               , let [l, r] = stargs t
-               ]
-    in
-       lrs
-
-
-
-leaves :: TNFA Int -> Int -> [()]
-leaves (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "CBackwardS.leaves.ts") p
-       lrs =   [ () 
-               | t <- setToList ts
-               , tconname (stcon t) == "S"
-               ]
-    in
-       lrs
-
-
-
-cbackwardS :: Opts -> TNFA Int -> TNFA Int
--- look back all matches of S x y z (successively)
--- add new states from that to x z (y z) 
-cbackwardS opts a @ (TNFA cons all starts moves) =
-    let        
-
-        quads = [ (t, (ll, rl, rr))
-                | t <- setToList all
-                , (l, r) <- sons a t
-                , (ll, lr) <- sons a l
-                , (rl, rr) <- sons a r
-                , lr == rr      -- these are the two z's
-                ]
-
-
-       -- next free state
-       next = 1 + maximum (setToList all)
-
-
-       -- this is a bit ugly
-       -- need to find the complete id information for the constructors
-       -- we hope they are there
-       ap = head [ con | con <- setToList cons, tconname con == "@" ]
-       s  = head [ con | con <- setToList cons, tconname con == "S" ]
-       
-
-       -- try to bypass complicate constructions.
-       -- catch cases like this:
-       -- X -> T X + something, Redex -> X S
-       -- by looking up where (x z), (y z), (x z(y z)) 
-       -- may go in the current automaton 
-       -- hoping it's deterministic
-
-       imoves = invert moves
-
-       ifn' t nxt =  
-           case setToList (lookupset imoves t) of
-               [c] -> (c, t)   -- state is already there, and unique
-               _ -> (nxt, t)   -- not there, or not unique
-
-
-       ifap x y nxt = ifn' (mksterm ap [x, y]) nxt
-       ifs      nxt = ifn' (mksterm s  [    ]) nxt
-
-       -- generate new states per quad
-       newsts (t, (x, y, z)) = 
-           let thes   @ (s  , ms  ) = ifs        (next + 0)
-               thesx  @ (sx , msx ) = ifap  s   x (next + 1)
-               thesxy @ (sxy, msxy) = ifap  sx  y (next + 2)
-               ( c, msxyz)          = ifap  sxy z (next + 3)
-           in
-               if c == t 
-               then []
-               else
-               [ (t       , msxyz)
-               , thesxy
-               , thesx
-               , thes
-               ]
-
-
-
-       -- generate new moves for automaton
-
-       red txyz @ (t, xyz) = TNFA cons all' starts moves'
-           where
-               moves' = moves `mergeFM` 
-                       listToFM [ (a, unitSet t) | (a, t) <- newsts txyz ]
-               all'= all `unionSet` mkSet (keysFM moves')
-
-
-       -- compute differences: a with redex replaced \\ original a
-       -- hack: first negate the input automaton a
-       -- then intersect with rewritten automaton
-
-       opts' = addToFM opts "trace" "on"
-       na = negTNFA opts' a
-
-       diff txyz @ (t, (x, y, z)) = 
-           let 
-               r = red txyz 
-               m =     if r == a 
-                       then trace "\n*** shortcut ***" 
-                               emptyTNFA 
-                       else trace "\n*** longcut ***" 
-                               usefulTNFA opts $ intersectTNFA opts r na
-               msg = "checking for contractum " ++ show txyz ++ ": "
-                       ++ show m ++ "\n"
-           in
-               ( chose opts "tracecbackward" (trace msg) id )
-               m
-
-
-       diffs = foldr (unionTNFA opts) emptyTNFA 
-               [ diff txyz | txyz <- quads ]
-
-    in
-
-       chose opts "tracecbackward" 
-       (trace (   
-                  "\ncbackward a: " ++ show a ++ "\n"
---             ++ "\ncbackward na: " ++ show na ++ "\n" 
-       ))
-       id $
-
-
-       diffs
-
-
-
-
-
-
-cbackwardSpublic :: Opts -> [ TNFA Int ] -> TNFA Int
-
-cbackwardSpublic opts args =
-    if length args /= 1 
-    then error "cbackwardSpublic.args"
-    else 
-       let [arg1] = args
-       in  cbackwardS opts arg1
-
-
-
diff --git a/real/rx/src/CForwardS.hs b/real/rx/src/CForwardS.hs
deleted file mode 100644 (file)
index e61b1ae..0000000
+++ /dev/null
@@ -1,183 +0,0 @@
-module CForwardS
-
-( cforwardS
-, cforwardSpublic
-)
-
--- checks whether a given grammar
--- is forward closed under reduction
--- in the system   S x y z   ->   x z (y z)
-
--- this implementation is ugly ugly ugly
--- w.r.t. the rest of the system
--- the reduction rule of S is hardwired
--- as are the names of the constructors (S and @)
-
-where
-
-import Trace
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAmin
-import FAuseful
-
-import FAneg
-import FAintersect
-import FAunion
-
--- import Reuse
-
-sons :: TNFA Int -> Int -> [(Int, Int)]
-sons (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "CForwardS.sons.ts") p
-       lrs =   [ (l, r) 
-               | t <- setToList ts
-               , tconname (stcon t) == "@"
-               , let [l, r] = stargs t
-               ]
-    in
-       lrs
-
-
-
-leaves :: TNFA Int -> Int -> [()]
-leaves (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "CForwardS.leaves.ts") p
-       lrs =   [ () 
-               | t <- setToList ts
-               , tconname (stcon t) == "S"
-               ]
-    in
-       lrs
-
-
-
-cforwardS :: Opts -> TNFA Int -> TNFA Int
--- look for all matches of S x y z (successively)
--- add new states from that to x z (y z) 
-cforwardS opts a @ (TNFA cons all starts moves) =
-    let        
-       quads = [ (t0, (x, y, z))
-               | t0 <- setToList all
-               , (t1, z) <- sons a t0
-               , (t2, y) <- sons a t1
-               , (t3, x) <- sons a t2
-               , ()     <- leaves a t3 -- this looks for S
-               ]
-
-       -- next free state
-       next = 1 + maximum (setToList all)
-
-
-       -- this is a bit ugly
-       -- need to find the complete id information for the constructors
-       -- we hope they are there
-       ap = head [ con | con <- setToList cons, tconname con == "@" ]
-       s  = head [ con | con <- setToList cons, tconname con == "S" ]
-       
-
-       -- try to bypass complicate constructions.
-       -- catch cases like this:
-       -- X -> T X + something, Redex -> X S
-       -- by looking up where (x z), (y z), (x z(y z)) 
-       -- may go in the current automaton 
-       -- hoping it's deterministic
-
-       imoves = invert moves
-
-       ifn x y nxt = 
-           let xy = mksterm ap [x, y]
-           in case setToList (lookupset imoves xy) of
-               [c] -> (c, xy)  -- state is already there, and unique
-               _ -> (nxt, xy)  -- not there, or not unique
-
-
-       -- generate new states per quad
-       newsts (t, (x, y, z)) = 
-           let thexz @ (xz, mxz) = ifn  x  z (next + 0)
-               theyz @ (yz, myz) = ifn  y  z (next + 1)
-               ( c, mxzyz) = ifn xz yz (next + 2)
-           in
-               if c == t 
-               then []
-               else
-               [ (t       , mxzyz)
-               , thexz
-               , theyz
-               ]
-
-
-
-       -- generate new moves for automaton
-
-       red txyz @ (t, xyz) = TNFA cons all' starts moves'
-           where
-               moves' = moves `mergeFM` 
-                       listToFM [ (a, unitSet t) | (a, t) <- newsts txyz ]
-               all'= all `unionSet` mkSet (keysFM moves')
-
-
-       -- compute differences: a with redex replaced \\ original a
-       -- hack: first negate the input automaton a
-       -- then intersect with rewritten automaton
-
-       opts' = addToFM opts "trace" "on"
-       na = negTNFA opts' a
-
-       diff txyz @ (t, (x, y, z)) = 
-           let 
-               r = red txyz 
-               m =     if r == a 
-                       then trace "\n*** shortcut ***" 
-                               emptyTNFA 
-                       else trace "\n*** longcut ***" 
-                               usefulTNFA opts $ intersectTNFA opts r na
-               msg = "checking for redex " ++ show txyz ++ ": "
-                       ++ show m ++ "\n"
-           in
-               ( chose opts "tracecforward" (trace msg) id )
-               m
-
-
-       diffs = foldr (unionTNFA opts) emptyTNFA 
-               [ diff txyz | txyz <- quads ]
-
-    in
-
-       chose opts "tracecforward" 
-       (trace (   
-                  "\ncforward a: " ++ show a ++ "\n"
---             ++ "\ncforward na: " ++ show na ++ "\n" 
-       ))
-       id $
-
-
-       diffs
-
-
-
-
-
-
-cforwardSpublic :: Opts -> [ TNFA Int ] -> TNFA Int
-
-cforwardSpublic opts args =
-    if length args /= 1 
-    then error "cforwardSpublic.args"
-    else 
-       let [arg1] = args
-       in  cforwardS opts arg1
-
-
-
diff --git a/real/rx/src/CharSeq.hs b/real/rx/src/CharSeq.hs
deleted file mode 100644 (file)
index 48f2b53..0000000
+++ /dev/null
@@ -1,122 +0,0 @@
--- this is from ghc/syslib-ghc originally, 
-
-
-
-
-
-
-
-
-
-
-
-
-
-module CharSeq (
-       CSeq,
-       cNil, cAppend, cIndent, cNL, cStr, cPStr, cCh, cInt,
-
-       cLength,
-       cShows,
-
-       cShow
-
-
-   ) where
-
-
-cShow  :: CSeq -> [Char]
-
-
--- not used in GHC
-cShows :: CSeq -> ShowS
-cLength        :: CSeq -> Int
-
-
-cNil    :: CSeq
-cAppend :: CSeq -> CSeq -> CSeq
-cIndent :: Int -> CSeq -> CSeq
-cNL    :: CSeq
-cStr   :: [Char] -> CSeq
-cPStr  :: String -> CSeq
-cCh    :: Char -> CSeq
-cInt   :: Int -> CSeq
-
-
-
-data CSeq
-  = CNil
-  | CAppend    CSeq CSeq
-  | CIndent    Int  CSeq
-  | CNewline                   -- Move to start of next line, unless we're
-                               -- already at the start of a line.
-  | CStr       [Char]
-  | CCh                Char
-  | CInt       Int     -- equiv to "CStr (show the_int)"
-
-
-cNil = CNil
-
--- cAppend CNil cs2  = cs2
--- cAppend cs1  CNil = cs1
-
-cAppend cs1 cs2 = CAppend cs1 cs2
-
-cIndent n cs = CIndent n cs
-
-cNL    = CNewline
-cStr   = CStr
-cCh    = CCh
-cInt   = CInt
-
-
-cPStr  = CStr
-
-
-cShow  seq     = flatten (0) True seq []
-
-
-cShows seq rest = cShow seq ++ rest
-cLength seq = length (cShow seq) -- *not* the best way to do this!
-
-
-data WorkItem = WI Int CSeq -- indentation, and sequence
-
-flatten :: Int -- Indentation
-       -> Bool -- True => just had a newline
-       -> CSeq         -- Current seq to flatten
-       -> [WorkItem]   -- Work list with indentation
-       -> String
-
-flatten n nlp CNil seqs = flattenS nlp seqs
-
-flatten n nlp (CAppend seq1 seq2) seqs = flatten n nlp seq1 ((WI n seq2) : seqs)
-flatten n nlp (CIndent (n2) seq) seqs = flatten (n2 + n) nlp seq seqs
-
-flatten n False CNewline seqs = '\n' : flattenS True seqs
-flatten n True  CNewline seqs = flattenS True seqs     -- Already at start of line
-
-flatten n False (CStr s) seqs = s ++ flattenS False seqs
-flatten n False (CCh  c) seqs = c :  flattenS False seqs
-flatten n False (CInt i) seqs = show i ++ flattenS False seqs
-
-
-flatten n True  (CStr s) seqs = mkIndent n (s ++ flattenS False seqs)
-flatten n True  (CCh  c) seqs = mkIndent n (c :  flattenS False seqs)
-flatten n True  (CInt i) seqs = mkIndent n (show i ++ flattenS False seqs)
-
-
-flattenS :: Bool -> [WorkItem] -> String
-flattenS nlp [] = ""
-flattenS nlp ((WI col seq):seqs) = flatten col nlp seq seqs
-
-mkIndent :: Int -> String -> String
-mkIndent (0) s = s
-mkIndent n       s
-  = if (n >= (8))
-    then '\t' : mkIndent (n - (8)) s
-    else ' '  : mkIndent (n - (1)) s
-    -- Hmm.. a little Unix-y.
-
-
-
diff --git a/real/rx/src/Command.hs b/real/rx/src/Command.hs
deleted file mode 100644 (file)
index 568567c..0000000
+++ /dev/null
@@ -1,72 +0,0 @@
--- for parsing formatting commands
-
--- changes:
-
--- 25. 4. 97: make '$' refer to value of some binding
-
-module Command
-
-( Cmd(..)
-, pcmd
-)
-
-where
-
-import Data.Char
-
-import Options
-
-import Lex
-import Parse
-
-
--- a command starts with a dot (which is eaten before the parser
--- down below is called) and only extends for one line
-
-data Cmd = Begin Opts
-       | End
-       | Set Opts
-       | Import Opts String
-
-       | Unknown String
-
---------------------------------------------------------
-
--- parsing commands
-
-paName = litp "Name" (\ cs -> 
-       isAlpha (head cs) || isDigit (head cs))
-
-
-paStrng = litp "String" (\ cs -> head cs == '"') -- rely on the lexer
-       `act` \ cs -> drop 1 (take (length cs - 1) cs)
-
-paNameStrng = paName ||! paStrng
-
-paBind opts = 
-       (paNameStrng +.. lit "=")
-  +.+  (   paNameStrng -- take it literally
-       ||! (lit "$" ..+ paNameStrng) `act` (getopt opts)
-       )
-       
-
-paGroup opts = lit "(" ..+ paBind opts `sepBy` lit "," +.. lit ")"
-       `act`  listToOpts
-
-paOptGroup opts = paGroup opts ||! succeed emptyOpts
-
-paCommand opts =   
-             ( lit "begin" ..+ paOptGroup opts
-               `act` \ g -> Begin g
-       ) ||! ( lit "end"
-               `act` \ _ -> End
-       ) ||! ( lit "set" ..+ paGroup opts
-               `act` \ g -> Set g
-       ) ||! ( lit "import" ..+ paOptGroup opts +.+ paNameStrng
-               `act` \ (g, n) -> Import g n 
-
-       ) ||! ( many (litp "unknown" (const True)) 
-               `act` \ ws -> Unknown (unwords ws) 
-       )
-
-pcmd opts inp = simpleParse (paCommand opts) (myLex (uncomment inp))
diff --git a/real/rx/src/Cross.hs b/real/rx/src/Cross.hs
deleted file mode 100644 (file)
index 9538888..0000000
+++ /dev/null
@@ -1,49 +0,0 @@
-module Cross (mmerge, couple, cross, mcross, zipzip, dove) where
-
-mmerge :: [[a]] -> [a]
-mmerge xss = mm xss []
-       where   mm [] [] = []
-               mm [] yss = mm yss []
-               mm ([] : xss) yss = mm xss yss
-               mm ((x : xs) : xss) yss = x : mm xss (xs : yss)
-
-
-dove :: [[a]] -> [a]
-dove xss = dd 1 xss -- where
-
-dd _ [] = []
-dd n (xs : xss) = kzip 0 n (dd (n+1) xss) xs
-
-kzip 0 n as (b : bs) = b : kzip n n as bs
-kzip k n (a : as) bs = a : kzip (k-1) n as bs
-kzip _ _ [] bs = bs
-kzip _ _ as [] = as
-
-
-
-couple :: [[a]] -> [[a]]
-couple [] = []
-couple xss = [ x | (x : _) <- xss ] : couple [ xs | (_ : xs) <- xss ]
-
-cross :: [a] -> [b] -> [(a, b)]
--- product of two infinite lists
-cross [] _ = []; cross _ [] = []
-cross (x : xs) (y : ys) = 
-       (x, y) : mmerge [ [ (x, y') | y' <- ys ]
-                       , [ (x', y) | x' <- xs ]
-                       , cross xs ys
-                       ]
-
-mcross :: [[a]] -> [[a]]
--- enumerates the dot product
--- mcross [[x11, x12, ..], [x21, x22, ..], .. , [xn1, xn2, ..]]
---     = [[x11, x21, .., xn1], [.. ], .. ]
-mcross xss = [ ys | n <- [0..], ys <- mc n xss] where
-    mc :: Int -> [[a]] -> [[a]]
-    mc n [xs] = [[xs !! n]]
-    mc n (xs : xss) = [ (xs !! m) : ys | m <- [0 .. n], ys <- mc (n-m) xss]
-
-
-zipzip :: [a] -> [a] -> [a]
-zipzip [] ys = ys; zipzip (x : xs) ys = x : zipzip ys xs
-
diff --git a/real/rx/src/Defaults.hs b/real/rx/src/Defaults.hs
deleted file mode 100644 (file)
index 55903fc..0000000
+++ /dev/null
@@ -1,51 +0,0 @@
-module Defaults 
-
-( opts0
-)
-
-where
-
-import Options
-
-opts0 :: Opts
-
--- default options for simple pocket calculator use
-
-opts0 = listToOpts
-       [ ("version", "0.0.0")
-
-       -- formatting
-       , ("output", "on") 
-       , ("text", "plain")
-       , ("code", "plain")
-       , ("current", "code")
-
-       -- parsing
-       , ("keepsep", "$")
-       , ("omitsep", "|")
-
-       , ("implicit",  "on")   -- do CL parsing
-       , ("apply", "@")        -- use that as apply symbol
-
-       -- input preprocessing (do it, but don't show it)
-       , ("expand", "off")
-       , ("unify", "on")
-       , ("useful", "on")
-       , ("min", "on")         -- this implies det
-       , ("det", "off")        -- therefore det is off
-
-
-       -- output postprocessing (do it)
-       , ("foldconst", "on")
-       , ("foldnonrec", "on")
-       , ("hidegrammar", "on")
-
-       -- course of evaluation
-       , ("exp", "on")         -- echo input
-       , ("eval", "on")        -- evaluate it
-       , ("trace", "off")      
-       , ("res", "on")         -- show result
-
-       , ("reuse", "off")      -- tricks with reductions?
-
-       ]
\ No newline at end of file
diff --git a/real/rx/src/Exp2FA.hs b/real/rx/src/Exp2FA.hs
deleted file mode 100644 (file)
index 296462b..0000000
+++ /dev/null
@@ -1,39 +0,0 @@
-module Exp2FA
-
-( grammar2etnfa
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Grammar
-
-import TA
-import FAtypes
-
-import Stuff
-import Options
-
-import Ids
-
-------------------------------------------------------------------------
-
-grammar2etnfa :: (Show a, Ord a) => Opts -> Grammar a -> ETNFA a
-grammar2etnfa opts (start, rules) =
-    let
-       all = unionManySets ( unitSet start
-               :  [ mkSet (v : stargs t) | (v, Right t) <- rules ] 
-               ++ [ mkSet (v : [w])      | (v, Left w ) <- rules ] )
-       moves = addListToFM_C unionSet emptyFM
-               [ (v, unitSet t) | (v, Right t) <- rules ]
-       eps =  addListToFM_C unionSet emptyFM
-               [ (v, unitSet w) | (v, Left w) <- rules ]
-       cons = mkSet [ stcon t | (v, Right t) <- rules ]
-       e = ETNFA cons all (unitSet start) moves eps
-    in
-
---     trace ("\ngrammar2etnfa.e = " ++ show e) $
-
-       e
diff --git a/real/rx/src/ExpParse.hs b/real/rx/src/ExpParse.hs
deleted file mode 100644 (file)
index a71043c..0000000
+++ /dev/null
@@ -1,233 +0,0 @@
--- -*- fundamental -*-
-
--- parse haskellized expressions
-
-module ExpParse 
-
-( pline -- expression or declaration
-)
-
-where
-
-
-import Maybes
-import Data.Char
-import Lex
-import Monad
-
-import PI
-import Ids
-import Syntax
-
-import Options
-
-import Prec
-
-
---------------------------------------------------------
-
-paParen   p = do { llit "("; x <- p; llit ")"; return x }
-paBrace   p = do { llit "{"; x <- p; llit "}"; return x }
-paBracket p = do { llit "["; x <- p; llit "]"; return x }
-paBackq   p = do { llit "`"; x <- p; llit "`"; return x }
-
-paCommas  p = p `lsepBy` llit ","
-
---------------------------------------------------------
-
---------------------------------------------------------
-
--- elements of expressions
-
-paNat :: PIS Int
-paNat = 
-    do { cs <- llitp "Nat" (\ cs -> and [isDigit c | c <- cs])
-       ; return (foldl (\ x y -> 10 * x + (fromEnum y - fromEnum '0')) 0 cs)
-       }
-
-paString :: PIS String
-paString =
-    do { cs <- llitp "String" (\ cs -> head cs == '"') -- rely on the lexer
-       ; return (drop 1 (take (length cs - 1) cs))
-       }
-
-paFn :: PIS String
-paFn = llitp "Fn" (\ cs -> isAlpha (head cs) && and [isAlphanum' c | c <- cs]) 
-
-paOp :: PIS String
-paOp = llitp "Op" (\ cs -> and [not (isAlphanum' c) && not(isDel c) | c <- cs]) 
-
-
-paFnLikeDef :: Bool -> PIS Id
-paFnLikeDef def = 
-               do { cs <-         paFn; makeidS   def cs Fn Fn }
-    `mplus`    do { n <-         paNat; makenatS  def n        }
-    `mplus`    do { cs <- paParen paOp; makeidS   def cs Op Fn }
-
-paOpLikeDef :: Bool -> PIS Id
-paOpLikeDef def = 
-               do { cs <-         paOp; makeidS   def cs Op Op }
-    `mplus`    do { cs <- paBackq paFn; makeidS   def cs Fn Op }
-
-
--- normally, don't create identifiers
-paFnLike = paFnLikeDef False
-paOpLike = paOpLikeDef False
-
-------------------------------------------------------------
-
--- building expressions from elements
-
-paCApp :: PIS Exp
--- a closed (parenthesised) expression
-paCApp =
-               do { xs <- paBrace (paCommas paExp); return (Coll CSet xs) }
-    `mplus`    do { xs <- paBracket (paCommas paExp); return (Coll CList xs) }
-    `mplus`    do { xs <- paParen (paCommas paExp)
-               ; case xs of [x] -> return x; _ -> return (Coll CTuple xs) 
-               }
-    `mplus`    do { x <- paFnLike
-               ; x' <- putarityS (idname x) 0
-               ; return (App x' [])
-               }
-
-stairway :: Exp -> [Exp] -> PIS Exp
-stairway x xs =
-    do { opts  <- getopts
-       ; let at = getopt opts "apply"
-       ; hat <- makeidS False at Op Op
-       ; return (foldl (\ l r -> App hat [l, r] ) x xs)
-       }
-
-paMCApp :: PIS Exp
--- a nonempty sequence closed expressions
-paMCApp = 
-    do { x <- paCApp; xs <- lmany paCApp
-       ; if null xs then return x else
-           do  { opts <- getopts
-               ; caseopts opts "implicit"
-                   [ ("on", stairway x xs)
-                   , ("off", error ("cannot build implicit apply node: "
-                                       ++ show (x : xs)))
-                   ]
-               }
-       }
-               
-
-paApp :: PIS Exp
--- a function application
-paApp = do { x <- paFnLike 
-          ; ys <- lmany paCApp 
-          ; x' <- putarityS (idname x) (length ys)     
-          ; papp x' ys
-          }
-
---papp :: Id -> [Exp] -> PIS Exp
-papp id args =
-    do { let nid = idarity id
-       ; let nargs = length args
-       ; o <- getopts ; let imp = onoff o "implicit"
-       ; if not imp then 
-           if nid /= nargs 
-           then error ("arities don't match: " ++ show id ++ show args)
-           else return (App id args)
-         else if nid > nargs
-               then error ("arguments missing: " ++ show id ++ show args)
-               else stairway (App id (take nid args)) (drop nid args)
-       }
-
-
-paExp :: PIS Exp
--- sequence App op App op ... App
-paExp = 
-    do         { x <- paApp `mplus` paMCApp
-       ; xs <- paExpRest
-       ; return (glue (Left x : xs))
-       }
-
--- we store Left App, Right op (these are Ids in fact)
-paExpRest = 
-    do         { op <- paOpLike; arg <- paApp `mplus` paMCApp; rest <- paExpRest
-       ; return (Right op : Left arg : rest)
-       }
-    `mplus` return []
-
-------------------------------------------------------------------
-
-
-paCmd :: PIS ()
-paCmd = 
-       do { llit "local"
-          ; pushlocals
-
-       -- just read ids, don't do anything with 'em
-          ; ids <- paCommas (paFnLikeDef True)
-          ; return ()
-
-          }
-
-    `mplus`    do { llit "unlocal"
-               ; poplocals
-               }
-
-    `mplus`    do { llit "global"
-
-       -- bit of trickery here: open new local group, read ids
-          ; pushlocals
-          ; ids <- paCommas (paFnLikeDef True)
-
-       -- this adds most recent local group to global one
-          ; mkglobals
-          ; poplocals
-          }
-
-    `mplus`    do { llit "infix"; n <- paNat; ops <- paCommas paOpLike
-               ; sequence_ [ putprecS (idname op) n Nn | op <- ops ]
-               }
-    `mplus`    do { llit "infixl"; n <- paNat; ops <- paCommas paOpLike
-               ; sequence_ [ putprecS (idname op) n Lft | op <- ops ]
-               }
-    `mplus`    do { llit "infixr"; n <- paNat; ops <- paCommas paOpLike
-               ; sequence_ [ putprecS (idname op) n Rght | op <- ops ]
-               }
-
-    -- obsolete?
-    `mplus`    do { llit "arity"; n <- paNat; fns <- paCommas paFnLike
-               ; sequence_ [ putarityS (idname fn) n | fn <- fns ]
-               }
-
-    `mplus`    do { llit "form"; fn <- paFnLike
-               ; do { llit "="; cs <- paString 
-                       ; putformS (idname fn) (Passive cs)
-                       }
-               `mplus` do{ n <- paNat; llit "="; cs <- paString 
-                       ; putformS (idname fn) (Active n cs)
-                       }
-               ; return ()
-               }
-       
-
-
-
----------------------------------------------------------------------
-
---paTop :: PIS (Maybe Exp)
-paTop  = 
-       do      { paCmd ; return Nothing }
-    `mplus` do { x <- paExp ; opt (llit ";"); return (Just x) }
-    
-
--------------------------------------------------------------------
---pline :: (Opts,IdTable) -> [Char] -> (Maybe Exp,(Opts,IdTable))
-pline oi cs =
-    case myLex (uncomment cs) of
-                -- empty input is OK
-        [] -> (Nothing, oi)     
-                -- otherwise parse one expression
-                -- closing semicolon is OK (ignored)
-        toks -> case lparse paTop oi toks of
-            Right [((x, oi'), [])] -> (x, oi')
-            _ -> (Just (App (usercon 0 "error") []), oi)
-
-
diff --git a/real/rx/src/FA.hs b/real/rx/src/FA.hs
deleted file mode 100644 (file)
index a48f8c4..0000000
+++ /dev/null
@@ -1,170 +0,0 @@
--- finite automata on trees (arbitrary term algebras)
-
-module FA
-
-( Auto
-
--- export something
-
-, e2d
-, t2d
-
-, d2t
-, d2e
-
-
-, fids         -- identifiers
-, hsTNFA       -- possible default operations
-
--- above this line, eveyrthing is fine, abstract, and so on
--- below is some stuff that is exported 
--- because the module structure isn't quite right
-
-
-, TNFA(..)     -- todo: make abstract
-
-
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Options -- may modify behaviour
-
-import Sorters
-
-
-import TA -- term algebra
-
-import Ids
-import Syntax
-
-import Stuff
-
-import FAtypes
-import FAconv
-
-import FAuseful
-import FAunify
-
-import FAdet
-import FAmin
-
-import FAunion
-import FAintersect
-import FAcon
-import FAminus
-
-import FAtimes
-import FAstar
-import FArquotient
-import FAlquotient
-
-
-
-import ForwardS
-import CForwardS
-
-import BackwardS
-import CBackwardS
-
-import SaturnS
-
-import Instance
-
--- import CloseS
-
------------------------------------------------------------------------
-
--- operations that are probably used often
-
-e2d :: (Show a, Ord a) => Opts -> ETNFA a -> BDFA Int
-e2d opts = tnfa2bdfa opts . etnfa2tnfa opts
-
-
-
-t2d :: (Show a, Ord a) => Opts -> TNFA a -> BDFA Int
-t2d opts = tnfa2bdfa opts
-
-d2t :: (Show a, Ord a) => Opts -> BDFA a -> TNFA a
-d2t opts =              bnfa2tnfa opts . bdfa2bnfa opts
-
-d2e :: (Show a, Ord a) => Opts -> BDFA a -> ETNFA a
-d2e opts = tnfa2etnfa opts . bnfa2tnfa opts . bdfa2bnfa opts
-
-----------------------------------------------------------------------------
-
-
-
-fids :: [ (Id, Opts -> [TNFA Int] -> TNFA Int) ]
-fids =
-       [       ( mkid "++" (Passive "++") (Just 2) Op Op (Just 30) Lft
-               , \ opts -> foldl1 (unionTNFA opts) )
-
-               -- cannot use "--" because that's a comment
-       ,       ( mkid "\\\\" (Passive "\\\\") (Just 2) Op Op (Just 40) Lft
-               , \ opts -> foldr1 (minusTNFA opts) )
-
-       ,       ( mkid "&"  (Passive "&") (Just 2) Op Op (Just 50) Lft
-               , \opts -> foldl1 (intersectTNFA opts) )
-
-       ,       ( mkid "->" (Passive "\\longrightarrow") (Just 2) Op Op (Just 20) Lft
-               , error "never evaluate fids.(->)" )
-
-       ,       ( mkid ";"  (Passive ";") (Just 2) Op Op (Just 10) Lft
-               -- todo: this is the wrong place
-               , error "never evaluate (;)" )
-       ,       ( mkid "=" (Passive "=") (Just 2) Op Op (Just 15) Lft
-               -- todo: this is the wrong place
-               , error "never evaluate (=)" )
-
-       ,       ( userfun 1 "det"
-               , \ opts [x] -> detTNFA opts x )
-       ,       ( userfun 1 "min"
-               , \ opts [x] -> minTNFA opts x )
-       ,       ( userfun 1 "useful" 
-               , \ opts [x] -> usefulTNFA opts x )
-       ,       ( userfun 1  "unify"
-               , \ opts [x] -> unifyTNFA opts x )
-
-       ,       ( userfun 3 "times"
-               , \ opts xs -> timesTNFApublic opts xs )
-       ,       ( userfun 3 "star"
-               , \ opts xs -> starTNFApublic opts xs )
-       ,       ( userfun 3 "rquotient"
-               , \ opts xs -> rquotientTNFApublic opts xs )
-       ,       ( userfun 3 "lquotient"
-               , \ opts xs -> lquotientTNFApublic opts xs )
-
-       ,       ( userfun 1 "forwardS"
-               , \ opts xs -> forwardSpublic opts xs )
-       ,       ( userfun 1 "cforwardS"
-               , \ opts xs -> cforwardSpublic opts xs )
-
-       ,       ( userfun 1 "backwardS"
-               , \ opts xs -> backwardSpublic opts xs )
-       ,       ( userfun 1 "cbackwardS"
-               , \ opts xs -> cbackwardSpublic opts xs )
-
-
-       ,       ( userfun 1 "saturnS"
-               , \ opts xs -> saturnSpublic opts xs )
-
-       ,       ( userfun 1 "inst"
-               , \ opts xs -> instpublic opts xs )
-
-
--- broken
---     ,       ( userfun 1 "closeS"
---             , \ opts xs -> closeSpublic opts xs )
-       
-       ]
-
--- some transformations (that keep the meaning)
--- most imortant (costly) first
-hsTNFA = ["min","det","useful","unify"]
-
-
-
diff --git a/real/rx/src/FA2Exp.hs b/real/rx/src/FA2Exp.hs
deleted file mode 100644 (file)
index 1bdaff1..0000000
+++ /dev/null
@@ -1,111 +0,0 @@
-module FA2Exp
-
-( etnfa2exp
-, tnfa2exp
-
-, foldnonrec
-) 
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import FAconv
-import FA
-
-import Ids
-import Syntax
-
-tnfa2exp :: (Show a, Ord a) => Opts -> TNFA a -> Exp
-tnfa2exp opts = etnfa2exp opts . tnfa2etnfa opts
-
-
-
------------------------------------------------------------------------
-
-
-etnfa2exp :: (Ord a, Show a) => Opts -> ETNFA a -> Exp
-etnfa2exp opts (ETNFA cons all starts moves eps) =
-    let
-       -- todo: this neither nice nor correct nor in the right place
-       -- (the user might have overridden the latex format entry)
-
-       plus = head [ id | (id, _) <- fids, idname id == "++" ]
-
-       expset [] = Coll CSet []
-       expset [x] = x
-       expset xs = foldl1 (\ x y -> App plus [x, y]) xs
-
-       leadsto = head [ id | (id, _) <- fids, idname id == "->" ]
-
-       eall = mapSet var2id all
-       estarts = expset (map var2exp (setToList starts))
-       emoves = [ ( var2exp x
-                , expset (  map sterm2exp (setToList ts)
-                      ++ map var2exp (setToList (lookupset eps x))) )
-              | (x, ts) <- fmToList moves
-              ]
-       
-       (cstarts, cmoves) =
-           (chose opts "foldnonrec" (foldnonrec eall) id) $
-           (chose opts "foldconst" (foldconst eall) id) $
-               (estarts, emoves)
-
-
-    in         if (null cmoves && onoff opts "hidegrammar")
-       then cstarts
-       else
-                App (userfun 2 "grammar")              -- todo: wrong place
-               [ cstarts
-               , Coll CSet [ App leadsto [ x, y ] 
-                       | (x, y) <- cmoves ]
-               ]
-
----------------------------------------------------------------------------
-
-varset r = mkSet (appids r)
-varsets xrs = unionManySets [ varset r | (x, r) <- xrs ]
-
-substMoves name val moves = 
-    [ (x, substExp name val r) | (x, r) <- moves ]
-
-foldconst vars (starts, moves) =
-    fixpoint (\ (starts, moves) ->
-       case    [ (x, r) | (x, r) <- moves 
-               , isEmptySet    (varset r `intersectSet` vars)
-               ] of
-           [] -> (starts, moves)
-           (x, r) : _ -> 
-
---             trace ("\nfoldconst " ++ show x ++ " => " ++ show r) $
-
-
-               ( substExp x r starts
-               , substMoves x r [ (y, s) | (y, s) <- moves, y /= x ] ) )
-       (starts, moves)
-
-------------------------------------------------------------------------
-           
-foldnonrec vars (starts, moves) =
-    fixpoint (\ (starts, moves) ->
-       case    [ (x, r) | (x, r) <- moves 
-               , not (unAppId x `elementOf` varset r)
-               ] of
-           [] -> (starts, moves)
-           (x, r) : _ -> 
-
---             trace ("\nfoldnonrec " ++ show x ++ " => " ++ show r) $
-
-
-               ( substExp x r starts
-               , substMoves x r [ (y, s) | (y, s) <- moves, y /= x ] ) )
-       (starts, moves)
-           
-
-
diff --git a/real/rx/src/FAcheat.hs b/real/rx/src/FAcheat.hs
deleted file mode 100644 (file)
index 50d83e2..0000000
+++ /dev/null
@@ -1,32 +0,0 @@
-module FAcheat
-
-( cheat
-)
-
-where
-
-
-import Set
-import FiniteMap
-
-import TA
-import FAtypes
-
-import Stuff
-
-
---------------------------------------------------------------------
-
--- we cheat a bit. the constructor
--- is acutally given as trivial automaton
-
-cheat :: TNFA Int -> TCon
-cheat (TNFA cons all starts moves) = 
-    let        prod = setToList (starts `bind` lookupset moves)
-    in  if length prod /= 1
-           then error "cheat.prod"
-           else
-               let [t] = prod; tc = stcon t
-               in  if tconarity tc /= 0
-                   then error "timesTNFApublic.tc"
-                   else tc
diff --git a/real/rx/src/FAcmpct.hs b/real/rx/src/FAcmpct.hs
deleted file mode 100644 (file)
index dbec786..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-module FAcmpct 
-
-( cmpctBDFA
-, cmpctTNFA
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-
-import FAmap
-
--------------------------------------------------------------
-
-cmpctBDFA :: Ord a => Opts -> BDFA a -> BDFA Int
--- number states from 0 onwards
-cmpctBDFA opts b @ (BDFA cons all starts moves) = 
-    let        h = listToFM (zip (setToList all) [0..])
-       f = lookupWithDefaultFM h (error "cmpctBDFA")
-    in mapBDFA opts f b
-
-
---cmpctTNFA :: Ord a => Opts -> TNFA a -> TNFA Int
--- number states from 0 onwards
-cmpctTNFA opts b @ (TNFA cons all starts moves) = 
-    let        h = listToFM (zip (setToList all) [0..])
-       f x = lookupWithDefaultFM h 
-               (error ("cmpctTNFA doesn't find: " ++ show x))
-               x
-    in 
---     trace ("\ncmpctTNFA.b : " ++ show b) $
-
-       mapTNFA opts f b
diff --git a/real/rx/src/FAcon.hs b/real/rx/src/FAcon.hs
deleted file mode 100644 (file)
index 8a3855b..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
-module FAcon
-
-( conTNFA
-)
-
-where
-
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAmap
-import FAcmpct
-
-conTNFA :: Opts -> TCon -> [TNFA Int] -> TNFA Int
--- apply a constructor
-conTNFA opts tc as = 
-    let -- make each arg top-down, tag it with its number
-       aks    = [ mapTNFA opts (\ v -> (k, v)) a 
-               | (k, a) <- zippy [1..tconarity tc] as ]
-
-       moves  = foldl  (plusFM_C (error "conTNFA.moves")) emptyFM
-                              [ m | TNFA _ _ _ m <- aks ]
-       starts =               [ s | TNFA _ _ s _ <- aks ]
-       alls   = unionManySets [ a | TNFA _ a _ _ <- aks ]
-       cons   = unionManySets (unitSet tc : [ c | TNFA c _ _ _ <- aks ]) 
-
-       top = (0,0); tops = unitSet top
-       its = unitFM top (mapSet (mksterm tc) (insts starts))
-       
-       t = TNFA cons (alls `unionSet` tops) tops
-               (plusFM_C (error "conTNFA.e") moves its)
-       d = cmpctTNFA opts t
-    in 
-
-       trinfo opts "con" d $
-
-       d
-
diff --git a/real/rx/src/FAconv.hs b/real/rx/src/FAconv.hs
deleted file mode 100644 (file)
index 72f87eb..0000000
+++ /dev/null
@@ -1,71 +0,0 @@
--- simple conversions
-
-module FAconv 
-
-( etnfa2tnfa, tnfa2etnfa
-, tnfa2bnfa, bnfa2tnfa
-, bdfa2bnfa, simplebnfa2bdfa
-, bdfa2tnfa
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff 
-import Options
-
-import FAtypes
-
-import TA
-
----------------------------------------------------------------
-
-etnfa2tnfa :: (Show a, Ord a) => Opts -> ETNFA a -> TNFA a
-etnfa2tnfa opts a @ (ETNFA cons all starts moves eps) =
-    let        ehull x = sethull (\ y -> lookupset eps y) x 
-       h x = ehull (unitSet x) `bind` lookupset moves
-       moves1 = listToFM [ (x, h x) | x <- setToList all ]
-       starts1 = mapSet unitSet starts `bind` ehull
-       t = TNFA cons all starts1 moves1
-    in 
---     trace ("etnfa2tnfa.a = " ++ show a) $
---     trace ("etnfa2tnfa.t = " ++ show t) $
-       t
-
---------------------------------------------------------------
-
-tnfa2bnfa :: Ord a => Opts -> TNFA a -> BNFA a
-tnfa2bnfa opts (TNFA cons all starts moves) =
-    BNFA cons all starts (invert moves)
-
-
-bnfa2tnfa :: Ord a => Opts -> BNFA a -> TNFA a
-bnfa2tnfa opts (BNFA cons all starts moves) =
-    TNFA cons all starts (invert moves)
-
-tnfa2etnfa :: Ord a => Opts -> TNFA a -> ETNFA a
-tnfa2etnfa opts(TNFA cons all starts moves) =
-    ETNFA cons all starts moves emptyFM
-
-
-
-bdfa2bnfa :: Ord a => Opts -> BDFA a -> BNFA a
-bdfa2bnfa opts (BDFA cons all starts moves) =
-    let        moves' = mapFM (\ x y -> unitSet y) moves
-    in BNFA cons all starts moves'
-
-
-simplebnfa2bdfa opts (BNFA cons all starts moves) =
-    let        moves1 = mapFM ( \ t ws -> 
-               case setToList ws of 
-                       [w] -> w
-                       _ -> error "simplebnfa2bdfa" ) moves
-    in         BDFA cons all starts moves1
-
--------------------------------------------------------
-
-bdfa2tnfa :: Opts -> BDFA Int -> TNFA Int
-bdfa2tnfa opts = bnfa2tnfa opts . bdfa2bnfa opts
-
diff --git a/real/rx/src/FAdet.hs b/real/rx/src/FAdet.hs
deleted file mode 100644 (file)
index e751d00..0000000
+++ /dev/null
@@ -1,99 +0,0 @@
--- powerset construction
-
-module FAdet
-
-( bnfa2bdfa
-, tnfa2bdfa
-, detTNFA
-)
-
-
-where
-
-
-
-import Set
-import FiniteMap
-
-import Options
-
-import Stuff
-
-import TA
-import FAtypes
-
-import FAconv
-
-import FAcmpct
-
-pick :: Ord a => FiniteMap (STerm a) (Set a) -> STerm (Set a) -> Set a
--- look up the (set of) predec. of a term (whose comps. are sets)
-pick m t =
-    let args = insts (stargs t) 
-       ts = mapSet (\ a -> mksterm (stcon t) a) args
-       ps = ts `bind` lookupset m 
-    in  ps
-
-
-phull :: Ord a =>
-       TCons -> FiniteMap (STerm a) (Set a)    -- original map
-       -> Set (Set a) -> Set (Set a)           -- known/unknown
-       -> FiniteMap (STerm (Set a)) (Set a)    -- input
-       -> (Set (Set a), FiniteMap (STerm (Set a)) (Set a))     -- output
-
-phull tcons m known unknown rels | isEmptySet unknown = (known, rels)
-phull tcons m known unknown rels =
-    let        ts =    [ mksterm tc a
-               | tc <- setToList tcons, n <- [tconarity tc], n > 0
-               , a <- packs n 1 (setToList known) (setToList unknown)
-               ]
-
-       ps = [ (t, p) | t <- ts, p <- [pick m t] -- new relations
-
--- x-perry-mental: don't generate the sink state {}
-                       , not (isEmptySet p)
-
-            ]                          
-
-       qs = listToFM ps                        -- new relations as map
-       gs = mkSet [ g | (t, g) <- ps ]         -- new sets
-       ks = known `unionSet` unknown           -- they are no longer unknown
-       ns = gs `minusSet` ks                   -- these are brand new
-       rs = plusFM_C (error "phull") rels qs   -- should not clash
-    in phull tcons m ks ns rs
-
-
-
-{-# SPECIALIZE bnfa2bdfa' :: Opts -> BNFA Int -> BDFA (Set Int) #-}
-bnfa2bdfa' :: Ord a => Opts -> BNFA a -> BDFA (Set a)
-bnfa2bdfa' opts (BNFA cons all starts moves) =
-    let        ps =    [ ( mksterm tc []
-                 , g
-                 )
-               | tc <- setToList cons, tconarity tc == 0
-
-               , g <- [lookupset moves (mksterm tc [])] 
-
--- x-perry-mental: don't generate sink state {}
-               , not (isEmptySet g)
-
-               ]
-       qs = listToFM ps                        -- start relations
-       gs = mkSet [ g | (t, g) <- ps ]         -- start sets
-       (ks, rs) = phull cons moves emptySet gs qs      -- find hull
-       fs = filterSet (\ s -> not (isEmptySet (s `intersectSet` starts))) ks
-    in BDFA cons ks fs rs
-
-------------------------------------------------------------------------
-
-bnfa2bdfa :: (Show a, Ord a) => Opts -> BNFA a -> BDFA Int
-bnfa2bdfa opts = cmpctBDFA opts . bnfa2bdfa' opts
-
-tnfa2bdfa :: (Show a, Ord a) => Opts -> TNFA a -> BDFA Int
-tnfa2bdfa opts = bnfa2bdfa opts . tnfa2bnfa opts
-
-
-detTNFA :: Opts -> TNFA Int -> TNFA Int
-detTNFA opts = bdfa2tnfa opts . tnfa2bdfa opts
-
-
diff --git a/real/rx/src/FAhom.hs b/real/rx/src/FAhom.hs
deleted file mode 100644 (file)
index b97b780..0000000
+++ /dev/null
@@ -1,73 +0,0 @@
-module FAhom
-
-( homBDFA
-, homTNFA
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Options
-
-import Stuff
-
-import TA
-import FAtypes
-
-
-
-
-homBDFA :: (Ord a, Ord b) => Opts -> (a -> b) -> (BDFA a -> BDFA b)
--- homomorphism: identifies some states
-homBDFA opts f (BDFA cons all starts moves) =
-    let 
-       -- some paranoid checks first
-       nostarts = all `minusSet` starts
-       starts' = mapSet f starts
-       nostarts' = mapSet f nostarts
-       all' = starts' `unionSet` nostarts'
-
-       moves' = addListToFM_C 
-               (\ x y -> if x /= y 
-                       then error "bfdahom identifies incosistent ruleset"
-                       else x)
-               emptyFM
-               [ (mksterm (stcon t) (map f (stargs t)), f w)
-               | (t, w) <- fmToList moves
-               ]
-               
-    in if not (isEmptySet (starts' `intersectSet` nostarts'))
-       then error "homBDFA identifies starts and nostarts"
-       else    BDFA cons all' starts' moves'
-
----------------------------------------------------------------
-
-homTNFA :: (Ord a, Ord b) => Opts -> (a -> b) -> (TNFA a -> TNFA b)
--- homomorphism: identifies some states
-homTNFA opts f (TNFA cons all starts moves) =
-    let 
-       -- can't do paranoia checking here
-       -- since rejecting states are not uniquely determined
-
-       starts' = mapSet f starts
-       all' = mapSet f all
-
-       moves' = addListToFM_C 
-               (\ x y -> if x /= y 
-                       then error "bfdahom identifies incosistent ruleset"
-                       else x)
-               emptyFM
-               [ ( f w 
-                 , mapSet ( \ t -> mksterm (stcon t) (map f (stargs t))) ts )
-               | (w, ts) <- fmToList moves
-               ]
-               
-       g = TNFA cons all' starts' moves'
-
-    in 
-       trinfo opts "hom" g $
-
-       g
-------------------------------------------------------------------------
diff --git a/real/rx/src/FAintersect.hs b/real/rx/src/FAintersect.hs
deleted file mode 100644 (file)
index 7ccc9e7..0000000
+++ /dev/null
@@ -1,65 +0,0 @@
-module FAintersect
-
-( intersectTNFA
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAcmpct
-import FAkeepcons
-
-intersectTNFA :: Opts -> TNFA Int -> TNFA Int -> TNFA Int
-intersectTNFA opts a1 @ (TNFA consa1 _ _ _) a2 @ (TNFA consa2 _ _ _) =
-    let        cons = consa1 `intersectSet` consa2
-       TNFA cons1 all1 starts1 moves1 = keepconsTNFA opts a1 cons
-       TNFA cons2 all2 starts2 moves2 = keepconsTNFA opts a2 cons
-
-       comb (w1, w2) = mkSet
-               [ mksterm (stcon t1) (zippy (stargs t1) (stargs t2)) 
-               | t1 <- setToList 
-                   (lookupWithDefaultFM moves1 (error "intersectTNFA.t1") w1)
-               , stcon t1 `elementOf` cons
-
-               , t2 <- setToList 
-                   (lookupWithDefaultFM moves2 (error "intersectTNFA.t2") w2)
-
-               , stcon t2 `elementOf` cons
-               , stcon t1 == stcon t2
-               ]
-
-       moves = listToFM [ ( (w1, w2), cs)
-               | w1 <- setToList all1, w2 <- setToList all2 
-               , cs <- [ comb (w1, w2) ], not (isEmptySet cs)
-               ]
-       starts3 = mkSet [ (x, y) 
-               | x <- setToList starts1, y <- setToList starts2 ]
-
-       all3 =  mkSet [ (x, y) 
-               | x <- setToList all1, y <- setToList all2 ]
-       b3 = TNFA cons all3 starts3 moves
-
-       c = cmpctTNFA opts b3
-
-    in         
---     trace ("\nintersectTNFA.a1: " ++ show a1) $
---     trace ("\nintersectTNFA.a2: " ++ show a2) $
---     trace ("\nintersectTNFA.cons: " ++ show cons) $
---     trace ("\nintersectTNFA.moves: " ++ show moves) $
---     trace ("\nintersectTNFA.starts': " ++ show starts') $
---     trace ("\nintersectTNFA.all: " ++ show all) $
---     trace ("\nintersectTNFA.starts: " ++ show starts) $
---     trace ("\nintersectTNFA.b: " ++ show b) $
-
-       trinfo opts "intersect" c $
-
-       c
diff --git a/real/rx/src/FAkeepcons.hs b/real/rx/src/FAkeepcons.hs
deleted file mode 100644 (file)
index e2e0e08..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
-module FAkeepcons
-
-( keepconsBDFA
-, keepconsTNFA
-)
-
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAuseful
-
-----------------------------------------------------------------------------
-
-keepconsBDFA :: (Ord a, Show a) => Opts -> BDFA a -> TCons -> BDFA a
-keepconsBDFA opts (BDFA cons all starts moves) cons0 =
-    let cons1 = cons `intersectSet` cons0
-       moves1 = filterFM (\ t _ -> stcon t `elementOf` cons1) moves
-       b = BDFA cons1 all starts moves1
-       c = usefulBDFA opts b   -- todo: really useful doing this?
-    in c
-
----------------------------------------------------------------------------
-
-keepconsTNFA :: (Ord a, Show a) => Opts -> TNFA a -> TCons -> TNFA a
-keepconsTNFA opts (TNFA cons all starts moves) cons0 =
-    let cons1 = cons `intersectSet` cons0
-       moves1 = filterFM ( \ _ ts -> not (isEmptySet ts) ) $
-               mapFM ( \ _ ts -> 
-                       filterSet ( \ t -> stcon t `elementOf` cons1) ts ) 
-               moves
-       b = TNFA cons1 all starts moves1
-       c = usefulTNFA opts b   -- todo: really useful doing this?
-    in c
-
----------------------------------------------------------------------------
-
diff --git a/real/rx/src/FAkeepst.hs b/real/rx/src/FAkeepst.hs
deleted file mode 100644 (file)
index e0b7f36..0000000
+++ /dev/null
@@ -1,52 +0,0 @@
-module FAkeepst
-
-( keepstBNFA
-, keepstTNFA
-)
-
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-
-----------------------------------------------------------------------------
-
-keepstBNFA :: Ord a => Opts -> BNFA a -> Set a -> BNFA a
-keepstBNFA opts (BNFA cons all starts moves) keeps = 
-    let starts' = (starts `intersectSet` keeps)
-       moves' = mapFM (\ t v -> v `intersectSet` keeps) moves
-       moves'' = filterFM (\ t v ->
-               not (isEmptySet v)
-               && isEmptySet (mkSet (stargs t) `minusSet` keeps)) moves'
-    in BNFA cons  keeps starts' moves''
-
---------------------------------------------------------------------------
-
-keepstBDFA :: Ord a => Opts -> BDFA a -> Set a -> BDFA a
-keepstBDFA opts (BDFA cons all starts moves) keeps = 
-    let starts' = (starts `intersectSet` keeps)
-       moves'' = filterFM (\ t v -> 
-               v `elementOf` keeps
-               && isEmptySet (mkSet (stargs t) `minusSet` keeps)) moves
-    in BDFA cons  keeps starts' moves''
-
-
----------------------------------------------------------------------------
-
-keepstTNFA :: Ord a => Opts -> TNFA a -> Set a -> TNFA a
-keepstTNFA opts (TNFA cons all starts moves) keeps = 
-    let        starts' = (starts `intersectSet` keeps)
-       rm s = filterSet 
-               (\ t -> isEmptySet (mkSet (stargs t) `minusSet` keeps))
-               s
-       moves'' = filterFM (\ t v ->
-               (t `elementOf` keeps)
-               && not (isEmptySet v)) moves
-    in TNFA cons keeps starts' moves''
diff --git a/real/rx/src/FAlquotient.hs b/real/rx/src/FAlquotient.hs
deleted file mode 100644 (file)
index f6e5f02..0000000
+++ /dev/null
@@ -1,93 +0,0 @@
-module FAlquotient
-
-( lquotientTNFA
-, lquotientTNFApublic
-)
-
-where
-
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAuseful (prods)
-
-import FAcheat
-
-----------------------------------------------------------------------
-
-lquotientTNFA :: Opts -> TCon -> TNFA Int -> TNFA Int -> TNFA Int
-lquotientTNFA opts tc a1 @ (TNFA consa1 _ _ _) a2 @ (TNFA consa2 _ _ _) =
-    let        
-       -- not surprisingly, this is copied from intersectTNFA
-
-       -- todo:check that tc not in cons1
-
-       cons = consa1 `unionSet` unitSet tc
-
-       TNFA cons1 all1 starts1 moves1 = a1
-       TNFA cons2 all2 starts2 moves2 = a2
-
-       comb (w1, w2) = mkSet
-               [ mksterm (stcon t2) (zippy (stargs t1) (stargs t2))
-               | t2 <- setToList 
-                   (lookupWithDefaultFM moves2 (error "lquoteTNFA.t2") w2)
-
-               , t1 <- setToList 
-                   (lookupWithDefaultFM moves1 (error "lquoteTNFA.t1") w1)
-               , stcon t2 == stcon t1
-
-               ]
-
-       moves = listToFM [ ( (w1, w2), cs)
-               | w1 <- setToList all1, w2 <- setToList all2 
-               , cs <- [ comb (w1, w2) ]       
-               , not (isEmptySet cs)
-               ]
-
-       moves3 = invert moves
-       prods3 = prods cons2 moves3     -- those that produce leaves
-
-       ws = prods3 `bind` \ (w1, w2) ->  -- mark their partners
-               if w2 `elementOf` starts2 then unitSet w1 else emptySet
-
-       moves4 = mapFM (\ w ts -> 
-               if w `elementOf` ws 
-               then ts `unionSet` unitSet (mksterm tc [])
-               else ts ) moves1
-
-       b3 = TNFA cons all1 starts1 moves4
-       
-
-    in         
-
---     trace ("\nlquotient.a1: " ++ show a1) $
---     trace ("\nlquotient.a2: " ++ show a2) $
---     trace ("\nlquotient.moves: " ++ show moves) $
---     trace ("\nlquotient.moves3: " ++ show moves3) $
---     trace ("\nlquotient.prods3: " ++ show prods3) $
---     trace ("\nlquotient.ws: " ++ show ws) $
---     trace ("\nlquotient.moves4: " ++ show moves4) $
---     trace ("\nlquotient.b3: " ++ show b3) $
-
-       trinfo opts "lquotient" b3 $
-
-       b3
-
-
-lquotientTNFApublic :: Opts -> [TNFA Int] -> TNFA Int
-lquotientTNFApublic opts args =
-    if length args /= 3 
-    then error "lquotientTNFApublic.args"
-    else 
-       let [tcarg, arg1, arg2] = args
-       in  lquotientTNFA opts (cheat tcarg) arg1 arg2
-
-
diff --git a/real/rx/src/FAmap.hs b/real/rx/src/FAmap.hs
deleted file mode 100644 (file)
index af3357f..0000000
+++ /dev/null
@@ -1,41 +0,0 @@
-module FAmap
-
-( mapBDFA
-, mapTNFA
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Options
-
-import Stuff
-
-import TA
-import FAtypes
-
-mapBDFA :: (Ord a, Ord b) => Opts -> (a -> b) -> BDFA a -> BDFA b
--- f must be injective
-mapBDFA opts f (BDFA cons all starts moves) =
-    let        h = listToFM [(a, f a)|a <- setToList all]
-       r = lookupWithDefaultFM h (error "mapBDFA")
-       all' = mapSet r all
-       starts' = mapSet r starts
-       moves' = listToFM [ (mksterm (stcon t) (map r (stargs t)), r v)
-                         | (t, v) <- fmToList moves ]
-    in BDFA cons all' starts' moves'
-
-mapTNFA :: (Ord a, Ord b) => Opts -> (a -> b) -> TNFA a -> TNFA b
--- f must be injective
-mapTNFA opts f (TNFA cons all starts moves) =
-    let        h = listToFM [ (a, f a) | a <- setToList all]
-       r = f -- lookupWithDefaultFM h (error "mapTNFA")
-       all' = mapSet r all
-       starts' = mapSet r starts
-       moves' = listToFM 
-           [ (r v, mapSet (\ t -> mksterm (stcon t) (map r (stargs t))) ts )
-           | (v, ts) <- fmToList moves ]
-    in TNFA cons all' starts' moves'
-
diff --git a/real/rx/src/FAmin.hs b/real/rx/src/FAmin.hs
deleted file mode 100644 (file)
index bfa1cb1..0000000
+++ /dev/null
@@ -1,122 +0,0 @@
-module FAmin 
-
-( minBDFA
-, minTNFA
-)
-
-where
-
-
-import Set
-import FiniteMap
-
-import Options
-
-import Stuff
-
-import TA
-import FAtypes
-import Ids
-
-import FAconv
-
-import FAdet
-import FAhom
-
--- amin stuff
-
-partFM :: Ord a => [[a]] -> FiniteMap a Int
--- input is list of lists that constitute a partition
--- output map each elem to the number of its class
-partFM p = 
-    addListToFM_C 
-       (\ _ _ -> error "partFM") -- paranoid: check uniq-ness
-       emptyFM
-       [ (v, k) | (k, vs) <- zip [0..] p, v <- vs ]
-
--- items :: [a] -> [(Int, a, [a])]
--- lists with dropped/picked nth element
-items [] = []
-items (x : xs) = (0, x, xs) : [ (n + 1, y, x : ys) | (n, y, ys) <- items xs ]
-
-refineFM :: (Show a, Ord a) =>
-       FiniteMap a Int -> FiniteMap a Int -> FiniteMap a Int
--- uses collectFM: result number range may have holes
--- f must be a complete map, g may have holes
-refineFM f g =
-    let        fg = mapFM ( \ x fx -> 
-               (fx, lookupFM g x)) 
-               f
-       p  = collectFM (eltsFM fg)
-       h  = mapFM ( \ x fgx -> 
-               lookupWithDefaultFM p (error "refineFM.h") fgx ) 
-               fg
-    in
-
---     trace ("\nrefineFM.fg = " ++ show fg) $
---     trace ("\nrefineFM.p  = " ++ show p ) $
---     trace ("\nrefineFM.h  = " ++ show h ) $
-
-       h               
-
-
-refineFMs :: (Show a, Ord a) => 
-       FiniteMap a Int -> [ FiniteMap a Int ] -> FiniteMap a Int
-refineFMs p [] = p
-refineFMs p (f : fs) =
-       if sizeFM p == cardinality (mkSet (eltsFM p))
-       then p                                  -- cannot be further refined
-       else refineFMs (refineFM p f) fs        
-    
-
-tconthrough :: (Show a, Ord a)
-       => FiniteMap (STerm a) a -- transition table
-       -> Set a                -- all variables
-       -> FiniteMap a Int      -- a partition of all variables
-       -> FiniteMap a Int      -- refinement of that partition
-
-tconthrough m all p =
-    let        tups (t, w) = 
-               [ ( ( stcon t, n, xs )
-                 , (x, lookupWithDefaultFM p (error "tconthrough.w") w) )
-               | (n, x, xs) <- items (stargs t)
-               ]
-
-       h = addListToFM_C 
-               (\ a b -> plusFM_C (error "tconthrough.h") a b) 
-               emptyFM 
-               [ (fun, unitFM x w) 
-               | tw <- fmToList m, (fun, (x, w)) <- tups tw 
-               ]
-
-       q = refineFMs p (eltsFM h)
-    in 
-
---     trace ("\ntconthrough.p: " ++ show p) $
---     trace ("\ntconthrough.h: " ++ show h) $
---     trace ("\ntconthrough.q: " ++ show q) $
-       
-       q
-
-------------------------------------------------------------------------
-
-minBDFA :: (Show a, Ord a) => Opts -> BDFA a -> BDFA Int
-minBDFA opts b @ (BDFA cons all starts moves) =
-    let        nostarts = all `minusSet` starts
-       p = partFM [ setToList starts, setToList nostarts ]
-       q = fixpoint (tconthrough moves all) p
-       f = lookupWithDefaultFM q (error "bdfamin.f")
-       c = homBDFA opts f b
-    in 
---     trace ("\nbdfamin.nostarts: " ++ show nostarts) $
---     trace ("\nbdfamin.p: " ++ show p) $
---     trace ("\nbdfamin.q: " ++ show q) $
---     trace ("\nbdfamin.c: " ++ show c) $
-       c
-
-
-minTNFA :: Opts -> TNFA Int -> TNFA Int
-minTNFA opts = bdfa2tnfa opts . minBDFA opts . tnfa2bdfa opts
-
-
-
diff --git a/real/rx/src/FAminus.hs b/real/rx/src/FAminus.hs
deleted file mode 100644 (file)
index 105e8ba..0000000
+++ /dev/null
@@ -1,36 +0,0 @@
-module FAminus
-
-( minusTNFA
-)
-
-where
-
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAintersect
-
-import FAneg
-
-----------------------------------------------------------------------
-
-minusTNFA :: Opts -> TNFA Int -> TNFA Int -> TNFA Int
-minusTNFA opts
-         x1 @ (TNFA cons1 all1 starts1 moves1)
-         x2 @ (TNFA cons2 all2 starts2 moves2) =
-    let        cons = cons1 `unionSet` cons2
-       y2 = TNFA cons all2 starts2 moves2
-       z2 = negTNFA opts y2
-       v  = intersectTNFA opts x1 z2
-    in 
-       trinfo opts "minus" v $
-       v
-
diff --git a/real/rx/src/FAneg.hs b/real/rx/src/FAneg.hs
deleted file mode 100644 (file)
index b252eea..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-module FAneg
-
-( negTNFA
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-
-import FAconv
-
-import FAdet
-
--------------------------------------------------------------------------
-
-negTNFA :: Opts -> TNFA Int -> TNFA Int
-negTNFA opts x =
-    let BDFA cons all starts moves =  tnfa2bdfa opts x
-       sink = 1 + maximum (0 : setToList all)
-       all1 = unitSet sink `unionSet` all
-       starts1 = all1 `minusSet` starts
-       moves1 = listToFM 
-               [ (t, lookupWithDefaultFM moves sink t)
-               | tc <- setToList cons, n <- [tconarity tc]
-               , args <- setToList (insts (take n (repeat all1)))
-               , t <- [ mksterm tc args ]
-               ]
-       d = BDFA cons all1 starts1 moves1
-       u = bnfa2tnfa opts (bdfa2bnfa opts d)
-    in 
-       trinfo opts "neg" u $
-       u
-
diff --git a/real/rx/src/FArquotient.hs b/real/rx/src/FArquotient.hs
deleted file mode 100644 (file)
index 9439c0b..0000000
+++ /dev/null
@@ -1,96 +0,0 @@
-module FArquotient
-
-( rquotientTNFA
-, rquotientTNFApublic
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAuseful
-import FAkeepst
-
-import FAcheat
-
-
-import Trace
-
-----------------------------------------------------------------------
-
-rquotientTNFA :: Opts -> TCon -> TNFA Int -> TNFA Int -> TNFA Int
-rquotientTNFA opts tc a1 @ (TNFA consa1 _ _ _) a2 @ (TNFA consa2 _ _ _) =
-    let        
-       -- not surprisingly, this is copied from intersectTNFA
-
-       cons = consa1 
-       TNFA cons1 all1 starts1 moves1 = a1
-       TNFA cons2 all2 starts2 moves2 = a2
-
-       comb (w1, w2) = mkSet
-               [ mksterm (stcon t2) (zip (stargs t1) (stargs t2))
-                       -- don't use zippy here!
-                       -- we're mis-using tc of arity 0 slightly
-               | t2 <- setToList 
-                   (lookupWithDefaultFM moves2 (error "rquoteTNFA.t2") w2)
-               , stcon t2 == tc || stcon t2 `elementOf` cons 
-
-               , t1 <- setToList 
-                   (lookupWithDefaultFM moves1 (error "rquoteTNFA.t1") w1)
-               , stcon t2 == tc || stcon t1 == stcon t2
-
-               ]
-
-       moves = listToFM [ ( (w1, w2), cs)
-               | w1 <- setToList all1, w2 <- setToList all2 
-               , cs <- [ comb (w1, w2) ], not (isEmptySet cs)
-               ]
-       starts3 = mkSet [ (x, y) 
-               | x <- setToList starts1, y <- setToList starts2 ]
-       all3 =  mkSet [ (x, y) 
-               | x <- setToList all1, y <- setToList all2 ]
-       b3 = TNFA (cons `unionSet` unitSet tc) all3 starts3 moves
-
---     reachables = precs moves starts3
---     t4 @ (TNFA cons4 all4 starts4 moves4) = keepstTNFA opts b3 reachables
-
-       t4 @ (TNFA cons4 all4 starts4 moves4) = usefulTNFA opts b3 -- ???
-
-       starts5 = mkSet [ v1 
-               | ((v1, v2) , ts ) <- fmToList moves4
-               , or [ stcon t == tc | t <- setToList ts ]
-               ]
-       b6 = TNFA cons1 all1 starts5 moves1
-
-    in         
-
---     trace ("\nrquotient.a1: " ++ show a1) $
---     trace ("\nrquotient.a2: " ++ show a2) $
---     trace ("\nrquotient.moves: " ++ show moves) $
---     trace ("\nrquotient.starts3: " ++ show starts3) $
---     trace ("\nrquotient.all3: " ++ show all3) $
---     trace ("\nrquotient.b3: " ++ show b3) $
---     trace ("\nrquotient.t4: " ++ show t4) $
---     trace ("\nrquotient.starts5: " ++ show starts5) $
-
-       trinfo opts "rquotient" b6 $
-       
-       b6
-
-
-rquotientTNFApublic :: Opts -> [TNFA Int] -> TNFA Int
-rquotientTNFApublic opts args =
-    if length args /= 3 
-    then error "rquotientTNFApublic.args"
-    else 
-       let [tcarg, arg1, arg2] = args
-       in  rquotientTNFA opts (cheat tcarg) arg1 arg2
-
diff --git a/real/rx/src/FAstar.hs b/real/rx/src/FAstar.hs
deleted file mode 100644 (file)
index 13d2945..0000000
+++ /dev/null
@@ -1,71 +0,0 @@
-module FAstar
-
-( starTNFA
-, starTNFApublic 
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-
-import Ids
-
-import FAmap
-
-import FAcheat
-
-
----------------------------------------------------------------------------
-
-starTNFA :: Opts -> TCon -> TNFA Int -> TNFA Int -> TNFA Int
--- star dot product of two langugaes.
--- replaces one specified nullary constructor of the first language
--- with an epsilon trasition to the second language
--- or with an epsilon to the first lang's start
-starTNFA opts tc
-       a @ (TNFA cons1 all1 starts1 moves1)
-       b =
-    let
-       startmoves1 = starts1 `bind` (lookupset moves1)
-
-       m = 1 + maximum (0 :  setToList all1)
-       TNFA cons2 all2 starts2 moves2 = mapTNFA opts (\ n -> n + m) b
-
-       -- all that can be constructed from the start
-       startmoves2 = starts2 `bind` (lookupset moves2)
-
-       startmoves = startmoves1 `unionSet` startmoves2
-
-       change t = if stcon t == tc then startmoves else unitSet t
-
-       moves3 = mapFM (\ v ts -> ts `bind` change) moves1
-       
-       cons = (cons1 `minusSet` unitSet tc) `unionSet` cons2 
-       all = all1 `unionSet` all2
-       starts = starts2 `unionSet` starts1
-       moves = plusFM_C (error "starTNFA.moves") moves3 moves2
-
-       c = TNFA cons all starts moves
-
-    in 
-
-       trinfo opts "star" c $
-
-       c
-
-
-starTNFApublic :: Opts -> [TNFA Int] -> TNFA Int
-starTNFApublic opts args =
-    if length args /= 3 
-    then error "starTNFApublic.args"
-    else 
-       let [tcarg, arg1, arg2] = args
-       in  starTNFA opts (cheat tcarg) arg1 arg2
-
diff --git a/real/rx/src/FAsubtrans.hs b/real/rx/src/FAsubtrans.hs
deleted file mode 100644 (file)
index b304558..0000000
+++ /dev/null
@@ -1,98 +0,0 @@
--- applies a transformation to exactly one of all states of an automaton
--- instance: reduce exactly one redex that may be situated aritrarily
-
-module FAsubtrans
-
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAmap
-import FAcmpct
-
-import FAuseful
-
---import Trace
-
---import List
-
-subtransTNFA :: Opts -> (Opts -> TNFA Int -> TNFA Int) -> TNFA Int -> TNFA Int
-
-subtransTNFA opts f a @ (TNFA cons all starts moves) =
-    let
-       n = maximum (setToList all)
-       orig = n + 1    -- next unused state
-       copy = n + 2    -- even more unused state
-
-       o @ (TNFA ocons oall ostarts omoves) 
-               = mapTNFA opts (\ m -> (orig, m)) a
-       c @ (TNFA ccons call cstarts cmoves) 
-               = mapTNFA opts (\ m -> (copy, m)) a
-
-       -- stepping from the copy to the original:
-       -- make exactly one argument point to the copy,
-       -- all the others to the original
-       -- that is, in the copy, there are no leaves here
-       cmoves' = mapFM (\ w ts -> mkSet 
-               [ mksterm tc (as' ++ b : cs')
-               | t <- setToList ts
-               , tc <- [ stcon t ], args <- [ stargs t ]
-               , (as, b : cs) <- zip (inits args) (tails args)
-               , as' <- [[ (orig, a) | (_, a) <- as ]]
-               , cs' <- [[ (orig, c) | (_, c) <- cs ]]
-               ] ) cmoves
-
-       -- the new automata
-       ns = listToFM 
-               [ (w, mapTNFA opts (\ m -> (w, m))
-                       (f opts (usefulTNFA opts        -- does this help?
-                               (TNFA cons all (unitSet w) moves))))
-               | w <- setToList all
-               ]
-
-       ncons  = unionManySets [ cons  | TNFA cons _ _ _ <- eltsFM ns ]
-       nall   = unionManySets [ all   | TNFA _ all  _ _ <- eltsFM ns ]
-
-       -- the moves in them
-       mmoves = foldl (plusFM_C unionSet) emptyFM 
-               [ moves | TNFA _ _ _ moves <- eltsFM ns ]
-
-       -- the moves to them
-       nmoves = listToFM 
-               [ ( (copy, w) , nstarts `bind` lookupset nmoves )
-               | w <- setToList all
-               , TNFA _ _ nstarts nmoves <- 
-                       [ lookupWithDefaultFM ns (error "subtransTNFA.ns") w ]
-               ]
-
-       -- all together now
-       cons' = cons `unionSet` ncons
-       all' = oall `unionSet` call `unionSet` nall
-
-       starts' = cstarts
-       moves' = plusFM_C unionSet 
-                       (plusFM_C unionSet nmoves mmoves)
-                       (plusFM_C unionSet omoves cmoves')
-
-       d = TNFA cons' all' starts' moves'
-       e = cmpctTNFA opts d
-
-    in
-
---     trace ("\nFAsubtrans.a = " ++ show a) $
---     trace ("\nFAsubtrans.o = " ++ show o) $
---     trace ("\nFAsubtrans.c = " ++ show c) $
---     trace ("\nFAsubtrans.d = " ++ show d) $
---     trace ("\nFAsubtrans.e = " ++ show e) $
-
-       e
-
diff --git a/real/rx/src/FAtimes.hs b/real/rx/src/FAtimes.hs
deleted file mode 100644 (file)
index 26b6d2b..0000000
+++ /dev/null
@@ -1,61 +0,0 @@
-module FAtimes
-
-( timesTNFA
-, timesTNFApublic
-)
-
-where
-
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAmap
-
-import FAcheat
-
----------------------------------------------------------------------------
-
-timesTNFA :: Opts -> TCon -> TNFA Int -> TNFA Int -> TNFA Int
--- dot product of two langugaes.
--- replaces one specified nullary constructor of the first language
--- with an epsilon trasition to the second language
-timesTNFA opts tc
-       a @ (TNFA cons1 all1 starts1 moves1)
-       b =
-    let
-       m = 1 + maximum (0 :  setToList all1)
-       TNFA cons2 all2 starts2 moves2 = mapTNFA opts (\ n -> n + m) b
-
-       -- all that can be constructed from the start
-       startmoves2 = starts2 `bind` (lookupset moves2)
-
-       change t = if stcon t == tc then startmoves2 else unitSet t
-
-       moves3 = mapFM (\ v ts -> ts `bind` change) moves1
-       
-       cons = (cons1 `minusSet` unitSet tc) `unionSet` cons2 
-       all = all1 `unionSet` all2
-       moves = plusFM_C (error "timesTNFA.moves") moves3 moves2
-
-       c = TNFA cons all starts1 moves
-    in 
-
-       trinfo opts "times" c $
-       c
-
-
-timesTNFApublic :: Opts -> [TNFA Int] -> TNFA Int
-timesTNFApublic opts args =
-    if length args /= 3 
-    then error "timesTNFApublic.args"
-    else 
-       let [tcarg, arg1, arg2] = args
-       in  timesTNFA opts (cheat tcarg) arg1 arg2
diff --git a/real/rx/src/FAtypes.hs b/real/rx/src/FAtypes.hs
deleted file mode 100644 (file)
index e9eaa12..0000000
+++ /dev/null
@@ -1,85 +0,0 @@
-module FAtypes
-
-( BDFA(..)
-, BNFA(..)
-, TNFA(..)
-, ETNFA(..)
-, Auto
-
-, emptyTNFA
-
-, trinfo
-
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Options
-
-import TA
-
-import Ids     -- provides instance Show Id
-
--- import Stuff        -- provides instances Show Set, Show FiniteMap
-
--- bottom up deterministic
-data BDFA a = BDFA 
-       TCons           -- what algebra we're in
-       (Set a)         -- all states
-       (Set a)         -- accepting states
-       (FiniteMap (STerm a) a) -- transition table
-
-       deriving (Eq, Show)
-
-
--- bottom up nondeterministic
-data BNFA a = BNFA 
-       TCons           -- what algebra we're in
-       (Set a)         -- all states
-       (Set a)         -- accepting states
-       (FiniteMap (STerm a) (Set a))   -- transition table
-
-       deriving (Eq, Show)
-       
-
--- top down non deterministic
-data TNFA a = TNFA
-       TCons           -- algebra
-       (Set a)         -- all states
-       (Set a)         -- start states
-       (FiniteMap a (Set (STerm a)))   -- production rules
-
-       deriving (Eq, Show)
-
-emptyTNFA = TNFA emptySet emptySet emptySet emptyFM
-
--- this is what we normally use
-type Auto = TNFA Int
-
-
--- top down non deterministic with epsilon moves
-data ETNFA a = ETNFA
-       TCons           -- algebra
-       (Set a)         -- all states
-       (Set a)         -- start states
-       (FiniteMap a (Set (STerm a)))   -- production rules
-       (FiniteMap a (Set a))           -- epsilon moves
-
-       deriving (Eq, Show)
-
----------------------------------------------------------------
-
-
-
----------------------------------------------------------------
-
-trinfo opts msg (TNFA cons all starts moves) =
-    let sc = " cons: " ++ show cons
-       sa = " |all|: " ++ show (cardinality all)
-       sm = " |moves|: " ++ show (sizeFM moves)
-    in  troff opts ("\n" ++ msg ++ sc ++ sa ++ sm)
-
-
diff --git a/real/rx/src/FAunify.hs b/real/rx/src/FAunify.hs
deleted file mode 100644 (file)
index a4b1dcb..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
-module FAunify
-
-( unifyTNFA
-)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAhom
-import FAcmpct
-
-
-unifyTNFA :: Opts -> TNFA Int -> TNFA Int
-unifyTNFA opts = fixpoint (same opts) where
-       same opts b @ (TNFA cons all starts moves) =
-           let -- this uses Ord on sets!
-               c = collectFM (eltsFM moves)
-               h = mapFM ( \ w ts -> 
-                   lookupWithDefaultFM c 
-                       (error ("same.c cannot find " ++ show ts)) ts) moves
-               d = homTNFA opts (\ x -> case lookupFM h x of
-                       Just y -> Right y; Nothing -> Left x) b 
-               e = cmpctTNFA opts d
-           in
-
---             trace ("(* heurist *)") $
-
---             trace ("\nheuristic.same.b: " ++ show b) $
---             trace ("\nheuristic.same.c: " ++ show c) $
---             trace ("\nheuristic.same.h: " ++ show h) $
---             trace ("\nheuristic.same.d: " ++ show d) $
---             trace ("\nheuristic.same.e: " ++ show d) $
-
-               trinfo opts "unify" e $
-
-               e
-
diff --git a/real/rx/src/FAunion.hs b/real/rx/src/FAunion.hs
deleted file mode 100644 (file)
index 2f5195d..0000000
+++ /dev/null
@@ -1,67 +0,0 @@
-module FAunion
-
-( unionTNFA
-)
-
-where
-
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAmap
-import FAcmpct
-import FAconv
-
----------------------------------------------------------------------
-
-unionTNFA :: Opts -> TNFA Int -> TNFA Int -> TNFA Int
-unionTNFA opts x1 x2 =
-    let        
-       TNFA cons1 all1 starts1 moves1 = x1
-       n1 = maximum (0 : (setToList all1)) + 1
-
-       TNFA cons2 all2 starts2 moves2 = mapTNFA opts (n1 + )  x2
-
---     added 17-sep-98
---     this was sitting here for half a year at least.
---     find out why it is wrong!
---     top = maximum (0  : (setToList all2)) + 1
-
---     and why this is better:
-       top = maximum (n1 : (setToList all2)) + 1
-
-       cons = cons1 `unionSet` cons2
-
-       y = ETNFA cons 
-               ((all1 `unionSet` all2) `unionSet` unitSet top)
-               (unitSet top)
-               (plusFM_C (error "unionTNFA") moves1 moves2)
-               (unitFM top (starts1 `unionSet` starts2))
-
-       e = etnfa2tnfa opts y
-       f = cmpctTNFA opts e
-
-
-    in 
-
---     trace ("\nunionTNFA.x1 = " ++ show x1) $
---     trace ("\nunionTNFA.x2 = " ++ show x2) $
---     trace ("\nunionTNFA.n1 = " ++ show n1) $
---     trace ("\nunionTNFA.top = " ++ show top) $
---     trace ("\nunionTNFA.cons = " ++ show cons) $
---     trace ("\nunionTNFA.y = " ++ show y) $
---     trace ("\nunionTNFA.e = " ++ show e) $
-
-       trinfo opts "union" f $
-
-       f
-
--------------------------------------------------------------------------
diff --git a/real/rx/src/FAuseful.hs b/real/rx/src/FAuseful.hs
deleted file mode 100644 (file)
index 9ba9022..0000000
+++ /dev/null
@@ -1,108 +0,0 @@
-module FAuseful
-
-( prods, precs
-, usefulBDFA, usefulTNFA
-) 
-
-where
-
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-
-import FAconv
-
-import FAkeepst
-
----------------------------------------------------------------------------
-
--- producers: those that ->> leaves
-
-prods :: Ord a => TCons -> FiniteMap (STerm a) (Set a) -> Set a
-prods tcons m =
-
-    let        ls = unionManySets -- find those that produce leaves
-               [ lookupset m (mksterm tc [])
-               | tc <- setToList tcons, tconarity tc == 0
-               ]
-
-       prhull known unknown | isEmptySet unknown = known
-       prhull known unknown =
-           let ps = unionManySets
-                       [ lookupset m (mksterm tc a)
-                       | tc <- setToList tcons, n <- [tconarity tc], n > 0
-                       , a <- packs n 1 (setToList known) (setToList unknown)
-                       ]
-               ks = known `unionSet` unknown
-               qs = ps `minusSet` ks
-           in prhull ks qs
-
-    in prhull emptySet ls
-
-------------------------------------------------------------------------
-
--- produceds: those that start ->> .
-
-precs :: Ord a => FiniteMap a (Set (STerm a)) -> Set a -> Set a
-precs m starts =
---    let      h x = lookupWithDefaultFM m (error "precs") x
-    let        h x = lookupset m  x
-               `bind` \ t -> mkSet (stargs t)
-    in sethull h starts
-
-------------------------------------------------------------------------
-
-usefulBDFA :: (Show a, Ord a) => Opts -> BDFA a -> BDFA a
-usefulBDFA opts e1 =
-    let e2 @ (BNFA cons2 all2 starts2 moves2) = bdfa2bnfa opts e1
-       qs = prods cons2 moves2
-       e3 = keepstBNFA opts e2 qs
-       e4 @ (TNFA cons4 all4 starts4 moves4) = bnfa2tnfa opts e3
-       ps = precs moves4 starts4
-       e5 = keepstTNFA opts e4 ps
-       e6 = tnfa2bnfa opts e5
-       e7 = simplebnfa2bdfa opts e6
-    in
-
---     trace ("\nuseful.e1 = " ++ show e1) $
---     trace ("\nuseful.e2 = " ++ show e2) $
---     trace ("\nuseful.qs = " ++ show qs) $
---     trace ("\nuseful.e3 = " ++ show e3) $
---     trace ("\nuseful.e4 = " ++ show e4) $
---     trace ("\nuseful.ps = " ++ show ps) $
---     trace ("\nuseful.e5 = " ++ show e5) $
---     trace ("\nuseful.e6 = " ++ show e6) $
---     trace ("\nuseful.e7 = " ++ show e7) $
-
-       e7
-
-----------------------------------------------------------
-
-usefulTNFA :: (Show a, Ord a) => Opts -> TNFA a -> TNFA a
--- keep only those states that produce leaves
--- and that are reachable from the start
-usefulTNFA opts e1 =
-    let        
-       e2 @ (BNFA cons2 all2 starts2 moves2) = tnfa2bnfa opts e1
-       qs = prods cons2 moves2
-       e3 = keepstBNFA opts e2 qs
-       e4 @ (TNFA cons4 all4 starts4 moves4) = bnfa2tnfa opts e3
-       ps = precs moves4 starts4
-       e5 = keepstTNFA opts e4 ps
-    in
-
---     trace ("\nuseful.e1 = " ++ show e1) $
---     trace ("\nuseful.e2 = " ++ show e2) $
---     trace ("\nuseful.qs = " ++ show qs) $
---     trace ("\nuseful.e3 = " ++ show e3) $
---     trace ("\nuseful.e4 = " ++ show e4) $
---     trace ("\nuseful.ps = " ++ show ps) $
---     trace ("\nuseful.e5 = " ++ show e5) $
-
-       e5
diff --git a/real/rx/src/FiniteMap.hs b/real/rx/src/FiniteMap.hs
deleted file mode 100644 (file)
index b6a6c68..0000000
+++ /dev/null
@@ -1,505 +0,0 @@
--- this is basically from ghc-2.01
--- with some specialisations added
-
-
-
-
-
-
-
-
-
-
-
-
-
-module FiniteMap (
-       FiniteMap,              -- abstract type
-
-       emptyFM, unitFM, listToFM,
-
-       addToFM,
-       addToFM_C,
-       addListToFM,
-       addListToFM_C,
-       delFromFM ,
-       delListFromFM,
-
-       plusFM,
-       plusFM_C,
-       minusFM,
-       foldFM,
-
-       intersectFM ,
-       intersectFM_C ,
-       mapFM , filterFM ,
-
-       sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
-
-       fmToList, keysFM, eltsFM
-
-
-    ) where
-
-import Maybes
-
-------------------------------------------
--- import TA
--- import Set
-
-{- # SPECIALIZE lookupFM :: FiniteMap Int (Set (STerm Int)) -> Int -> Maybe (Set (STerm Int)) #-}
-{- # SPECIALIZE lookupFM :: FiniteMap (STerm Int) (Set Int) -> (STerm Int) -> Maybe (Set Int) #-}
-
-{- # SPECIALIZE lookupWithDefaultFM :: FiniteMap Int (Set (STerm Int)) -> Set (STerm Int) -> Int -> (Set (STerm Int)) #-}
-{- # SPECIALIZE lookupWithDefaultFM :: FiniteMap (STerm Int) (Set Int) -> (Set Int) -> (STerm Int) -> (Set Int) #-}
-
-
-
-
-
-
--- SIGH: but we use unboxed "sizes"...
-
-
-
-
---     BUILDING
-emptyFM                :: FiniteMap key elt
-unitFM         :: key -> elt -> FiniteMap key elt
-listToFM       :: (Ord key {--}) => [(key,elt)] -> FiniteMap key elt
-                       -- In the case of duplicates, the last is taken
-
-
---     ADDING AND DELETING
-                  -- Throws away any previous binding
-                  -- In the list case, the items are added starting with the
-                  -- first one in the list
-addToFM                :: (Ord key {--}) => FiniteMap key elt -> key -> elt  -> FiniteMap key elt
-addListToFM    :: (Ord key {--}) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
-
-                  -- Combines with previous binding
-addToFM_C      :: (Ord key {--}) => (elt -> elt -> elt)
-                          -> FiniteMap key elt -> key -> elt
-                          -> FiniteMap key elt
-addListToFM_C  :: (Ord key {--}) => (elt -> elt -> elt)
-                          -> FiniteMap key elt -> [(key,elt)]
-                          -> FiniteMap key elt
-
-                  -- Deletion doesn't complain if you try to delete something
-                  -- which isn't there
-delFromFM      :: (Ord key {--}) => FiniteMap key elt -> key   -> FiniteMap key elt
-delListFromFM  :: (Ord key {--}) => FiniteMap key elt -> [key] -> FiniteMap key elt
-
---     COMBINING
-                  -- Bindings in right argument shadow those in the left
-plusFM         :: (Ord key {--}) => FiniteMap key elt -> FiniteMap key elt
-                          -> FiniteMap key elt
-
-                  -- Combines bindings for the same thing with the given function
-plusFM_C       :: (Ord key {--}) => (elt -> elt -> elt)
-                          -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
-minusFM                :: (Ord key {--}) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-                  -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
-
-intersectFM    :: (Ord key {--}) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C  :: (Ord key {--}) => (elt -> elt -> elt)
-                          -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
---     MAPPING, FOLDING, FILTERING
-foldFM         :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
-mapFM          :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM       :: (Ord key {--}) => (key -> elt -> Bool)
-                          -> FiniteMap key elt -> FiniteMap key elt
-
---     INTERROGATING
-sizeFM         :: FiniteMap key elt -> Int
-isEmptyFM      :: FiniteMap key elt -> Bool
-
-elemFM         :: (Ord key {--}) => key -> FiniteMap key elt -> Bool
-lookupFM       :: (Ord key {--}) => FiniteMap key elt -> key -> Maybe elt
-lookupWithDefaultFM
-               :: (Ord key {--}) => FiniteMap key elt -> elt -> key -> elt
-               -- lookupWithDefaultFM supplies a "default" elt
-               -- to return for an unmapped key
-
---     LISTIFYING
-fmToList       :: FiniteMap key elt -> [(key,elt)]
-keysFM         :: FiniteMap key elt -> [key]
-eltsFM         :: FiniteMap key elt -> [elt]
-
-data FiniteMap key elt
-  = EmptyFM
-  | Branch key elt             -- Key and elt stored here
-    Int{-STRICT-}      -- Size >= 1
-    (FiniteMap key elt)                -- Children
-    (FiniteMap key elt)
-
-emptyFM = EmptyFM
-{-
-emptyFM
-  = Branch bottom bottom 0 bottom bottom
-  where
-    bottom = panic "emptyFM"
--}
-
--- #define EmptyFM (Branch _ _ 0 _ _)
-
-unitFM key elt = Branch key elt 1 emptyFM emptyFM
-
-listToFM = addListToFM emptyFM
-
-
-
-addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt
-
-addToFM_C combiner EmptyFM key elt = unitFM key elt
-addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
-
-  | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
-  | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
-  | otherwise    = Branch new_key (combiner elt new_elt) size fm_l fm_r
-
-
-addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs
-
-addListToFM_C combiner fm key_elt_pairs
-  = foldl add fm key_elt_pairs -- foldl adds from the left
-  where
-    add fmap (key,elt) = addToFM_C combiner fmap key elt
-
-delFromFM EmptyFM del_key = emptyFM
-delFromFM (Branch key elt size fm_l fm_r) del_key
-
-  | del_key > key
-  = mkBalBranch key elt fm_l (delFromFM fm_r del_key)
-
-  | del_key < key
-  = mkBalBranch key elt (delFromFM fm_l del_key) fm_r
-
-  | key == del_key
-  = glueBal fm_l fm_r
-
-
-delListFromFM fm keys = foldl delFromFM fm keys
-
-plusFM_C combiner EmptyFM fm2 = fm2
-plusFM_C combiner fm1 EmptyFM = fm1
-plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
-  = mkVBalBranch split_key new_elt
-                (plusFM_C combiner lts left)
-                (plusFM_C combiner gts right)
-  where
-    lts     = splitLT fm1 split_key
-    gts     = splitGT fm1 split_key
-    new_elt = case lookupFM fm1 split_key of
-               Nothing   -> elt2
-               Just elt1 -> combiner elt1 elt2
-
--- It's worth doing plusFM specially, because we don't need
--- to do the lookup in fm1.
-
-plusFM EmptyFM fm2 = fm2
-plusFM fm1 EmptyFM = fm1
-plusFM fm1 (Branch split_key elt1 _ left right)
-  = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
-  where
-    lts     = splitLT fm1 split_key
-    gts     = splitGT fm1 split_key
-
-minusFM EmptyFM fm2 = emptyFM
-minusFM fm1 EmptyFM = fm1
-minusFM fm1 (Branch split_key elt _ left right)
-  = glueVBal (minusFM lts left) (minusFM gts right)
-       -- The two can be way different, so we need glueVBal
-  where
-    lts = splitLT fm1 split_key                -- NB gt and lt, so the equal ones
-    gts = splitGT fm1 split_key                -- are not in either.
-
-intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2
-
-intersectFM_C combiner fm1 EmptyFM = emptyFM
-intersectFM_C combiner EmptyFM fm2 = emptyFM
-intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
-
-  | maybeToBool maybe_elt1     -- split_elt *is* in intersection
-  = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
-                                               (intersectFM_C combiner gts right)
-
-  | otherwise                  -- split_elt is *not* in intersection
-  = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
-
-  where
-    lts = splitLT fm1 split_key                -- NB gt and lt, so the equal ones
-    gts = splitGT fm1 split_key                -- are not in either.
-
-    maybe_elt1 = lookupFM fm1 split_key
-    Just elt1  = maybe_elt1
-
-foldFM k z EmptyFM = z
-foldFM k z (Branch key elt _ fm_l fm_r)
-  = foldFM k (k key elt (foldFM k z fm_r)) fm_l
-
-mapFM f EmptyFM = emptyFM
-mapFM f (Branch key elt size fm_l fm_r)
-  = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
-
-filterFM p EmptyFM = emptyFM
-filterFM p (Branch key elt _ fm_l fm_r)
-  | p key elt          -- Keep the item
-  = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)
-
-  | otherwise          -- Drop the item
-  = glueVBal (filterFM p fm_l) (filterFM p fm_r)
-
---{-# INLINE sizeFM #-}
-sizeFM EmptyFM              = 0
-sizeFM (Branch _ _ size _ _) =  size
-
-isEmptyFM fm = sizeFM fm == 0
-
-lookupFM EmptyFM key = Nothing
-lookupFM (Branch key elt _ fm_l fm_r) key_to_find
-
-  | key_to_find < key = lookupFM fm_l key_to_find
-  | key_to_find > key = lookupFM fm_r key_to_find
-  | otherwise    = Just elt
-
-
-key `elemFM` fm
-  = case (lookupFM fm key) of { Nothing -> False; Just elt -> True }
-
-lookupWithDefaultFM fm deflt key
-  = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
-
-fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
-keysFM fm   = foldFM (\ key elt rest -> key : rest)       [] fm
-eltsFM fm   = foldFM (\ key elt rest -> elt : rest)       [] fm
-
-sIZE_RATIO :: Int
-sIZE_RATIO = 5
-
-mkBranch :: (Ord key {--})             -- Used for the assertion checking only
-        => Int
-        -> key -> elt
-        -> FiniteMap key elt -> FiniteMap key elt
-        -> FiniteMap key elt
-
-mkBranch which key elt fm_l fm_r
-  = --{--}
-
-    let
-       result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r
-    in
---    if sizeFM result <= 8 then
-       result
---    else
---     pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
---     result
---     )
-  where
-    left_ok  = case fm_l of
-               EmptyFM                  -> True
-               Branch left_key _ _ _ _  -> let
-                                               biggest_left_key = fst (findMax fm_l)
-                                           in
-                                           biggest_left_key < key
-    right_ok = case fm_r of
-               EmptyFM                  -> True
-               Branch right_key _ _ _ _ -> let
-                                               smallest_right_key = fst (findMin fm_r)
-                                           in
-                                           key < smallest_right_key
-    balance_ok = True -- sigh
-{- LATER:
-    balance_ok
-      = -- Both subtrees have one or no elements...
-       (left_size + right_size <= 1)
--- NO        || left_size == 0  -- ???
--- NO        || right_size == 0 -- ???
-       -- ... or the number of elements in a subtree does not exceed
-       -- sIZE_RATIO times the number of elements in the other subtree
-      || (left_size  * sIZE_RATIO >= right_size &&
-         right_size * sIZE_RATIO >= left_size)
--}
-
-    left_size  = sizeFM fm_l
-    right_size = sizeFM fm_r
-
-
-    unbox :: Int -> Int
-    unbox x = x
-
-
-mkBalBranch :: (Ord key {--})
-           => key -> elt
-           -> FiniteMap key elt -> FiniteMap key elt
-           -> FiniteMap key elt
-
-mkBalBranch key elt fm_L fm_R
-
-  | size_l + size_r < 2
-  = mkBranch 1{-which-} key elt fm_L fm_R
-
-  | size_r > sIZE_RATIO * size_l       -- Right tree too big
-  = case fm_R of
-       Branch _ _ _ fm_rl fm_rr
-               | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
-               | otherwise                       -> double_L fm_L fm_R
-       -- Other case impossible
-
-  | size_l > sIZE_RATIO * size_r       -- Left tree too big
-  = case fm_L of
-       Branch _ _ _ fm_ll fm_lr
-               | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
-               | otherwise                       -> double_R fm_L fm_R
-       -- Other case impossible
-
-  | otherwise                          -- No imbalance
-  = mkBranch 2{-which-} key elt fm_L fm_R
-
-  where
-    size_l   = sizeFM fm_L
-    size_r   = sizeFM fm_R
-
-    single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
-       = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
-
-    double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
-       = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key   elt   fm_l   fm_rll)
-                                (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
-
-    single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
-       = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)
-
-    double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
-       = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll  fm_lrl)
-                                (mkBranch 12{-which-} key   elt   fm_lrr fm_r)
-
-mkVBalBranch :: (Ord key {--})
-            => key -> elt
-            -> FiniteMap key elt -> FiniteMap key elt
-            -> FiniteMap key elt
-
--- Assert: in any call to (mkVBalBranch_C comb key elt l r),
---        (a) all keys in l are < all keys in r
---        (b) all keys in l are < key
---        (c) all keys in r are > key
-
-mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
-mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
-
-mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
-                    fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
-  | sIZE_RATIO * size_l < size_r
-  = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
-
-  | sIZE_RATIO * size_r < size_l
-  = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
-
-  | otherwise
-  = mkBranch 13{-which-} key elt fm_l fm_r
-
-  where
-    size_l = sizeFM fm_l
-    size_r = sizeFM fm_r
-
-glueBal :: (Ord key {--})
-       => FiniteMap key elt -> FiniteMap key elt
-       -> FiniteMap key elt
-
-glueBal EmptyFM fm2 = fm2
-glueBal fm1 EmptyFM = fm1
-glueBal fm1 fm2
-       -- The case analysis here (absent in Adams' program) is really to deal
-       -- with the case where fm2 is a singleton. Then deleting the minimum means
-       -- we pass an empty tree to mkBalBranch, which breaks its invariant.
-  | sizeFM fm2 > sizeFM fm1
-  = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
-
-  | otherwise
-  = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
-  where
-    (mid_key1, mid_elt1) = findMax fm1
-    (mid_key2, mid_elt2) = findMin fm2
-
-glueVBal :: (Ord key {--})
-        => FiniteMap key elt -> FiniteMap key elt
-        -> FiniteMap key elt
-
-glueVBal EmptyFM fm2 = fm2
-glueVBal fm1 EmptyFM = fm1
-glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
-        fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
-  | sIZE_RATIO * size_l < size_r
-  = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
-
-  | sIZE_RATIO * size_r < size_l
-  = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
-
-  | otherwise          -- We now need the same two cases as in glueBal above.
-  = glueBal fm_l fm_r
-  where
-    (mid_key_l,mid_elt_l) = findMax fm_l
-    (mid_key_r,mid_elt_r) = findMin fm_r
-    size_l = sizeFM fm_l
-    size_r = sizeFM fm_r
-
-splitLT, splitGT :: (Ord key {--}) => FiniteMap key elt -> key -> FiniteMap key elt
-
--- splitLT fm split_key  =  fm restricted to keys <  split_key
--- splitGT fm split_key  =  fm restricted to keys >  split_key
-
-splitLT EmptyFM split_key = emptyFM
-splitLT (Branch key elt _ fm_l fm_r) split_key
-
-  | split_key < key = splitLT fm_l split_key
-  | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key)
-  | otherwise      = fm_l
-
-
-splitGT EmptyFM split_key = emptyFM
-splitGT (Branch key elt _ fm_l fm_r) split_key
-
-  | split_key > key = splitGT fm_r split_key
-  | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r
-  | otherwise      = fm_r
-
-
-findMin :: FiniteMap key elt -> (key,elt)
-findMin (Branch key elt _ EmptyFM _) = (key,elt)
-findMin (Branch key elt _ fm_l    _) = findMin fm_l
-
-deleteMin :: (Ord key {--}) => FiniteMap key elt -> FiniteMap key elt
-deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r
-deleteMin (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r
-
-findMax :: FiniteMap key elt -> (key,elt)
-findMax (Branch key elt _ _ EmptyFM) = (key,elt)
-findMax (Branch key elt _ _    fm_r) = findMax fm_r
-
-deleteMax :: (Ord key {--}) => FiniteMap key elt -> FiniteMap key elt
-deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l
-deleteMax (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
-
-
-
-
-instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
-  fm_1 == fm_2 = (sizeFM   fm_1 == sizeFM   fm_2) &&   -- quick test
-                (fmToList fm_1 == fmToList fm_2)
-
-{- NO: not clear what The Right Thing to do is:
-instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
-  fm_1 <= fm_2 = (sizeFM   fm_1 <= sizeFM   fm_2) &&   -- quick test
-                (fmToList fm_1 <= fmToList fm_2)
--}
-
-
-
-
-
-
-instance (Show a, Show b) => Show (FiniteMap a b) where
-    showsPrec p fm =
-       showsPrec p (fmToList fm) 
diff --git a/real/rx/src/ForwardS.hs b/real/rx/src/ForwardS.hs
deleted file mode 100644 (file)
index 093c755..0000000
+++ /dev/null
@@ -1,132 +0,0 @@
-module ForwardS
-
-( forwardS
-, forwardSpublic
-)
-
--- implements thomas genet's algorithm
--- for approximating term replacement in a finite automaton
-
--- we're looking at the system   S x y z   ->   x z (y z)
-
--- this implementation is ugly ugly ugly
--- w.r.t. the rest of the system
--- the reduction rule of S is hardwired
--- as are the names of the constructors (S and @)
-
-where
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import Reuse
-
-sons :: TNFA Int -> Int -> [(Int, Int)]
-sons (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "ForwardS.sons.ts") p
-       lrs =   [ (l, r) 
-               | t <- setToList ts
-               , tconname (stcon t) == "@"
-               , let [l, r] = stargs t
-               ]
-    in
-       lrs
-
-
-
-leaves :: TNFA Int -> Int -> [()]
-leaves (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "ForwardS.leaves.ts") p
-       lrs =   [ () 
-               | t <- setToList ts
-               , tconname (stcon t) == "S"
-               ]
-    in
-       lrs
-
-
-
-forwardS :: Opts -> TNFA Int -> TNFA Int
--- look for all matches of S x y z
--- add new states from that to x z (y z) 
-forwardS opts a @ (TNFA cons all starts moves) =
-    let        
-       quads = [ (t0, (x, y, z))
-               | t0 <- setToList all
-               , (t1, z) <- sons a t0
-               , (t2, y) <- sons a t1
-               , (t3, x) <- sons a t2
-               , ()     <- leaves a t3 -- this looks for S
-               ]
-
-       -- next free state
-       next = 1 + maximum (setToList all)
-
-       -- write new top state numbers to quads
-       -- warnig: the number 2 depends on the states used in "new" below
-       iquads = zip [next, next + 2 .. ] quads
-
-       -- this is a bit ugly
-       -- need to find the complete id information for the constructors
-       -- we hope they are there
-       ap = head [ con | con <- setToList cons, tconname con == "@" ]
-       s  = head [ con | con <- setToList cons, tconname con == "S" ]
-       
-       -- generate new states per quad
-       new (i, (t, (x, y, z))) = 
-               [ (t    , mksterm ap [i + 0, i + 1]) 
-               , (i + 0, mksterm ap [x, z]) 
-               , (i + 1, mksterm ap [y, z]) 
-               ]
-
-       newsl = [ p | iq <- iquads, p <- new iq ]
-
-       news = listToFM [ (a, unitSet t) | (a, t) <- newsl ]
-
-       moves' = moves `mergeFM` news
-       all' = all `unionSet` mkSet (keysFM moves')
-
-       r = TNFA cons all' starts moves'
-
-       addons = [ a | a <- keysFM news, a >= next ]
-       r' = reuse opts r addons
-
-       r'' = chose opts "reuse" r' r
-
-    in
-
-       trinfo opts "forwardS" r'' $
-
-       r''
-
-
-
-
-
-forwardSpublic :: Opts -> [ TNFA Int ] -> TNFA Int
-
-forwardSpublic opts args =
-    if length args /= 1 
-    then error "forwardSpublic.args"
-    else 
-       let [arg1] = args
-       in  forwardS opts arg1
-
-
-
--- later:
-
--- iterate the forwardS operation
--- making the automaton deterministic and minimal
--- before and after each step
--- until process converges
-
diff --git a/real/rx/src/Gen.hs b/real/rx/src/Gen.hs
deleted file mode 100644 (file)
index bb5e43d..0000000
+++ /dev/null
@@ -1,58 +0,0 @@
-module Gen 
-
-( genval
-, genpid
-, genenv
-)
-
-where
-
-import FiniteMap
-import Ids
-import IdStack
-
-
-import FA
-import FAtypes 
-import FAuseful
-import FA2Exp
-
-import Grammar
-import Gram2FA
-import Loop 
-import Semantik
-
-import WrapSubtrans
-
----------------------------------------------------------------------
-
-genval :: Val (Env (Auto) (Auto))
-genval opts env x = case unFIO (comp opts env x) of
-    Right (x1, env1) -> Right (tnfa2exp opts x1, env1)
-    Left msg -> Left msg
-
-
--- for parsing
-genpid :: IdStack
-genpid = globIS ( inIts (
-               [ userfun 2 "grammar"   -- todo: wrong place
-               , userfun 2 "subtrans"  -- todo: wrong place
-               ] 
-               ++
-               [ id | (id, _) <- fids ] 
-       ))
-
--- for evaluating
-genenv = listToFM  (
-       [ ( idname id
-         , mkfunction (idname id) 
-               (\ opts -> usefulTNFA opts . val opts) -- wrong place?
-         )
-       | (id, val) <- fids 
-       ] 
-       ++
-       [ ("grammar", mkFun gram) 
-       , ("subtrans", mkFun subtrans) 
-       ]
-                )
-
diff --git a/real/rx/src/Gram2FA.hs b/real/rx/src/Gram2FA.hs
deleted file mode 100644 (file)
index 1808e07..0000000
+++ /dev/null
@@ -1,175 +0,0 @@
-module Gram2FA
-
-( gram
-
-)
-
-where
-
-
-import Maybes
-
-import Set             -- syslib ghc
-import FiniteMap       -- syslib ghc
-
-import State
-
-import Options
-
-import Grammar
-
-import Ids
-import Syntax
-
-import Semantik
-
-import TA
-import FAtypes
-import FA
-
-import FAmap
-import FAcmpct
-import FAconv
-
-import Exp2FA
-
-
-mapL             :: Monad m => (a -> m b) -> ([a] -> m [b])
-mapL f []         = return []
-mapL f (x:xs)     = do y<-f x; ys<-mapL f xs; return (y:ys)
-
-
--- converts an Exp describing a grammar into an ETNFA
-
-
-gram :: Opts -> Env (Auto) (Auto) -> [Exp] -> FIO (Auto, Env (Auto) (Auto))
-gram opts env xs =
-    do { moops (length xs /= 2)
-               ( "grammar needs exactly two arguments "
-                 ++ "(start expression and rule set): " ++ show xs )
-       ; let [ s, r ] = xs
-
-       ; moops (not (isColl r) || cType r /= CSet) 
-               ( "grammar rules must be given as set: " ++ show r)
-       ; let rs = cArgs r
-
-       ; rss <- mapL convertrule rs
-       ; let b = mkgram opts env s rss
-
-       ; 
---       trace ("\ngram.xs = " ++ show xs) $
---       trace ("\ngram.rss = " ++ show rss) $
---       trace ("\ngram.b = " ++ show b) $
-         return (b, env)
-       }
-
-
-
-convertrule r =
-    do { moops (not (isApp r)) 
-               ("rule in grammar must use (->): " ++ show r)
-       ; let App id xs = r
-       ; moops (idname id /= "->")
-               ("rule in grammar must use (->): " ++ show r)
-       ; moops (length xs /= 2)
-               ("(->) needs exactly two arguments: " ++ show r)
-       ; let [lhs, rhs] = xs
-       ; moops (not (isAppId lhs))
-               ("left hand arg of (->) must be identifier: " ++ show r)
-       ; let lhsname = idname (unAppId lhs)
-       ; return (lhsname, rhs)
-       }
-
--------------------------------------------------------------------------
-
-mkgram :: Opts -> Env (Auto) (Auto) -> Exp -> [(String, Exp)] -> Auto
-mkgram opts e x rs = 
-    let        vs = [ i | (i, _) <- rs ]       -- local variables
-       e' = delListFromFM e vs         -- they shadow global ones
-       (start, rules) = dosym (mkgs opts e' (mkSet vs) x rs)
-       d = g2t opts (start, rules)
-    in 
-
---     trace ("\nmkgram.vs = " ++ show vs) $
---     trace ("\nmkgram.start = " ++ show start) $
---     trace ("\nmkgram.rules = " ++ show rules) $
---     trace ("\nmkgram.d = " ++ show d) $
-
-       d
-       
-------------------------------------------------------------------------
-
-
-type MK a = Sym (Int, [(String, Either String (STerm String))]) a
-
-
-
---tnfa2grammar :: Ord a => Opts -> String -> TNFA a -> MK ()
-tnfa2grammar opts name b @ (TNFA consb allb startsb movesb) =
-
---  trace ("\ntnfa2grammar.b : " ++ show b) $
-
-    do { n <- mapL (\ a -> gensym >>= \ k -> return (a, k)) (setToList allb)
-       ; let h = listToFM n    
-       ; let c @ (TNFA consc allc startsc movesc) = 
-               mapTNFA opts (lookupWithDefaultFM h (error "tnfa2grammar.c")) b
-       ; sequence_ [ push (v, Right t)   
-               | (v, ts) <- fmToList movesc, t <- setToList ts ]
-       ; sequence_[ push (name, Left s) | s <- setToList startsc ]
-       }
-
---------------------------------------------------------------------------
-mkgs :: Opts -> Env (Auto) (Auto) -> Set String -> Exp -> [(String, Exp)]
-       -> MK String
-mkgs opts env vars x rs =
-    do { sequence_ (map (mkg opts env vars) rs)
-       ; start <- gensym
-       ; mkg opts env vars (start, x)
-       ; return start
-       }
-
-mkg :: Opts -> Env (Auto) (Auto) -> Set String -> (String, Exp) -> MK ()
-
-mkg opts env vars (name, exp) 
-  | isEmptySet (mkSet (map idname (appids exp)) `intersectSet` vars) =
-    do { let (val, _) = forceFIO (comp opts env exp)
-       ; tnfa2grammar opts name val
-       }
-
-mkg opts env vars (name, App id []) = 
-       -- must be a variable of the grammar
-    push (name, Left (idname id))
-
-mkg opts env vars (name, App id xs) | idname id == "++" =
-    sequence_  [ do    { nx <- gensym
-                       ; push (name, Left nx) 
-                       ; mkg opts env vars (nx, x)
-                       }
-               | x <- xs ]
-
-mkg opts env vars (name, x @ (App id xs)) = 
-       -- a constructor (good)
-       -- or a function call (bad)
-    mkgname opts env vars name x id xs
-
-
-mkg opts env vars (name, x) = 
-    error ("cannot handle rule: " ++ show x)
-
-
-mkgname opts env vars name x id xs =
-    if exists (lookupFM env (idname id))
-    then error ("function calls cannot have grammar vars as args: " ++ show x)
-    else -- it's a constructor
-     do        { args <- mapL ( \ x -> do 
-               { k <- gensym; mkg opts env vars (k, x); return k } ) xs
-       ; push (name, Right (mksterm id args))
-       }
-
---------------------------------------------------------------------
-
-
-g2t :: (Show a, Ord a) => Opts -> Grammar a -> TNFA Int
-g2t opts = cmpctTNFA opts . etnfa2tnfa opts . grammar2etnfa opts
-
diff --git a/real/rx/src/Grammar.hs b/real/rx/src/Grammar.hs
deleted file mode 100644 (file)
index 3683322..0000000
+++ /dev/null
@@ -1,14 +0,0 @@
-module Grammar 
-
-( Grammar 
-
-)
-
-where
-
-import TA
-
-type Grammar a = (a, [(a, Either a (STerm a))])        -- perhaps some eps moves
-
-
-
diff --git a/real/rx/src/Heave.hs b/real/rx/src/Heave.hs
deleted file mode 100644 (file)
index ed675a5..0000000
+++ /dev/null
@@ -1,288 +0,0 @@
--- uh yeah, another literate programming tool
-
-module Heave
-
-( heave, gheave, stream
-, Formatter
-) 
-
-where
-
-import Trace
-
-
-import System
-import Stuff (intersperse)
-import Data.Char (isSpace)
-
-import Options
-import Command
-
-------------------------------------------------------------------
-
-
-
--- we use a stack of options
-type Optss = [Opts] 
-
--------------------------------------------------------
-
-{- 
-
-an essay on line breaking:
-
-inline code (in between $) will be sent directly to the code parser,
-which calls myLex which ignores linebreaks completely.
-
-display code (.begin ... .end) will be chopped into lines,
-those are sent to the code parser separately,
-i. e. each line must be a complete expression.
-
-if an expression doesn't fit on one line, you may use
-a continuation line: one that starts with a white space.
-such lines will be appended to the most recent line
-that started at position 0
-
--}
-
-glueLines :: [String] -> (String, [String])
--- returns first logical line (including continuations), and rest
-glueLines [] = ([],[])
-glueLines (l : ls) = 
-    let (as, bs) = span (\ l' -> null l' || isSpace (head l')) ls
-    in (unlines (l : as), bs)
-
----------------------------------------------------------
-
-type Formatter a = (Opts, a) -> String -> IO a
-
--- a formatter reads a line and outputs something (to stdout)
--- it has a state :: a that is chained through
--- it may also read (not change) the environment provided by the unlit-ter
-
----------------------------------------------------------
-
-unlit :: Formatter a -> (Optss, a) -> [String] -> IO (Optss, a)
-
-unlit f oss [] = return oss
-
--- commands must start at the beginning of a line
--- and they start with a dot
-unlit f oss (('.' : cmd) : rest) =
-    do { oss' <- unlitcmd f oss cmd
-       ; unlit f oss' rest
-       }
-
--- otherwise it's not a command
-unlit f oss @ (os @ (opts:_), state) lines =
-    caseopts opts "current"
-       [ ("text", do   { let (h : t) = lines 
-                       ; unlittext f oss h
-                       ; maybePutChar opts '\n'
-                       ; unlit f oss t
-                       } )
-       , ("code", do   { let (h, t) = glueLines lines
-               
-                       -- start of line hook
-                       ; if onoff opts "output"
-                         then  caseopts opts "code"
-                               [ ("latex", putStr "\\\\\n & & ") 
-                               , ("plain", return ())
-                               ]
-                         else return ()
-
-                       ; oss' <- unlitcode f oss h
-
-                       -- end of line hook
-                       ; if onoff opts "output"
-                         then  caseopts opts "code"
-                               [ ("latex", putChar '\n') 
-                               , ("plain", putChar '\n')
-                               ]
-                         else return ()
-
-                       ; unlit f oss' t
-                       } )
-       ]
-
---------------------------------------------------------------------
-
-unlittext :: Formatter a -> (Optss, a) -> String -> IO ()
-
--- inline code, look for $..$ (keepsep) or |..| (omitsep)
--- result () because it may not change opts or env
-
-unlittext f oss @ (os @ (opts : _), state) cs =
-    do { let [keep] = getopt opts "keepsep"
-       ; let [omit] = getopt opts "omitsep"
-
-       ; let (as, bs) = span (\ c -> c /= keep && c /= omit) cs
-
-       ; maybePutStr opts as
-
-       ; let sep = head bs -- only called when bs /= []
-       ; let ds = drop 1 bs 
-       ; let (es, fs) = span (/= sep) ds 
-       ; let gs = drop 1 fs 
-
-       ; let opts1 = addListToOpts opts 
-               [("current","code"), ("context", "inline")]
-
-       ; if not (null bs) then do
-               { if onoff opts "output" && sep == keep
-                 then  if getopt opts "text" == "latex"
-                         && getopt opts "code" == "plain"
-                       then putStr "\\verb;"
-                       else putChar sep 
-                 else return ()
-
-               ; f (opts1, state) es
-
-               ; if onoff opts "output" && sep == keep
-                 then  if getopt opts "text" == "latex"
-                         && getopt opts "code" == "plain"
-                       then putStr ";"
-                       else putChar sep 
-                 else return ()
-
-               ; unlittext f oss gs
-               }
-         else return ()        -- line finished
-       }
-
---------------------------------------------------------------------
-
-unlitcode :: Formatter a -> (Optss, a) -> String -> IO (Optss, a)
-unlitcode f (oss @ (opts: _), state) s =
-    do { state' <- f (opts, state) s   -- execute code
-       ; return (oss, state')          
-       }
-
-
---------------------------------------------------------------------
-
-
--- perhaps start or end a code block
--- this: current options, that: previous options
-block this that = 
-       if -- we've changed current mode
-         getopt this "current" /= getopt that "current" 
-         -- we're latexing
-         && caseopts that "text" [("latex",True),("plain",False)]
-
-       then
-           if  -- we are in code mode now
-               caseopts this "current" [("code",True),("text",False)]
-               -- we were in text mode before
-               && caseopts that "current" [("text",True),("code",False)]
-               -- we _are_ printing
-               && onoff this "output" 
-           then
-               caseopts this "code"
-                   [ ("plain", putStrLn "\\begin{verbatim}")
-
--- nice hack -----------------------------------------------------------
--- output "%%" at end of line
--- so that latex ignores the "\\"
--- that will be output before first code line
-                   , ("latex", putStr "\\begin{eqnarray*} %% hack: ")
--- end hack -------------------------------------------------------------
-
-                   ]
-           else if -- we were in code mode 
-               caseopts that "current" [("code",True),("text",False)]
-               -- we return to text mode
-               && caseopts this "current" [("text",True),("code",False)]
-               -- we _were_ printing
-               && onoff that "output" 
-           then
-               caseopts this "code"
-                   [ ("plain", putStrLn "\\end{verbatim}")
-                   , ("latex", putStrLn "\\end{eqnarray*}")
-                   ]   
-           else return ()
-       else return ()
-
-
-unlitcmd :: Formatter a -> (Optss, a) -> String -> IO (Optss, a)
-unlitcmd f oss @ (os @ (opts:ros), state ) cmd =
-    case pcmd opts cmd of
-
-       -- import a file, change environment locally only
-       -- but globally thread the state through
-       Import g name -> 
-           do  { let opts1 = plusOpts opts g
-               ; block opts1 opts
-
-               ; cs <- if name == "-" -- means stdin
-                       then 
-                               trace ("\nreading stdin\n") $
-                               getContents
-                       else 
-                               trace ("\nreading file " ++ name ++ "\n") $
-                               readFile name
-
-               ; (opts2, state2) <- unlit f (opts1 : os, state) (lines cs)
-               ; block opts (head opts2)
-               ; return (os, state2)
-               }
-
-       -- change environment, continue parsing
-       Set g -> 
-           do  { let opts1 = plusOpts opts g
-               ; block opts1 opts
-               ; return (opts1 : ros , state)
-               }
-
-       -- begin of a display code group
-       Begin g -> 
-           do  { let opts1 = plusOpts opts g
-               ; block opts1 opts
-               ; return (opts1 : os, state)
-               }
-
-       -- end of a display code group
-       End ->
-           if null ros then error "error: extraneous .end"
-           else do
-               { let opts1 = head ros
-               ; block opts1 opts      -- note: the other way round
-               ; return (ros, state)
-               }
-
-       -- some unknown command
-       Unknown cs ->
-           do  { putStrLn ("unkown cmd: " ++ cs) 
-               ; return oss
-               }
-
-
-----------------------------------------------------------------------
-
--- the command line is preprended to the input
-stream opts f init argv = 
-    let        
-       process arg = 
-           if '=' `elem` arg 
-           then -- it's a binding
-               ".set (" ++ arg ++ ")"
-           else -- it's a file name
-               ".import \"" ++ arg ++ "\""
-
-       limbo = [ process arg | arg <- argv ]
-
-    in unlit f ([opts], init) limbo >> return ()
-
--- what we do when interpreted (i. e. we type the command line)
--- read arguments from string, read input from file
-gheave opts f init args = 
-       stream opts f init (words args)
-
-
--- what we call when compiled
--- read arguments (don't read stdin per default. give "-" argument instead)
-heave opts f init =
-       getArgs >>= \ argv ->
-       stream opts f init argv 
-
-
diff --git a/real/rx/src/Heuristic.hs b/real/rx/src/Heuristic.hs
deleted file mode 100644 (file)
index 2b05f0b..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
--- the read-eval-print loop 
--- without the eval
-
-
-module Heuristic
-
-( heu
-)
-
-where
-
-import Options
-
-import Ids
-
-import Syntax
-
-----------------------------------------------------------------------
-
--- check through a list of operations,
--- prepend these to the input
-heuristic :: Opts -> [ String ] -> Exp -> Exp
-heuristic opts hs inp = foldr (\ name inp' -> case onoff opts name of
-               True -> App (userfun 1 name) [inp']
-               False -> inp' 
-       ) inp hs
-
--- look through the complete tree and insert heuristics after each "="
-heureq :: Opts -> [ String ] -> Exp -> Exp
-heureq opts hs (App id args) | idname id == "=" =
-       let a : as = args 
-       in App id (a : map (heuristic opts hs . heureq opts hs) as)
-heureq opts hs (App id args) =
-       App id (map (heureq opts hs) args)
-heureq opts hs x = x   -- don't change
-
--- insert heuristics at each top-level expression that is not an assignment
-heutop :: Opts -> [ String ] -> Exp -> Exp
-heutop opts hs (App id args) | idname id == ";" =
-       App id (map (heutop opts hs) args)
-heutop opts hs x @ (App id args) | idname id == "=" = x        -- won't change
-heutop opts hs x = heuristic opts hs x -- do change
-
-
-
-heu opts hs = heutop opts hs . heureq opts hs
\ No newline at end of file
diff --git a/real/rx/src/IdStack.hs b/real/rx/src/IdStack.hs
deleted file mode 100644 (file)
index c8322b0..0000000
+++ /dev/null
@@ -1,92 +0,0 @@
-module IdStack
-
-( IdStack
-
-, emptyIS, globIS
-
-, pushlocs, poplocs, mkglobs
-
-, findidS, changeprecS
-, setarityS, setformS
-
-)
-
-where
-
-import Ids
-
---------------------------------------------------------------------
-
-data IdStack = IS
-       [ IdTable ]     -- stack of local bindings
-       IdTable         -- global environment
-       deriving Show
-
-globIS it = IS [] it
-emptyIS = globIS emptyIT
-
-
---------------------------------------------------------------------
-
-pushlocs (IS locs glob) = IS (emptyIT : locs) glob
-
-poplocs (IS [] glob) = error "cannot pop locals (stack empty)"
-poplocs (IS (loc : locs) glob ) = IS  locs glob
-
-mkglobs (IS [] glob) = error "cannot make globals (local stack empty)"
-mkglobs (IS (loc : locs) glob ) = IS ( loc : locs) (plusIT glob loc)
-
---------------------------------------------------------------------
-
--- lift a function on an IdTable
--- to a function on an IdStack:
-
--- first look for a local name
--- then default to the global one
-
-wrapIS :: Bool -> (String -> IdTable -> (a, IdTable)) 
-       -> (String -> IdStack -> (a, IdStack))
-
-wrapIS def f name (IS [] glob) = 
-       let (x, glob') = f name glob
-       in  (x, IS [] glob')
-
-wrapIS def f name (IS (loc : locs) glob) =
-    if def 
-
-    then -- don't search, rather define new variable right here
-       let (x, loc') = f name loc
-       in (x, IS (loc' : locs) glob)
-
-    else -- do search
-       case lookupIT loc name of
-           Just _ ->   let (x, loc') = f name loc
-                       in (x, IS (loc' : locs) glob)
-           Nothing ->  let (x, IS locs' glob') 
-                               = wrapIS def f name (IS locs glob)
-                       in (x, IS (loc : locs') glob')
-
---------------------------------------------------------------------
-
-
-findidS :: Bool -> String -> Kind -> Kind -> IdStack -> (Id, IdStack)
-findidS def name look use is = 
-       wrapIS def (\ name it -> findid name look use it ) name is
-
-changeprecS :: IdStack -> String -> Int -> Bind -> (Id, IdStack)
-changeprecS is name level bind =
-       wrapIS False (\ name it -> changeprec it name level bind) name is
-
-
-setarityS :: IdStack -> String -> Int -> (Id, IdStack)
--- does nothing if arity is already set 
--- (will complain elsewhere if does not agree and switch implicit is off)
-setarityS is name ar  =
-       wrapIS False (\ name it -> setarity it name ar) name is
-
-
-setformS :: IdStack -> String -> Form -> (Id, IdStack)
--- does never complain
-setformS is name form =
-       wrapIS False (\ name it -> setform it name form ) name is
-
diff --git a/real/rx/src/Ids.hs b/real/rx/src/Ids.hs
deleted file mode 100644 (file)
index 90713a3..0000000
+++ /dev/null
@@ -1,283 +0,0 @@
-module Ids 
-
-( Id(..)
-, Form(..)
-
-, Kind(..)
-, Bind(..)
-
-, changeprec
-, setarity
-, setform
-
-, idname
-, idform
-
-, idarity      -- returns Int
-, maybe_idarity        -- returns Maybe Int
-
-, idlook 
-, iduse  
-, idprec 
-, idbind 
-
-, findid
-
-, mkid 
-, mknat
-
-, userfun
-, uservar
-, usercon
-
-
-, ppfn, ppop
-
-, IdTable
-
-, inIts
-, emptyIT
-, lookupIT
-, addToIT
-, plusIT
-
-)
-
-where
-
--- import Trace
-
-import Maybes
-
-import Data.Char (isDigit)
-
-import FiniteMap
-import Pretty
-import PrettyClass
-
-import Lex (updown)
-
-import Options
-
-data Kind = Fn | Op 
-    deriving (Eq, Show)
-
-data Bind = Lft | Rght | Nn    -- associativity
-    deriving (Eq, Show)
-
-data Form 
-       = Passive String        -- is just expanded
-       | Active Int String     -- arguments get plugged in
-
-data Id = Id 
-       String  -- name (that is typed in)
-       Form    -- latex expansion (may contain #1, #2 ...)
-               -- for expansions of arguments
-       (Maybe Int) -- arity 
-       Kind    -- looks like Fn or Op
-       Kind    -- used as Fn or Op
-       (Maybe Int) -- precedence
-       Bind    -- Associativity
-
--- won't need this much, except for debugging
-instance Show Id where showsPrec p id = showString (idname id)
-
-
-instance Eq Id where
-  x == y = idname x == idname y        -- disregarding all other fields
-
-instance Ord Id where
-  x <= y = idname x <= idname y        -- disregarding all other fields
-
-----------------------------------------------
-
-
-ppfn opts id = caseopts opts "code"
-    [ ("plain", case idlook id of
-       Fn -> ppStr (       idname id       )
-       Op -> ppStr ("(" ++ idname id ++ ")") )
-
-    , ("latex",
-       let f = case idform id of 
-                       Active _ _ -> idname id -- shouldn't happen
-                       Passive form -> form
-       in case idlook id of
-               Fn -> ppStr (       f       )
-               Op -> ppStr ("(" ++ f ++ ")") )
-    ]
-
-ppop opts id = caseopts opts "code"
-    [ ("plain", case idlook id of
-       Fn -> ppStr ("`" ++ idname id ++ "`")
-       Op -> if idname id == getopt opts "apply" && onoff opts "implicit"
-             then ppNil 
-             else ppStr (idname id)
-      )
-    , ("latex",
-       let f = case idform id of 
-                       Active _ _ -> idname id -- shouldn't happen
-                       Passive form -> form
-       in case idlook id of
-
-
---             Fn -> ppStr ("`" ++ f ++ "`")
--- TODO: something more clever here
-               Fn -> ppStr (       f       )
-
-
-               Op -> ppStr (       f       ) )
-    ]
-
------------------------------------------------
-
-
--- todo: use records here ?
-idname  (Id name form arity look use prec bind) = name
-idform  (Id name form arity look use prec bind) = form
-maybe_idarity (Id name form arity look use prec bind) = arity
-idlook  (Id name form arity look use prec bind) = look
-iduse   (Id name form arity look use prec bind) = use
-idprec  (Id name form arity look use prec bind) = prec
-idbind  (Id name form arity look use prec bind) = bind
-
-idarity id = case maybe_idarity id of
-       Just n -> n
-       Nothing -> error ("no arity for " ++ show id)
-
-mkid :: String -> Form -> Maybe Int -> Kind -> Kind -> Maybe Int -> Bind 
-       -> Id
-mkid name form arity look use prec bind = 
-       Id name form arity look use prec bind 
-
-mknat :: Int -> Id
-mknat n = mkid (show n) (Passive (show n)) 
-       (Just 0) Fn Fn Nothing Nn   
-
-userfun :: Int -> String -> Id
-userfun n name = mkid name (Passive (pform "\\mathrm" name))
-       (Just n) Fn Fn Nothing Nn
-
-uservar ::        String -> Id
-uservar   name  = mkid name (Passive (pform "\\mathit" name))
-       (Just 0) Fn Fn Nothing Nn
-       
-usercon :: Int -> String -> Id
-usercon n name =  mkid name (Passive (pform "\\mathbf" name))
-       (Just n) Fn Fn Nothing Nn
-
---------------------------------------------------
-
-data IdTable = IT (FiniteMap String Id) deriving Show
-
-emptyIT = IT (emptyFM)
-
-lookupIT (IT fm) = lookupFM fm
-
-addToIT (IT fm) name id =
-       IT (addToFM_C (error "addToIt") fm name id)
-
-plusIT (IT fm1) (IT fm2) = 
-       IT (plusFM_C (error "Ids.plusIT: IdTables not disjoint") fm1 fm2)
-
-inIts :: [Id] -> IdTable
-inIts ids = IT (listToFM [ (idname id, id) | id <- ids ])
-
--------------------------------------------------
-
-
-
-pform style name | isDigit (head name) = name
-
-pform style name | length name == 1 =
-       if style == "\\mathit" 
-       then name -- one letter ids are mathit automatically
-       else style ++ "{" ++ name ++ "}"
-
-pform style name = 
-    let (as, bs) = span (not . updown) name
-       (cs, ds) = span (      updown) bs
-    in style ++ "{" ++ as ++ "}"
-       ++ case bs of
-               [] -> ""
-               _ -> case ds of
-                       [] -> cs        -- hopefully these are primes ''''
-                                       -- otherwise, just "_" or "^" (we hope)
-                       _ -> cs ++ "{" ++ pform style ds ++ "}"
-
------------------------------------------------------------
-
-findid :: String -> Kind -> Kind -> IdTable -> (Id, IdTable)
-findid name look use it =
-    case lookupIT it name of
-       Just id -> (id, it)
-       Nothing -> 
-           let id = mkid name 
-                       (case look of -- tex form
-                               Fn -> Passive (pform "\\mathit" name)
-                               Op -> Passive ("\\verb;"   ++ name ++ ";")
-                       )
-                       (case use of -- arity
-                               Fn -> Nothing
-                               Op -> Just 2    
-                       )
-                       look
-                       use
-                       Nothing -- precedence
-                       Nn      -- associativity
-           in
---             trace ("\nmaking " ++ show id) $
-               (id, addToIT it name id)
-
-changeprec :: IdTable -> String -> Int -> Bind -> (Id, IdTable)
-changeprec it @ (IT fm) name level bind =
-    let id' = lookupFM fm name
-    in if exists id' && not (exists (idprec (the id')))
-       then 
-           let id'' = mkid
-                       (idname (the id')) (idform (the id')) 
-                       (maybe_idarity (the id'))
-                       (idlook (the id')) (iduse (the id'))
-                       (Just level) 
-                       bind 
-           in  (id'', IT (addToFM fm name id''))
-
-       else error ("cannot change precedence of: " ++ name)
-
-setarity :: IdTable -> String -> Int -> (Id, IdTable)
--- does nothing if arity is already set 
--- (will complain elsewhere if does not agree and implicit_apply is off)
-setarity it @ (IT fm) name ar  =
-    let id' = lookupFM fm name
-    in if exists id' 
-       then
-           if exists (maybe_idarity (the id'))
-           then (the id', it)  -- needs no change
-           else
-                   let id'' = mkid
-                               (idname (the id')) (idform (the id')) 
-                               (Just ar)
-                               (idlook (the id')) (iduse (the id'))
-                               (idprec (the id')) (idbind (the id')) 
-                   in  (id'', IT (addToFM fm (name) id''))
-
-       else error ("setarity: id doesn't exist: " ++ name)
-
-
-setform :: IdTable -> String -> Form -> (Id, IdTable)
--- does never complain
-setform it @ (IT fm) name cs =
-    let id' = lookupFM fm name
-    in if exists id' 
-       then
-                   let id'' = mkid
-                               (idname (the id')) cs 
-                               (maybe_idarity (the id'))
-                               (idlook (the id')) (iduse (the id'))
-                               (idprec (the id')) (idbind (the id')) 
-                   in  (id'', IT (addToFM fm (name) id''))
-
-       else error ("setform: id doesn't exist: " ++ name)
-
-
-
-
diff --git a/real/rx/src/Instance.hs b/real/rx/src/Instance.hs
deleted file mode 100644 (file)
index 5ce3dd9..0000000
+++ /dev/null
@@ -1,64 +0,0 @@
-module Instance 
-
-( instpublic
-)
-
--- find some instances of a language
--- just delete all recursive rules in the automaton
-
-where
-
-import Trace
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-
-
-
-
-weed moves current seen =
-    if isEmptySet current then moves
-    else 
-       let
-           -- reachables
-           neigh = mkSet [ d
-                       | c <- setToList current
-                       , st <- setToList (lookupset moves c)
-                       , d <- stargs st
-                       ]
-
-           seen' =  (seen `unionSet` current)
-           current' =  (neigh `minusSet` seen) 
-
-           moves' = mapFM (\ q sts -> mkSet [ st  | st <- setToList sts
-                                       , q `elementOf` seen
-                                         || not (or [ p `elementOf` seen' 
-                                             | p <- stargs st ])
-                                       ]
-               ) moves
-       in
-           weed moves' current' seen'
-
-
-inst :: TNFA Int -> Set Int -> TNFA Int
-inst a @ (TNFA cons all starts moves) is =
-    let
-       moves' = weed moves is emptySet
-    in  TNFA cons all is moves'
-
-instpublic :: Opts -> [ TNFA Int ] -> TNFA Int
-
-instpublic opts args =
-    if length args /= 1 
-    then error "instpublic.args"
-    else 
-       let [ arg1 @ (TNFA cons all starts moves) ] = args
-       in  inst arg1 starts
-
-
diff --git a/real/rx/src/Lex.hs b/real/rx/src/Lex.hs
deleted file mode 100644 (file)
index 866e6f2..0000000
+++ /dev/null
@@ -1,76 +0,0 @@
-
-
-module Lex
-
-( uncomment
-, isDel
-, isAlphanum', updown
-
-, myLex
-
-)
-
-where
-
-import Data.Char
-
-
---------------------------------------------------------
-
-uncomment :: String -> String
-uncomment [] = []
-uncomment ('-' : '-' : cs) = uncomment (dropWhile (/= '\n') cs)
-uncomment ('{' : '-' : cs) = recomment cs
-uncomment (c : cs) = c : uncomment cs
-
-recomment :: String -> String
-recomment [] = []
-recomment ('-' : '-' : cs) = recomment (dropWhile (/= '\n') cs)
-recomment ('-' : '}' : cs) = uncomment cs
-recomment (c : cs) = recomment cs
-
--------------------------------------------------------
-
--- treat TeX operators 
-updown c = c `elem` "_^'"
-
-isAlphanum' c = isAlphaNum c || updown c
-
--------------------------------------------------------
-
-
-myLex [] = []
-
-myLex ('"' : cs) = 
-    let (as, bs) = span (/= '"') cs
-    in  ('"' : as ++ "\"") : myLex (drop 1 bs)
-
-
-myLex (c : cs) | isSpace c = myLex cs
-myLex (c : cs) | isAlpha c =
-       let (ds, es) = span isAlphanum' cs
-        in (c : ds) : myLex es
-myLex (c : cs) | isDigit c =
-       let (ds, es) = span isDigit cs
-        in (c : ds) : myLex es
-myLex (c : cs) | isDel c =
-       [c] : myLex cs
-
-myLex (c : cs) = 
-       let (ds, es) = break (\ c -> isAlphanum' c || isSpace c || isDel c) cs
-       in (c : ds) : myLex es
-
-----------------------------------------------------------------------------
-
-isDel '(' = True; isDel ')' = True
-isDel '[' = True; isDel ']' = True
-isDel '{' = True; isDel '}' = True
-isDel '`' = True
-isDel '"' = True
-isDel ',' = True
-
--- isDel ';' = True  NOT: semicolon is an operator, has semantics
-
-isDel _ = False
-
-
diff --git a/real/rx/src/Loop.hs b/real/rx/src/Loop.hs
deleted file mode 100644 (file)
index 17849ad..0000000
+++ /dev/null
@@ -1,77 +0,0 @@
--- the read-eval-print loop 
--- without the eval
-
-
-module Loop
-
-( Val
-, expformat
-)
-
-where
-
-import Options
-
-import Pretty  -- syslib ghc
-import PrettyClass (linewidth)
-
-
-import Syntax (Exp, pr)
-import ExpParse (pline)
-import PI
-import Ids
-
-import Heuristic
-
-import Heave (Formatter)
-
------------------------------------------------------------------------
-
-type Val e = Opts -> e -> Exp -> Either String (Exp, e)
--- evaluates, with some environment
-
--- expformat :: [String] -> Val e -> Formatter (IdTable, e)
-expformat hs val (opts0, (pi0, env0)) inp =
-    do { let (mx, (opts1, pi1)) = pline (opts0, pi0) inp       -- parse input
-
-       ; case mx of
-            Nothing -> return (pi1, env0)
-           Just y -> do 
-
-               -- prepend some defaults (if evaluating)
-               { let x = chose opts1 "eval" (heu opts1 hs y) y
-
-               -- possibly echo the input (with defaults?)
-               ; if onoff opts1 "output" && onoff opts1 "exp"
-                 then (putStr (ppShow linewidth 
-                               (pr opts1 (chose opts1 "expand" x y) )))
-                 else (return ())
-
-               -- evaluate input
-               ; chose opts1 "eval"
-                   ( case val opts1 env0 x of
-                 Left msg -> 
-                   do  { maybePutStrLn opts1 msg
-                       -- continue with old environment
-                       ; return (pi1, env0) 
-                       }
-
-                 Right (y, env1) ->
-                   do  { if onoff opts1 "output" && onoff opts1 "res"
-                         then (putChar '\n' >> putStr (ppShow linewidth 
-                                       (ppSep [ppStr "==", pr opts1 y])))
-                         else (return () )
-
-                       -- continue with new env
-                       ; return (pi1, env1)
-                       }
-                    )
-
-               (return (pi1, env0))    -- nothing happens
-
-           }
-       }
-
-------------------------------------------------------------------------
-
-
diff --git a/real/rx/src/Makefile b/real/rx/src/Makefile
deleted file mode 100644 (file)
index 162b53d..0000000
+++ /dev/null
@@ -1,6 +0,0 @@
-TOP = ../../..
-include $(TOP)/mk/boilerplate.mk
-NOFIB_PROG=rx
-SRC_HC_OPTS += -recomp -H50M -K10M  -Onot
-
-include $(TOP)/mk/target.mk
diff --git a/real/rx/src/Maybes.hs b/real/rx/src/Maybes.hs
deleted file mode 100644 (file)
index cdbca8b..0000000
+++ /dev/null
@@ -1,198 +0,0 @@
--- %
--- % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-
--- with changes by myself (joe@informatik.uni-jena.de)
-
--- %
--- \section[Maybes]{The `Maybe' types and associated utility functions}
---
-
-
-module Maybes (
-
-       exists, the,    -- this is missing in 1.4 ?
-
-
---     Maybe(..), -- no, it's in 1.3
-       MaybeErr(..),
-
-       allMaybes,
-       firstJust,
-       expectJust,
-       maybeToBool,
-
-       assocMaybe,
-       mkLookupFun, mkLookupFunDef,
-
-       failMaB,
-       failMaybe,
-       seqMaybe,
-       returnMaB,
-       returnMaybe,
-       thenMaB
-
-
-
-       , findJust
-       , foldlMaybeErrs
-       , listMaybeErrs
-
-    ) where
-
-
--- import Maybe -- renamer will tell us if there are any conflicts
-
-
-exists = maybeToBool
-
-the (Just x) = x; the Nothing = error "the"
-
---
---
--- %************************************************************************
--- %*                                                                  *
--- \subsection[Maybe type]{The @Maybe@ type}
--- %*                                                                  *
--- %************************************************************************
---
-maybeToBool :: Maybe a -> Bool
-maybeToBool Nothing  = False
-maybeToBool (Just x) = True
---
--- @catMaybes@ takes a list of @Maybe@s and returns a list of
--- the contents of all the @Just@s in it.      @allMaybes@ collects
--- a list of @Justs@ into a single @Just@, returning @Nothing@ if there
--- are any @Nothings@.
---
-
-
-allMaybes :: [Maybe a] -> Maybe [a]
-allMaybes [] = Just []
-allMaybes (Nothing : ms) = Nothing
-allMaybes (Just x  : ms) = case (allMaybes ms) of
-                            Nothing -> Nothing
-                            Just xs -> Just (x:xs)
---
--- @firstJust@ takes a list of @Maybes@ and returns the
--- first @Just@ if there is one, or @Nothing@ otherwise.
---
-firstJust :: [Maybe a] -> Maybe a
-firstJust [] = Nothing
-firstJust (Just x  : ms) = Just x
-firstJust (Nothing : ms) = firstJust ms
---
-findJust :: (a -> Maybe b) -> [a] -> Maybe b
-findJust f []    = Nothing
-findJust f (a:as) = case f a of
-                     Nothing -> findJust f as
-                     b  -> b
---
-expectJust :: String -> Maybe a -> a
-{- not # INLINE expectJust #-}
-expectJust err (Just x) = x
-expectJust err Nothing  = error ("expectJust " ++ err)
---
--- The Maybe monad
--- ~~~~~~~~~~~~~~~
-seqMaybe :: Maybe a -> Maybe a -> Maybe a
-seqMaybe (Just x) _  = Just x
-seqMaybe Nothing  my = my
-
-returnMaybe :: a -> Maybe a
-returnMaybe = Just
-
-failMaybe :: Maybe a
-failMaybe = Nothing
---
--- Lookup functions
--- ~~~~~~~~~~~~~~~~
---
--- @assocMaybe@ looks up in an assocation list, returning
--- @Nothing@ if it fails.
---
-assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
-
-assocMaybe alist key
-  = lookup alist
-  where
-    lookup []            = Nothing
-    lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
-
-
---
--- @mkLookupFun eq alist@ is a function which looks up
--- its argument in the association list @alist@, returning a Maybe type.
--- @mkLookupFunDef@ is similar except that it is given a value to return
--- on failure.
---
-mkLookupFun :: (key -> key -> Bool)    -- Equality predicate
-           -> [(key,val)]              -- The assoc list
-           -> key                      -- The key
-           -> Maybe val                -- The corresponding value
-
-mkLookupFun eq alist s
-  = case [a | (s',a) <- alist, s' `eq` s] of
-      []    -> Nothing
-      (a:_) -> Just a
-
-mkLookupFunDef :: (key -> key -> Bool) -- Equality predicate
-              -> [(key,val)]           -- The assoc list
-              -> val                   -- Value to return on failure
-              -> key                   -- The key
-              -> val                   -- The corresponding value
-
-mkLookupFunDef eq alist deflt s
-  = case [a | (s',a) <- alist, s' `eq` s] of
-      []    -> deflt
-      (a:_) -> a
---
--- %************************************************************************
--- %*                                                                  *
--- \subsection[MaybeErr type]{The @MaybeErr@ type}
--- %*                                                                  *
--- %************************************************************************
--- 
-data MaybeErr val err = Succeeded val | Failed err
---
-thenMaB :: MaybeErr val1 err -> (val1 -> MaybeErr val2 err) -> MaybeErr val2 err
-thenMaB m k
-  = case m of
-      Succeeded v -> k v
-      Failed e   -> Failed e
-
-returnMaB :: val -> MaybeErr val err
-returnMaB v = Succeeded v
-
-failMaB :: err -> MaybeErr val err
-failMaB e = Failed e
---
---
--- @listMaybeErrs@ takes a list of @MaybeErrs@ and, if they all succeed, returns
--- a @Succeeded@ of a list of their values.  If any fail, it returns a
--- @Failed@ of the list of all the errors in the list.
---
-listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err]
-listMaybeErrs
-  = foldr combine (Succeeded [])
-  where
-    combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs)
-    combine (Failed err)  (Succeeded _)         = Failed [err]
-    combine (Succeeded v) (Failed errs)         = Failed errs
-    combine (Failed err)  (Failed errs)         = Failed (err:errs)
---
--- @foldlMaybeErrs@ works along a list, carrying an accumulator; it
--- applies the given function to the accumulator and the next list item,
--- accumulating any errors that occur.
---
-foldlMaybeErrs :: (acc -> input -> MaybeErr acc err)
-              -> acc
-              -> [input]
-              -> MaybeErr acc [err]
-
-foldlMaybeErrs k accum ins = do_it [] accum ins
-  where
-    do_it []   acc []    = Succeeded acc
-    do_it errs acc []    = Failed errs
-    do_it errs acc (v:vs) = case (k acc v) of
-                             Succeeded acc' -> do_it errs       acc' vs
-                             Failed err     -> do_it (err:errs) acc  vs
diff --git a/real/rx/src/Options.hs b/real/rx/src/Options.hs
deleted file mode 100644 (file)
index 307c0cc..0000000
+++ /dev/null
@@ -1,94 +0,0 @@
-module Options
-
-( Opts
-
-, emptyOpts
-, listToOpts
-, addToOpts
-, addListToOpts
-, plusOpts
-
-, getopt
-, caseopts
-, onoff
-, chose
-
-, troff
-
-, maybeIO
-, maybePutStr
-, maybePutStrLn
-, maybePutChar
-
-)
-
-where
-
-import Trace
-
-import Stuff (intersperse)
-
-import FiniteMap -- from syslib ghc
-
-type Opts = FiniteMap String String
-
-emptyOpts :: Opts
-emptyOpts = emptyFM
-
-listToOpts :: [(String, String)] -> Opts
-listToOpts = listToFM
-
-addListToOpts :: Opts -> [(String, String)] -> Opts
-addListToOpts = addListToFM
-
-addToOpts :: Opts -> String -> String -> Opts
-addToOpts = addToFM
-
-plusOpts :: Opts -> Opts -> Opts
-plusOpts = plusFM
-
-getopt :: Opts -> String -> String
-getopt opts name =
-    lookupWithDefaultFM opts
-       (error ("no argument for option: " ++ name))
-       name
-
-caseopts :: Opts -> String -> [(String, a)] -> a
-caseopts opts name acts =
-    let val = lookupWithDefaultFM opts (wrong Nothing) name
-
-
-       quote s = "`" ++ s ++ "'"
-       wrong v = error (unlines 
-           [ "error: when looking up option " ++ quote name
-           , case v of 
-               Nothing -> "error: value not specified"
-               Just val -> "error: value " ++ quote val ++ " not understood"
-           , "error: possible values are: " 
-               ++ concat (intersperse ", " (map (quote . fst) acts))
-           , "error: program stops"
-           ] )
-               
-    in case lookup val acts of
-       Just act -> act
-       Nothing -> wrong (Just val)
-
-
-onoff :: Opts -> String -> Bool
-onoff opts name = caseopts opts name [("on", True),("off",False)]
-
-chose :: Opts -> String -> a -> a -> a
-chose opts name yeah noh = if onoff opts name then yeah else noh
-
-maybeIO opts io =
-    case onoff opts "output" of 
-       True -> io
-       False -> return ()
-
-maybePutStr   opts s =  maybeIO opts (putStr   s)
-maybePutStrLn opts s =  maybeIO opts (putStrLn s)
-maybePutChar  opts c =  maybeIO opts (putChar  c)
-
-troff :: Opts -> String -> a -> a
-troff opts msg = chose opts "trace" (trace msg) id
-
diff --git a/real/rx/src/PI.hs b/real/rx/src/PI.hs
deleted file mode 100644 (file)
index 1745f72..0000000
+++ /dev/null
@@ -1,170 +0,0 @@
-module PI
-
-( PI
-, PIS
-
-, PY   -- export required by hbc ???
-
-, llit, llitp
-, lmany, lmany1
-, lsepBy, lsepBy1
-
-, lparse, opt
-
-, getopts
-
-, makeid, makenat
-, putprec, putarity, putform
-
-, pushlocals, poplocals, mkglobals
-
-, makeidS, makenatS
-, putprecS, putarityS, putformS
-
-)
-
-where
-
--- import Trace
-
-import Options
-import Ids
-import Monad
-
-import IdStack
-
-import Parse   -- from syslib hbc
-
-
-
--- data PI v = PI ((Opts, IdTable) -> Parser [String] (v, (Opts, IdTable)))
--- unPI (PI p) = p
-
-data PY a v = PY (a -> Parser [String] (v, a))
-unPY (PY p) = p
-
-type PI v = PY (Opts, IdTable) v
-type PIS v = PY (Opts, IdStack) v
-
-------------------------------------------------------------------------
-
-instance Functor (PY a) where
-    fmap f (PY p) = PY (\ x -> 
-       p x `act` (\ (v, x) -> (f v, x)))
-
-instance Monad (PY a) where
-    return r = PY ( \ x -> succeed (r, x) )
-    PY p >>= g = PY (\ x -> 
-       p x `into` (\ (v, x') -> unPY (g v) x'))
-
-instance MonadPlus (PY a) where
-    mzero = PY (\ x -> failP "PY.zero")
-    (PY p) `mplus` (PY q) = PY ( \ x -> p x ||! q x )
-
---------------------------------------------------------------------------
-
-lparse (PY p) x toks = parse (p x) toks
-
-    
---------------------------------------------------------------------------
-
-getopts :: PY (a, b) a
-getopts = PY (\ (o, i) -> succeed (o, (o, i)))
-
---------------------------------------------------------------------------
-
-makenat :: Int -> PI Id
-makenat n = makeid (show n) Fn Fn
-
-
-
-makeid :: String -> Kind -> Kind -> PI Id
-makeid name look use = PY ( \ (o, i) -> 
-       let (id, i') = findid name look use i
-       in succeed (id, (o, i')) )
-
-putprec id level bind = PY ( \ (o, i) ->
-       let (id', i') = changeprec i id level bind
-       in succeed (id', (o, i')) )
-
-putarity id ar = PY ( \ (o, i) ->
-       let (id', i') = setarity i id ar
-       in 
---             trace ("\nputarity.id : " ++ show id) $
---             trace ("\nputarity.id.arity : " ++ show (maybe_idarity id)) $
---             trace ("\nputarity.ar : " ++ show ar) $
---             trace ("\nputarity.id'.arity : " ++ show (idarity id')) $
-               succeed (id', (o, i')) )
-
-putform id cs = PY ( \ (o, i) ->
-       let (id', i') = setform i id cs
-       in succeed (id', (o, i')) )
-
------------------------------------------------------------------------
-
-makenatS :: Bool -> Int -> PIS Id
-makenatS def n = makeidS def (show n) Fn Fn
-
-makeidS :: Bool -> String -> Kind -> Kind -> PIS Id
-makeidS def name look use = PY ( \ (o, i) -> 
-       let (id, i') = findidS def name look use i
-       in succeed (id, (o, i')) )
-
-putprecS id level bind = PY ( \ (o, i) ->
-       let (id', i') = changeprecS i id level bind
-       in succeed (id', (o, i')) )
-
-putarityS id ar = PY ( \ (o, i) ->
-       let (id', i') = setarityS i id ar
-       in 
---             trace ("\nputarity.id : " ++ show id) $
---             trace ("\nputarity.id.arity : " ++ show (maybe_idarity id)) $
---             trace ("\nputarity.ar : " ++ show ar) $
---             trace ("\nputarity.id'.arity : " ++ show (idarity id')) $
-               succeed (id', (o, i')) )
-
-putformS id cs = PY ( \ (o, i) ->
-       let (id', i') = setformS i id cs
-       in succeed (id', (o, i')) )
-
----------------------------------------------------------------------
-
-
-lift :: Parser [String] v -> PY a v
-lift p = PY (\ x -> p `act` \ v -> (v, x) )
-
----------------------------------------------------------------------
-
-pushlocals :: PIS ()
-pushlocals = PY ( \ (o, i) -> succeed ((), (o, pushlocs i)) )
-
-poplocals :: PIS ()
-poplocals = PY ( \ (o, i) -> succeed ((), (o, poplocs i)) )
-
-mkglobals :: PIS ()
-mkglobals = PY ( \ (o, i) -> succeed ((), (o, mkglobs i)) )
-
-
----------------------------------------------------------------------
-
-llit x = lift (lit x)
-
-llitp msg p = lift (litp msg p)
-
-lmany1 p = do { x <- p; xs <- lmany p; return (x : xs) }
-lmany  p = lmany1 p `mplus` return []
-
-p `lsepBy1` q = 
-    do         { x <- p
-       ; ys <- lmany ( do { q; y <- p; return y } )
-       ; return (x : ys)
-       }
-
-p `lsepBy` q = p `lsepBy1` q `mplus` return []
-
-
-opt p = fmap Just p `mplus` return Nothing
-
-----------------------------------------------------------------------
-
-
diff --git a/real/rx/src/Parse.hs b/real/rx/src/Parse.hs
deleted file mode 100644 (file)
index 2a9d073..0000000
+++ /dev/null
@@ -1,272 +0,0 @@
--- this is adapted from ghc/syslib-hbc
-
-
-module Parse(
-       Parser, (+.+), (..+), (+..), (|||), (>>>), (||!), (|!!), (.>),
-       into, lit, litp, many, many1, succeed, sepBy, count, sepBy1, testp, token, recover,
-       ParseResult, parse, sParse, simpleParse,
-       act, failP
-       ) where
-
-
-
-
-
-infixr 8 +.+ , ..+ , +..
-infix  6 `act` , >>>, `into` , .>
-infixr 4 ||| , ||! , |!!
-
-type ErrMsg = String
-
-{-
-data FailAt a
-       = FailAt !Int [ErrMsg] a                        -- token pos, list of acceptable tokens, rest of tokens
-       deriving (Show)
-data ParseResult a b
-       = Many [(b, Int, a)] (FailAt a)                         -- parse succeeded with many (>1) parses)
-       | One b !Int a !(FailAt a)      -- parse succeeded with one parse
-       | None !Bool !(FailAt a)                -- parse failed. The Bool indicates hard fail
-       deriving (Show)
--}
-
-data FailAt a
-       = FailAt Int [ErrMsg] a                 -- token pos, list of acceptable tokens, rest of tokens
-       deriving (Show)
-data ParseResult a b
-       = Many [(b, Int, a)] (FailAt a)                         -- parse succeeded with many (>1) parses)
-       | One b Int a (FailAt a)        -- parse succeeded with one parse
-       | None Bool (FailAt a)          -- parse failed. The Bool indicates hard fail
-       deriving (Show)
-
-
-type Parser a b = a -> Int -> ParseResult a b
-
-noFail = FailAt (-1) [] (error "noFail")               -- indicates no failure yet
-
-updFail f (None w f')     = None w (bestFailAt f f') 
-updFail f (One c n as f') = One c n as (bestFailAt f f')
-updFail f (Many cas f')   = let r = bestFailAt f f' in seq r (Many cas r)
-
-bestFailAt f@(FailAt i a t) f'@(FailAt j a' _) =
-       if i > j then 
-           f 
-       else if j > i then 
-           f' 
-       else if i == -1 then 
-           noFail --FailAt (-1) [] [] 
-       else 
-           FailAt i (a ++ a') t
-
--- Alternative
-(|||) :: Parser a b -> Parser a b -> Parser a b
-p ||| q = \as n ->
-    case (p as n, q as n) of
-        (pr@(None True  _), _                ) -> pr
-        (pr@(None _     f), qr               ) -> updFail f qr
-       (    One b k as f , qr               ) -> Many ((b,k,as) : l') (bestFailAt f f') where (l',f') = lf qr
-       (    Many  l f    , qr               ) -> Many (        l++l') (bestFailAt f f') where (l',f') = lf qr
-    where lf (Many l f)     = (l,          f)
-         lf (One b k as f) = ([(b,k,as)], f)
-         lf (None _   f)   = ([],         f)
-
--- Alternative, but with committed choice
-(||!) :: Parser a b -> Parser a b -> Parser a b 
-p ||! q = \as n -> 
-    case (p as n, q as n) of
-        (pr@(None True  _), _                ) -> pr
-        (    None _     f , qr               ) -> updFail f qr
-       (pr               , _                ) -> pr
-
-process f [] [] = seq f (None False f)
-process f [(b,k,as)]  [] = seq f (One b k as f)
-process f rs [] = seq f (Many rs f)
-process f rs (w@(None True _):_) = seq f w
-process f rs (None False f':rws) = process (bestFailAt f f') rs rws
-process f rs (One b k as f':rws) = process (bestFailAt f f') (rs++[(b,k,as)]) rws
-process f rs (Many rs' f'  :rws) = process (bestFailAt f f') (rs++rs') rws
-
-doMany g cas f = Many [ (g c, n, as) | (c,n,as) <- cas] f
-
--- Sequence
-(+.+) :: Parser a b -> Parser a c -> Parser a (b,c)
-p +.+ q = 
-    \as n-> 
-    case p as n of
-       None w f -> None w f
-       One b n' as' f ->
-           case q as' n' of
-               None w f'         -> None w (bestFailAt f f') 
-               One c n'' as'' f' -> One (b,c) n'' as'' (bestFailAt f f')
-               Many cas f'       -> doMany (\x->(b,x)) cas (bestFailAt f f')
-       Many bas f ->
-           let rss = [ case q as' n' of { None w f -> None w f;
-                                          One c n'' as'' f' -> One (b,c) n'' as'' f';
-                                          Many cas f' -> doMany (\x->(b,x)) cas f'  }
-                        | (b,n',as') <- bas ]
-           in  process f [] rss
-
--- Sequence, throw away first part
-(..+) :: Parser a b -> Parser a c -> Parser a c
-p ..+ q = -- p +.+ q `act` snd
-    \as n-> 
-    case p as n of
-       None w f       -> None w f
-       One _ n' as' f -> updFail f (q as' n')
-       Many bas f     -> process f [] [ q as' n' | (_,n',as') <- bas ]
-
--- Sequence, throw away second part
-(+..) :: Parser a b -> Parser a c -> Parser a b
-p +.. q = -- p +.+ q `act` fst
-    \as n-> 
-    case p as n of
-       None w f -> None w f
-       One b n' as' f ->
-           case q as' n' of
-               None w f'         -> None w (bestFailAt f f')
-               One _ n'' as'' f' -> One b n'' as'' (bestFailAt f f')
-               Many cas f'       -> doMany (const b) cas (bestFailAt f f')
-        Many bas f ->
-           let rss = [ case q as' n' of { None w f -> None w f; 
-                                          One _ n'' as'' f' -> One b n'' as'' f';
-                                          Many cas f' -> doMany (const b) cas f' }
-                        | (b,n',as') <- bas ]
-           in  process f [] rss
-
--- Return a fixed value
-(.>) :: Parser a b -> c -> Parser a c
-p .> v =
-    \as n-> 
-    case p as n of
-      None w f        -> None w f
-      One _ n' as' f' -> One v n' as' f'
-      Many bas f      -> doMany (const v) bas f
-
--- Action
-act :: Parser a b -> (b->c) -> Parser a c
-p `act` f = \as n-> 
-    case p as n of
-       None w f       -> None w f
-       One b n as' ff -> One (f b) n as' ff
-       Many bas ff    -> doMany f bas ff
-
--- Action on two items
-(>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d
-p >>> f = \as n-> 
-    case p as n of
-       None w ff          -> None w ff
-       One (b,c) n as' ff -> One (f b c) n as' ff
-       Many bas ff        -> doMany (\ (x,y)->f x y) bas ff
-
--- Use value
-into :: Parser a b -> (b -> Parser a c) -> Parser a c
-p `into` fq = \as n -> 
-    case p as n of
-       None w f       -> None w f
-       One b n' as' f -> updFail f (fq b as' n')
-       Many bas f     -> process f [] [ fq b as' n' | (b,n',as') <- bas ]
-
--- Succeeds with a value
-succeed :: b -> Parser a b
-succeed v = \as n -> One v n as noFail
-
--- Always fails.
-failP :: ErrMsg -> Parser a b
-failP s = \as n -> None False (FailAt n [s] as)
-
--- Fail completely if parsing proceeds a bit and then fails
-mustAll :: Parser a b -> Parser a b
-mustAll p = \as n->
-       case p as n of
-       None False f@(FailAt x _ _) | x/=n -> None True f
-       r -> r 
-
--- If first alternative gives partial parse it's a failure
-p |!! q = mustAll p ||! q
-
--- Kleene star
-many :: Parser a b -> Parser a [b]
-many p = p `into` (\v-> many p `act` (v:))
-     ||! succeed []
-
-many1 :: Parser a b -> Parser a [b]
-many1 p = p `into` (\v-> many p `act` (v:))
-
--- Parse an exact number of items
-count :: Parser a b -> Int -> Parser a [b]
-count p 0 = succeed []
-count p k = p +.+ count p (k-1) >>> (:)
-
--- Non-empty sequence of items separated by something
-sepBy1 :: Parser a b -> Parser a c -> Parser a [b]
-p `sepBy1` q = p `into` (\v-> many (q ..+ p) `act` (v:))       -- p +.+ many (q ..+ p) >>> (:)    is slower
-
--- Sequence of items separated by something
-sepBy :: Parser a b -> Parser a c -> Parser a [b]
-p `sepBy` q = p `sepBy1` q
-          ||! succeed []
-
--- Recognize a literal token
-lit :: (Eq a, Show a) => a -> Parser [a] a
-lit x = \as n ->
-       case as of
-       a:as' | a==x -> One a (n+1) as' noFail
-       _ -> None False (FailAt n [show x] as)
-
--- Recognize a token with a predicate
-litp :: ErrMsg -> (a->Bool) -> Parser [a] a
-litp s p = \as n->
-       case as of
-       a:as' | p a -> One a (n+1) as' noFail
-       _ -> None False (FailAt n [s] as)
-
--- Generic token recognizer
-token :: (a -> Either ErrMsg (b,a)) -> Parser a b
-token f = \as n->
-       case f as of
-           Left s -> None False (FailAt n [s] as)
-           Right (b, as') -> One b (n+1) as' noFail
-
--- Test a semantic value
-testp :: String -> (b->Bool) -> Parser a b -> Parser a b
-testp s tst p = \ as n ->
-    case p as n of
-      None w f -> None w f
-      o@(One b _ _ _) -> if tst b then o else None False (FailAt n [s] as)
-      Many bas f ->
-       case [ r | r@(b, _, _) <- bas, tst b] of
-           [] -> None False (FailAt n [s] as)
-           [(x,y,z)] -> One x y z f
-           rs -> Many rs f
-
--- Try error recovery.
-recover :: Parser a b -> ([ErrMsg] -> a -> Maybe (a, b)) -> Parser a b
-recover p f = \ as n ->
-       case p as n of
-           r@(None _ fa@(FailAt n ss ts)) ->
-               case f ss ts of
-                   Nothing -> r
-                   Just (a, b) -> One b (n+1) a fa
-           r -> r
-
--- Parse, and check if it was ok.
-parse :: Parser a b -> a -> Either ([ErrMsg],a) [(b, a)]
-parse p as =
-       case p as 0 of
-           None w (FailAt _ ss ts) -> Left (ss,ts)
-           One b _ ts _            -> Right [(b,ts)]
-           Many bas _              -> Right [(b,ts) | (b,_,ts) <- bas ]
-
-sParse :: (Show a) => Parser [a] b -> [a] -> Either String b
-sParse p as =
-       case parse p as of
-           Left (ss,ts)     -> Left ("Parse failed at token "++pshow ts++", expected "++unwords ss++"\n")
-                                 where pshow [] = "<EOF>"
-                                       pshow (t:_) = show t
-           Right ((b,[]):_)  -> Right b
-           Right ((_,t:_):_) -> Left ("Parse failed at token "++show t++", expected <EOF>\n")
-
-simpleParse :: (Show a) => Parser [a] b -> [a] -> b
-simpleParse p as =
-       case sParse p as of
-       Left msg -> error msg
-       Right x -> x
diff --git a/real/rx/src/Prec.hs b/real/rx/src/Prec.hs
deleted file mode 100644 (file)
index b4cd967..0000000
+++ /dev/null
@@ -1,80 +0,0 @@
-module Prec
-
-( glue
-)
-
-where
-
-import Maybes
-
-import Syntax
-import Ids
-
-
-import Trace
-
--------------------------------------------------------------------
-
-
-glue :: [Either Exp Id] -> Exp
-
--- handle precedences of operators, input looks like
--- [ Left 3, Right (+), Left 4, Right (*), Left 7, Right (-), Left 5 ]
-
-glue [Left x] = x
-
--- glue [Left x , Right op , Left y] = App op [x, y]
-
-glue (Left x : rest) = pop (handle rest ([x], []))
-
-
-pop :: ([Exp],[Id]) -> Exp
--- pop stacks completely
-pop ([x],          []      ) = x
-pop (x : y : rest, op : ops) = pop (App op [y, x] : rest, ops)
-
-
-handle :: [Either Exp Id] -> ([Exp],[Id]) -> ([Exp],[Id])
-
-handle [] (args, ops) = (args, ops)
-handle inp @ (Right nop : Left arg : rest) (args, ops {- @ ~(op : _) -} ) = 
-    let
-        np = the (idprec nop); p = the (idprec op)
-        (op : _) = ops -- lazily (hbc doesn't like ~ patterns)
-    in
-       
---     trace ("\nhandle.inp : " ++ show inp) $
---     trace ("\nhandle.args : " ++ show args) $
---     trace ("\nhandle.ops : " ++ show ops) $
-
-       if not (null ops) && not (exists (idprec nop))
-       then error ("operator has no precedence: " ++ idname nop)
-
-       else if null ops || np > p      -- push it
-       then handle rest (arg : args, nop : ops)
-
-       else if np < p  -- pop it
-       then handle inp  ( App op [args !! 1, args !! 0] : drop 2 args
-                          , tail ops)
-
-
-       -- here, precedence levels coincide
-       -- therefore operators must be identical
-       else if nop /= op 
-       then error ("same precedences: " ++ idname nop ++ ", " ++ idname op)
-
-       -- now they are the same
-       else case idbind op of
-           Nn -> error ("not associative at all: " ++ idname op)
-           Rght -> -- push it
-               handle rest (arg : args, nop : ops)
-           Lft -> -- pop it
-               handle inp ( App op [args !! 1, args !! 0] : drop 2 args
-                          , tail ops)
-
-
-handle inp (args, ops) = 
-    error ("strange case for handle: "
-       ++ "\nhandle.inp : " ++ show inp
-       ++ "\nhandle.args : " ++ show args
-       ++ "\nhandle.ops : " ++ show ops)
diff --git a/real/rx/src/Pretty.hs b/real/rx/src/Pretty.hs
deleted file mode 100644 (file)
index 784e615..0000000
+++ /dev/null
@@ -1,350 +0,0 @@
--- this is from ghc/syslib-ghc originally, 
--- but i made some changes, marked by ???????
-
-
-
-
-module Pretty (
-
-
-       Pretty,
-
-       ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
-       ppFloat, ppDouble,
-
-       ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
-       ppSemi, ppComma, ppEquals,
-       ppBracket, ppParens, ppQuote,
-
-       ppBesideSP,     -- this wasn't exported originally, why ???????????
-
-       ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
-       ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
-       ppShow, speakNth,
-
-
-
-       -- abstract type, to complete the interface...
-       PrettyRep(..), Delay
-   ) where
-
-
-import Ratio
-
-
-import CharSeq
-
-ppNil          :: Pretty
-ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
-
-ppStr          :: [Char] -> Pretty
-ppPStr         :: String -> Pretty
-ppChar         :: Char    -> Pretty
-ppInt          :: Int     -> Pretty
-ppInteger      :: Integer -> Pretty
-ppDouble       :: Double  -> Pretty
-ppFloat                :: Float   -> Pretty
-ppRational     :: Rational -> Pretty
-
-ppBracket      :: Pretty -> Pretty -- put brackets around it
-ppParens       :: Pretty -> Pretty -- put parens   around it
-
-ppBeside       :: Pretty -> Pretty -> Pretty
-ppBesides      :: [Pretty] -> Pretty
-ppBesideSP     :: Pretty -> Pretty -> Pretty
-ppCat          :: [Pretty] -> Pretty           -- i.e., ppBesidesSP
-
-ppAbove                :: Pretty -> Pretty -> Pretty
-ppAboves       :: [Pretty] -> Pretty
-
-ppInterleave   :: Pretty -> [Pretty] -> Pretty
-ppIntersperse  :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep
-ppSep          :: [Pretty] -> Pretty
-ppHang         :: Pretty -> Int -> Pretty -> Pretty
-ppNest         :: Int -> Pretty -> Pretty
-
-ppShow         :: Int -> Pretty -> [Char]
-
-
-
-type Pretty = Int      -- The width to print in
-          -> Bool      -- True => vertical context
-          -> PrettyRep
-
-data PrettyRep
-  = MkPrettyRep        CSeq    -- The text
-               (Delay Int) -- No of chars in last line
-               Bool    -- True if empty object
-               Bool    -- Fits on a single line in specified width
-
-data Delay a = MkDelay a
-
-forceDel (MkDelay _) r = r
-
-forceBool True  r = r
-forceBool False r = r
-
-forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
-
-ppShow width p
-  = case (p width False) of
-      MkPrettyRep seq ll emp sl -> cShow seq
-
-
-
-ppNil    width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0)
-                          -- Doesn't fit if width < 0, otherwise, ppNil
-                          -- will make ppBesides always return True.
-
-ppStr  s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
-                          where ls = length s
-ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls)
-                          where ls = length s
-ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1)
-
-ppInt  n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
-                          where s = show n; ls = length s
-
-ppInteger n  = ppStr (show n)
-ppDouble  n  = ppStr (show n)
-ppFloat   n  = ppStr (show n)
-
-ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
-
-ppSP     = ppChar ' '
-pp'SP    = ppStr ", "
-ppLbrack  = ppChar '['
-ppRbrack  = ppChar ']'
-ppLparen  = ppChar '('
-ppRparen  = ppChar ')'
-ppSemi    = ppChar ';'
-ppComma   = ppChar ','
-ppEquals  = ppChar '='
-
-ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack)
-ppParens  p = ppBeside ppLparen (ppBeside p ppRparen)
-ppQuote   p = ppBeside (ppChar '`') (ppBeside p (ppChar '\''))
-
-ppInterleave sep ps = ppSep (pi ps)
-  where
-   pi []       = []
-   pi [x]      = [x]
-   pi (x:xs)   = (ppBeside x sep) : pi xs
-
-ppIntersperse sep ps = ppBesides (pi ps)
-  where
-   pi []       = []
-   pi [x]      = [x]
-   pi (x:xs)   = (ppBeside x sep) : pi xs
-
-ppBeside p1 p2 width is_vert
-  = case (p1 width False) of
-      MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
-         MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2))
-                     (MkDelay (ll1 + ll2))
-                     (emp1 && emp2)
-                     ((width >= 0) && (sl1 && sl2))
-                     -- This sequence of (&&)'s ensures that ppBeside
-                     -- returns a False for sl as soon as possible.
-       where -- NB: for case alt
-        seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
-        MkDelay ll2 = x_ll2
-        MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False
-        -- ToDo: if emp{1,2} then we really
-        -- should be passing on "is_vert" to p{2,1}.
-
-ppBesides [] = ppNil
-ppBesides ps = foldr1 ppBeside ps
-
-ppBesideSP p1 p2 width is_vert
-  = case (p1 width False) of
-      MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
-         MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2)))
-                  (MkDelay (li + ll2))
-                  (emp1 && emp2)
-                  ((width >= wi) && (sl1 && sl2))
-       where -- NB: for case alt
-        seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
-        MkDelay ll2 = x_ll2
-        MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
-        li, wi :: Int
-        li = if emp1 then 0 else ll1+1
-        wi = if emp1 then 0 else 1
-        sp = if emp1 || emp2 then cNil else (cCh ' ')
-
-ppCat []  = ppNil
-ppCat ps  = foldr1 ppBesideSP ps
-
-ppAbove p1 p2 width is_vert
-  = case (p1 width True) of
-      MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
-         MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2))
-                     (MkDelay ll2)
-                     -- ToDo: make ll depend on empties?
-                     (emp1 && emp2)
-                     False
-       where -- NB: for case alt
-        nl = if emp1 || emp2 then cNil else cNL
-        seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
-        MkDelay ll2 = x_ll2 -- Don't "optimise" this away!
-        MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True
-            -- ToDo: ditto about passing is_vert if empties
-
-ppAboves [] = ppNil
-ppAboves ps = foldr1 ppAbove ps
-
-ppNest n p width False = p width False
-ppNest n p width True
-  = case (p (width-n) True) of
-      MkPrettyRep seq (MkDelay ll) emp sl ->
-       MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl
-
-ppHang p1 n p2 width is_vert   -- This is a little bit stricter than it could
-                               -- be made with a little more effort.
-                               -- Eg the output always starts with seq1
-  = case (p1 width False) of
-      MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
-         if emp1 then
-             p2 width is_vert
-         else
-         if (ll1 <= n) || sl2 then     -- very ppBesideSP'ish
-             -- Hang it if p1 shorter than indent or if it doesn't fit
-             MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
-                       (MkDelay (ll1 + 1 + ll2))
-                       False
-                       (sl1 && sl2)
-         else
-             -- Nest it (pretty ppAbove-ish)
-             MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
-                       (MkDelay ll2') -- ToDo: depend on empties
-                       False
-                       False
-       where -- NB: for case alt
-        seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
-        MkDelay ll2 = x_ll2
-        MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
-            -- ToDo: more "is_vert if empty" stuff
-
-        seq2' = forceInfo x_ll2' emp2' sl2' x_seq2'
-        MkDelay ll2' = x_ll2'          -- Don't "optimise" this away!
-        MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False     -- ToDo: True?
-
-ppSep []  width is_vert = ppNil width is_vert
-ppSep [p] width is_vert = p     width is_vert
-
-
-{-
--- CURRENT, but BAD.  Quadratic behaviour on the perfectly reasonable
---     ppSep [a, ppSep[b, ppSep [c, ... ]]]
-
-ppSep ps  width is_vert
-  = case (ppCat ps width is_vert) of
-      MkPrettyRep seq x_ll emp sl ->
-       if sl then                      -- Fits on one line
-          MkPrettyRep seq x_ll emp sl
-       else
-          ppAboves ps width is_vert    -- Takes several lines
--}
-
--- a different attempt:
-ppSep ps @ (p : q : qs)  width is_vert = 
-  let (as, bs) = splitAt (length ps `div` 2) ps
-  in
-   case (ppSep as width False, ppSep bs width False) of
-      ( MkPrettyRep seq1 x_ll1 emp1 sl1 , MkPrettyRep seq2 x_ll2 emp2 sl2 ) ->
-       if {- sl1  && -} sl2 &&  (ll1 + ll2 < width)
-       then MkPrettyRep 
-               (seq1 `cAppend` (cCh ' ' `cAppend` (cIndent (ll1 + 1) seq2)))
-               (MkDelay (ll1 + 1 + ll2))
-               (emp1 && emp2)
-               sl1
-       else MkPrettyRep 
-               (seq1 `cAppend` (cNL `cAppend` seq2))
-               x_ll2
-               (emp1 && emp2)
-               False
-       where MkDelay ll1 = x_ll1; MkDelay ll2 = x_ll2
-
-
-
-
-speakNth :: Int -> Pretty
-
-speakNth 1 = ppStr "first"
-speakNth 2 = ppStr "second"
-speakNth 3 = ppStr "third"
-speakNth 4 = ppStr "fourth"
-speakNth 5 = ppStr "fifth"
-speakNth 6 = ppStr "sixth"
-speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
-  where
-    st_nd_rd_th | n_rem_10 == 1 = "st"
-               | n_rem_10 == 2 = "nd"
-               | n_rem_10 == 3 = "rd"
-               | otherwise     = "th"
-
-    n_rem_10 = n `rem` 10
-
-
-
--- from Lennart
-fromRationalX :: (RealFloat a) => Rational -> a
-
-fromRationalX = error "Pretty.fromRationalX"
-{-
-fromRationalX r =
-       let
-           h = ceiling (huge `asTypeOf` x)
-           b = toInteger (floatRadix x)
-           x = fromRat 0 r
-           fromRat e0 r' =
-               let d = denominator r'
-                   n = numerator r'
-               in  if d > h then
-                      let e = integerLogBase b (d `div` h) + 1
-                      in  fromRat (e0-e) (n % (d `div` (b^e)))
-                   else if abs n > h then
-                      let e = integerLogBase b (abs n `div` h) + 1
-                      in  fromRat (e0+e) ((n `div` (b^e)) % d)
-                   else
-                      scaleFloat e0 (fromRational r')
-       in  x
--}
-
--- Compute the discrete log of i in base b.
--- Simplest way would be just divide i by b until it's smaller then b, but that would
--- be very slow!  We are just slightly more clever.
-integerLogBase :: Integer -> Integer -> Int
-integerLogBase b i =
-     if i < b then
-       0
-     else
-       -- Try squaring the base first to cut down the number of divisions.
-       let l = 2 * integerLogBase (b*b) i
-
-           doDiv :: Integer -> Int -> Int
-           doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
-       in
-       doDiv (i `div` (b^l)) l
-
-
-------------
-
--- Compute smallest and largest floating point values.
-{-
-tiny :: (RealFloat a) => a
-tiny =
-       let (l, _) = floatRange x
-           x = encodeFloat 1 (l-1)
-       in  x
--}
-
-huge :: (RealFloat a) => a
-huge =
-       undefined
-{-
-       let (_, u) = floatRange x
-           d = floatDigits x
-           x = encodeFloat (floatRadix x ^ d - 1) (u - d)
-       in  x
--}
diff --git a/real/rx/src/PrettyClass.hs b/real/rx/src/PrettyClass.hs
deleted file mode 100644 (file)
index bb099b1..0000000
+++ /dev/null
@@ -1,125 +0,0 @@
-module PrettyClass
-
-( PrettyClass (..)
-
-, ppSepp
-
-, tabstop
-, linewidth
-
-, alParens, alBrackets, alBraces
-, ppCommas
-, emitascii, emitlatex
-
-, ppSep2
-)
-
-where
-
-import Options
-
-import Pretty -- hslibs/ghc/src/Pretty.lhs, with modifications
-
-tabstop = 4 :: Int
-linewidth = 75 :: Int
-
-------------------------------------------------------------------------
-
-
-alParens opts p = 
-    caseopts opts "code"
-       [ ("plain", ppBesides 
-               [ ppStr "(", ppNest tabstop p, ppStr ")" ])
-       , ("latex", ppBesides 
-               [ ppStr "\\left(", ppNest tabstop p, ppStr "\\right)" ])
-       ]
-
-alBrackets opts p =
-    caseopts opts "code"
-       [ ("plain", ppBesides 
-               [ ppStr "[", ppNest tabstop p, ppStr "]" ])
-       , ("latex", ppBesides 
-               [ ppStr "\\left[", ppNest tabstop p, ppStr "\\right]" ])
-       ]
-
-alBraces opts p =
-    caseopts opts "code"
-       [ ("plain", ppBesides 
-               [ ppStr "{", ppNest tabstop p, ppStr "}" ])
-       , ("latex", ppBesides 
-               [ ppStr "\\left\\{", ppNest tabstop p, ppStr "\\right\\}" ])
-       ]
-
---------------------------------------------------------------------------
-
-x `ppSep2` y = ppSep [x, y]
-
-ppSepp :: [ Pretty ] -> Pretty
-ppSepp [] = ppNil
-ppSepp xs = 
-    let l = length xs
-       (as, bs) = splitAt (l `div` 2) xs
-    in case xs of
-       [x] -> x
-       _ -> ppSepp as `ppSep2` ppSepp bs
-       
-
-ppInterleave2 :: Pretty -> [Pretty] -> Pretty
-ppInterleave2 p [] = ppNil
-ppInterleave2 p qs = ppi2 False p qs
-
-ppi2 finis p qs = 
-    let l = length qs
-       (as, bs) = splitAt (l `div` 2) qs
-    in         case qs of [q] -> if finis then q `ppBeside` p else q
-                  [ ] -> error "ppInterleave2"
-                  _   -> ppi2 True p as `ppSep2` ppi2 finis p bs
-
-
----------------------------------------------------------------------
-
-
-class PrettyClass a where
-       -- prettyprint
-       pp :: Opts -> a -> Pretty
-
-       -- prettyprint, with precedence
-       ppp :: Opts -> Int -> a -> Pretty
-
-       -- default methods
-       pp opts = ppp opts 0
-       ppp opts n = pp opts
-
-optslatex = listToOpts [("code","latex")]
-optsplain = listToOpts [("code","plain")]
-
-
-emitascii  :: PrettyClass a => a -> ShowS
-emitascii x cs = ppShow linewidth (pp optsplain x) ++ cs
-
-emitlatex  :: PrettyClass a => a -> ShowS
-emitlatex x cs = ppShow linewidth (pp optslatex x) ++ cs
-
-
---------------------------------------------------------------------------
-
-instance PrettyClass Int  where pp opts n = ppStr (show n)
-instance PrettyClass Char  where pp opts n = ppStr (show n)
-instance PrettyClass Float  where pp opts n = ppStr (show n)
-instance PrettyClass Bool where pp opts n = ppStr (show n)
-
-ppCommas pps = ppInterleave2 ppComma pps
-
-instance PrettyClass a => PrettyClass [a] where
-    pp opts xs = alBrackets opts 
-       (ppCommas (map (pp opts) xs))
-
-instance (PrettyClass a, PrettyClass b) => PrettyClass (a, b) where
-    pp opts (x, y) = alParens opts 
-       (ppCommas [pp opts x, pp opts y])
-
-instance (PrettyClass a, PrettyClass b, PrettyClass c) 
-       => PrettyClass (a, b, c) where
-    pp opts (x, y, z) = alParens opts 
-       (ppCommas [pp opts x, pp opts y, pp opts z])
-
diff --git a/real/rx/src/RX.hs b/real/rx/src/RX.hs
deleted file mode 100644 (file)
index d61b55c..0000000
+++ /dev/null
@@ -1,22 +0,0 @@
-module Main (main) where
-
-
-import FA (hsTNFA)
-
-import Heave 
-import Loop
-
-import Gen
-import Defaults
-
-
-gmain :: String -> IO ()
--- give argument string, as you would on the command line
-gmain args = gheave opts0 
-       (expformat hsTNFA genval) (genpid, genenv) args
-
-main :: IO ()
--- reads command line
-main = heave opts0 
-       (expformat hsTNFA genval) (genpid, genenv)
-
diff --git a/real/rx/src/Reader.hs b/real/rx/src/Reader.hs
deleted file mode 100644 (file)
index a7b381e..0000000
+++ /dev/null
@@ -1,38 +0,0 @@
-module Reader
-
-( rg   -- reads a grammar from a string
-       -- returns corresponding deterministic automaton
-)
-
-where
-
-import ExpParse (pline)
-
-import FiniteMap
-
-import Options
-import Defaults
-
-import Ids
-import IdStack
-import Gen
-
-import FA
-import FAtypes
-import Gram2FA
-
-import Syntax
-import Semantik
-
---------------------------------------------------------------------
-
-rg :: String -> BDFA Int
-rg cs = 
-    let
-       (Just x, _) = pline (opts0, genpid) cs
-       g = docomp opts0 genenv x
-               
-    in
-       t2d opts0 g
-
-
diff --git a/real/rx/src/Reuse.hs b/real/rx/src/Reuse.hs
deleted file mode 100644 (file)
index 571a3f4..0000000
+++ /dev/null
@@ -1,70 +0,0 @@
-module Reuse
-
-( reuse
-
-)
-
-where
-
-import Trace
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-
-import FAmap
-import FAkeepst
-
-reuse :: Opts -> TNFA Int -> [Int] -> TNFA Int
-
-
--- replace some of the states used in |news|
--- by eps moves to states already used in |moves|
-
-reuse1 opts a @ (TNFA cons all starts moves) addons =
-
-    let
-       rmoves = invert moves
-
-       -- find possible covers for addon state b
-
-       -- relies on strange behaviour of 
-       -- intersectManySets [] = emptySet
-       cands b = intersectManySets
-               [ lookupset rmoves t `minusSet` unitSet b
-               | t <- setToList (lookupset moves b)
-               ]
-               
-       bas = listToFM  
-               [ (b, head as)
-               | b <- addons
-               , let as = setToList (cands b)
-               , not (null as)
-               ]
-
-       f x = lookupWithDefaultFM bas x x
-
-       nobs = all `minusSet` mkSet (keysFM bas)
-
-       a1 = keepstTNFA opts a nobs 
-       a2 = mapTNFA opts f a1
-
-    in
-
-       trace ("Reuse.reuse1.moves = " ++ show moves) $
-       trace ("Reuse.reuse1.bas = " ++ show bas) $
-       trace ("Reuse.reuse1.nobs = " ++ show nobs) $
-
-       a2
-
-
-
-reuse opts a addons = fixpoint (\ b -> reuse1 opts b addons) a
-       
diff --git a/real/rx/src/SaturnS.hs b/real/rx/src/SaturnS.hs
deleted file mode 100644 (file)
index 50a3260..0000000
+++ /dev/null
@@ -1,182 +0,0 @@
-module SaturnS
-
-( saturnS
-, saturnSpublic
-)
-
--- checks whether a given grammar
--- is forward saturated under reduction
--- in the system   S x y z   <->   x z (y z)
-
--- i. e. each state that produces a redex
--- must also produce its contractum (and back)
-
-
--- this implementation is ugly ugly ugly
--- w.r.t. the rest of the system
--- the reduction rule of S is hardwired
--- as are the names of the constructors (S and @)
-
-where
-
-import Trace
-
-import Set
-import FiniteMap
-
-import Stuff
-import Options
-
-import TA
-import FAtypes
-import Ids
-
-import FAmin
-import FAuseful
-
-import FAcon
-
-import FAneg
-import FAintersect
-import FAunion
-
--- import Reuse
-
-sons :: TNFA Int -> Int -> [(Int, Int)]
-sons (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "CForwardS.sons.ts") p
-       lrs =   [ (l, r) 
-               | t <- setToList ts
-               , tconname (stcon t) == "@"
-               , let [l, r] = stargs t
-               ]
-    in
-       lrs
-
-
-
-leaves :: TNFA Int -> Int -> [()]
-leaves (TNFA cons all starts moves) p =
-    let
-       ts = lookupWithDefaultFM moves (error "CForwardS.leaves.ts") p
-       lrs =   [ () 
-               | t <- setToList ts
-               , tconname (stcon t) == "S"
-               ]
-    in
-       lrs
-
-
-
-stackit txyzs = addListToFM_C unionSet emptyFM 
-       [ (xyz, unitSet t) | (t, xyz) <- txyzs ]
-
-
-
-saturnS :: Opts -> TNFA Int -> TNFA Int
--- look for all matches of S x y z (successively)
--- add new states from that to x z (y z) 
-saturnS opts a @ (TNFA cons all starts moves) =
-    let        
-
-       redexquads =    [ (t0, (x, y, z))
-               | t0 <- setToList all
-               , (t1, z) <- sons a t0
-               , (t2, y) <- sons a t1
-               , (t3, x) <- sons a t2
-               , ()     <- leaves a t3 -- this looks for S
-               ]
-
-       redexes = stackit redexquads
-
-
-        contraquads = [ (t0, (ll, rl, rr))
-                | t0 <- setToList all
-                , (l, r) <- sons a t0
-                , (ll, lr) <- sons a l
-                , (rl, rr) <- sons a r
-                , lr == rr      -- these are the two z's
-                ]
-
-       contras = stackit contraquads
-
-       purgeFM = filterFM (\ k e -> not (isEmptySet e))
-
-
-       nof = purgeFM $ addListToFM_C minusSet redexes (fmToList contras)
-       nob = purgeFM $ addListToFM_C minusSet contras (fmToList redexes)
-       
-       nofs = (keysFM nof)
-       nobs = (keysFM nob)
-
-       -- this is a bit ugly
-       -- need to find the complete id information for the constructors
-       -- we hope they are there
-       ap = head [ con | con <- setToList cons, tconname con == "@" ]
-       s  = head [ con | con <- setToList cons, tconname con == "S" ]
-
-
-       -- next free state
-       next = 1 + maximum (setToList all)
-
-
-       mksterm' c args = unitSet (mksterm c args)
-
-       mkredex (x, y, z) = listToFM
-               [ (next + 0, mksterm' ap [next + 3, z])
-               , (next + 1, mksterm' s [])
-               , (next + 2, mksterm' ap [next + 1, x])
-               , (next + 3, mksterm' ap [next + 2, y])
-               ]
-
-       mkcontra (x, y, z) = listToFM
-               [ (next + 0, mksterm' ap [next + 1, next + 2])
-               , (next + 1, mksterm' ap [x, z])
-               , (next + 2, mksterm' ap [y, z])
-               ]
-
-       nofx = [ ("no contractum for:"
-               , unitSet next
-                , plusFM_C (error "SaturnS.nofs") moves (mkredex xyz)
-                )
-               | xyz <- nofs ]
-
-       nobx = [ ("no redex for:" 
-               , unitSet next
-               , plusFM_C (error "SaturnS.nobs") moves (mkcontra xyz)
-               )
-               | xyz <- nobs ]
-
-       okeh = [ ("everything closed", starts, emptyFM) ]
-       
-       (msg, starts', moves') = head (nofx ++ nobx ++ okeh)
-
-    in
-
-       trace ("redexes: " ++ show redexes) $
-       trace ("contras: " ++ show contras) $
-
-       trace ("redexes w/o contra: = " ++ show nofs) $
-       trace ("contras w/o redex : = " ++ show nobs) $
-
-       trace ("SaturnS : " ++ msg) $
-
-       TNFA cons (all `unionSet` mkSet (keysFM moves')) starts' moves'
-
-
-
-
-
-
-saturnSpublic :: Opts -> [ TNFA Int ] -> TNFA Int
-
-saturnSpublic opts args =
-    if length args /= 1 
-    then error "saturnSpublic.args"
-    else 
-       let [arg1] = args
-       in  saturnS opts arg1
-
-
-
diff --git a/real/rx/src/Semantik.hs b/real/rx/src/Semantik.hs
deleted file mode 100644 (file)
index 1c0780a..0000000
+++ /dev/null
@@ -1,202 +0,0 @@
--- C-like imperative semantics:
-
--- expressions have values and side effects (that modify the environment)
--- and they may do output
-
-module Semantik 
-
-( Env
-
-, FIO, unFIO, forceFIO
-
-, oops
-, moops
-
-, Fun, mkFun, mkfunction
-
-, vargs
-
-, comp
-, docomp
-
-)
-
-where
-
-import Maybes
-
-import Options
-
-import FiniteMap -- syslib ghc
-
-import Syntax
-import Ids
-
-import FAcon
-
-
--- identifiers are bound to functions from Exp^* -> a
--- that is they see the literal form of their arguments
--- they need to evaluate them if they want
--- this is like lisp and allows for (setq foo bar)
-
-newtype FIO s = FIO (Either String s); unFIO (FIO n) = n
-
-instance Functor FIO where
-    fmap f (FIO (Left l)) = FIO (Left l)
-    fmap f (FIO (Right r)) = FIO (Right (f r))
-
-instance Monad FIO where
-    return x = FIO (Right x)
-    FIO (Left l) >>= f = FIO (Left l)
-    FIO (Right r) >>= f = f r
-
--- instance MonadPlus FIO where
---    mzero = FIO (Left "some error")
-
-oops :: String -> FIO a
-oops cs = FIO (Left cs)
-
-moops :: Bool -> String -> FIO ()
-moops p cs = if p then oops cs else return ()
-
-forceFIO :: FIO a -> a
-forceFIO (FIO (Left l)) = error ("error (FIO): " ++ l)
-forceFIO (FIO (Right r)) = r
-
-
--- only look at the result
-docomp opts env arg = 
-    forceFIO (do { (x, env') <- comp opts env arg; return x } )
-
-
-
--------------------------------------------------------------------
-
-type Env e a = FiniteMap String (Fun e a)
-
-data Fun e a = Fun (Opts -> Env e a -> [Exp] -> FIO (a, Env e a))
-mkFun f = Fun f; unFun (Fun f) = f
-
-
---------------------------------------------------------------------
-
--- a plain function that evaluates its arguments
-
--- mkfunction :: String -> ([a] -> a) -> Fun e a
-mkfunction name f = Fun (\ opts env args -> 
-
-    do { troff opts ("\nentered: " ++ name) (return ())
-       ; (vals, env1) <- vargs opts env args
-       ; return (f opts vals, env1)    -- todo: really env1 here?
-       } )
-
-
-----------------------------------------------------------------------
-
--- evaluate a list of expressions from left to right
--- return list of results
--- thread state through
-
--- vargs :: Opts -> Env e a -> [Exp] -> FIO ([a], Env e a)
-vargs opts env [] = return ([], env)
-vargs opts env (x : xs) = 
-    do { (y, env1) <- comp opts env x
-       ; (ys, env2) <- vargs opts env1 xs
-       ; return (y : ys, env2)
-       }
-
-
--- a computation
--- has a result
--- maybe changes the environment
--- maybe does some FIO
--- sequential composition ";" and assignment "=" are wired in
-
--- comp :: Opts -> Env e a -> Exp -> FIO (a, Env e a)
-
-comp opts env (App id args) | idname id == ";" =
-    do { (xs, env1) <- vargs opts env args
-       ; return (last xs, env1)
-       }
-
-comp opts env x @ (App id args) | idname id == "=" =
-    do { moops (length args /= 2)
-               ( "(=) needs exactly two arguments: " ++ show x )
-       ; let [lhs, rhs] = args
-
-       ; case lhs of
-           App id locs -> compbind opts env x (idname id) locs rhs
-           _ -> oops ( "lhs of (=) must be application of function or operator: " ++ show x )
-       }
-
-comp opts env x @ (App id args) =
-
-    troff opts ("\ncomp: " ++ show x ) $
-
-    let name = idname id in case lookupFM env name of
-       Just f -> unFun f opts env args
-       Nothing -> -- oops ("identifier " ++ name ++ " not bound")
-               -- NO, rather: unbound ids are treated as constructors
-
-               -- todo: this breaks the abstraction
-           do  { (vs, env1) <- vargs opts env args
-               ; return (conTNFA opts id vs, env1)
-               }
-
-
-compbind opts env x name locs rhs = 
-    do { moops (exists (lookupFM env name))
-               ( "identifier already bound: " ++ show x )
-       
-       ; if null locs 
-         then define_value    opts env name rhs        -- see below
-         else define_function opts env x name locs rhs -- see below
-       }
-
--------------------------------------------------------------------
-
-mkconst :: a -> Fun e a
-mkconst x =  Fun ( \ opts env args -> do       
-       { moops (not (null args)) 
-               ("a constant cannot have args: " ++ show args)
-       ; return (x, env)
-       } )
-
--- a value (function with 0 args) is evaluated right now
-define_value opts env name rhs =
-    do { (v, env1) <- comp opts env rhs -- env1 is ignored
-       ; let val = mkconst v
-       ; let env2 = addToFM env name val
-       ; return (v, env2)
-       }
-
--- a `real' function (with > 0 args) is stored as closure
-define_function opts env x name lhsargs rhs =
-    do { moops (any (not . isAppId) lhsargs) 
-               ( "local args must be ids: " ++ show x )
-       ; let locs = map (idname . unAppId) lhsargs
-
-       -- here's the semantics of a function call
-       ; let val = Fun (\ opts env1 args1 -> do        
-               -- evaluate args in caller's environment
-               { (vs, env2) <- vargs opts env1 args1
-               ; moops (length vs /= length locs)
-                       ( "wrong number of args: " ++ show args1
-                         ++ ", should be " ++ show (length locs) )
-               -- local bindings over callee's environment
-               ; let bnds = listToFM (zip locs (map mkconst vs))
-               ; let env3 = env1 `plusFM` bnds
-               ; (v, env4) <- comp opts env3 rhs
-               -- return caller's environment
-               ; return (v, env2)
-               } )
-
-       ; let env1 = addToFM env name val
-
---     ; return (undefined, env1)      -- todo: what to return here?
-       ; return (conTNFA opts (usercon 0 "defined") [], env1)  
-
-       }
-
-
diff --git a/real/rx/src/Set.hs b/real/rx/src/Set.hs
deleted file mode 100644 (file)
index df27c29..0000000
+++ /dev/null
@@ -1,124 +0,0 @@
--- this is from ghc/syslib-ghc
-
--- this is patched !!!
-
--- renamed union -> unionSet, intersect -> intersectSet
--- because it clashes with List.hs
-
--- included filterSet function
--- included mergeFM function
-
--- added some specialisations
-
-module Set (
-       -- not a synonym so we can make it abstract
-       Set,
-
-       mkSet, setToList, emptySet, singletonSet, unitSet,
-       unionSet, unionManySets, minusSet,
-       elementOf, mapSet,
-       intersectSet, isEmptySet,
-       intersectManySets,
-       cardinality,
-       
-       filterSet,
-
-       mergeFM
-
-    ) where
-
-
-import FiniteMap
-import Maybes
-
-
-infixl 5 `unionSet`
-infixl 6 `intersectSet`
-
-
--- import TA -- for specializations
-
--- just to see if and how this works
-
-{- # SPECIALIZE mkSet :: [Int] -> Set Int #-}
-{- # SPECIALIZE mkSet :: [(Int, Int)] -> Set (Int, Int) #-}
-{- # SPECIALIZE mkSet :: [STerm Int] -> Set (STerm Int) #-}
-
-{- # SPECIALIZE setToList :: Set Int -> [Int] #-}
-{- # SPECIALIZE setToList :: Set (Int, Int) -> [(Int, Int)] #-}
-{- # SPECIALIZE setToList :: Set (STerm Int) -> [(STerm Int)] #-}
-
---------------------------------------------------------------------
-
--- This can't be a type synonym if you want to use constructor classes.
-newtype Set a = MkSet (FiniteMap a ())
-
-emptySet :: Set a
-emptySet = MkSet emptyFM
-
-unitSet :: a -> Set a
-unitSet x = MkSet (unitFM x ())
-singletonSet = unitSet -- old;deprecated?
-
-setToList :: Set a -> [a]
-setToList (MkSet set) = keysFM set
-
-mkSet :: Ord a => [a]  -> Set a
-mkSet xs = MkSet (listToFM [ (x, ()) | x <- xs])
-
-unionSet :: Ord a => Set a -> Set a -> Set a
-unionSet (MkSet set1) (MkSet set2) = MkSet (plusFM set1 set2)
-
-unionManySets :: Ord a => [Set a] -> Set a
-unionManySets ss = foldr unionSet emptySet ss
-
-minusSet  :: Ord a => Set a -> Set a -> Set a
-minusSet (MkSet set1) (MkSet set2) = MkSet (minusFM set1 set2)
-
-intersectSet :: Ord a => Set a -> Set a -> Set a
-intersectSet (MkSet set1) (MkSet set2) = MkSet (intersectFM set1 set2)
-
-intersectManySets :: Ord a => [Set a] -> Set a
-intersectManySets [] = emptySet -- STRANGE
-intersectManySets ss = foldr1 intersectSet ss
-
-elementOf :: Ord a => a -> Set a -> Bool
-elementOf x (MkSet set) = exists (lookupFM set x)
-
-isEmptySet :: Set a -> Bool
-isEmptySet (MkSet set) = sizeFM set == 0
-
-mapSet :: Ord a => (b -> a) -> Set b -> Set a
-mapSet f (MkSet set) = MkSet (listToFM [ (f key, ()) | key <- keysFM set ])
-
-cardinality :: Set a -> Int
-cardinality (MkSet set) = sizeFM set
-
-filterSet :: Ord a => (a -> Bool) -> Set a -> Set a
-filterSet p (MkSet set) = MkSet (filterFM (\ x _ -> p x) set)
-
-
-mergeFM :: (Ord a, Ord b) => 
-       FiniteMap a (Set b) -> FiniteMap a (Set b) -> FiniteMap a (Set b)
-mergeFM l r = plusFM_C unionSet l r
-
-
--- fair enough...
-instance (Eq a) => Eq (Set a) where
-  (MkSet set_1) == (MkSet set_2) = set_1 == set_2
-  (MkSet set_1) /= (MkSet set_2) = set_1 /= set_2
-
--- but not so clear what the right thing to do is:
-{- NO:
-instance (Ord a) => Ord (Set a) where
-  (MkSet set_1) <= (MkSet set_2) = set_1 <= set_2
--}
-
-instance Ord a => Ord (Set a) where
-       s <= t = setToList s <= setToList t
-
-
-instance Show a => Show (Set a) where 
-    showsPrec p s = 
-       showsPrec p (setToList s)
-
diff --git a/real/rx/src/Sorters.hs b/real/rx/src/Sorters.hs
deleted file mode 100644 (file)
index ff9804b..0000000
+++ /dev/null
@@ -1,138 +0,0 @@
-module Sorters 
-
-( msort, msortwith
-, oemerge, oemerges
-, unimerge, unimerges
-, diff, dsplit
-, uniq, us
-, Plug(..), unplug
-) 
-
-where
-
-import Trace
-
-infixl 5 `oemerge`
-infixl 5 `unimerge`
-
-msort :: Ord a => [a] -> [a]
-msort = oemerges . runs                -- todo: which is better?
-       -- mrgsort
-       
-
--- utilities for sorting and merging -----------------------------------
-
--- find runs
-runs :: Ord a => [a] -> [[a]]
-runs [] = []
-runs [x] = [[x]]
-runs (x : xs) = 
-    let        rrs @ (r @ (y:_) : rs) = runs xs
-    in if x <= y then (x : r) : rs
-       else [x] : rrs
-
-
-mrgsort :: Ord a => [a] -> [a]
-mrgsort [] = []; mrgsort [x] = [x]
-mrgsort [x,y] = if x < y then [x,y] else [y,x]
-mrgsort xs = 
-    let (as, bs) = conquer xs
-    in oemerge (mrgsort as) (mrgsort bs)
-
-conquer [] = ([],[])
-conquer [x] = ([x], [])
-conquer (x : y : zs) = let (as, bs) = conquer zs in (x : as, y : bs)
-
-
-
-
-oemerge :: Ord a => [a] -> [a] -> [a]
--- keeps duplicates
-oemerge [] ys = ys; oemerge xs [] = xs
-oemerge xxs @ (x : xs) yys @ (y : ys) = 
-    if x < y then x : oemerge xs yys else y : oemerge xxs ys
-
-
-oemerges :: Ord a => [[a]] -> [a]
-oemerges [] = []
-oemerges [xs] = xs
-oemerges [xs,ys] = oemerge xs ys
-oemerges xss = 
-       let (ass, bss) = conquer xss
-       in oemerge (oemerges ass) (oemerges bss)
-
-
-unimerge :: Ord a => [a] -> [a] -> [a]
--- removes duplicates
-unimerge xs [] = xs; unimerge [] ys = ys
-unimerge xxs @ (x : xs) yys @ (y : ys) = case compare x y of
-       LT -> x : unimerge xs yys
-       GT -> y : unimerge xxs ys
-       EQ -> x : unimerge xs ys
-
-unimerges :: Ord a => [[a]] -> [a]
--- removes duplicates
-unimerges [] = []
-unimerges [xs] = xs
-unimerges [xs,ys] = unimerge xs ys
-unimerges xss = 
-       let (ass, bss) = conquer xss
-       in unimerge (unimerges ass) (unimerges bss)
-
-
-
-
-uniq :: Ord a => [a] -> [a]
--- arg must be sorted already
-uniq [] = []; uniq [x] = [x]
-uniq (x : yys @ (y : ys)) 
-    = (if x == y then id else (x :)) (uniq yys)
-
-us :: Ord a => [a] -> [a]
-us = uniq . msort
-
-diff :: Ord a => [a] -> [a] -> [a]
--- diff xs ys = all x <- xs that are not in ys
--- args must be sorted, without duplicates
-diff [] ys = []; diff xs [] = xs
-diff xxs @ (x : xs) yys @ (y : ys)
-    | x == y    =     diff  xs  ys
-    | x < y     = x : diff  xs yys
-    | otherwise =     diff xxs  ys
-dsplit :: Ord a => [a] -> [a] -> ([a],[a])
--- dsplit xs ys = (as, bs) where as = xs intersect ys, bs = xs setminus ys
-dsplit [] ys = ([], [])
-dsplit xs [] = ([], xs)
-dsplit xxs @ (x : xs) yys @ (y : ys)
-       | x == y    = let (as, bs) = dsplit xs  ys in (x : as, bs)
-       | x <  y    = let (as, bs) = dsplit xs yys in (    as, x : bs)
-       | otherwise = let (as, bs) = dsplit xxs ys in (    as, bs)
-
----------------------------------------------------------------------
-
-best :: Ord a => [a] -> [a]
-best = take 1 . reverse . msort
-
----------------------------------------------------------------------
-
-asc :: Ord b => [(a, b)] -> [(a, b)]
--- show successive maxima, lazily
-asc [] = []
-asc ((x, c) : xs) = (x, c) : asc [ (x', c') | (x', c') <- xs, c' > c ]
-
-ascWith :: Ord b => (a -> b) -> [a] -> [a]
-ascWith f xs = [ x | (x, c) <- asc [ (x, f x) | x <- xs ] ]
-
-
------------------------------------------------------------------------
-
-data Plug a b = Plug a b deriving Show
-
-instance Eq a => Eq (Plug a b) where Plug x _ == Plug y _ = x == y
-instance Ord a => Ord (Plug a b) where Plug x _ < Plug y _ = x < y
-
-unplug :: Plug a b -> b; unplug (Plug x y) = y
-
-msortwith :: Ord b => (a -> b) -> [a] -> [a]
-msortwith f xs = map unplug . msort $ [ Plug (f x) x | x <- xs ]
diff --git a/real/rx/src/State.hs b/real/rx/src/State.hs
deleted file mode 100644 (file)
index 9f7de56..0000000
+++ /dev/null
@@ -1,39 +0,0 @@
-module State
-
-( Sym, dosym
-, gensym, push
-)
-
-where
-
-
--- state Monad ----------------------------------------------------
-
-data Sym s a = Sym (s -> (s, a))
-
-dosym :: Sym (Int, [s]) a -> (a, [s])
--- start computation, show effect
-dosym (Sym f) = let ((_, x), r) = f (0, []) in (r, x)
-
-instance Functor (Sym s) where 
-       fmap f (Sym s) = Sym (\ c -> 
-               let (d, a) = s c in (d, f a) )
-
-instance Monad (Sym s) where
-    return x = Sym (\ c -> (c, x))
-    Sym x >>= f = Sym (\ c -> 
-
--- phorward state is this:
-       let (d, r) = x c; Sym y = f r; (e, s) = y d in (e, s) )
-
--- but we're using backward state (NOT)
---     let (d, s) = y c; Sym y = f r; (e, r) = x d in (e, s) )
-
--- used for symbol supply
-gensym :: Sym (Int, a) String
-gensym = Sym (\ (c,x) -> ((c+1,x), "$" ++ show c))
-
--- remember a result
-push :: a -> Sym (b, [a]) ()
-push x = Sym ( \ (c, xs) -> ((c, x : xs), () ))
-
diff --git a/real/rx/src/Stuff.hs b/real/rx/src/Stuff.hs
deleted file mode 100644 (file)
index 43a1b0b..0000000
+++ /dev/null
@@ -1,134 +0,0 @@
-module Stuff
-
-( bind
-, fixpoint
-, sethull
-, zippy
-, lookupset
-, invert
-, packs
-, insts
-, collectFM
-
-, exists
-, the
-
-, inits
-, tails
-, intersperse
-
-, partition
-)
-
-where
-
-import Set
-import FiniteMap
-
--- hbc complains
-
-{- # SPECIALIZE instance Eq (Set Int) #-}
-{- # SPECIALIZE instance Ord (Set Int) #-}
-
-{- # SPECIALIZE instance Eq (Set (Int, Int)) #-}
-{- # SPECIALIZE instance Ord (Set (Int, Int)) #-}
-
-
-exists (Just _) = True
-exists Nothing = False
-
-the (Just x) = x
-the _ = error "the"
-
-
-
-bind :: Ord b => Set a -> (a -> Set b) -> Set b
--- looks familiar? could be a monad, eh?
-s `bind` f = unionManySets (map f (setToList s))
-
-fixpoint :: Eq a => (a -> a) -> a -> a
-fixpoint f x = 
-    let        y = f x
-    in         if x == y then x else fixpoint f y
-
-zippy :: [a] -> [b] -> [(a,b)]
--- checks that args have equal length
-zippy [] [] = []
-zippy (x : xs) (y : ys) = (x,y) : zippy xs ys
-zippy _ _ = error "zippy: unequal lengths"
-
-sethull :: Ord a => (a -> Set a) -> Set a -> Set a
-sethull f init = sh emptySet init 
-    where
-       sh known unknown | isEmptySet unknown = known
-       sh known unknown = 
-           let xs = unknown `bind` f
-               uk = known `unionSet` unknown
-               ys = xs `minusSet` uk
-           in  sh uk ys
-
--- returns empty set as default
-lookupset m x = lookupWithDefaultFM m emptySet x
-
-
-
--- inits xs returns the list of initial segments of xs, shortest first.
--- e.g., inits "abc" == ["","a","ab","abc"]
-inits                  :: [a] -> [[a]]
-inits []                = [[]]
-inits (x:xs)            = [[]] ++ map (x:) (inits xs)
-
--- tails xs returns the list of all final segments of xs, longest first.
--- e.g., tails "abc" == ["abc", "bc", "c",""]
-tails                  :: [a] -> [[a]]
-tails []                = [[]]
-tails xxs@(_:xs)        = xxs : tails xs
-
-
-
-
-invert :: (Ord a, Ord b) => FiniteMap a (Set b) -> FiniteMap b (Set a)
-invert fab = 
-    addListToFM_C unionSet emptyFM 
-       [(y,unitSet x)|(x,ys) <- fmToList fab, y <- setToList ys]
-
-
-partition :: (a -> Bool) -> [a] -> ([a], [a])
-partition p [] = ([], [])
-partition p (x : xs) = 
-    let (as, bs) = partition p xs
-    in if p x then (x : as, bs) else (as, x : bs)
-
-
-
-packs :: Int -> Int -> [a] -> [a] -> [[a]]
--- packs n m xs ys = all list of length n 
--- whose elements are in xs ++ ys
--- with at least m from ys
-packs 0 _ _ _   = [[]]
-packs n m xs ys = [ h : t | n > m, t <- packs (n - 1) m       xs ys, h <- xs ]
-              ++ [ h : t |        t <- packs (n - 1) (m - 1) xs ys, h <- ys ]
-
-insts :: Ord a => [Set a] -> Set [a]
--- all instances of a given list whose elements are sets
-insts []       = unitSet []
-insts (x : xs) = insts xs `bind` \ t -> mapSet (\ h -> h : t) x
-
--- intersperse sep inserts sep between the elements of its list argument.
--- e.g. intersperse ',' "abcde" == "a,b,c,d,e"
-intersperse            :: a -> [a] -> [a]
-intersperse sep []      = []
-intersperse sep [x]     = [x]
-intersperse sep (x:xs)  = x : sep : intersperse sep xs
-
-
-collectFM :: Ord a => [a] -> FiniteMap a Int
--- collect elements, count them
--- duplicates get same number
--- but beware: numbers are not used contiguously
-collectFM xs = addListToFM_C
-       (\ x old -> old)        -- already there, don't overwrite
-       emptyFM
-       (zip xs [0..])          -- count them
-
-
diff --git a/real/rx/src/Syntax.hs b/real/rx/src/Syntax.hs
deleted file mode 100644 (file)
index 4e29bbf..0000000
+++ /dev/null
@@ -1,218 +0,0 @@
--- functions and operators
-
-
-module Syntax
-
-( CType(..)
-, Exp(..)
-
-
-
-, appId, appArgs, appids
-, isApp, isAppId, unAppId
-
-
-, pr
-
-, substExp
-
-, cType, cArgs, isColl
-
-)
-
-where
-
--- import List
-import Maybes
-
-import Ids
-
-import Pretty          -- syslib ghc
-import PrettyClass 
-
-import Options         -- to find out about print format
-
-import FiniteMap
-
------------------------------------------------------------------------
-
-data CType = CSet | CList | CTuple
-       deriving (Eq, Ord, Show)
-
-data Exp 
-       = App Id [Exp]  -- function (identifier) application
-       | Coll CType [Exp]
-
-       deriving (Eq, Ord)
-
-isApp (App _ _) = True; isApp _ = False
-isColl (Coll _ _) = True; isColl _ = False
-
-cType (Coll ct _) = ct
-cArgs (Coll _ ca) = ca
-
-appId (App id args) = id
-appArgs (App id args) = args
-
-isAppId (App id []) = True; isAppId _ = False
-unAppId (App id []) = id; unAppId _ = error "unAppId"
-
-appids (App id xs) = id : concat (map appids xs)
-appids (Coll _ xs) =      concat (map appids xs)
-
-------------------------------------------------------------------
-
-
-
-substExp :: Exp -> Exp -> Exp -> Exp
-
-substExp a val x | a == x = val
-substExp a val (App id xs) = App id ( map (substExp a val) xs )
-substExp a val (Coll t xs) = Coll t ( map (substExp a val) xs )
-
-
-----------------------------------------------
-
-paren opts f p = if f then alParens opts p else p
-brack opts f p = if f then alBrackets opts p else p
-curls opts f p = if f then alBraces opts p else p
-
-lgroup :: Pretty -> Pretty
-lgroup p = ppBesides [ppStr "{", p, ppStr "}"]
-
-instance Show Exp where showsPrec p = emitascii
-
--- todo: something more distinctive
-pr opts = pp opts
-
-instance PrettyClass Exp where
-
-    ppp opts p (Coll tc args) = (case tc of
-       CSet -> curls ; CList -> brack; CTuple -> paren) 
-       opts True (ppCommas (map (pp opts) args))
-       
-
-    ppp opts p (App f args) = 
-       if null args
-       then ppfn opts f
-
-       else case idform f of
-         Active _ _ -> caseopts opts "code"
-                       [ ("latex", activate opts p f args)
-                       , ("plain", passivate opts p f args)
-                       ]
-         Passive _ -> passivate opts p f args
-
-activate :: Opts -> Int -> Id -> [ Exp ] -> Pretty
-activate opts p f args =
-    let        Active n cs = idform f
-
-       fs :: FiniteMap Int Pretty
-       fs =    if length args /= n 
-               then error ("active form used with wrong number of args, "
-                               ++ show f ++ show args)
-               else listToFM (zip [1..n] 
-                       [lgroup (ppp opts 0 arg) | arg <- args])
-               -- note: individual args are formatted with
-               -- surrounding precedence level 0
-
-       atoi :: Char -> Int
-       atoi c = fromEnum c - fromEnum '0'
-
-       farg :: Int -> Pretty
-       farg i = lookupWithDefaultFM fs 
-               (error ("arg no " ++ show i ++ " missing")) i
-               
-       eat :: String -> Pretty
-       eat "" = ppNil
-       eat ('#' : c : cs) = farg (atoi c) `ppBeside` eat cs
-       eat (c : cs) = ppChar c `ppBeside` eat cs
-
-    in eat cs
-
-
-
-passivate :: Opts -> Int -> Id -> [ Exp ] -> Pretty
-passivate opts p f args =
-     if  iduse f == Fn 
-     then paren opts (p == 100)
-               (ppfn opts f `ppSep2`
-                       ppNest tabstop (ppSepp 
-                               [ ppp opts 100 arg | arg <- args ])
-                       )
-     else case args of
-               [x, y] -> props opts p f x y
-               _ -> error "in ppp: op needs exactly 2 args"
-
-
-props opts p f x y =
-    case idprec f of
-       Nothing -> paren opts (0 < p)   -- todo: 100 more abstract
-                       (ppp opts 100 x `ppSep2` ppNest tabstop 
-                               (ppop opts f `ppSep2` (ppp opts 100 y)))
-       Just q ->
-           let qx = q + offset Lft f x
-               qy = q + offset Rght f y
-           in  paren opts (q < p)
-                       (ppp opts qx x `ppSep2` ppNest tabstop 
-                               (ppop opts f `ppSep2` (ppp opts qy y) ))
-
-
-offset dir f (App id args) = 
-    if idlook id == Fn then 0  -- harmless
-    else if idprec id == Nothing then 0        -- will get parens anyway
-    else if the (idprec id) /= the (idprec f) then 0 -- precs are distinct
-    else if id /= f then 1     -- same precs, different ops: need parens
-    else if idbind f == dir then 0     -- i am assoc, need no parens
-    else 1     -- i am not assoc, need paren
-
-
-{-
-    ppp LaTeX p (App f args) = 
-       let ff = idform f
-           fargs = [ lgroup (pp LaTeX arg) | arg <- args ]
-
-           expand "" = ppStr ""
-           expand ('#' : c : cs) = 
-               let n = fromEnum c - fromEnum '0'
-               in (fargs !! (n - 1)) `ppBeside` (expand cs)
-           expand (c : cs) = ppChar c `ppBeside` expand cs
-
-       in  expand ff
-
--}
-
-{-
-    ppp st _ (Let x b) =
-       ppSep   [ ppStr "let", ppNest 4 (pp st b)
-               , ppStr "in", ppNest 4 (pp st x) ]
--}
-
-{-
-    ppp Ascii p (Con x y) = paren Ascii (conprec < p) 
---  for debugging, show constructors:
---     (ppSep [ ppp Ascii conprec x, ppStr "^", ppp Ascii (conprec + 1) y ])
-       (ppSep [ ppp Ascii conprec x,            ppp Ascii (conprec + 1) y ])
-
-    ppp LaTeX p (Con x y) = paren LaTeX (conprec < p) 
-       (ppBesides [ ppStr "\\con"
--- make precedences in constructor args very low
--- in order to avoid parentheses that are visually unnecessary
-               , lgroup (ppp LaTeX 0 x)
-               , lgroup (ppp LaTeX 0 y) 
-               ])
--}
-
-{-
-    ppp st p (Bpp op (arg : args)) =
-       let q = opprec op 
-       in paren st (q < p) 
-
--- todo: check whether to hide application
--- todo: do precedences correctly
-
-           ( ppp st q arg `ppSep2`
-               ppNest tabstop
-                 (ppSepp [ ppp st q op `ppSep2` ppp st (q+1) arg 
-                         | arg <- args ] ))
--}
diff --git a/real/rx/src/TA.hs b/real/rx/src/TA.hs
deleted file mode 100644 (file)
index 4379266..0000000
+++ /dev/null
@@ -1,63 +0,0 @@
--- term algebras
-
-module TA
-
-( TCon, TCons, tconname, tconarity
-, STerm        -- todo: do we need (..) to export instances with hbc?
-, stcon, stargs, starity, mksterm
-
-, var2id, var2exp, sterm2exp
-)
-
-where
-
-
-import Set     -- syslib ghc
-
-import Ids
-import Syntax
-
-
-
-type TCon = Id
-
-tconname = idname
-tconarity = idarity
-
-type TCons = Set TCon
-
-
-data STerm a = STerm TCon [a]
-       deriving (Eq, Ord, Show)
-
--- hbc complains
-
-{- # SPECIALIZE instance Eq (STerm Int) #-}
-{- # SPECIALIZE instance Ord (STerm Int) #-}
-
-{- # SPECIALIZE instance Eq (STerm (Int, Int)) #-}
-{- # SPECIALIZE instance Ord (STerm (Int, Int)) #-}
-
-
-stcon (STerm tcon _) = tcon
-starity t = tconarity (stcon t)
-stargs (STerm _ args) = args
-mksterm tcon args = STerm tcon args
-
--------------------------------------------------------------------
-
-var2id n = uservar ("x" ++ show n)
-var2exp n = App (var2id n) []
-
-sterm2exp t =
-
-    let        tc = stcon t
-       vs = map var2exp (stargs t)
-    in
-       -- looks like a function
-       App tc vs
-
-
-
---------------------------------------------------------------------
-
diff --git a/real/rx/src/Trace.hs b/real/rx/src/Trace.hs
deleted file mode 100644 (file)
index 66f3b74..0000000
+++ /dev/null
@@ -1 +0,0 @@
-module Trace (trace) where trace msg x = x
diff --git a/real/rx/src/WrapSubtrans.hs b/real/rx/src/WrapSubtrans.hs
deleted file mode 100644 (file)
index b08e6c0..0000000
+++ /dev/null
@@ -1,39 +0,0 @@
-module WrapSubtrans
-
-where
-
-import FAtypes
-import FAsubtrans
-
-import Syntax
-import Ids
-import Semantik
-import Options
-
-import FA2Exp
-
-subtrans :: Opts -> Env Auto Auto -> [Exp] -> FIO (Auto, Env Auto Auto)
-subtrans opts env args =
-    do { moops (length args /= 2)
-               ( "subtrans needs exactly 2 arguments" ++ show args )
-       ; let [f, a] = args
-       ; v <- case f of 
-           App id _ -> return id
-           _ -> oops ("first arg of subtrans must be function name " 
-                       ++ show args)
-       ; (w, _) <- comp opts env a
-
-       -- for converting auto to exp
-       ; let opts1 = addListToOpts opts
-               [("expand","off"),("foldconst","off"),("foldnonrec","off")]
-
-       -- for computing intermediate results
-       ; let opts2 = addListToOpts opts
-               [("min","off"),("det","off")]
-
-       ; return ( subtransTNFA opts 
-                       (\ opts a -> docomp opts2 env 
-                               (App v [tnfa2exp opts1 a]))
-                       w
-               , env )
-       }
diff --git a/real/rx/template.html b/real/rx/template.html
deleted file mode 100644 (file)
index 0cb84c1..0000000
+++ /dev/null
@@ -1,37 +0,0 @@
-<HTML>
-
-<HEAD>
-<TITLE>RX: Rational Tree Languages</TITLE>
-<LINK REV="made" HREF="mailto:joe@informatik.uni-leipzig.de">
-</HEAD>
-
-<BODY>
-<HR>
-
-<H2>RX: an interpreter for Rational Tree Languages</H2>
-
-<HR>
-
-<HR>
-<P ALIGN="CENTER">
-<A HREF="http://www.anybrowser.org/campaign/"><IMG 
-SRC="http://www.informatik.uni-leipzig.de/~joe/anybrowsernow.gif" 
-ALT="best viewed with any browser"></A>
-</P>
-
-
-<HR>
-<ADDRESS>
-<A HREF="http://www.informatik.uni-leipzig.de/~joe/">
-<TT>http://www.informatik.uni-leipzig.de/~joe/</TT></A>
-<A HREF="mailto:joe@informatik.uni-leipzig.de">
-<TT>mailto:joe@informatik.uni-leipzig.de</TT></A>
-</ADDRESS>
-
-</BODY>
-</HTML>
-
-
-
-
-