(* SML 93 VERSION *)

(* New implementation of Mark2 theorem prover *)
(* now officially called "Watson" *)

(* copyright M. Randall Holmes, 2000 -- you may freely distribute as long
as this notice is preserved *)

(* at this point, all commands should be documented in babydocs *)

(* August 31:

error messages now raise a flag which prevents proofs; this flag
is reset by the start command (and by derived commands like startover,
starthere).

This is a seemingly minor feature which should protect one against
the effects of overeager drag-and-drop proofs (since these carry on
through error messages without stopping).

It seems that only the prove command needs to look at this flag, and
it is sufficient to have the start family of commands set it.  Experience
will tell us whether it is too finicky!  It does mean that proofs by
hand will need to be started over whenever an error message is raised.
I added a clearerrorflag() user command which will also clear the
error flag.

Another improvement:  files with the iri "theorem";; format
for talking to the INPUT command now work as scripts. But
the format is still quite rigid:  the iri lines need to appear
one to a line with no intervening commands.  So scripts are
still much more limited than top-level dialogue at the INPUT
prompt.  Still, this makes it easier to edit interactively developed
INPUT files to scripts.

*)

(* August 22:

THINGS TO DO (no code changes):

Another idea:  make it so that iri "<term>"; works in scripts
by having the INPUT reader extract whatever is between quotes
in the line read?

Re modularity:  think about reintroducing the ability to
hide subtactics inside tactics, and further consider having
the ability to specify which theorems a theory "exports"
to other theories (and abandon/forget all others when leaving
the theory -- subtactics needed but not exported automatically
hidden?).  Also, think about restricting forget to work only
on theorems of the current theory.  But what happens when one
loads a later theory?

eliminate undeclared infix variables (automatic declaration of
opaque infix variables seems to be the way to go).

Testing:  (recent) the UP tactic (longstanding) theorem dependency.
I should probably run a test of the built-in arithmetic and consider
the upgrade to base 10000.

Development of automatic support for type inference for absolute types.
See agenda of August 22.

Append (or simply send) OUTPUT term displays to the global term window.

User command access to scin/scout info (display relevant theorems!)

Think about delayed substitution and other term type efficiencies, and
about rewrite rule compilation (Fast Tactic Prover paper).

Think about code security: possible use of abstract types (as the
HOL theorem type) and use of structures and signatures for code
modularity and SML partial compilation.

Note that an improved type system should facilitate implementation
of "Sigma_2 replacement".  (any class function from an s.c. set
to an s.c. set which doesn't run afoul of opacity should be a set
function).  This may be implementable fairly easily with current type
info, though.

Is it worthwhile to consider user extensibility of the context-dependent
properties of || to other operators?

The problem of extra parentheses around unary operators...

remember question of modular organization of theorems.  This might
assist with search for multi-step proofs -- in fact, Otter strategies
might be relevant to this line of thought.  The Mark2 idea of storing
subtactics in a hidden list inside the parent theorem and popping them
onto a cache when the parent theorem was executed deserves
consideration.  It is certainly odd that the theorem list of a theory
like omnibus is simply "flat".  Idea of having ML-like "structures"
inside theories?  Note that limiting theorem list sizes can facilitate
multi-step proof search.

Think about the problem of "proof objects" and version control for
axioms?

Idea for interface:  type terms to be "started" in the Global Term window;
then a keystroke could carry out the start command.  fields for entering
arguments to other commands would make it possible to do this with other
commands as well.  

The interface needs to be able to issue an interrupt to the mosml process.
A restart using the same windows would be handy, but may be ruled out by
the structure of the classes?


*)

(* August 20:

UP tactic has been tested and appears to work.

Version now has the UP tactic installed!  Complete installation
but not much testing.  Oddly, competing UP tactics are executed
from the back of the term.

For the moment, I think that UP tactics at top level should
be left hanging; one might want to go up and execute again,
and the droprule command exists.

Notes made on laptop after TPHOLs:

3 corrections to file made during conference.  Hypothesis display
added a return for the sake of the interface.  I changed the pause
message to Watson:  Paused, again for the sake of the interface.
Finally, I fixed an actual bug in the "functional programming"
feature:  the program attempted to execute constant names
rather than their associated programs.

As an immediate upgrade, I project the UP built-in tactic.

*)

(* August 10:

corrects an oversight re the INPUT command:  the display will now
tell you if the theorem supplied to INPUT is being applied in the
converse sense.  I don't know if anyone will ever use this, but it
should be there.

changed "errormessage" in envname() to "nopausemessage" -- probably
fixed problem with demo scripts?

The SHELL built-in tactic has been disabled, since it is now
redundant.  One still might like it in guimode, but guimode is
deprecated anyway...

Is it a good idea to display a theorem whenever it is introduced
by a ruleintro command, for purposes of the interface?

I have set up tabular displays so that they are captured in the equation
window, and messages so that they are appended to the local term window.
I think that essentially all Watson output is now captured in one of
the special windows in the GUI.

*)

(* August 9:

adding annotations to theorem and other equation displays so that
the GUI can extract them and post them to an equation window.

The GUI now displays initial displays in the global term window,
INPUT displays in the local term window, and equations, statements,
and hypotheses in a new equation window.

There ought to be a message window as well (or provision to display
messages somewhere, at any rate).

*)

(* August 8:

The intention is to install the "secure menu" of commands which can
be carried out when prover operation is paused.

Note that ; by itself now works as quit(); and e; as exit();
(though any line beginning with a non-alphanumeric currently
causes quit() and might better cause an error message).

The secure menu has been installed, and the handling of command
menus has been made (we hope) more stable.

This should mean that the new methods of handling pauses are now
stable...we hope!

*)

(* August 1:

Note that the load command now gives some output telling you what it
is doing; I introduced this during a bug fix in the last couple of days,
and I liked it...

I'm planning code cleanup today.  

1.  check about handling of nested processes in various contexts.

2.  restore the option of having the old behavior of the INPUT command
(but obviously keep the new one!)

3.  eliminate old versions of text which cause confusion.  This includes
most code related to commutative matching.

4.  create list in this comment of changes made and lacunae in the prover
which need work.

cleaning up relics of the original attempt to implement suspended
processes.

It has been noted that it may be necessary for all infix variables
to be declared.

The problem of redundant parentheses around infix terms.

The dependency machinery has never been thoroughly tested.

For the GUI, theorem display may need to be marked so that it
can be pulled out for a theorem display window.  Also, it may
be desirable to be able to thmdisplay a theorem with parameters.

guimode() user command (a toggle to turn off some of the GUI changes)
introduced.

Idea of secure menu to associate with the suspend() command should
be considered.  A TEMPMENU for swapping is already available.
The minimal secure menu would just have exit on it...

Fixed minor bug in July 31 script handling.(q; did not work)

Introduced a fix for the possibility of commands in scripts not
using up their arguments.  The prover raises an error message at
the next line of the script when it notices that the argument list
is not null.  A special case is needed for the unit argument.  This
does mean that one cannot put space between the end of a line and
the following semicolon!

I have run this on existing files and found some errors.  This process
hasn't been completed, but all this testing will be done at the end...

The script reader should now read essentially the same things acceptable
to ML (except that it can handle returns inside strings, unlike ML).

The handling of autoscripting seems to be clearly wrong for nested
scripts? I think I have corrected it by moving information from
executefile to script.

Is there a question about scin/scout prefix variables?

forget is still not safe with segmented theory storage?

I eliminated a bunch of cmatch comments, including the now very outdated
matching function itself.

Is the unification function usable at all?  Consider updating it so
that it will work with the full capabilities of the prover (it never
handled abstractions, as I recall?).

reset needs to work when we break out of load, too.

SHELL may be obsolete?

attempted installation of guimode() for INPUT...The code compiles,
but still needs to be tested.  Because guimode is deprecated, it is
not supported by noml or scripts.  guimode() will also turn off the
. . . displays used by the GUI.  But the changes in showalltheorems
and steps are not affected.  Note that because of the omission of . . .
the GUI will DEFINITELY NOT WORK unless guimode is on.

There remains a lacuna in the redefinition facilities, having to do with
type definitions.  But it is unclear how much redefinition may be used?

what happens when INPUT is applied in reverse?  The user should be told!

There is still a line of investigation to pursue on intelligent theorem
searches.

*)

(* July 31:

I doubt that autoscripting for nested scripts is actually handled correctly.
I believe a general review of the code might be useful at this point; patches
are accumulating...

I changed the way that unknown commands are handled in scripts
(and in load files, noml).

A new version of INPUT command at the top level:  at the top level
(but not in scripts) instead of seeing an INPUT prompt and typing the
name of a theorem, one sees a Watson prompt at which one types

inputri <name of theorem>; quit();

iri abbreviates inputri.

Since one is in a shell, one can do all the things one can do with
the SHELL command, but there is so far no security against modifying
the environment (I think this can be installed?)

q abbreviates quit and e abbreviates exit.

The iri idea seems to work but requires security.  One idea, simpler
than the SHELL kind of security, is to create a new, very restricted,
command menu, only containing iri and commands which do not affect
the environment.

At this point I think that all interactive input to the prover
is carried out through the noml shell.  Abbreviation of quit and
exit makes this less verbose.  (just q; or e; will work).

*)

(* July 28:  the Feb 25 improvement of display of prefix terms turns
out not to work, and has been removed.  Some of the parentheses around
infix terms which it eliminates turn out to be needed!  The difficulty
is that the validity of eliminating parentheses around the second term
of an infix term when it is a prefix term depends on the context of the
entire term; this is hard to deal with. 

Also, exit() now allows one to cancel suspended processes (like
sat();)

I have set up errormessage to break out of scripts.  I have
created a separate nopausemessage command which handles informative
messages which are not error messages and should not "stop the show".

Note another occurrence of the infelicity of storing and retrieving
terms via their displayed form!  But this one seems essentially
unavoidable.  It may be possible to write a smarter display function
which _can_ eliminate the unnecessary parentheses around some infix
terms; I'll think about this.

*)

(* July 26:  a mere note, reflecting no change in code.  It is necessary
to figure out how to get INPUT mode to work with the GUI.  An idea
which I am considering is to get INPUT mode to invoke the noml
interface (an extension of the idea I have used to handle other
kinds of interaction with the prover in the GUI).

*)

(* July 7:

I changed the technique of handling breaks again.  The internal
details are unimportant (I used the noml shell instead of trying
to construct a new process handler); the result is that one uses
quit() instead of next().  Demo mode now works more or less as
expected.

I think the interface should be able to handle INPUT by stopping
at its prompt?

It should be possible to recover the ability to break out
of interactive loops by clever use of exceptions.

The GUI needs to be fixed to catch "guidone();" in diagnostic
mode, but otherwise everything now works.  I have not tested
INPUT mode; I expect that the interface will work OK if it
is told to catch the INPUT prompt in the same way it catches GUIDONE.


*)

(* July 6:

modifications used to support the GUI.

A closing string . . . added to all term displays so that the GUI
can extract them from the output of mosml.

Theorem listing commands now work differently.  If you issue the
command "showalltheorems" (for example)  you will get one theorem;
to get the next one type next();  You can type other commands in between
executions of next();  the rest of the theorem display will be suspended
until you finish it or execute another command that uses the same resource.

Pause function is disabled.  The demo() function now no longer does
anything; there is a command filedemo file_name which will run files
effectively in demo mode, but nested filedemos are not possible.  A
filedemo will not take input for the INPUT command from its file.

If an error occurs in a script and pause is set, the prover
will automatically break out.

Proof development with INPUT will probably require repeated submissions
of lists of theorems to be applied ending with STOPINPUT so that one
will reemerge correctly.

The input problems are fixed, except for the vexed problem of INPUT
and the limited possibilities of filedemo (which I don't understand;
I don't know why filedemo can't handle the stack of theories, which seems
to be the problem).

One ought to turn on diagnostic mode for the GUI?

Latest innovation allows stacked interrupted processes; this calls
for care in use of presuspend() and cancel() commands to start
and stop these processes.  

I need to understand why files don't seem to like suspend().  Why
are these Out of memory errors happening when I try to implement the
old demo mode?  it seems that it does not like getting file information
from a stack?

*)

(* June 29:

add dummy command to signal to GUI that commands are done.

*)

(* June 27: 

doesn't yet reflect any code changes.

statement of intent:  I want to add "screen-based"
movement commands which will allow (virtual) movement up down
left and right in the nice display of a term.  The way this is
achieved is by having the fancy display function build a data
structure that records where each subterm begins on the screen.
This will require the fancy display function to build position
lists of binaries as it goes.  The movement commands will require the
prover to search the screen structure for the position of the currently
viewed subterm?  Or perhaps a global variable could hold the cursor position
of the Parenthesis subterm, just as a global variable holds the position
of the whole screen structure.

These commands will then be useful for talking to the projected GUI.
I have no idea what they will look like to the user with the current
interface.

*)

(* June 19:  added defaultprecsame command, which sets default precedence
to be the same as that of an existing operator, completing the suite
of "relative" precedence commands *)

(* June 16 suggestion:  automatically generated scripts should include
verify statements (no change yet) *)

(* June 16: planning an upgrade to precedence setting, allowing
precedences to be set relative to precedences of existing operators,
without any reference to numbers. 

new commands

sameprec
leftprecabove
rightprecabove
leftprecbelow
rightprecbelow

Each command takes two arguments, the first being an operator
to be assigned precedence, and the second being an operator which
presumably already has precedence.  The new precedence is set to be
the same, inserted just above, or inserted just below the old
precedence, and set to group left or right as appropriate.

*)

(* June 15 note (no change):  For easy use of precedences, there should
be a device for "inserting" precedences -- give an operator a certain
precedence and raise the precedence of all operators with precedence 
higher than that by one.  An idea:  don't use numbers at all!
Define precedence as "same as ^+" (a simple assignment), "just above
^+" (an insertion) or "just below ^+" (another kind of insertion).
This should make for a much more natural approach!  (the showprecedences
command can then be used to look at the resulting order of precedence).

New "verify" command added.  Also new "showdef" command.

*)

(* June 15:  updated documentation again.  Added new commands showdef
(which displays the defining theorem, if any, of a constant or operator)
and verify (which can be used in scripts to check that theorems are
proved correctly). *)

(* June 14: fine-tuning of incremental backup.  The handling of the
LASTNAME variable by scriptinscript was changed, and backuptheory will
do nothing if LASTNAME = NAME.  Either of these changes would probably
handle most problems.

*)

(* June 12:  the theory backup situation is still not satisfactory.
For example, the theory counting never gets backed up in the omnibus
construction.  How is it going to get backed up?  Maybe explicitly?
Or should one of the commands gettheory, scriptinscript, or storeall
be automatically backing it up? *)

(* Apr. 27-8:  I regard the higher-order matching upgrades as now complete,
barring discovery of bugs.

The next issue is adding security to incremental theory saving to file
and desktop by enforcing a tree-like structure of dependency between
theories.  The simplest technique is to maintain a registry of precursor lists
of theories, and prevent a theory name from being assigned if the list
of precursor theories (SCRIPTS) is not appropriate.

A registry of theory dependencies is now maintained and checked.
I do not know whether it works.

I think that the current registry scheme is secure against at least
the most obvious kinds of abuse of mutual calls of theory files; it enforces
a sensible tree structure.

There is a new user command droptheory; droptheory s will delete theory
s and every theory which depends on it from the desktop.

A nice addition would be the ability to load a theory file with a different
name than the file name?  Same for scripts.

Needed things:

A sensible user interface.

on-line help

aliased load and script commands?

tests of proofs in the main corpus with struct2 and firstorder. (testing
that use of @! does not cause problems).

tests of the theory dependency lists; these have not been tested
extensively, and they are generally among the most complex functions
of the prover.  Redefinition of types is still not supported.

tests of the new higher-order matching facilities, but I've done
some of this.

The forsome problem with @! is still an issue of sorts.

Should @* (the @! of design) be supported?

A complete review of the source for clutter; for example, all the 
commutative matching stuff should be eliminated.

Smart multi-step matching is still a goal.

*)

(* Apr. 25:  changed strongeval to automatically evaluate p1,
p2, and constant functions at ?0; this makes strongeval inverse to bind.

Evaluation functions no longer do anything special with ?0 and expressions
with functions applied to ?0 can be rule-free.

p1 and p2 remain programmed, but this is optional.

*)

(* Apr. 24:

The treatment of formats didn't work right with the matching of
terms [?P@?1]@?x as if they were ?P@?x; the cleanup seems to be complete,
and much better than the original version (it is much more obviously
a matter of using the format match to make substitutions into the theorem
to be applied before matching with the theorem).

UNEVAL can now be implemented by the user.  But the system does not
yet know to carry out more than one function application before matching.

At least a draft of the full higher-order matching upgrade (supporting
multiple implicit UNEVALs) is now present).  It passes the obvious tests
so far.

The prover will now both abstract to get a match and evaluate to get a match.
Query:  will this cause many applications of UNEVAL to become unnecessary?

*)

(* Apr. 21:  brought higher-order matching with @! more into line
with that for @ 

This version now includes at least a draft version of all the higher
order matching upgrades that were intended.

*)

(* Apr. 19:

a change in the treatment of formats which may make higher-order
matching more powerful.  The match of formats is used to make substitutions
into the theorem to be used before it is applied.  This should make it
possible to implement BIND, for example.  The change is strictly
confined to the function USE.

Further refinements will be needed.  The match that will allow user
implementation of UNEVAL will also allow elimination of possible unexpected
behavior of the new approach to format matching.  Also, @! should be
made more like @ in higher order matching (but no need to support the
pair).

*)

(* Apr. 18:

best fix so far for problems with segmented saved theories.  backuptheory
reappears in most places (though possible redundancies should be explored).
newsegment now consults a new global reference LASTNAME for the most
recent "old" theory, and it is the responsibility of other commands
to update LASTNAME correctly.  algebra2.wat can storeall to itself again
without trouble, for funny reasons.  I still need to think about whether
all theory update commands work correctly in scripts.

Treelike theory structure should be checkable.  Also, "forget"
should be controlled.

*)

(* Apr. 17:

removed backuptheory from storeall, load, gettheory to avoid subtler
problems.  The whole segmentation deal needs to be thought through
_very_ carefully!  But gettheory needs backuptheory for the current
scripts to work -- or else backuptheory should be invoked explicitly.

Scripts don't work with the current version; try adding explicit
backuptheory, or think _very carefully_ about when this command
should be invoked -- or what commands should be allowed in scripts!

Go through and think about each instance of backuptheory that I commented
out!!!

*)

(* Mar. 6:

There were actually major difficulties which I didn't notice!
The way in which scripts call each other has to be carefully controlled
to avoid problems -- this should never be a problem in a simple linear
accumulation of scripts, but any situation where we set up for theorem
export will require considerable care.

The current version ought to work as long as theory structure is
strictly tree-like (every theory has a simple linear accumulation of
predecessors) but it is easy to goof this up; the previous state of
omnibus was not tree-like (typestuff was the culprit).

The prover needs to be able to test for certain bad conditions, but 
it also needs to be noted that the incremental backup scheme is inherently
less secure!

The prover does now successfully build and load omnibus on my home
machine.

*)

(* Mar. 3:

mod minor difficulties, the segmented desktop and save file system
now seems to work.

Invariants:  the first element of the SCRIPTS list should always be
the current theory.  the second element of the SCRIPTS list should
always be the theory to be loaded just before the current theory.
The hierarchy of "modules" is still strictly linear, though I have
some ideas how this might be changed.

The file sizes are _dramatically_ smaller.  On the other hand,
one needs .sav.wat files for all precursors of a theory to load it;
this is a new situation.  Maybe the old load command could be preserved?

It is quite likely that there will be other peculiar problems.

*)

(* Mar. 2:

A general idea is in place, but the recursion between the setup
of the save file and the functions preload and load is not right yet;
it will NOT work as now given!  Look at functions savefile, addscript,
load, preload.

Desktop functions now work with segments -- or so it seems.  They
are quite sensitive, so it is necessary to be careful!

the strategy for file saving  is to strip the desktop theory down
to the "new segment" and save that.

An idea for file loading:  put commands at the head of the file
which set the script, then pre-load the theories indicated in the
script file.

still alternative file segments.sml.

A new idea:  keep the current THEORIES data structure and develop
a mechanism whereby the "new" part of the desktop theory is extracted
and put into saved desktop structures or into theory files.

Conversely, the top level load procedure will clear everything, then
load the list of previous files used (recorded in SCRIPTS, which
thus becomes more important) with overwriting.

The only visible effect will be that applying "forget" to objects
found in precursor theories will not be effective unless the forgotten
name is reused.

Also, saving may become slower.  Loading should not be affected.

*)

(* Feb. 29:

New file "segments.sml" created for upgrade to "theories"
data structure.

Notes for segmented theory scheme:

the idea is for the file associated with each theory to store only
theorems which are new (or changed) in that theory, and to "open"
theories already present or load them from files if they are absent
when they are started up.

The "theory" data structure will be the same as it is now; there
will be a new "theories" data structure which is a partitioned list
of all theorems available in theories on the desktop.  This will
eliminate the vast reduplication in the current scheme.

The idea is to write this in such a way as to be completely invisible
to the user.  Commands like "load", "storeall", "script", "gettheory",
"backuptheory", and the theorem export commands need to be rewritten
for the new data structure.

The structure needs to include a number of blocks of theorems, each
labelled with a name and the blocks on which it immediately (?)
depends.  When theorems are proved or reproved, they need to be
updated in the current block as well as in the desktop theory.  (so
"prove" and "reprove" are also affected).  Axioms and definitions not
in the current block need to be untouchable -- no, but
reaxiomatization may cause a lot of overwriting.  Later blocks can
always overrrule earlier ones?  How is theorem export going to work?

design question:  what about all the other theory components?

The -deps2 components are large, and present a problem for the segmented
model.  Maybe we really need to do it right -- have a single theorems
list with individual theorems tagged by theory.  But does this really
help?  The cross-reference structures will still present a problem, won't
they?  Or will they be a single structure, too?  Overriding will
be handled in this structure by having theorems of the same name
in different theories?

The opposite model has _every_ structure have additional qualifications
on its entries for theory.  How about a generic approach?  Each structure
is replaced (or shadowed) by a partitioned structure with components
indexed by theory, in which only "new" entries are added.  Shadowing
is better than replacing -- we don't want this coming into play every
time a theorem is applied!

Model is that there is an additional theorem list NEW_THEOREMS
to which each theorem proved or reproved is added; when theory is saved,
this NEW_THEOREMS replaces the partition labelled by the current theory
name.  The deps2 structures might have a more complex model in which 
deps2 are constructed by consulting all the deps2 lists in currently
relevant partitions?  (otherwise segmentation wouldn't really save
anything for these).  But this really doesn't harmonize well with
reproof, for example.

a droptheory command would be handy...just for testing what the
problem is in Windows, for example!

*)

(* Feb. 25: brilliant idea of putting unary terms in a "user
parenthesis" when preparsing was a bug, not a feature; fixed this
(replaced it with the old approach of not reassociating to reveal a
prefix).  This probably means I need to think about what parentheses
need to be displayed -- there's probably a similar case in the display
functions which needs to be fixed so that redundant parentheses don't
show up.  I think that's fixed, too. *)

(* also Feb 17:  the Feb 7 and Feb 17 updates also need to be ported to
design *)

(* Feb 17:  noticed bug which causes repeated displays in "downtoleft";
not fixed yet FIXED *)

(* Feb. 7: installed facilities to suppress display of embedded theorems
in the trace feature 

New command stepsnorules() does trace without display of rules.  One
still sees parentheses hinting at where rules might be; this might not
be a bad thing?

How about security for funny breakouts?  I suppose reset() can do that.

It is theoretically possible (and unavoidable) that stepsnorules
will get caught in certain infinite loops, because it displays only
those steps where something other than an embedded theorem changes.

*)

(* Jan 7:  a question:  why do automatically generated scripts not
respond to statementdisplay? *)

(* Dec. 17:

have EVAL and BIND issue warning messages when they fail?

a toggle command "stratwarning" turns warning messages on and off.
Are warning messages needed with UNEVAL, too?

Another note: metatrat and metahead probably no longer need a level
parameter.  Check this.  (this doesn't represent a change).

*)

(* Dec. 14:  set up facilities for many (but probably not all)
user commands to catch bad substitutions (for predicate abuse) 

corrected metastrat to really enforce Dec. 10 restrictions, and
moved metastrat check to before application of autoeval in the definition
of substitution.

*)

(* Dec. 10:  new clause in declarecheck further restricts use of meta-
application; a curried meta-application in all contexts must be headed
either by a free variable or by a sufficiently iterated function to clear
all the meta-applications.  Actually, this is really only fully
enforced Dec. 14.

it proves necessary to allow permissible meta-functions to be built by
rule applications and by cases from permissible meta-functions.

It seems that this may actually work; it may be demonstrably equivalent
to enforcing "typing" of meta-functions.  Look for a proof of this.

*)

(* Dec. 6: defineopaque modified to work correctly (exclude
mata-application from text defining opaque operators).  Still draft. *)

(* Dec. 1: this is a draft version with a different approach to first-
order logic and the "meta-application" operator @!

I need to make sure that Isstratified is called when needed to post
dependencies on scin/scout theorems.

The eval function needs to check stratification when applied with "@",
in order to post scin/scout deps.

stratification needs to be put in the correct relationship with the
new @! (it will have a much less accepting attitude!)  This, by the
way, means that some of the new commutativity results will fail.

Definition commands need meta versions.  No, they don't; defined
matafunctions are excluded by Dec. 10 design decisions.  It is possible
to introduce operators on predicates by axiom -- carefully!

There's quite a lot of stuff to be done...

There need to be new EVAL, BIND, UNEVAL commands to use with first
order abstraction.  (EVALM, BINDM, UNEVALM; they are implemented.)

There do need to be checks for failure of metastrat after
assignments; I think that the only danger is assignment to a
free variable in a "metapred".  There might be a need for segregation
of variables having roles in "metapreds"?  The role of being an
n-place predicate should not be mixed up with anything else, as it were.
It may be that metastrat will catch this anyway?  The rule would be that
a letter occurring in an n-place predicate position would not be allowed
to occur in any other position.  A stronger condition is imposed in the
Dec. 10 version.

The stipulation against abuse of substitution into predicates is just
fine, but only if it raises an exception?  The BadSub exception raising
approach works for the specific case of assignment, but it is not clear
to me that it will work in all situations?  Something like segregation
is probably wanted?  But the BadSub approach may actually work!

If BadSub is to be used, the commands that might raise it will each need
to have provisions to handle it.  Which commands?

Current solution is that a substitution of a predicate of too low an order
for a predicate of high order raises an exception.  No quantification over
variables in predicate position is possible, which suggests that this is
an acceptable solution?

*)

(* Oct. 19:  extremely minor correction of higher-order matching:
does not affect correct execution of existing files. *)

(* Oct. 18:  installed SHELL command which invokes the shell
from inside an INPUT tactic (or from anywhere, I suppose...) *)

(* Oct. 6: attempt to install bailout for INPUT commands --
STOPINPUT aborts execution of all INPUT commands (in fact, of
everything) 

New built in theorem STOPINPUT has effect of converting target theorem
to a bogus value and causing all INPUT commands to do the same thing;
this has the effect of crashing the tactic interpreter and returning to
the first theorem that invoked INPUT, which is just what is wanted for
proof editing.

*)

(* Sept. 7:

All modifications in this version are purely technical from the 
standpoint of current users; they involve the behaviour of the
special operator @! , which I have not yet discussed.

I'm not happy entirely with the state of @!  I could make it entirely
safe by restricting matching to arguments ?n other than ?0 (ensuring
that all operators matching ?P in the context ?P@!... would be
stratified (but possibly inhomogeneous)) and segregating variables
representing stratified but inhomogeneous operators from other
variables as part of stratification checks.  But it is unclear to me
that there is any hazard from the present situation. The unexpected
new consequence is that at level 0 a variable can match a completely
unstratified abstraction!  Or can I prove that the current setup is
safe?

I must opt in favor of security.  I will restrict higher-order
matching involving @!  to positive-indexed bound variables (there is
no premium on matching pair and constant function arguments in this
case, anyway); this eliminates matching to unstratified abstracts.
I will also insert a check for segregation of variables matching
possibly inhomogeneous operators from other free variables into 
stratification criteria.  This should make the whole @! facility
provably secure.

I have made the changes indicated above (making @! theoretically secure)
and also inserted a stratification check into the assign command
(because it is now possible for a level 0 expression to be unstratified,
which was not possible before).  Uses of the @! command which are expected
should be completely unaffected.

segregation checks need to be run on whole theorems;
this has been implemented systematically.

Fixed glitch in autoeval which caused failure to eliminate some applications
of function terms using @!

*)

(* Sept. 2:  fixed autoeval function so that it works correctly with the
new match function.  The whole library runs except that some old proofs
on quantifier switching break; it was necessary to expand some upto
commands in the proof of ASSIGN_WP because of the changes in the definition
of matching. *)

(* Sept. 1:

For some reason, UNIV_SWITCH is broken.

This version has much stronger higher-order matching facilities than
any previous version.  It is also better designed:  the higher-order
matching uses the bind function, so upgrades to BIND will automatically
upgrade matching.

Fixed up the special case of ?0 in higher order matching; there is no
danger of invocations of "level -1" any more.

Fixed up BIND to bind intelligently with constant function parameters.
BIND now (again) does not commute with EVAL.

General problem:  extend matching to handle pairs neatly; there need
to be matches for P1@x and P2@x as well as for x?  This is what's needed
to make a new UNEVAL work nicely.

Idea:  a pairprep which converts a variable ?x occurring in a context
p1@?x to variables ?x_1,?x_2 throughout the expression before matching
(and carries out execution of p1 and p2 after matching).

The handling of constant functions motivates doing pairprep on both left
and right (not restricting to list binding).

A daring experiment works:  implement higher-order matching using the
new bind function, and get all kinds of new higher-order binding power
all at once!

installed automatic execution of applications to ?0, and fixed an
old bug in steps()

simplified higher order matching to @! to bring it into line with @;
I think this ought to work...

*)

(* August 31st:

This seems to be a version with full strength higher order matching.
Note that introduction of ?0 as default argument required modifications
to declarecheck and also a clause identifying level ~1 with level 1 in
strat (as in declarecheck).

Further upgrades projected:  improve matching and bind/eval functions
to take pairing into account.  Also, improve matching to handle type
labels?  This last might or might not fly?

When working on the pairing upgrade, think about ?m..?n; think about
whether I'm working on a pair or list model.

I should check whether matching to ?F@?0 works as expected?

Should restrictions be placed on the use of ?0?  Should ?0 take over
as nil?  (this last sounds like an excellent idea!)

I have now made BIND into a list binding function.  To preserve
commutativity of BIND and EVAL, I used new versions p1 and p2 of the
projection operators which have functional programming set to evaluate
automatically.  I have to think about what to do with UNEVAL, and also
how to extend this to higher-order matching.  Note that the behavior
of BIND now depends on the grouping (left or right) of the comma
operator.

*)

(* August 30th:

Consider possibility of using ?0 as default value?  One could use
a general strategy of always evaluating when a "bound variable" is
involved?

I have commented out the part in declarecheck where ?0 is outlawed.

I have also introduced the aptoeq function to handle preemption of
higher order matching.

Plan to rewrite higher order matching to do it with all bound
variables; this will handle one of the new cases automatically!
(using ?0 as the default value).

Note that one may want to rework bind to handle values at [?x]
differently as well as values at ?x,?y?

*)

(* August 27th:

restricted terms to the left of a deepest @! to free variables and function
terms.  For completely demonstrable soundness, one could further forbid
free variables occurring in such a context from occurring in any other
context; is there a neat trick for doing this?  Idea:  add info about
free variables to strat?  Not readily typable.  This is probably enough
as it is to support a soundness argument?

Fixed up the levels in the implementation of matching with @!;
I don't think the earlier ones were actually valid.

Get rid of the stuff with @`; this idea can work, but not the way I did it!
Also, "=" would work just as well!  Introduce a function which changes
applications to equations and apply it in the test.

*)

(* August 26th:

In demo mode one can now invoke a noml() shell by hitting s at most
(not all) returns.  Hit return after the two following messages
(turning off diagnostic and demo modes), then type commands as usual.
The script will resume after you type quit();  You will sometimes get
a message "Unknown command quit in script", which is harmless.

Of course, you can mess up what's happening in the script if you aren't
careful!  Right after the proof of a theorem is usually a safe place to
shell out.

I outlined but did not implement generalized higher order matching
in typed situations.

*)

(* August 25th (once again an official release):

This new release has two major features, one straightforward and one
experimental (and maybe even dangerous):

the UNEVAL tactic is now much smarter (this is straightforward); it
will find iterated (curried) values of multiply bracketed functions.
In the existing theory, try

s "?x+?y+?z"; ri "UNEVAL@[[[?1+?2+?3]]]"; ex();

There is a new, very special operator @! which allows the construction
of terms which will match general terms with iterated quantifiers.
For example, there was no term which would match all terms of the form
forall@[forall@[...?1...?2...]] in the previous version (whereas
forall@[?P@?1] matches all singly universally quantified terms); the term
forall@[forall@[(?P@!?1)@?2]] will match all such terms at this point.
The basic idea is that ?P@!?1 will match any term with ?1 in it (not
necessarily at the same type as ?P@!?1); in order to avoid paradoxes,
the term ?P@!?1 can occur only in a context where terms depending on
?1 in any way can be put (for example, both ?1 and [?1] have to be
substitutable in such a context).  This is true of the context
forall@[forall@[...?1...]]; because forall@[...?1...] is known by the
prover to be boolean, its type can be manipulated to allow [?1] to
replace ?1, for example.  The term
forall@[forall@[forall@[((?P@!?1)@!?2)@?3]]] will match any triple
quantification, and so forth.  (A term ((?P@!?1)@!?2) is only
permitted in a context where ?1 and ?2 could be adorned with
independently chosen numbers of brackets without affecting the
stratification of the resulting term.)  This will mostly be useful for
the construction of tactics which will act intelligently on multiply
quantified terms.  The strengthening of UNEVAL will also be useful for
this.  

In general, one can think of a term like (?P@!?1)@!?2 as being
intended to match any term which is stratified except for the fact
that ?1 and ?2 have been translated in type by fixed and possibly
different amounts.  A term of this form is allowed only in a context
where ?1 and ?2 can actually be translated in type (by adding
brackets, say) by uniform amounts (possibly different for ?1 and ?2
but the same for all occurrences of ?1 and the same for all
occurrences of ?2) without perturbing the stratification of the whole
term.  This is true, for example, of ?1 and ?2 inside
forall@[forall@[forall@[((?P@!?1)@!?2)@?3]]].

Further enhancements of higher-order matching may follow.

There is the minor additional feature of a command demoremark
which does nothing except get displayed with its string argument
in demo mode; it allows remarks to be put into demos, as its name 
suggests.

There's a comment in the function executelines concerning a possible
improvement to demo mode; it almost works as written.

*)

(*  standing list of "rough edges" of the prover (arbitrary features
which cause trouble)

Are defined objects defined via their application as functions actually
lambda terms or not?  It would be possible to define a built-in function
which would handle this automatically.

Idea about internalizing type information:  provide a built-in tactic
which will convert an infix term to a functional form, with appropriate
introduction of constant functions and values.

definitions of constants have same names as constants; this has 
inspired the prevention of application of functional programming
to theorem names.

the problem of new variables breaking stratification -- accommodated but
still there and not easily removed.  Of course, I might be able to
use ?f@!?n instead of ?f@?n and fix the problem in this experimental 
version!  (no, newest treatment of ?f@!?n does not permit this).

I might want to generalize the forms allowed as formats to anything
with an "eitherhead".  This would eliminate the need for the peculiar
solution to stratification problems with makescinvar.

Should autoeval be more aggressive:  should it do more automatic evaluations?
Probably to be avoided because it would require repair of many existing
theory files!

Should there be a way to recognize the kind of "scin" behaviour that
the theorem FORALLBOOL2 tells us that forall has?  This goes along with
the recent generalization of argument lists.

There remains the problem of scin/scout for functions with parameter
lists.

Inconvenience of extracting type information.  How about a primitive
tactic which labels the terms on each side of an infix with their
relative type?  How about the major modification of maintaining local
type info and info on type of all abstracts to remove the
stratification failures due to new variables?  Diagnostic information
on relative types would be useful when issues of stratification arise?

Loss of the prompt when demo mode is invoked inside a demo.

The = builtin theorem ought to require matching of the appropriate
side of the given equation; it might be that it ought to have a "matchtri"
analogue, but this would probably behave extremely unpredictably.

I need to analyze the various situations in which stratification
errors can show up in the course of execution and make sure that they
can't lead to incorrect proofs.  The most worrisome situation is the
one in which a variable on the left of a @! (matching an operation
which may not be a function) is introduced somewhere else as a
function; such a theorem will pass stratification tests but will crash
with a stratification failure if the operation is instantiated as a
non-function; I believe that this is harmless (because it is
impossible to generalize over such a variable) but it would be nice to
prove this formally.  If it were a problem, there is a fix:  it would 
require declaration checking to verify implicit typing of certain
variables as general operators, and probably restrict the forms of
expressions occurring on the left of a topmost @! to function terms
and free variables; maybe I should do this anyway.

still question as to whether the implicit typing of stratified
inhomogeneous operators should be enforced.

idea that operators declared scin or scout should be retyped (scin
as flat and scout so as to get smallest type to 0).  Recognize that
if one is on two of the scin/scout lists one should be on all three?

*)

(* August 25:

I think I finally have a sound definition for behavior of the @!
infix for generalized higher-order matching.

Further generalizations of matching which are possible involve direct
support for matching projections of pairs (iterated projections of
free variables would be allowed to match and matches of variables to
pairs would induce matches to projections; some care needed to avoid
regress) and stronger higher-order matching for cases of concrete type
differentials (iterate higher order matching and match to things like
(?P@?x)@0 and ?P@[?x]).

The idea is that ?P in (e.g.) ((?P@!?m)@!?n must match a "stratified
inhomogeneous" operation on ?m and ?n; one which is an operation on ?m
and ?n yielding a stratifiable expression but not necessarily one
which can be expressed as a function of ?m and ?n (the relative types
of ?m and ?n may be too high or low for this to work).  A general
operation of this kind can appear in a stratified function definition
only in special contexts: ones in which the types of its arguments can
be arbitrarily displaced with respect to the context and one another
without affecting stratification.  These are the conditions enforced
on the @! operator (along with the condition that the head of a
curried expression in @! is an opaque environment; no binding can
occur there at all).  It doesn't seem that the possibility of having
?P appear in other positions can be exploited to prove anything (after
all, it isn't clear that one can prove much of anything about
expressions ((?P@!?m)@!?n).

*)

(* August 24:

New experimental implementation of higher-order matching
seems to work, more or less.  The approach is to allow ?P@!?1
only in positions where the relative type of ?1 floats.
The implementation involves carrying out stratification twice,
with different output types assigned to @!.

The idea is that ?P@!?n matches any expression of the same "level" as
?n (involving no bound variables with higher index) whose type
"floats" in its context.  The stratification function types each term
twice now, with two different output types for the @! operator.

The term forall@[forall@[(?P@!?1)@?2]] (note that there is just one
@!) matches any double quantification.

Any reasoning with terms of the form @! will encounter restrictions;
it must preserve the floating character of the typing of all ?P@!?n
terms and also respect other logically motivated precautions.

I believe this feature is sound in concept, but an earlier version
allowed bad proofs; there may of course be bugs!

Do we still need more general forms of higher-order matching?  is
the x@!y@!...z@w pattern enough?

UNEVAL is now full-powered; it handles multiple bracket terms as
parameters and produces iterated values thereof.

I might be able to write a general bound variable switching procedure
without running into the usual blocks:  

forall @ [forall @ [bool : (?P @! ?2) @ ?1]]

is an acceptable term!  But it still might not work. (LATER:  this does
work!)

*)

(* August 23:  

fixed bug:  => and <= were supposed to be scinleft; now they really are!
In general, properties of built-in operators need to be updated by
the clear() command.

*)

(* August 20:

installed ability to declare scin infix variables with command
makescinvar <name>.  Corrected match to allow this.  Supermatch
appears to handle this correctly already.  The modifications to other
functions appear to be sufficient to allow the declaration of scout,
scinleft, or scinright infix variables as well if they are ever wanted.
Scout infix variables would need to have their relative types shifted
to a canonical form (say with one of the types 0).  Scinleft or scinright
infix variables would have the "hidden" type switched to 0.  Commands for
these cases have not been installed.  The type transformations suggested
above might be desirable for purposes of theory matching for non-variable
operators as well.

This appears to work; it solves the problem of stratification problems
in embedded theorems completely (use a scin infix variable instead of
, in the parameter list of a theorem to make it secure).  The
installation of makescinleftvar, makescinrightvar, makescoutvar is
relatively easy, but I do not as yet see applications for such
variables?

*)

(* August 20:

nothing implemented here -- just ideas.

1.  scin infix variables would be useful.  scout, scinleft, and
scinright infix variables might also be nice, but this takes more work.
I should look at the conjecture that being on more than one of these
three lists should put you on the third as well, and check that variables
on more than one list are treated correctly.  An advantage of scin
infix variables is that they could be used to build parameter lists for
tactics, eliminating all problems with stratification in embedded theorems.

2.  The problem of higher order matching inside more than one bracket
appears again.  A generalization of UNEVAL to handle curried functions
might help.  Generalized binding tactics might be useful as well.  A
true generalization of higher-order matching remains a possibility, I
suppose.  Use expressions in ?P@[?n] and (?P@?n)@0.  I can also write
generalized binding tactics (especially when scin infix variables
are available).  There's an old idea that higher-order matching should
be integrated with the type system somehow?

*)

(* August 19: notes on possible editor function.

This would be used in conjunction with makescript.

List basic functionalities wanted:

load the current autoscript into buffer

move around in editor buffer in usual ways

search-replace in editor buffer

display ranges of lines; copy ranges of lines

execute ranges of lines in prover

This would create a text-based environment in which all commands
passed to prover would be recorded automatically and it would be possible
to manipulate these commands and reissue them in a reasonable way without
relying on an external editor or the cut/paste capabilities of the
OS

*)

(* August 19:

Try the compress() command to get a vertically compressed output
format.  A dashed line separates dependencies from the text of a theorem.
expand undoes compress and both are found on the script command menu.

In demo mode, a "d" entered at any pause will exit demo mode while
continuing execution of the script (you will have to hit return once
or twice in response to messages before the renewed execution starts).

The script command inside the noml() interface is now "script"
(the same as at the ML prompt) although the alternative "truescript"
will still work.  The noml() interface now catches any exception, rather
than just I/O exceptions, and this source should compile under SML 96
without any change.

I suggest trying noml(); compress(); to set up your working environment.
To return to the ML prompt, type quit();  

makescript "test"; compress(); will set up the same environment,
recording your commands in a script test.log.wat.

Added demoremark "string" command which does nothing; its only purpose
is to be displayed in the demo function.

Since I am not planning to add commutative matching to the prover as
a standard feature, the (no cmatch) comment has been deleted from the
versiondate message.

*)

(* August 18:

more work on look and feel.  Theorems are now separated from their 
dependencies by a dashed line in the compressed theorem display.

compress and expand added to script command menu.

Also, entering "d" during a script in demo mode will take you out of
demo mode, allowing the script to finish (unlike "q", which will stop
the script).

things now seem to work.

*)

(* August 17:

minor modification to lookhyps: it displays the variable binding
situation even if there are no hypotheses.

Changes to term display:  displayed terms are indented (which
should be good for "human factors") and additional commands are provided:
the compress() command will eliminate lots of carriage returns
(compress things vertically) and the expand() command will restore
the usual situation with lots of returns.

*)

(* August 13:  

modification to preexecute and preonestep; earlier versions
did not do any execution inside embedded theorems; this version executes
the parameters of parameterized theorems.  This will allow simplification
of tactics like POP_CASE.

The effects of this change on any current theory should be nil.

Ideas from the visit of Aug. 9-12 in Moscow (not implemented yet):

an INPUTP@?tactic command which allows one to input parameters to a tactic.

a shell command which would allow one to go into a noml shell (with
limited command list) from the INPUT prompt.  One could do things like
thmdisplay, srt, targetruleinto.  DONE!!!

Can I reduce the number of returns (white lines) in prover output?  Jim
would like this. DONE

There is something funny about the use of demo inside a script; it didn't
display the command prompt. 

Idea:  there ought to be a letter one can type to cause a demo'ed file
to go back up to full speed.

The builtin theorem "=" ought to check for matches to the given equation,
not just to the theorem which justifies it.  In other words, it should
effectively define more specialized versions of theorems.

*)

(* August 2:  at this point all commands should be documented in babydocs. *)

(* July 14:  statement display now works in lookhyps as well;
this is useful in deduction theory, for example.  It is a little
weird that $|- is the default "prompt" for a hypothesis, due to the
preference for "true=T" in hypotheses (which is itself caused by the
right associativity preference).

a question:  does the reversal of free variables in supermatch
have to be applied to infix variables as well?  The obvious thing
to do is to introduce a match between bogus free variables in 
reverse in addition to the direct match between infix variables
which is needed to check declarations?

This is implemented, though it is not clear that it is really needed;
the problem probably would never arise.

A brief note about this problem might be useful.  Example is 
in terms of free variables rather than infix variables.  The
problem is that if the match direction was what one would
naturally expect, a theorem

?x+?y = ?y+?x

in a source theory would match a theorem

?x*?x = ?x*?x

in a target theory (with * translating +).  This would allow the
translation of theorems proved using commutativity of + to theorems
about *, which is not known to be commutative, which is unsound.

The modification preventing this has already been made; the modification
made here enforces the same reversal on infix variables.  It is hard to
see how this could really be a problem, though.

The stripvars function needed to be modified to recognize
bogus "free variables" generated in supermatch to enforce the reversal
of matching for infix variables.

*)

(* July 13:  automatically generated scripts now include texts of
theorems in comments after the proof.  This is a change in the
prove function.

fixed matchtri and anothermatchtri to work better

added some new abbreviations

dtl dtr ut = downtoleft, downtoright, upto

ldtl ldtr lut = litdowntoleft, litdowntoright, litupto

mtri amtri = matchtri anothermatchtri

*)

(* July 9:  removed pause after OUTPUT because of bad effects 
on interactions between emacs and the ML interpreter.

Installed messages using the OUTPUT command in deduction.wat.

Installed autoscript facility, with new commands autoscript and
makescript.  autoscript puts the current script file in a file
with the .log.wat extension.  makescript clears the current script
file and calls noml, creating a new script file when noml is exited.
The scriptinscript command automatically clears the current script
when it exits a script successfully (we presumably don't need to
duplicate a script which works).

Correcting problem with INPUT in the noml() command.  The fix is that
INPUT will no longer accept a blank input.

Final situation:  makescript is a user command; autoscript is not.
Logging only happens inside the makescript command, and it does not
happen in loads or script runs inside the makescript command (the
consequences of this when theory files are loaded are disastrous).
The makescript command cannot be nested; it will do nothing if 
scripting is on.

*)

(* July 6: fix to matchtri; also added command anothermatchtri() which
gives further possible theorems; Issuing this command just after
matchtri (or anothermatchtri) will change the theorem to the next
appropriate one in the list; issuing at other times will have bizarre
results.

This doesn't seem worth posting as an official upgrade.

*)

(* July 2:  minor modification -- "dropview" command no longer
sends an error message if the view dropped does not exist 

installed new "literal" movement commands

litupto litdowntoleft litdowntoright

which look for equality rather than a match.  Warning:  these
commands do not do level changes (they won't find [?1] in [[?2]]),
and they will find [?2]).

A new variant "matchtri" of targetruleintro/tri is now available.
This one will look for a theorem which will send the current term
to something which its argument matches.  For example, if we are
looking at "(~ ?x) & ~ ?y", matchtri "~?z" gives us the theorem
DEMb, which sends this term to "~ ?x | ?y".  This allows us to look
for theorems which will send us to terms with a certain structure,
rather than to an exact target.

matchtri's status in the cmatch version has not been decided.

A built-in theorem which implements matchtri might be of interest.
This is likely to be more unpredictable than the = builtin theorem.
It is important to note that it is dependent on the order of the theorems
in the master theorems list, which changes!

*)

(* July 1:  some bug fixes and extensive addition of error messages in
the theorem export mechanism.  The clause for free variables in supermatch
needed to be reversed ((t,s) instead of (s,t)), a rather subtle logical
point!

Supermatch now uses a new version of mergematches which itself gives
messages about match failures.

The previous version created more theorems than it needed to in exports;
it now looks at the expanded view (after supermatch is run) and does not
create a new theorem if it sees that there is a view of that theorem.
This also makes it possible to use the expanded view repeatedly; in the
previous version it created junk entries.

Theorem export remains unstable, I think.

*)

(* July 1:  change to supermatch -- a bijective match between free
variables in theorems is needed *)

(* June 30:

The cmatch version has been changed; its behaviour should be a little
less unexpected than the previous version (commfix is used in a different
way).

Fixed a problem with initialization of the basic view.

*)


(* June 29:  

Minor changes made in course of review of comments:  the script command
will now treat carriage returns in strings as spaces.  the statementdisplay()
command now sends a message as to whether statement display is on or off.

Idea is that June 29 source is a unified source which
can be modified to support all versions of the prover desired.  All
maintenance should be done on this file.

investigations of compatibility of the various sources
being used.  This one will work for SML 93 if the SML 96 conversion
functions are commented out and the line

flush_Out s = ();

is added.

For SML 96, one needs to replace Io with IO.Io in the noml function.

Plan for today is to add material supporting commutative matching in comments,
so that only one source needs to be maintained, then to do cleanup of old
comments.

cmatch stuff is now included in comments labelled cmatch

I made the changes to steps indicated in the cmatch comments,
which are needed anyway.  Also liberalized the type definition functions
to allow the converses of retraction theorems; the wb() in the stereotyped
procedure is no longer needed.

This also reflects the strengthening of commutative matching caused by
use of the function commfix.

inserted old comments from the cmatch source:

(* June 2 (added here June 28):  general cleanup of comments.  
Liberalized the retraction
test in type definitions so that the wb() is no longer needed (a retraction
theorem may safely be replaced by its converse).

This is experimental source "cmatch.sml" *)

(* June 1 (added here June 28):  modifications to get 
commutative matching to post correct
dependencies.

Put postdeps and dropdeps into steps command.

Still stuck with inappropriate posting of commutativity axioms when
commutative matching is on.  This is rather like the extra deps on
typing axioms that show up due to scin/scout.

Should I automate makescin and makescout inside the addtheorem command
in the same way that I have automated commutative laws?

*)

(* May 28 (added here June 28):  testing commutative matching

The prover now maintains a registry of commutative laws 

User command cmatch() turns commutative matching on and off.

Modifications involve the new list COMMUTATIVE, functions iscommutative0
and iscommutative, changes to addtheorem and droptheorem, and changes
to match (and use of oldmatch where needed) as well as very important
change to mergematches (match gives a nontrivial list of
different alternative matches)

Prover never uses commutative matching for control structures
in the tactic interpreter or for special movement commands

use of = in prematchtheorem needed changing to , since = is commutative 

Note that GCLEAN tactic does not work under cmatch -- maybe the
point is that it _does_ work but works very differently.

Now testing oldmatch in prematchtheorem; this appears to cause GCLEAN
to work correctly.  (version weakprematchtheorem does not use oldmatch)

The toggle needs to be provided for backward compatibility even
if commutative matching is the default! 

This remains a provisional version:  for example, it does not 
have correct theorem dependencies -- something needs to be done
to post dependencies of commutative laws when the matching 
uses them. *)


*)

(* June 28:  This has been tested with SML 96.  The only problem
in building it is that the Io x exception in noml doesn't work; 
use IO.Io instead.

It appears that SML96 is perfectly happy with the Moscow ML source--
except for the same problem with the Io exception.  What is the I/O
exception type for SML 96?

Stuff about exportML:


      exportML, heap image files, @SMLload command line parameter 

            Question: Calling the function exportML, as in 

            - SMLofNJ.exportML "image";

            creates a file called "image.mipseb-irix" that is not executable,
            while with SML/NJ 93 I would get an executable file called
            "image". I wonder if I am doing the export correctly or if there is a
            new procedure for using the exported image? 

            Answer: The file "image.mipseb-irix" is a heap image -- not an
            executable. You can load it as follows: 

            % sml @SMLload=image

            Note that you do not need to specify the ".mipseb-irix" suffix
            when specifying the image file, it will be inferred. 

*)


(* June 25: a very minor point; when one leaves the script command,
it will always turn off demo mode.  Also, turning demo off or on 
sets the verbosity as appropriate (this means that users will not want
to turn demo mode off at the top level -- but they should not have to!)

changes to script, reset and demo

This still needs to be ported.DONE

*)

(* June 16:  very slight refinement of comments in INPUT text
In the June 15 version, either { or } started a comment to the end
of the line; now it is only { which starts a comment, which will
go either to the end of the line or to a }.  A } acts like an
end of line and could be used to put more than one input on the
same line.

changes to script, reset and demo


*)

(* June 15:  upgrade to display local level in lookhyps command;
the prover tells what bound variables are locally free *)

(* June 14:

Modified prover so that input can be supplied to the INPUT command 
in scripts.

The theory stack TESTTH has to be declared early (before applybuiltin)
so that the INPUT command knows where to get its input.  It is also
initialized differently (as [std_in]; no file "dummy" is needed any
more).  The theory stack is reset to [std_in] when users break out
of scripts.

A new reset() command is now provided for users to execute whenever
they break out of a script with Control-C.  The reset() command fixes
the theory stack so that INPUT will know to read from std_in again.
reset() cannot (and should not!) be run in any script.

The DIAGNOSTIC toggle is declared early so that INPUT can behave correctly
in diagnostic and demo mode.  In diagnostic or demo mode, the user can
break out of a script by using "q" instead of hitting return after an input.

In scripts, stuff supplied to INPUT is read line by line.  Comments
with (* *) cannot be embedded in text for INPUT, but to-end-of-line
comments can be started with either kind of brace.  (this required
a modification to the stringinput function).  If something breaks in
a script with INPUT text in it, one can expect bizarre errors!

*)

(* June 10:  added backuptheory before running scripts

fixed bug in tactic interpreter; it did not correctly enter
the levels of hypotheses encountered in abstraction terms.

The change is in coercehypslistsense.

statementdisplay() now enables a special display for true=T theorems
(converse statements) with $|- This did not interact with lookhyps,
which does not use eqdisplay, contrary to my earlier beliefs.  This is
OK. 

 *)

(* June 2:  be aware that the experimental file cmatch.sml
now exists (with commutative matching) and will probably eventually
supersede this file *)

(* May 26: completed modifications of thmtextdeps

also added statement display, enabled by statementdisplay() toggle *)

(* May 25:  introduced statement command:

fun statement na ls = axiom na ls "true";  

Completely changed the implementation of theorem text dependencies.

*)

(* May 18:  

fixed bug in the 1|-|n and 2|-|n commands which did not correct level
of hypotheses containing bound variables.

*)

(* March 24:  duplicated from SML/NJ version

eliminated lots of old comments (also in this file).

no change in code:  just a remark that a search for a theorem which
will take the current term to something matching a given term would
often be useful; a built-in tactic for carrying out such searches also
might be interesting.

The current version of the prover has almost all the upgrades I care
about.

Gaps which remain:

a redefinition command appropriate for type definitions.  This can wait
for proof that redefinition will actually be used.

treatment of stratification problems caused by embedded theorems:
tactics defined by abstraction, built-in theorem type thm, automatic
scout declarations for operator theorems (avoiding extra deps posted
to SCINSCOUTDEPS).  This probably can wait until problems are actually
encountered.

the general, hard problem of scin/scout for functions or operators with lists 
of arguments.  This is hard, and requires reflection.

a theoretical question about weak vs. strong versions of opacity.
Should we be able to abstract into opaque contexts when the variables
involved are safely "typed"?  There are plusses and minusses to this;
perhaps a toggle would be the right approach.  This seems too technical;
a related idea would be revival of predicativity restrictions.

"program packages" were not implemented.  Wait until programming is in use.

Note that tri2 and trimetric are not "upgrades that I care about";
they represent experimentation in a new area.  (which will continue).

Another thing I still might do is implement parallel execution order for
the tactic language.  Do this, though it is not highest priority.

Note that targetruleintro can make intelligent use of parameterized
tactics; is there a way to make the multistep commands do this?  This
is a good question; think about it!

Implementation of standard variable binding.  Probably not needed, but
useful for educational applications.

Improved search options; this should be an area of active work.  More
versatile movement commands fall under a similar heading.  Do this!
PARTLY DONE:  See litupto and kin and matchtri above.

Did not reimplement modularity, comments, or on-line help!  On-line help
(which can subsume comments) is needed.

I need to update the documentation (command reference; also add a
section to the command reference on built-in tactics).  Do this.

add application of commutative laws (and perhaps other laws of
stereotyped form) to tri.  There is a vague idea of having an ability
to register new abstract forms which theorems can take and have the
system flag theorems of these kinds?  (so one could add idempotent laws,
for example, without modifying code).  Do this, or at least think about it.

let tri know about hypotheses!  Think about this and do it if it is easy.

rewrite logic?  refinement of success/failure? theoretical questions
about infix variables (generation of new ones, unification?)  All
things not to worry about now.

other built-in data types?  (strings, terms?)

true hierarchical organization of theories; labelling of theorems as
belonging to particular theories (and keeping them all in the same
space).  theorem search across theory boundaries (through views).
This is a practical issue and should be considered!

I need to look at the pretty-printing and see if it is really doing
what I want.  Do this.

Testing of the dependency system is needed; particularly worrying is
the possiblity that type definitions might not be handled correctly.
Do this by working on examples of export (say teaching files).

I definitely need to implement sensible binding and abstraction with
multiple variables of each type (?m..n).  Try doing it in structural,
but be open to idea of doing it hard-wired.  Do this, but first try
writing tactics for structural.wat that do it.

*)


(* March 14:  see SML/NJ version notes *)

(* Sept. 8:  it is no longer necessary (or advisable) to run setup()
when starting up; all that is needed is

load "design";
open design;

*)

(* August 13: developed unification functions; optimized changelevel
and changehlevel by telling them to do nothing when the source and
target are the same *)

(* August 12: fixed yet another bug in the module; setup didn't properly
initialize dependency scratch lists to nil.  August 10 and earlier revisions
concerned output control; Moscow ML needs to be told to flush the output
in certain functions for scripts to work acceptably *)

(* comment these out for SML 93 *)

(* SML 96 Conversion functions 

(* load "Int"; *)

(* val load = load; *)

val std_in = TextIO.stdIn;
val std_out = TextIO.stdOut;
fun output (out, msg) = TextIO.output(out,msg);
fun input (inp, n) = TextIO.inputN(inp,n);

fun makestring(value) = Int.toString(value);
fun explode (s) = (List.map str (String.explode s));
fun implode (ls) = String.concat ls;
fun max(n1,n2) = Int.max(n1,n2);

fun open_out(s) = TextIO.openOut(s);
fun close_out(s) = TextIO.closeOut(s);
fun flush_Out(s) = TextIO.flushOut(s);

fun open_in(s) = TextIO.openIn(s);
fun close_in(s) = TextIO.closeIn(s);

fun flush_Out(s) = TextIO.flushOut(s);

fun substring s = String.substring(s);

(* fun exit() = OS.Process.exit(OS.Process.success); *)
(* fun abort() = OS.Process.exit(OS.Process.failure); *)

 END SML 96 Conversion functions *)

(* used for SML 93 compatibility *)

 fun flush_Out s = (); 


(* Error message function with pause control functions *)

val ERRORPAUSE = ref false;

fun setpause() = ERRORPAUSE := true;

fun setnopause() = ERRORPAUSE := false;

exception Breakout;

val Returns = ref("\n\n");

fun compress() = Returns := "\n";

fun expand() = Returns := "\n\n";



(* due to the needs of the GUI, the error message command
raises an exception rather than pausing (and so waiting for
input that the GUI can't handle) *)

val ERRORFLAG = ref false;

fun clearerrorflag() = ERRORFLAG:=false;

fun errormessage s = (output(std_out,(!Returns)^"Watson:  "^s^(!Returns));
			flush_Out(std_out);ERRORFLAG:=true;
                        if (!ERRORPAUSE) then raise Breakout
                        else ());

(* this command is used for merely informative messages
that should not interrupt script execution *)

fun nopausemessage s = (output(std_out,(!Returns)^"Watson:  "^s^(!Returns));
			flush_Out(std_out));


(* this toggle tells the prover to use the new method of handling
INPUT at top level -- but the old method is available *)

(* It may eventually be used to turn off some other changes used by
the GUI.  In general, turning GUI mode off is deprecated,
and it is not guaranteed to restore previous behavior in all respects. *)

val GUIMODE = ref true;

fun guimode() = (GUIMODE := not(!GUIMODE);nopausemessage 
("GUI mode is "^(if (!GUIMODE) then "on" else "off")));


(* verbosity of output *)

val VERBOSITY = ref 2;

fun bequiet() = VERBOSITY := 0; 

fun thmsonly() = VERBOSITY := 1;

fun speakup() = VERBOSITY := 2;

(* version command *)

fun versiondate() = errormessage 
     "August 31, 2000 (first-order, segmented, for GUI)";

(* container classes *)

(* Watson requires two kinds of container classes, finite sets and
finite functions.  These were implemented as balanced binary trees in
Mark2.  In this design, they are implemented in a very simple way as
lists.  There doesn't seem to be any deficit in performance. *)

(* all operations attempt to maintain the invariant that any
set or function element appears no more than once *)

(* sets *)

(* a set of objects of a given type is simply a list of objects of
that type *)

(* is an object x found in a given set? *)

fun foundinset x nil = false |

	foundinset x (a::rest) = if x = a then true else foundinset x rest;

(* add x to a given set *)

fun addtoset x L = if foundinset x L then L else (x::L);

(* drop x from given set *)

fun dropfromset x nil = nil |

	dropfromset x (a::rest) = if x = a then rest 
	else (a::(dropfromset x rest));

(* union of sets *)

fun union nil L = L |

	union (a::L) M = a::(union L (dropfromset a M));

fun union2 nil = nil |

	union2 (L::M) = union L (union2 M);

fun intersection nil L = nil |

	intersection (a::L) M = if foundinset a M

		then a::(intersection L M)

		else intersection L M;

(* subset relation *)

fun subset nil L = true |

	subset (a::L) M = (foundinset a M) andalso (subset L M);

(* the subset of a list of which the predicate f is true *)

fun separate f nil = nil |

	separate f (a::L) = if (f a) then (a::(separate f L))
	else separate f L;

(* suppose one only wants to find one object for which f is true... *)

fun separate2 f nil = nil |

	separate2 f (a::L) = if (f a) then [a] else separate2 f L;


fun setminus a b = separate (fn x=>not(foundinset x b)) a;

(* sorting a set *)

fun sortsetput (s:string) nil = [s] |

	sortsetput (s:string) (a::L) = if s < a then (s::(a::L))
		else (a::(sortsetput s L));

fun sortset nil = nil |

	sortset (a::L) = sortsetput a (sortset L);

(* functions *)

(* find an object in the list associated with key s; return a one-element
list of the found object if it is found, otherwise nil *)

fun find s nil = nil |

	find s ((t,x)::rest) = if s = t then [x] else find s rest;

(* a safe version of find which gives the object found and a default
when there is no such object *)

fun safefind default s L = let val A = find s L in 
			if A = nil then default else (hd A) end;


(* is there an object with key s in L? *)

(* changed so that lists of things not of equality types can be handled *)

(* fun foundin s L = find s L <> nil; *)

fun foundin s L = length(find s L) > 0;

(* drop item with given key *)

fun drop s nil = nil |

	drop s ((t,x)::L) = if s = t then L else ((t,x)::(drop s L));

(* an optimization, perhaps; it brings the found item to the front
of the list.  this version of find is used inside the thmresult
function below. *)

fun Find s reference = let val A = find s (!reference) in
	if A = nil then nil
	else (reference:=((s,hd A)::drop s (!reference));A) end;

fun Safefind default s reference = let val A = Find s reference in
		if A = nil then default else (hd A) end;

fun Foundin s L = Find s L <> nil;

(* add item with given key; the first will not overwrite and the
second will *)

fun addto s x L = if foundin s L then L else ((s,x)::L);

fun strongadd s x L = addto s x (drop s L);

(* this is the union operation for the theory segments construction;
keys in the second file override keys found in the first. *)

fun strongunion nil L = L |

	strongunion L nil = L |

	strongunion ((s,x)::L) ((t,y)::M) = strongadd t y(
	addto s x(strongunion L M));

(* this is the difference operation for the theory segments construction *)

fun strongdiff L nil = L |
	strongdiff nil M = nil |
	strongdiff ((s,x)::L) M =
		let val FOUND = find s M in
			if FOUND = nil then ((s,x)::strongdiff L M)
			else if (hd FOUND) = x then strongdiff L M
			else ((s,x)::strongdiff L M)
		end;
	            

(* is a list of pairs a function? *)

fun isfun nil = true |

	isfun ((s,x)::L) = let val A = find s L in 
			if A = nil orelse A = [x]
				then isfun L
				else false end;

(* merge function used with match lists; it returns nil as an
error object, and packages resultant lists in a unit list *)

fun merge L M = if isfun (union L M) then [union L M] else nil;

(* sorting a function *)

fun sortfunput (s:string,x) nil = [(s,x)] |

	sortfunput (s:string,x) ((a,y)::L) = if s < a then ((s,x)::((a,y)::L))
		else ((a,y)::(sortfunput(s:string,x) L));

fun sortfun nil = nil |

	sortfun (a::L) = sortfunput a (sortfun L);


(* The primary objects manipulated by Mark2 are terms; the
manipulations allowed are algebraic.  Atomic terms in Mark2 are of
three kinds, constants (which must be declared), free and bound
variables.  Composite terms are of three kinds: terms constructed
using binary infix operators (which must be declared; though there is
a provision for variable infixes), function terms, and terms defined
by cases.  Unary operators are also supported, but they are
coded as binary operators as will be seen below.  *)

(* the separate clauses for reserved identifiers and for case
expressions are a new idea *)

(* term data type declaration *)

(* type of infix operators *)

datatype operator =

	ConOp of string |
	VarOp of string |
	ResOp of string |  (* reserved operator *)
	ParOp of string;   (* an internal device *)

datatype term = 

	(* atomic terms *)
	
	Constant of string |
	Numeral of int list |  (* Mark2 has built in arithmetic *)
	FreeVar of string |
        BoundVar of int |

	(* composite terms *)
	
	Infix of term*operator*term |
	Function of term |
	CaseExp of term*term*term |
	Parenthesis of term;  (* Parenthesis is a special construction
			used internally for various purposes *)

	

(* There are some differences between the surface form of Mark2 terms
(as displayed and understood by a user) and the "deep structure" exhibited
in the type declaration above.  There are also some notational points
not capable of being made in this format.

All atomic terms are represented by strings made of alphanumeric characters
plus the special characters "?" and "_".

The empty string does not represent a constant; Constant "" is used 
internally as an error object.

Strings made up entirely of digits stand for numerals.  They are stored
as lists of digits (in reverse order).  The built in arithmetic of Mark2 is
unlimited precision arithmetic of non-negative integers.

Strings made up of the special character "?" followed by a non-zero-initial
numeral represent bound variables.

Strings which begin with "?" and do not represent bound variables are 
used to represent free variables.

Strings which do not represent any of the above represent constants.
Unlike the three other sorts of atomic term, constants need to be declared
by the user.

We now consider terms defined using operators.  This includes the case
of unary prefix operators, which are in fact supported by Mark2, though
this is not reflected in the data type.  An infix which has been declared
may be used as a prefix operator if a declaration has been made which
assigns to that infix a default left argument; when the operator is
used as a prefix, an invisible left argument is present, equal to the
default; moreover, when a term is entered in binary form whose left
term happens to be the default left argument for its infix, the prover
will display it in unary form.

Operators are represented by nonempty strings made up entirely of special 
characters other than 
the two special characters allowed in atomic terms.

Operators of more than one character beginning with "^" are operator
variables.

All other operators are constant operators and must be declared.

A final refinement: an operator may actually end with alphanumerics:
it consists of (zero or more) special characters possibly followed by
a suffix consisting of one backquote "`" followed by zero or more
alphanumerics, with the length of the whole being nonzero.

Function terms are of the form [term]; a term enclosed in brackets is
a function term.  The appearance of bound variables is restricted to
appropriate function terms; the bound variable ?n may only appear in a
context within at least n nested brackets.

Case expression terms take the surface form ?x || ?y , ?z
This causes some peculiarities because the apparent subterm ?y , ?z
does not correspond to any actual term.  This is handled differently
in the current version of Mark2, but a related problem occurs.

*)

(* we now give code for functions which retrieve the first token of
a given kind (atomic term or operator) from a list of characters; it
has a companion function which returns the rest of the string *)

(* the tokenizer does not consult the declaration lists, but it
does recognize reserved constants and operators *)

(* the list of reserved operators *)

val RESERVED = ref([("bogus",(0,0))]);

(* RESERVED := nil; *)

fun isreserved x = foundin x (!RESERVED);


(* kinds of character *)

fun iscap x = x = "A" orelse x= "B" orelse x = "C" orelse x = "D"
	orelse x = "E" orelse x = "F" orelse x = "G" orelse x = "H"
	orelse x = "I" orelse x = "J" orelse x = "K" orelse x = "L"
	orelse x = "M" orelse x = "N" orelse x = "O" orelse x = "P"
	orelse x = "Q" orelse x = "R" orelse x = "S" orelse x = "T"
	orelse x = "U" orelse x = "V" orelse x = "W" orelse x = "X"
	orelse x = "Y" orelse x = "Z";

fun islowercase x = x = "a" orelse x= "b" orelse x = "c" orelse x = "d"
	orelse x = "e" orelse x = "f" orelse x = "g" orelse x = "h"
	orelse x = "i" orelse x = "j" orelse x = "k" orelse x = "l"
	orelse x = "m" orelse x = "n" orelse x = "o" orelse x = "p"
	orelse x = "q" orelse x = "r" orelse x = "s" orelse x = "t"
	orelse x = "u" orelse x = "v" orelse x = "w" orelse x = "x"
	orelse x = "y" orelse x = "z";

fun isspecial x = x = "!" orelse x = "@" orelse x = "#" orelse x = "$"
	orelse x = "%" orelse x = "^" orelse x = "&" orelse x = "*"
	orelse x = "=" orelse x = "+" orelse x = "-" orelse x = "<"
	orelse x = ">" orelse x = "/" orelse x = "," orelse x = ";"
	orelse x = "." orelse x = ":" orelse x = "~"
	orelse x = "|";

fun isdigit x = x = "0" orelse x = "1" orelse x = "2" orelse x = "3"
orelse x = "4" orelse x = "5" orelse x = "6" orelse x = "7"orelse x = "8" 
orelse x = "9";

(* remove whitespace *)

fun strip nil = nil |

	strip (" "::L) = strip L |
	strip ("\n"::L) = strip L |
	strip ("\t"::L) = strip L |
	strip L = L;

fun isalpha x = iscap x orelse islowercase x orelse isdigit x
	orelse x = "?" orelse x = "_";

(* get desired characters from a list of characters *)

fun getalpha nil = nil |
	getalpha (a::L) = if isalpha a then a::(getalpha L) else nil

and restalpha nil = nil |
	restalpha (a::L) = if isalpha a then restalpha L else (a::L);

fun getnumeral nil = nil |
	getnumeral (a::L) = if isdigit a then a::(getnumeral L) else nil

and restnumeral nil = nil |
	restnumeral (a::L) = if isdigit a then restnumeral L else (a::L);


fun getspecial nil = nil |

getspecial (a::L) = if isspecial a then (a::(getspecial L)) else 
	if a = "`" then (a::(getalpha L))
	else nil
and restspecial nil = nil |
	restspecial (a::L) = if isspecial a then restspecial L 
	else if a = "`" then restalpha L
	else (a::L);

(* integer character value *)

fun numvalue "0" = 0 |
	numvalue "1" = 1 |
	numvalue "2" = 2 |
	numvalue "3" = 3 |
	numvalue "4" = 4 |
	numvalue "5" = 5 |
	numvalue "6" = 6 |
	numvalue "7" = 7 |
	numvalue "8" = 8 |
	numvalue "9" = 9 |
	numvalue x = ~1;

(* fun evalnum nil = 0 |

	evalnum ("0"::L) = 0 + 10*(evalnum L) |
	evalnum ("1"::L) = 1 + 10*(evalnum L) |
	evalnum ("2"::L) = 2 + 10*(evalnum L) |
	evalnum ("3"::L) = 3 + 10*(evalnum L) |
	evalnum ("4"::L) = 4 + 10*(evalnum L) |
	evalnum ("5"::L) = 5 + 10*(evalnum L) |
	evalnum ("6"::L) = 6 + 10*(evalnum L) |
	evalnum ("7"::L) = 7 + 10*(evalnum L) |
	evalnum ("8"::L) = 8 + 10*(evalnum L) |
	evalnum ("9"::L) = 9 + 10*(evalnum L) |
	evalnum x = ~1; *)

fun evalnum nil = 0 |

	evalnum (x::L) = if isdigit x 
	then let val A = evalnum L in
	if A = ~1 then ~1 else (numvalue x) + (10*A)
	end 
	else ~1;

fun listtoint nil = 0 |

	listtoint (n::L) = n + 10*(listtoint L);

(* strips unwanted zeroes off fronts of numerals *)

fun stripzeroes nil = (0::nil) |

	stripzeroes (0::nil) = 0::nil |

	stripzeroes (0::L) = stripzeroes L |

	stripzeroes L = L;

(* strips unwanted zeroes off ends of reversed lists of digits
(our internal representation of integers) *)

fun stripzeroes2 L = rev(stripzeroes(rev L));


(* functions which extract the first atom represented in a list
of characters and return the rest of the list *)


fun prefirstatom s = let val A = getnumeral  s and B = getalpha s in

		if A <> nil andalso A = B then 
			Numeral (rev (stripzeroes(map numvalue A)))

		else 

		if B<>nil then 

			if hd B = "?" then

				let val C = getnumeral (tl B) in

				if C <> nil andalso C = tl B

				then BoundVar (evalnum (rev C)) 

				else FreeVar (implode B) end

			else Constant (implode B)

		else Constant "" end  (* conventional error value *)

and prerestfirstatom s  = let val A = getnumeral s and B = getalpha s in

		if A <> nil andalso A = B then restnumeral s

		else

		if B<>nil then restalpha s

		else s end   (* conventional error value *)

(* this function returns the first atomic term in the string s,
if any.  A locution like "stringtocon s = FreeVar s" asks whether
s is a free variable; in the case of constants, one also needs to
stipulate that s is not "" *)

fun stringtocon s = prefirstatom (strip (explode s));

fun firstatom s = prefirstatom (strip s);

fun restfirstatom s = prerestfirstatom (strip s);

(* functions for getting the first operator from a list of characters
and the rest of the list *)

fun prefirstop s = let val A = getspecial s in

			if A = nil then ConOp "" (* error value *)

			else if hd A = "^" andalso tl A <> nil

				then VarOp (implode A)

			else if isreserved (implode A)

				then ResOp (implode A)

				else ConOp (implode A)

			end;

(* this function gets the first operator from a string; see comments under
stringtocon *)

fun stringtoop s = prefirstop (strip (explode s));

fun firstop s = prefirstop (strip s);

fun restfirstop s = restspecial (strip s);

(* cleans up parentheses -- appears here because stringtoop is needed *)

fun deparenthesize1 (Parenthesis t) = t |

	deparenthesize1 t = t;

fun deparenthesize (Parenthesis t) = deparenthesize t |
	deparenthesize (Function s) = Function(deparenthesize s) |
	deparenthesize (Infix(x,ParOp s,y)) =Infix(deparenthesize x,
					stringtoop s,
					deparenthesize y) |
	deparenthesize (Infix(x,i,y)) = Infix(deparenthesize x,i,
					deparenthesize y) |
	deparenthesize (CaseExp(u,v,w)) = CaseExp(deparenthesize u,
					deparenthesize v,deparenthesize w) |
	deparenthesize t = t;


(* We now construct a family of functions culminating in the parser.
In this version, we do not allow user declared precedence, which is
found in the full implementation; most users have been content with
the APL precedence (all operators have same precedence, all operators
group to the right) which is the default in the full implementation *)

(* We begin with the declaration lists (needed by the display function
to handle prefix operators, as well as by the parser), follow with the
display functions, and conclude with the parser *)

(* the constant declaration list *)

val CONSTANTS = ref(["bogus"]);

fun isaconstant s = (stringtocon s = 
	Numeral (rev(stripzeroes(map (numvalue) (explode s)))))
	orelse foundinset s (!CONSTANTS);

(* USER COMMAND *)

fun declareconstant s = if s <> "" andalso stringtocon s = Constant s

	then if foundinset s (!CONSTANTS)

		then errormessage ("Constant "^s^" already declared")

		else CONSTANTS:=addtoset s (!CONSTANTS)

	else errormessage ("Ill-formed constant "^s^" cannot be declared");

(* operator declarations *)

(* operators require integer "left type" and "right type" parameters for
the stratification function *)


val OPERATORS = ref([("bogus",(1,2))]);

fun isoperator s = if stringtoop s = VarOp s then true

	else if stringtoop s = ResOp s then true

	else if s <> "" andalso stringtoop s = ConOp s then

		if foundin s (!OPERATORS) then true

		else false

	else false;


val defaultop = (0,0);

fun opof s = if (stringtoop s) = ResOp s then safefind defaultop s (!RESERVED)
		else safefind defaultop s (!OPERATORS);

fun lefttype s = (fn (a,b) => a) (opof s);
fun righttype s = (fn (a,b) => b) (opof s);

(* It is permissible to declare variable operators in order 
to record their type information *)

(* USER COMMAND *)

fun declaretypedinfix m n s = if stringtoop s = ResOp s

	then errormessage ("Reserved operator "^s^" cannot be redeclared")

	else if stringtoop s = VarOp s 

	then if foundin s (!OPERATORS) 

		then errormessage 
	("Variable operator "^s^" has already been typed")

		else OPERATORS:=
		addto s (m,n)(!OPERATORS)

	else if s <> "" andalso stringtoop s = ConOp s

		then  if foundin s (!OPERATORS)

		then errormessage ("Operator "^s^" has already been declared")

		else OPERATORS:=
		addto s (m,n) (!OPERATORS)

	else errormessage ("Ill-formed operator "^s^" cannot be declared");

(* Declaration of reserved operators:  not a user command! *)

fun reserveop m n s = if s <> "" andalso 
	stringtoop s = ConOp s andalso (not (isoperator s))

	then RESERVED:=addto s (m,n) (!RESERVED)

	else errormessage ("Improper operator reservation of "^s); 

(* reserveop 0 0 "||";

reserveop 0 0 ","; *)

(* declares the usual "flat" operators with only trivial type information *)

(* USER COMMAND *)

fun declareinfix s = declaretypedinfix 0 0 s;


(* lists of operators with special properties needed by the
stratification functions of the prover *)

val OPAQUE = ref["bogus"];
val SCOUT = ref[("bogus","bogus")];
val SCINLEFT = ref[("bogus","bogus")];
val SCINRIGHT = ref[("bogus","bogus")];

(* opaque operators are "opaque" to abstraction; one cannot define
a function in a way which essentially involves an opaque operator
(an opaque operator could appear in the name of a constant) *)

(* distinct from defined opaque "constant" operators (not used in 
any current theory, though they could be) are opaque variable operators;
an operator variable with declared type matches only operators of that
same type, while an opaque operator matches any operator, and for that
reason must observe the same restrictions on abstraction as an opaque
declared operator *)

fun isopaque s = s = "@!" orelse foundinset s (!OPAQUE);

fun istypedoperator s = (foundin s (!RESERVED) orelse foundin s (!OPERATORS))
	andalso not (isopaque s);

(* declare opaque operator *)

fun declareopaque s = if stringtoop s = ResOp s 

	then errormessage ("Reserved operator "^s^" cannot be made opaque")

	else if stringtoop s = VarOp s 

	then if foundin s (!OPERATORS) 

		then errormessage 
	("Reserved or variable operator "^s^" has already been typed")

		else (OPERATORS:=
		addto s (0,0)(!OPERATORS);OPAQUE:=addtoset s (!OPAQUE))

	else if s <> "" andalso stringtoop s = ConOp s

		then  if foundin s (!OPERATORS)

		then errormessage ("Operator "^s^" has already been declared")

		else (OPERATORS:=
		addto s (0,0) (!OPERATORS);OPAQUE:=addtoset s (!OPAQUE))

	else errormessage ("Ill-formed operator "^s^" cannot be declared");
 

(* scout = strongly Cantorian output; scinleft = strongly Cantorian input
(left argument) and scinright = strongly Cantorian input (right argument) 
strongly Cantorian = (in practice) belonging to some data type *)

val SCINSCOUT = ref ["bogus"];  (* list used in posting axiom 
				dependencies induced by scin/scout functions *)

fun scoutof s = safefind "" s (!SCOUT);

fun scinleftof s = safefind "" s (!SCINLEFT);

fun scinrightof s = safefind "" s (!SCINRIGHT);

fun isscout s = let val A = foundin s (!SCOUT) in
	(if A then SCINSCOUT:=addtoset (scoutof s) (!SCINSCOUT) else ();A) end;

fun isscinleft s = let val A = foundin s (!SCINLEFT) in
	(if A then SCINSCOUT:=addtoset (scinleftof s) (!SCINSCOUT) 
	else ();A) end;

fun isscinright s = let val A = foundin s (!SCINRIGHT) in
	(if A then SCINSCOUT:=addtoset (scinrightof s) (!SCINSCOUT) 
	else ();A) end;

(* assignment of scin/scout properties to theorems needs to
be witnessed by existence of theorems of appropriate forms and
will be handled later *)

(* prefix display declarations -- needed for display as well as
parser *)

(* variable prefix operators are needed! *)

(* the default left argument of an operator will be an atomic constant *)

val PREFIX = ref([("bogus","bogus")]);

(* PREFIX := nil; *)

fun prefixof s = safefind "" s (!PREFIX);

fun hasprefix s = foundin s (!PREFIX);

(* command to assign a default left argument to an operator;
this version only permits such an assignment to be made once *)

(* USER COMMAND *)

fun declareprefix s t = if hasprefix s then 

	errormessage ("Cannot reassign default left argument of "^s)

	else if (stringtoop s = ResOp s orelse (stringtoop s
	= ConOp s andalso isoperator s)) andalso
		isaconstant t

	then PREFIX := addto s t (!PREFIX)

	else errormessage ("Invalid prefix "^t^" proposed for operator "^s);

(* NOT a user command -- this command creates strict prefix operators,
which are those operators which have a prefix on the list equal to "" *)

(* it is necessary to be able to declare strict prefix operator
variables so that one can build structural tactics which will work
on prefix terms *)

fun isstrictprefix s = hasprefix s andalso prefixof s = "";

fun declarestrictprefix s = if (stringtoop s = ResOp s orelse 
	stringtoop s = VarOp s orelse (stringtoop s
	= ConOp s andalso isoperator s)) then PREFIX := addto s "" (!PREFIX)
	else errormessage 
	("Undeclared operator "^s^" cannot be declared strict prefix");

(* declarations of strictly unary operators *)

fun declaretypedunary n s = (declaretypedinfix 0 n s; declarestrictprefix s);

fun declareunary s = declaretypedunary 0 s;

fun declareunaryopaque s = (declareopaque s; declarestrictprefix s);

(* default type handling:  this allows the suppression of type labels
on variables which are understood to usually have a given type; the
type label infix : appears as a prefix operator in this case *)

val VARTYPES = ref [("bogus",Constant "")];

(* VARTYPES := nil; *)

fun hasdefaulttype v = foundin v (!VARTYPES);

fun defaulttypeof v = safefind (Constant "") v (!VARTYPES);

fun hasdtprefix ":" (FreeVar v) = hasdefaulttype v |

	hasdtprefix s t = false;

fun dtprefixof ":" (FreeVar v) = defaulttypeof v |

	dtprefixof s t = Constant "";

fun haseitherprefix s t = hasprefix s orelse hasdtprefix s t;

fun eitherprefixof s t = if hasprefix s then stringtocon (prefixof s)

			else dtprefixof s t;

(* USER COMMAND *)

fun notypeinfo v = if foundin v (!VARTYPES)

	then VARTYPES:=drop v (!VARTYPES)

	else errormessage ("No default type for "^v^" found to drop");

(* function for assigning types is found below; it requires
declaration checking *)

(* I might want to add scin/scout information *)

fun showdec s = if stringtocon s = Constant s 
		then if isaconstant s
		then errormessage (s^" is a declared constant")
		else errormessage ("Undeclared constant "^s)
		else if stringtocon s = 
		Numeral (rev (stripzeroes(map numvalue (explode s))))

		then errormessage "Numerals are predeclared"

		else if (stringtoop s = ResOp s)
			then if isopaque s 
			then errormessage ("Opaque reserved operator "^s)
			else if isoperator s
			then errormessage 
			("Reserved operator "^s^" left type:  "
			^(makestring (lefttype s))^" right type: "
				^(makestring(righttype s)^
				" left arg (if any): "^(prefixof s)))
			else errormessage ("Undeclared reserved operator?!")
		else if (stringtoop s = ConOp s)
			then if isopaque s 
			then errormessage ("Opaque declared operator "^s)
			else if isoperator s
			then errormessage ("Declared operator "^s^
				" left type: "
			^(makestring (lefttype s))^" right type: "
				^(makestring(righttype s))^
				(if hasprefix s then 
				if prefixof s = "" then " Prefix operator only"
				else " Default left argument:  "^(prefixof s)
				else " Infix argument only"))
		
			else errormessage ("Undeclared operator")
		
		else if stringtoop s = VarOp s andalso foundin s (!OPERATORS)
		then errormessage ("Typed variable operator "^s^" left type: "
		^(makestring (lefttype s))^" right type: "^
		(makestring(righttype s))^
		(if hasprefix s then " (strict prefix)" else ""))

		else if stringtoop s = VarOp s andalso isopaque s
		then errormessage ("Opaque operator variable "^s^
		(if hasprefix s then " (strict prefix)" else ""))

		else if stringtoop s = VarOp s then errormessage
			("Undeclared operator variable "^s)

		else errormessage "No applicable declaration";


(* simple display function *)

fun opdisplay (ConOp s) = s |

	opdisplay (VarOp s) = s |

	opdisplay (ResOp s) = s |

	opdisplay (ParOp s) = "{"^s^"}";

(* the master precedence list *)

val PRECEDENCES = ref ([("bogus",0)]);

(* PRECEDENCES:=nil; *)

(* default precedence *)

val DEFAULTPREC = ref 0;

(* user command to set precedence of an operator *)

fun setprecedence s n = if n<0 then setprecedence s 0 
			else PRECEDENCES := strongadd s n (!PRECEDENCES);

(* user command to set default precedence *)

fun setdefaultprec n = if n < 0 then setdefaultprec 0 else
			DEFAULTPREC := n;

(* user command to reset precedences to standard *)

fun clearprecs () = (PRECEDENCES := nil; DEFAULTPREC := 0);

fun precedenceof s = safefind (!DEFAULTPREC) s (!PRECEDENCES);

(* sophisticated precedence commands *)

fun preraiseprecs n nil = nil |
preraiseprecs n ((s,m)::L) = (s,if m>=n then m+2 else m)::(preraiseprecs n L);

fun raiseprecs n = PRECEDENCES := preraiseprecs n (!PRECEDENCES);

(* USER COMMANDS (5) *)

(* these commands allow precedences to be set relative to an
existing precedence -- either the same, just above, or just below
(making insertions in the latter two cases) and with left or
right grouping as indicated *)

fun sameprec s t = setprecedence s (precedenceof t);

fun defaultprecsame s = setdefaultprec (precedenceof s);

fun leftprecabove s t = (raiseprecs ((precedenceof t)+2);
                           setprecedence s ((precedenceof t)+1+
                                           ((precedenceof t) mod 2)));

fun rightprecabove s t = (raiseprecs ((precedenceof t)+2);
                           setprecedence s ((precedenceof t)+2-
                                           ((precedenceof t) mod 2)));

fun leftprecbelow s t = (raiseprecs ((precedenceof t));
                           setprecedence s ((precedenceof t)-1+
                                           ((precedenceof t) mod 2)));

fun rightprecbelow s t = (raiseprecs ((precedenceof t));
                           setprecedence s ((precedenceof t)-2+
                                           ((precedenceof t) mod 2)));


(* NORULES supports a mode in which embedded theorems are not
displayed (when it is true) *)

val NORULES = ref false;

(* in the old version, =>> and <<= were rule infixes as well, but they
are not in this version (they are operators linking a pair of theorems) *)

fun ruleinfix s = s = "=>" orelse s = "<=";

fun stickiness (Infix(x,s,y)) = if (!NORULES) andalso

	ruleinfix (opdisplay s) then stickiness y else

	precedenceof (opdisplay s) |

	stickiness (CaseExp(u,v,w)) = precedenceof "||" |

	stickiness x = 0;

(* this refers to surface form *)

fun isinfixterm (Infix(x,s,y)) = if (!NORULES) andalso
	ruleinfix (opdisplay s) then isinfixterm y else true |

	isinfixterm (CaseExp(u,v,w)) = true |

	isinfixterm x = false;

fun isprefixterm (Infix(x,s,y)) = (x = eitherprefixof (opdisplay s) y) |

	isprefixterm x = false;

(* parentest x s b tells us whether term x needs to be parenthesized
when it is term b (left term has b=0, right term has b=1) in an infix
term with infix s *)

(* there is a difficulty with parentheses around prefix terms to the
right of an infix; such parentheses are sometimes eliminable, but this
depends on context in a way which is hard to implement. *)

fun parentest x s b = ((not (!NORULES)) 
	orelse (not (ruleinfix (opdisplay s)))) 
	andalso (isinfixterm x andalso ((stickiness x <
	precedenceof (opdisplay s)) orelse
	(stickiness x = precedenceof (opdisplay s) andalso 
	((stickiness x) mod 2 = b))));

(* pp for "possible parenthesis" *)

fun pp x s b p = if parentest x s b then p else ""; 

(* function for converting preparsed terms to correct form *)

fun reassociate1 (Infix(x,s,Infix(y,t,z))) =

	if ((precedenceof (opdisplay s) > precedenceof (opdisplay t))
	orelse (precedenceof (opdisplay s) = precedenceof (opdisplay t)
	andalso ((precedenceof (opdisplay s)) mod 2) = 1))
	andalso y <> eitherprefixof (opdisplay t) z

	then Infix(reassociate1(Infix(x,s,y)),t,z)

	else (Infix(x,s,Infix(y,t,z))) |

	reassociate1 t = t;

fun reassociate (Parenthesis t) = Parenthesis (reassociate t) |

	reassociate (Function t) = Function (reassociate t) |

	reassociate (Infix(x,s,y)) = 
		reassociate1 (Infix(reassociate x,s,reassociate y)) |

	reassociate t = t;

(* baredisplay should now handle user-defined precedence correctly *)

fun baredisplay (Constant s) = s |

	baredisplay (Numeral n) = implode(rev (map makestring n)) |

	baredisplay (FreeVar s) = s |

	baredisplay (BoundVar s) = "?"^(makestring s) |

	baredisplay (Infix(t,i,u)) = let val T = baredisplay t in

		(* the baredisplay function does not use 
		default type information; this avoids trouble
		for load and save commands *)

		if T = prefixof (opdisplay i)

			then (opdisplay i)^" "^(pp u i 1 "(")^
			(baredisplay u)^(pp u i 1 ")")

			else (pp t i 0 "(")^T^(pp t i 0 ")")^" "
			^(opdisplay i)^" "
			^(pp u i 1 "(")
			^(baredisplay u)^(pp u i 1 ")") end |

	baredisplay (Function t) = "["^(baredisplay t)^"]" |

	(* display of case expressions "cheats"; it relies on the
	surface form of case expressions as complex infix expressions *)

	(* this works because the display functions are independent
	of declarations *)

	baredisplay (CaseExp(t,u,v)) = baredisplay 
		(Infix(t,ResOp("||"),Infix(u,ResOp(","),v))) |

	(* the case for Parenthesis handles highlighting the current subterm *)

	baredisplay (Parenthesis t) = "{"^(baredisplay t)^"}";

val CURSOR = ref 0;

fun bumpcursor s = (CURSOR:=(!CURSOR)+(length(explode s));s);

val MARGIN = ref 50;

fun setline n = MARGIN:=n;

fun spaces 0 = "   " |

	spaces n = (spaces (n-1))^"   ";

fun predashes 0 = "" |
	predashes 1 = " " |
	predashes 2 = "  " |
        predashes 3 = "   " | 
	predashes n = if n<0 then "" else (predashes (n-1))^"-";

fun dashes() = predashes (!MARGIN);

fun Newline() = (CURSOR:=0;"\n");

fun maybebreak d = if (!CURSOR) >= (!MARGIN)

		then (Newline()^bumpcursor(spaces d))

		else ""; 


fun predisplay d (Constant s) = 
	(bumpcursor s) |

	predisplay d (Numeral n) = (bumpcursor
		(implode(rev (map makestring n)))) |

	predisplay d (FreeVar s) =(bumpcursor s) |

	predisplay d (BoundVar s) = 
	(bumpcursor ("?"^(makestring s))) |

	predisplay d (Infix(t,i,u)) = 

		if (!NORULES) andalso ruleinfix (opdisplay i)

			then predisplay d u

		else let val T = baredisplay t in

		if T = baredisplay(eitherprefixof (opdisplay i) u)

			then 

			(bumpcursor (opdisplay i))
			^" "
			^(bumpcursor (pp u i 1 "("))
			^(predisplay (if parentest u i 1 then d+1 else d) u)
			^(bumpcursor (pp u i 1 ")"))

			else (bumpcursor (pp t i 0 "("))
			^(predisplay (if parentest t i 0 then d+1 else d) t)
			^(bumpcursor (pp t i 0 ")"))
			^(bumpcursor " ")
			^(maybebreak d)
			^(bumpcursor(opdisplay i))
			^(bumpcursor " ")
			^(bumpcursor (pp u i 1 "("))
			^(predisplay (if parentest t i 0 then d+1 else d) u)
			^(bumpcursor (pp u i 1 ")")) end |

	predisplay d (Function t) = (bumpcursor "[")^
				(predisplay (d+1) t)^(bumpcursor "]") |

	(* display of case expressions "cheats"; it relies on the
	surface form of case expressions as complex infix expressions *)

	(* this works because the display functions are independent
	of declarations *)

	predisplay d (CaseExp(t,u,v)) = predisplay d
		(Infix(t,ResOp("||"),Infix(u,ResOp(","),v))) |

	(* the case for Parenthesis handles highlighting the current subterm *)

	predisplay d (Parenthesis t) = (bumpcursor "{")
				^(predisplay (d+1) t)^(bumpcursor "}");


fun display t = (CURSOR:=0;(spaces 0)^(predisplay 0 t));

(* the parser *)

(* the parser engine works, like the tokenizer, with a list of characters *)

(* functions for extracting projections from pairs *)

fun p1(x,y) = x;

fun p2(x,y) = y;

(* the only change involved in user-defined precedence is recording
of user-supplied parentheses *)

fun getfirstterm L =

	if (strip L) = nil then (Constant "", nil)
	else let val A = firstatom L and B = strip(restfirstatom L) in
	if A <> Constant ""
		then (* first term is atomic *)
		(A,B)
	else let val C = firstop L and D = strip(restfirstop L) in
	if C <> ConOp ""
		then (* first term has a prefix operator *)
		let val E = getterm D in
		if haseitherprefix (opdisplay C) (p1 E) then
			if p1 E = Constant "" then (Constant "",nil)
			else ((* Parenthesis *)(
				Infix(eitherprefixof(opdisplay C)(p1 E),
				C,p1 E)),p2 E)
			
		else (Infix(Constant "",C,p1 E),p2 E) end
	else if hd (strip L) = "["
		then (* function term *)
		let val G = getterm (tl(strip L)) in
		if p1 G = Constant "" orelse p2 G = nil orelse
			hd(p2 G) <> "]"
			then (Constant "", nil)
		else (Function(p1 G),strip(tl(p2 G)))
		end
	else if hd (strip L) = "("
		then (* parenthesis term *)
		let val G = getterm (tl(strip L)) in
		if p1 G = Constant "" orelse p2 G = nil 
			orelse hd(p2 G) <> ")"
			then (Constant "", nil)
		else (Parenthesis (p1 G),strip(tl(p2 G)))
		end
	else (Constant "",nil)
	end
	end

and getterm L = let val (A,B) = getfirstterm L in
if A = Constant "" 
	then (Constant "",nil)
else if B = nil orelse hd B = "]" orelse hd B = ")"
	then (A,B)
else let val C = firstop B and D = strip(restfirstop B) in
	if C = ConOp "" then (Constant "",nil)
	else let val E = getterm D in
		if p1 E = Constant "" then (Constant "",nil)
		else (Infix(A,C,p1 E),p2 E)
		end
	end
end;


(* the parser reads case expressions as a particular kind of infix
expression; the casefix function rectifies this situation and rejects
expressions of the form ?x || ?y where ?y is not a pair. *)

fun casefix (Infix(x, ResOp "||",Infix(y,ResOp",",z))) =

		CaseExp(casefix x,casefix y,casefix z) |

	casefix (Infix(x,ResOp"||",y)) = 
	(errormessage "Ill-formed case expression"; Constant "") |

	casefix (Function t) = Function (casefix t) |

	casefix (Infix (x,s,y)) = Infix(casefix x,s,casefix y) |

	casefix t = t;

fun parse s = let val A = getterm(explode s) in if p2 A = nil then 
	casefix(deparenthesize(reassociate(p1 A)))
	else Constant "" end;

(* the theorem-embedding infixes which signal intentions to rewrite *)

(* reserveop 0 0 "=>";

reserveop 0 0 "<="; *)

(* they are actually declared in the setup command at the end *)


(* operators of built-in arithmetic *)

(* the declarations are actually made later in the setup command *)

(* reserveop 0 0 "+!"; reserveop 0 0 "-!"; reserveop 0 0 "*!"; reserveop 0 0 "/!";
reserveop 0 0 "%!"; reserveop 0 0 "<!"; reserveop 0 0 ">!"; 
reserveop 0 0 "=!"; *)

fun arithop s = s = "+!" orelse s = "-!" orelse s = "*!" orelse s = "/!"
orelse s = "%!" orelse s = "<!" orelse s = ">!" orelse s = "=!";

(* the rulefree function certifies a term as free of "execution
behaviour" *)

(* execution behaviour refers to presence of embedded theorems,
operations of the built-in arithmetic, or case expressions whose
hypotheses are truth values or equations with first term true. *)

(* declarations for functional programming *)

val PROGRAMS = ref ([("bogus","bogus")]);

(* command setprogram to bind a program to a constant or operator 
is found below *)

(* USER COMMAND *)

(* user program to remove any tactic bound to a function or operator *)

fun deprogram s = PROGRAMS := drop s (!PROGRAMS);

fun hasprogram s = foundin s (!PROGRAMS);

fun programof s = safefind "" s (!PROGRAMS);

(* moved here from near changehlevel below because of needs of 

enhanced higher-order matching  *)

fun changelevel source target (BoundVar s) = 
	if s <= source andalso s <= target then BoundVar s
	else if s <= source andalso s > target then Constant ""
	else BoundVar (target + (s - source)) |
	changelevel source target (Function t) =

		let val TRY = changelevel source target t in
		if TRY = Constant "" then Constant "" else Function TRY end |
	changelevel source target (Infix(x,i,y)) =

		let val TRY1 = changelevel source target x
		and TRY2 = changelevel source target y in
		if (TRY1 = Constant "" andalso ((not(hasprefix (opdisplay i)))
			orelse prefixof (opdisplay i) <> ""))
		orelse TRY2 = Constant ""
		then Constant "" else Infix(TRY1,i,TRY2)  end |
	changelevel source target (CaseExp(u,v,w)) =

		let val TRY1 = changelevel source target u
		and TRY2 = changelevel source target v
		and TRY3 = changelevel source target w in

		if TRY1 = Constant "" orelse TRY2 = Constant "" 
			orelse TRY3 = Constant ""
		then Constant ""
		else (CaseExp(TRY1,TRY2,TRY3))
		end |
	changelevel source target (Parenthesis u) =

		let val TRY = changelevel source target u in

		if TRY = Constant "" then Constant "" else Parenthesis TRY 
		end |

	changelevel source target t = t;


fun rulefree (Infix(Numeral m,ResOp s,Numeral n)) = not(arithop s) |

	rulefree (Infix(x,ResOp s, y)) = (not(ruleinfix s))

	andalso rulefree x andalso rulefree y |

	rulefree (CaseExp(Infix(Constant"true",ResOp"=",x),y,z)) = false |

	rulefree (CaseExp (u,v,w)) = u <> Constant "true" andalso
	u <> Constant "false" andalso rulefree u andalso rulefree v
	andalso rulefree w |

	rulefree (Function t) = rulefree t |

	rulefree (Infix(x,i,y)) = rulefree x andalso rulefree y |

	rulefree t = true;

(* list of "locally free" bound variables on which a term
depends -- obviously this needs the level as a parameter *)

fun boundvarlist level (BoundVar s) = if s=0 then nil else [s] |

	boundvarlist level (Infix(u,i,v)) = union (boundvarlist level u) 
		(boundvarlist level v) |

	boundvarlist level (Function t) = dropfromset (level + 1) 
		(boundvarlist (level+1) t) |

	boundvarlist level (CaseExp(u,v,w)) = union
		(boundvarlist level u) (union
		(boundvarlist level v)(boundvarlist level w)) |

	boundvarlist level t = nil;

(* the "stratification" function for "predicate" abstraction:
roughly, no bound variables to occur free in applied position *)

(* it's actually rather more elegantly described now; the constraint
described above is obtained without any direct reference to bound
variables per se *)

fun metahead level n (Function t) = metahead (level+1) (n-1) t |

	metahead level n (Infix(x,ResOp"@!",y)) = metastrat level y
		andalso metahead level (n+1) x |

	metahead level n (FreeVar x) = true |

	metahead level n (Infix(x,ResOp"=>",y)) =

		metahead level n y |

	metahead level n (Infix(x,ResOp"<=",y)) =

		metahead level n y |

	metahead level n (Parenthesis t) = metahead level n t |

	metahead level n (CaseExp(u,v,w)) =

		metahead level n v andalso metahead level n w |

	metahead level n t = (n<=0 andalso metastrat level t)

and	metastrat level (Infix (x,ResOp"@!",y)) = 

	metahead level 1 x andalso metastrat level y |

	metastrat level (Infix(x,i,y)) = 
	metastrat level x andalso metastrat level y |

	metastrat level (Function t) = metastrat (level+1) t |

	metastrat level (CaseExp(t,u,v)) = metastrat level t 
		andalso metastrat level u andalso metastrat level v |

	metastrat level (Parenthesis t) = metastrat level t |

	metastrat level t = true;


(* the master declaration checking function; it checks constants,
operators, and bound variables for meaningfulness *)

(* declarecheck sends error messages (if the quiet parameter is false), 
but only for the first error it
encounters *)

(* design decision:  we do not check for meaningless m|-|n, because
such things appear to be harmless (and even potentially useful) *)

fun declarecheck quiet (level:int) (Constant s) = 
		if isaconstant s then true 
	else

	((if quiet then () else 
	errormessage ("Undeclared constant "^s^" found"));false) |

	declarecheck quiet level (Numeral n) = true |

	declarecheck quiet level (FreeVar s) = true |

	declarecheck quiet level (BoundVar s) = if s<=level 
		then true else ((if quiet then () else errormessage 
	("Meaningless bound variable ?"^(makestring s)^" found"));false) |

	declarecheck quiet level (Function t) = metastrat level (Function t)
		andalso
		declarecheck quiet ((level:int)+1) t |

	declarecheck quiet level (CaseExp(u,v,w)) = 
		(declarecheck  quiet level u) 
		andalso
		(declarecheck quiet level v) andalso 
		(declarecheck quiet level w) |

	declarecheck quiet level (Infix(x,ResOp"@!",y)) = 

		declarecheck quiet level x andalso declarecheck quiet level y
		andalso metahead level 1 x | 

	declarecheck quiet level (Infix(u,ResOp s,v)) =

		if isstrictprefix s
		then if u = Constant "" then declarecheck quiet level v
		else ((if quiet then () else errormessage 
		("Exclusive prefix operator "^s^" used as infix"));false)
		else (declarecheck quiet level u) 
		andalso
		(declarecheck quiet level v) |

	declarecheck quiet level (Infix(u,VarOp s,v)) = 


		if stringtoop s <> VarOp s 
		then ((if quiet then () 
		else errormessage ("Ill-formed infix variable "^s));false)
		else if isstrictprefix s 
		then if u = Constant "" then declarecheck quiet level v
		else ((if quiet then () else errormessage 
		("Exclusive prefix operator "^s^" used as infix"));false)
		else (declarecheck  quiet level u) 
		andalso
		(declarecheck quiet level v) |

	declarecheck quiet level (Infix(u,ConOp s,v)) = 
		if isstrictprefix s  
		then if u = Constant "" then 
		(declarecheck quiet level v)

		andalso if isoperator s then true 
		else ((if quiet then () 
		else errormessage ("Undeclared operator "^s^" found"));false)

		else ((if quiet then () else errormessage 
		("Exclusive prefix operator "^s^" used as infix"));false)

		else (declarecheck  quiet level u) 
		andalso
		(declarecheck quiet level v)

		andalso if isoperator s then true 
		else ((if quiet then () 
		else errormessage ("Undeclared operator "^s^" found"));false) |

	declarecheck quiet level (Parenthesis u) = 

		((if quiet then () else errormessage ("Braces found"));false);

(* stratification checking *)

(* reserveop 0 0 ":"; *)  (* the type label (retraction) infix *)

(* the actual declaration is deferred to setup *)

(* the stratification function takes as its parameter a local
type and generates a list of lists of type assignments to bound variables,
which will be empty if there is no consistent type assignment; otherwise,
the first of these lists will be the types fixed for bound variables
in the given context, while subsequent lists record known "relative"
types which may be shifted by a constant amount *)

(* utilities which operate on lists of type assignments *)

fun shifttype n nil = nil |

	shifttype (n:int) ((p,q)::L) = ((p,q+n)::shifttype n L);

(* finds a candidate for the displacement between two type
assignments -- does not check for consistency! *)

(* returns nil if there is no point of contact between the lists *)

fun typediff nil L = nil |

	typediff ((p,q:int)::L) M = let val A = find p M in
		if A = nil then typediff L M  else [q -(hd A)] end;

(* shiftmerge, given two type assignment lists, returns the list of
the two if they have no point of contact, returns nil if they are
inconsistent, and returns the merged list otherwise (shifting the
second list by the amount reported by typediff) *)

(* the first two clauses allow for considerable simplification; "floating"
lists with zero or one entry do not supply any information, but may
not merge using the third clause *)

fun shiftmerge L nil = [L] |

	shiftmerge L (x::nil) = [L] |

	shiftmerge L M = if typediff L M = nil then [L, M]
	else merge L (shifttype (hd (typediff L M)) M); 

(* crushtypes simplifies a list of type assignment lists, merging any
lists which have a point of contact and preserving the special role
of the head of the list (whose types must be fixed) *)

fun crushtypes nil = nil |

	crushtypes (L::nil) = (L::nil) |

	crushtypes (L::(M::rest)) = let val A = crushtypes (M::rest)
		in if A = nil then nil else let val (N::rest2) = A in
		if shiftmerge L N = nil then nil
		else if shiftmerge L N = [L,N] 
		then ((crushtypes (L::rest2))@[N])
		else crushtypes ((shiftmerge L N)@rest2) end end;

(* merges two type lists *)

fun mergetypes nil L = nil |

		mergetypes M nil = nil |

		mergetypes (L::rest1) (M::rest2) = 

			if merge L M = nil then nil

			else crushtypes((merge L M)@rest1@rest2);

(* checkappend is used in strat for "floating" a type list; we check that the
list we are "floating" isn't nil before we prepend [nil] to it *)

fun checkappend L M = if M = nil then nil else L@M;


(* the main stratification function *)

(* another stratification function will be needed by the
definition function -- it will type free variables rather
than bound variables *)

val CHECKTYPE = ref 0;

fun strat level localtype (Constant s) = [nil] |

	strat level localtype (FreeVar s) = [nil] |

	strat level localtype (Numeral s) = [nil] |

	strat level localtype (BoundVar s) = if s = 0 then [nil] else 
		[[(s,localtype)]] |

	strat level localtype (Function s) = map (drop (level+1))
		(mergetypes
			(strat (level+1) (localtype-1) s)
			[[(level+1,localtype-1)]]) |

	strat level localtype (CaseExp(t,u,v)) =

		mergetypes((checkappend[nil](strat level localtype t)))
		(mergetypes(strat level localtype u)
			(strat level localtype v)) |

	strat level localtype (Infix(t,ResOp":",u)) =

		mergetypes (strat level (localtype+1) t) 
		(checkappend [nil] (strat level localtype u)) |

	strat level localtype (Infix(Constant f,ResOp "@",t)) =
		crushtypes(checkappend
		(if level = 0 
			orelse isscout f orelse isscinright f 
			then [nil] else [])
		(strat level localtype t)) |

	strat level localtype (Infix(t,i,u)) =

		if istypedoperator (opdisplay i)

		then
		crushtypes(checkappend
		(if level = 0 orelse isscout (opdisplay i) then [nil] else [])
		(mergetypes

		(checkappend(if level = 0 
			orelse isscinleft (opdisplay i) then [nil] else [])
		(strat level (lefttype(opdisplay i)+localtype) t))

		(checkappend(if level = 0 orelse
			isscinright (opdisplay i) then [nil] else [])
		(strat level (righttype(opdisplay i)+localtype) u))))

		else (* case of opaque or undeclared variable operators *)

		if boundvarlist level (Infix(t,i,u)) = nil
		andalso strat level 0 t <> nil
		andalso strat level 0 u <> nil
		then [nil] else nil;

fun isstratified level t = strat level 0 t <> nil;

(* USER COMMAND *)

(* delayed to here because it uses declaration and stratification
checking *)

fun defaulttypeinfo v t = if stringtocon v = FreeVar v andalso
	declarecheck false 0 (parse t) (* andalso isstratified 0 (parse t) *)

	then VARTYPES := strongadd v (parse t) (!VARTYPES)

	else errormessage 
("Declaration or syntax error in assigning type "^t^" to variable "^v);

(* the prover environment comes into view! *)

(* the prover environment consists of the following elements:

	name of environment (a string)

	"format" of environment (a term, used to indicate parameters
		of a parameterized theorem/tactic)

	left side of equation being proved (a term)

	right side of equation being proved (a term)

	current position in term (a list of booleans, true = right,
		false = left, the step into a function term is
		either right or left indifferently)

	current level and "hypothesis level" (two integers)

	list of local hypotheses (a list of "theorems" derived
		from hypotheses of case expressions -- a triple
		consisting of two terms to be equated and an
		integer coding the "sense" (positive, negative,
		or inactive) of the hypothesis)

	dependencies of current environment -- only the traditional
	kind will be considered; the new definition and theorem-text
	dependencies will be maintained separately

The theorem data structure is almost the same, except that it does
not have position-dependent components *)

(* a workhorse function -- apply a function to a term at a
position *)

fun applyat f nil t = f t |

	applyat f (a::L) (Constant s) = 
		(errormessage "Subterm error";Constant s) | 
	applyat f (a::L) (FreeVar s) = 
		(errormessage "Subterm error";FreeVar s) | 
	applyat f (a::L) (BoundVar s) = 
		(errormessage "Subterm error";BoundVar s) | 
	applyat f (a::L) (Numeral s) = 
		(errormessage "Subterm error";Numeral s) | 

	applyat f (a::L) (Function t) = Function (applyat f L t) |

	applyat f (false::L) (Infix(u,i,v)) =
		if u = Constant ""
		then (errormessage "Subterm error";(Infix(u,i,v)))
		else (Infix(applyat f L u,i,v)) |
	applyat f (true::L) (Infix(u,i,v)) =
		(Infix(u,i,applyat f L v)) |

	applyat f (false::L) (CaseExp(u,v,w)) =
		CaseExp(applyat f L u,v,w) |

	applyat f (true::(false::L)) (CaseExp(u,v,w)) =
		CaseExp(u,applyat f L v,w) |
	applyat f (true::(true::L)) (CaseExp(u,v,w)) =
		CaseExp(u,v,applyat f L w) |

	(* the Parenthesis case below helps prevent the 
	prover from issuing an error message when just looking
	at the virtual subterm *)

	applyat f (true::nil) (CaseExp(u,v,w)) =

		((let val A = f (Infix(v,ResOp",",w)) in
		if A = (Infix(v,ResOp",",w)) orelse
		A = Parenthesis((Infix(v,ResOp",",w))) then ()
		else errormessage "Virtual subterm of case expression" end);
		(CaseExp(u,v,w)));


(* the prover environment data type *)
(* this is a structure with nine fields as indicated above *)

fun ename (na,fo,lt,rt,po,lev,hlev,hyps,deps) = na;
fun formatof (na,fo,lt,rt,po,lev,hlev,hyps,deps) = fo;
fun leftside (na,fo,lt,rt,po,lev,hlev,hyps,deps) = lt;
fun rightside (na,fo,lt,rt,po,lev,hlev,hyps,deps) = rt;
fun position (na,fo,lt,rt,po,lev,hlev,hyps,deps) = po;
fun level (na,fo,lt,rt,po,lev,hlev,hyps,deps) = lev;
fun hlevel (na,fo,lt,rt,po,lev,hlev,hyps,deps) = hlev;
fun hypslist (na,fo,lt,rt,po,lev,hlev,hyps,deps) = hyps;
fun deps (na,fo,lt,rt,po,lev,hlev,hyps,deps) = deps;

(* functions which change environment fields to given values *)

fun changeename na2 (na,fo,lt,rt,po,lev,hlev,hyps,deps) = 
	(na2,fo,lt,rt,po,lev,hlev,hyps,deps);
fun changeformatof fo2 (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo2,lt,rt,po,lev,hlev,hyps,deps);
fun changeleftside lt2 (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt2,rt,po,lev,hlev,hyps,deps);
fun changerightside rt2 (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,rt2,po,lev,hlev,hyps,deps);
fun changeposition po2 (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,rt,po2,lev,hlev,hyps,deps);
fun changeelevel lev2 (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,rt,po,lev2,hlev,hyps,deps);
fun changeehlevel hlev2 (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,rt,po,lev,hlev2,hyps,deps);
fun changehypslist hyps2 (na,fo,lt,rt,po,lev,hlev,hyps,deps)=
	(na,fo,lt,rt,po,lev,hlev,hyps2,deps);
fun changedeps deps2 (na,fo,lt,rt,po,lev,hlev,hyps,deps)=
	(na,fo,lt,rt,po,lev,hlev,hyps,deps2);

(* functions which apply given functions to environment fields *)

fun changeename2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps) = 
	(f na,fo,lt,rt,po,lev,hlev,hyps,deps);
fun changeformatof2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,f fo,lt,rt,po,lev,hlev,hyps,deps);
fun changeleftside2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,f lt,rt,po,lev,hlev,hyps,deps);
fun changerightside2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,f rt,po,lev,hlev,hyps,deps);
fun changeposition2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,rt,f po,lev,hlev,hyps,deps);
fun changelevel2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,rt,po,f lev,hlev,hyps,deps);
fun changehlevel2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps) =
	(na,fo,lt,rt,po,lev,f hlev,hyps,deps);
fun changehypslist2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps)=
	(na,fo,lt,rt,po,lev,hlev,f hyps,deps);
fun changedeps2 f (na,fo,lt,rt,po,lev,hlev,hyps,deps)=
	(na,fo,lt,rt,po,lev,hlev,hyps,f deps);

(* the current prover environment *)

val ENV = ref("",Constant "", Constant "", Constant "",
	[true],0,0,[(Constant"",Constant"",[true],0,0)],["bogus"]);

(* apply a function to the environment *)

fun envmod f = ENV:=f (!ENV);

(* reference for temporarily posting new dependencies *)

val NEWDEPS = ref ["bogus"];

(* dependency posting function *)

fun postdeps() = (envmod(changedeps2 (union(!NEWDEPS)))
	;NEWDEPS:=nil);

fun dropdeps() = NEWDEPS:=nil;

(* term viewing functions *)

(* these are actually identity functions with side effects *)

val PROMPT = ref true;

fun termprompts() = PROMPT := not (!PROMPT);

fun showterm prompt t = (if (!VERBOSITY) = 2 then 
(output(std_out,
(if (!PROMPT) then ("\n"^prompt^":") else "")
^"\n\n"^(display t)^(if (!GUIMODE) then ((!Returns)^". . .") else "")
^(!Returns));
flush_Out(std_out)) else ();t);

fun exec f = envmod (changerightside2 (applyat f
	(position(!ENV))));

(* USER COMMAND *)

(* look at current subterm *)

fun lookhere() = exec (showterm "Local term display");

(* variables controlling the look display *)

val LOCAL_DISPLAY = ref true;

val GLOBAL_DISPLAY = ref true;

(* USER COMMAND *)

(* look at current subterm and at top of right side of equation *)

(* insert a "parenthesis" temporarily to highlight current subterm *)

fun look() = (exec Parenthesis;
	envmod(changerightside2 (if (!GLOBAL_DISPLAY) 
	then (showterm "Global term display") else (fn x => x))); 
	exec deparenthesize1;
	lookhere());

(* USER COMMANDS (3) *)

(* control the look display *)

fun localdisplayoff() = (LOCAL_DISPLAY:=false;GLOBAL_DISPLAY:=true;look());

fun globaldisplayoff()= (LOCAL_DISPLAY:=true;GLOBAL_DISPLAY:=false;look());

fun bothdisplays()= (LOCAL_DISPLAY:=true;GLOBAL_DISPLAY:=true;look());

(* USER COMMAND *)

(* look at the left side of the equation under construction *)

fun lookback() = envmod(changeleftside2 (showterm "Initial term display"));

(* term starting functions appear below after the environment
saving commands, which have to appear after the declaration of
the theorem list *)


val SWAPTERM = ref (Constant "");

(* USER COMMAND *)

(* interchange the left and right sides of the equation under
construction *)

fun workback() =  (SWAPTERM:=leftside(!ENV);
	envmod(changeleftside (rightside(!ENV)));
	envmod(changerightside (!SWAPTERM));
	envmod(changeposition nil);
	envmod(changeelevel 0); envmod(changeehlevel 0);
	envmod(changehypslist nil);look());

(* functions acting on positions that implement the
term navigation commands *)

fun preup nil = (errormessage "At top already!";nil) |

	preup L = rev(tl(rev L));

fun preright L = rev (true::(rev L));

fun preleft L = rev (false::(rev L));

(* we also need functions acting on levels, hlevels, and hypothesis 
lists which support the movement commands *)

(* when one moves into or out of a function term, one needs to adjust
the level (the number of nested brackets enclosing one); when moving
into or out of case expressions, one needs to adjust the hlevel (the
number of relevant hypotheses of case expressions) and the list of
relevant hypotheses with their senses (positive, negative, or (at
the virtual subexpression) inactive) *)

val CURRENTTERM = ref(Constant "");

fun makecurrent t = (CURRENTTERM:=t;t);

fun getcurrent() = exec (makecurrent);

fun levelchange (Function f) n  = n+1 |

	levelchange t n = n;

fun uplevelchange (Function f) n = n-1 |

	uplevelchange t n = n;

fun hlevelchange (CaseExp(u,v,w)) n  = n+1 |

	hlevelchange t n = n;

fun uphlevelchange (CaseExp(u,v,w))  n = n-1 |

	uphlevelchange t n = n;

(* builds equation from hypothesis of a case expression and
records current position *)

(* true=?y is indistinguishable from ?y *)

fun equationfromterm (Infix(x,ResOp"=",y)) = 
	(x,y,position(!ENV),0,level(!ENV)) |

	equationfromterm t = (Constant "true",t,position(!ENV),0,level(!ENV));

fun hypslistchange (CaseExp(u,v,w)) L = 

	rev((equationfromterm u)::(rev L)) |

	hypslistchange t L = L;

fun listindex n nil = nil |

	listindex 1 (a::L) = [a] |

	listindex n (a::L) = listindex (n-1) L;

fun presethypslistsense (x,y,p,n,l) = let val A =
	listindex ((length p)+2) (position(!ENV)) in
		if A = nil then (x,y,p,0,l)
		else if A = [false] then (x,y,p,1,l)
		else if A = [true] then (x,y,p,2,l)
		else (x,y,p,0,l)
		end;

fun sethypslistsense L = if L = nil then nil else

rev((presethypslistsense(hd (rev L)))::(tl (rev L)));

fun coercehypslistsense n lv (x,y,p,m,l) = (x,y,p,n,lv);  

fun uphypslistchange (CaseExp(u,v,w)) L =

	if L = nil then nil

	else rev(tl (rev L)) |

	uphypslistchange t L = L;


(* the basic movement commands *)
(* they have "silent" variants used by the fancy movement
commands below *)

(* USER COMMAND *)

fun up() = if position(!ENV) = nil then errormessage "At top already!"

else if hd (rev (position (!ENV))) = true then  (* coming up from right *)

	(envmod (changeposition2 preup);
	getcurrent();
	envmod (changelevel2 (uplevelchange (!CURRENTTERM)));
	envmod (changehlevel2 (uphlevelchange (!CURRENTTERM)));
	envmod (changehypslist2 (uphypslistchange(!CURRENTTERM)));
	envmod (changehypslist2 (sethypslistsense));
	look())

else (* coming up from left *)

(envmod (changeposition2 preup);
	getcurrent();
	envmod (changelevel2 (uplevelchange (!CURRENTTERM)));
	envmod (changehypslist2 (sethypslistsense));	
	look());

fun sup() = if position(!ENV) = nil then errormessage "At top already!"

else if hd (rev (position (!ENV))) = true then  (* coming up from right *)

	(envmod (changeposition2 preup);
	getcurrent();
	envmod (changelevel2 (uplevelchange (!CURRENTTERM)));
	envmod (changehlevel2 (uphlevelchange (!CURRENTTERM)));
	envmod (changehypslist2 (uphypslistchange(!CURRENTTERM)));
	envmod (changehypslist2 (sethypslistsense)))

else (* coming up from left *)

(envmod (changeposition2 preup);
	getcurrent();
	envmod (changelevel2 (uplevelchange (!CURRENTTERM)));
	envmod (changehypslist2 (sethypslistsense))	
	);

(* USER COMMAND *)

fun left() = (getcurrent(); 
envmod (changelevel2 (levelchange (!CURRENTTERM))); 
envmod (changeposition2 preleft);
envmod (changehypslist2 (sethypslistsense));
look());

fun sleft() = (getcurrent(); 
envmod (changelevel2 (levelchange (!CURRENTTERM))); 
envmod (changeposition2 preleft);
envmod (changehypslist2 (sethypslistsense))
);

(* USER COMMAND *)

fun right() = (getcurrent(); 
envmod (changelevel2 (levelchange (!CURRENTTERM)));
envmod (changehlevel2 (hlevelchange (!CURRENTTERM))); 
envmod (changehypslist2 (hypslistchange (!CURRENTTERM)));
envmod (changeposition2 preright);
envmod (changehypslist2 (sethypslistsense));
look());

fun sright() = (getcurrent(); 
envmod (changelevel2 (levelchange (!CURRENTTERM)));
envmod (changehlevel2 (hlevelchange (!CURRENTTERM))); 
envmod (changehypslist2 (hypslistchange (!CURRENTTERM)));
envmod (changeposition2 preright);
envmod (changehypslist2 (sethypslistsense))
);

(* USER COMMAND *)

fun top() = (envmod (changeelevel 0); envmod (changeehlevel 0);
envmod(changehypslist nil);
envmod (changeposition nil); look());

(* USER COMMAND *)

(* used to check correct execution in scripts *)

fun verify s = (top();if (parse s) = rightside(!ENV) then ()
                      else errormessage ("Verification failure"));

(* theorem declaration list *)

(*

A theorem consists of the following components:

	a name (which appears as a key in the theorems list rather
	than part of the structure)

	a format (used to supply parameters) (a term)

	left side of equation (a term)

	right side of equation  (a term)

	a dependency list (the new definition and theorem-text
	dependency schemes will be supported by separate lists)

Note the similarity to a proof environment; eliminating the components
of a proof environment which support navigation yields a theorem.

*)

val THEOREMS = 
ref ([("bogus",(Constant "",Constant "",Constant "",["bogus"]))]);

(* theorems declared but to be proved later -- i.e., recursive tactics *)

val PRETHEOREMS = ref ["bogus"];

(* commands for manipulating theorems list and individual theorems *)

fun addtheorem name fo ls rs dps = (THEOREMS:= 
	strongadd name (fo,ls,rs,dps) (!THEOREMS);
	PRETHEOREMS := dropfromset name (!PRETHEOREMS));

fun droptheorem name = THEOREMS:= drop name (!THEOREMS);

val dummythm = (Constant "", Constant "", Constant "", []);

fun PreFormatof (a,b,c,d) = a;

fun PreLeftside (a,b,c,d) = b;

fun PreRightside (a,b,c,d) = c;

fun PreDeps (a,b,c,d) = d;

fun Thm name = safefind dummythm name (!THEOREMS);

fun Formatof name = PreFormatof (safefind dummythm name (!THEOREMS));

fun Leftside name = PreLeftside (safefind dummythm name (!THEOREMS));

fun Rightside name = PreRightside (safefind dummythm name (!THEOREMS));

fun Deps name = PreDeps (safefind dummythm name (!THEOREMS));

(* string lists will be converted to terms when needed for theorem deps *)

fun listtoterm nil = Numeral [0] |

	listtoterm (s::L) = Infix(if stringtocon s = Constant s
	then Constant s else Infix(FreeVar "?x",ConOp s,FreeVar "?y")
	,ResOp ",",listtoterm L);

fun listtoterm2 L = baredisplay(listtoterm L);

fun termtolist (Numeral [0]) = nil |

	termtolist (Infix(Constant s,ResOp",",y)) = (s::(termtolist y)) |

	termtolist (Infix(Infix(x,ConOp s,y),ResOp",",z)) = 
		(s::(termtolist z)) |

	termtolist x = nil;

fun termtolist2 s = termtolist (parse s);

(* either version of isatheorem is true only of "theorems" actually
found on the theorem list; built-in tactics are treated separately *)

fun isatheorem name = foundin name (!THEOREMS);

(* this version of isatheorem is used inside thmresult only as
a possible optimization *)

fun Isatheorem name = Foundin name (THEOREMS);

fun isapretheorem name = foundinset name (!PRETHEOREMS);

(* this version of isstratified posts dependencies to the environment *)

fun Isstratified1 level t = (SCINSCOUT := nil; 
	let val A = isstratified level t in
	((if A then
	(envmod (changedeps2 (union (union2(map Deps (!SCINSCOUT))))))
	else ());SCINSCOUT:=nil;A) end);

fun Isstratified t = Isstratified1 0 t;

(* built-in tactics *)

fun isbuiltinthm name = foundinset name ["EVAL","BIND","UNEVAL",
	"EVALM","BINDM","UNEVALM","FLIP",
	"INPUT","OUTPUT","STOPINPUT","UP",
	"|-|","=",
	"=>>", "<<=","*>","<*","!@","!$"];

(* other aspects of theorems are not usually changed,
but dependencies are more often modified *)

fun changedeps name f = if isatheorem name then

	let val A = hd (find name (!THEOREMS)) in

		(droptheorem name;
		addtheorem name (PreFormatof A) (PreLeftside A) 
			(PreRightside A) (f (PreDeps A))) end

		else ();

(* theorem display command *)

val STATEMENTDISPLAY = ref false;

(* USER COMMAND *)

(* toggle which turns on and off special statement display *)

fun statementdisplay() = (STATEMENTDISPLAY := not (!STATEMENTDISPLAY);
		nopausemessage ("Statement display is "^(if (!STATEMENTDISPLAY)
		then "on" else "off")));

fun eqdisplay fo ls rs dps = if (!STATEMENTDISPLAY) andalso
		rs = Constant "true"

		then output(std_out,(if (!GUIMODE)
                then(!Returns)^"Statement display:"
                else "")^

		(!Returns)^(display fo)^":"^(!Returns)^
		"|-"^(display ls)^(!Returns)^
		(if (!Returns) = "\n" then (dashes())^(!Returns) else "")^
		(display (listtoterm dps))^(!Returns)

                ^(if (!GUIMODE) then ". . ."^(!Returns) else ""))

		else if (!STATEMENTDISPLAY) andalso
		ls = Constant "true"

		then output(std_out,(if (!GUIMODE)
                then(!Returns)^"Statement display:"
                else "")^

		(!Returns)^(display fo)^":"^(!Returns)^
		"$|-"^(display rs)^(!Returns)^
		(if (!Returns) = "\n" then (dashes())^(!Returns) else "")^
		(display (listtoterm dps))^(!Returns)
                ^(if (!GUIMODE) then ". . ."^(!Returns) else ""))

		else output(std_out,(if (!GUIMODE)
                then(!Returns)^"Equation display:"
                else "")^

		(!Returns)^(display fo)^":  "^(!Returns)^
		(display ls)^"   ="^(!Returns)^(display rs)^(!Returns)^
		(if (!Returns) = "\n" then (dashes())^(!Returns) else "")^
		(display (listtoterm dps))^(!Returns)
                ^(if (!GUIMODE) then ". . ."^(!Returns) else ""));

(* USER COMMAND *)

(* display a theorem *)

fun thmdisplay name = if isatheorem name

		then if (!VERBOSITY) > 0 then

		let val (fo,ls,rs,dps) = Thm name in

			(eqdisplay fo ls rs dps;flush_Out(std_out)) end

		else ()

		else if isbuiltinthm name

		then errormessage (name^" is a built in tactic")

		else errormessage ("Theorem "^name^" not found");

(* USER COMMAND *)

(* look at dependencies of current environment *)

fun seedeps() = output(std_out,display(listtoterm(deps(!ENV)))^(!Returns));

(* material related to script reading *)

(* string to hold automatically generated script *)

val AUTOSCRIPT = ref "";

val SCRIPTING = ref false;

val NEXTCHAR = ref "a";  val CHARSYET = ref false;

fun prestringinput file = (

	NEXTCHAR:=input(file,1);

	if (!NEXTCHAR) = "\n" orelse (!NEXTCHAR) = "}" 

	then ""

	(* these lines allow comments in INPUT text in scripts *)

	else if (!NEXTCHAR) = "{" 

		then (prestringinput file;"")

	else if (!NEXTCHAR) = " " then if (!CHARSYET) then " "^
		(prestringinput file)

		else prestringinput file

	else (CHARSYET:=true;(!NEXTCHAR)^(prestringinput file)));

fun quoteextract nil = nil |

    quoteextract ("\""::L) = quoteextract2 L |

    quoteextract  (a::L) = let val M = quoteextract L in
                   if L=M then a::L else M end

and quoteextract2 nil = nil |

     quoteextract2 ("\""::L) = nil |

     quoteextract2 (a::L) = a::(quoteextract2 L);

fun qe s = implode(quoteextract(explode s));

fun stringinput file = (CHARSYET:=false;
        let val T = qe(prestringinput file)
	in if T = "" then qe(stringinput file) else if (!SCRIPTING) then
	(AUTOSCRIPT:=(!AUTOSCRIPT)^T^"\n";T) else T end );

val TESTTH = ref([std_in]);

val DIAGNOSTIC = ref false;

val SAVEINPUT = ref "bogus";


fun inputri s = SAVEINPUT:=s;

(* script machinery *)
(* including scripts for saving and loading theories *)

(* this is incorporated, with minor adaptations for different
tokenization functions, from the full implementation *)

(* it is moved here, up to noml, to support the SHELL builtin
tactic (which is used to get information from inside INPUT tactics) *)

(* the development resumes below at the makescript command *)

(* function for reading line input *)

fun prelineinput commentlevel stringlevel file =

(NEXTCHAR:=input(file,1);

(* ignore anything but closing brace  if comments are being read *)

if commentlevel > 0 

	then if (!NEXTCHAR) = "*"

	then (NEXTCHAR:=input(file,1);
		if (!NEXTCHAR) = ")" then 
		prelineinput (commentlevel-1) stringlevel file
		else prelineinput commentlevel stringlevel file)

	else if (!NEXTCHAR) = "("

	then (NEXTCHAR:=input(file,1);
		if (!NEXTCHAR) = "*" then
		prelineinput (commentlevel+1) stringlevel file
		else prelineinput commentlevel stringlevel file)

	else prelineinput commentlevel stringlevel file

(* from here on we can assume commentlevel = 0 *)

(* tabs are read as spaces *)

else if (!NEXTCHAR) = "\t" then 
	(" "::(prelineinput commentlevel stringlevel file))

(* carriage returns are read as spaces except inside strings, where 
an error occurs *)

(* unclosed string error has been removed; the old code is preserved
in a comment *)

else if (!NEXTCHAR) = "\n"

	then (* if stringlevel = 0 then (" "::
		(prelineinput commentlevel stringlevel file))

	else (errormessage "Unclosed string in script";nil) *)

	(" ":: (prelineinput commentlevel stringlevel file))

else if stringlevel = 1 then 

	if (!NEXTCHAR) = "\"" then "\""::(prelineinput commentlevel 0 file)
	else (!NEXTCHAR)::(prelineinput commentlevel 1 file)

(* we can assume from here on that stringlevel = 0 *)

else if (!NEXTCHAR) = "\"" then

	"\""::(prelineinput commentlevel 1 file)

else if (!NEXTCHAR) = "("

	then (NEXTCHAR:=input(file,1);
		if (!NEXTCHAR)="*" 
			then prelineinput (commentlevel+1) stringlevel file
		else if (!NEXTCHAR)=")"
			then "()"::(prelineinput commentlevel stringlevel file)
			else (errormessage 
			"Incomprehensible parenthesis in script";nil))

else if (!NEXTCHAR) = ";" then nil

else (!NEXTCHAR)::(prelineinput commentlevel stringlevel file));

(* the lineinput command extracts the next command line from a
script file *)

fun lineinput file = let val T = implode(strip((prelineinput 0 0 file)))
		in if (!SCRIPTING) 
		then (AUTOSCRIPT:=(!AUTOSCRIPT)^T^";\n";T) else T end;

fun listsafefind default s nil = default |
	listsafefind default s ((t,x)::L) = if s = t then x 
	else listsafefind default s L;

fun listaddto s x L = (s,x)::L;

(* reference holding all current commands *)

val MENU = ref [("seedeps",seedeps)];

val MENUNAME = ref "main";

(* main command menu *)

val MAINMENU = ref (!MENU);

(* load/save menu *)

val LOADMENU = ref (!MENU);

(* the secure menu -- commands allowed when prover is paused *)

val SECUREMENU = ref (!MENU);

fun mainmenu() = (MENUNAME:="main";MENU := (!MAINMENU));

fun loadmenu() = (MENUNAME:="load";MENU := (!LOADMENU));

fun securemenu() = (MENUNAME:= "secure";MENU := (!SECUREMENU));

(* reference to string of arguments of current line *)

val ARGUMENTS = ref (explode(""));

val ARGUMENTS2 = ref (explode(""));

fun executeline s = let val command = implode(getalpha(explode s)) in

(ARGUMENTS:=(restalpha(explode s)); 
listsafefind (fn () => (errormessage ("Unknown command "^
command^" in script")))
command (!MENU))() end;

fun getchararg1 nil = "" |
	getchararg1 ("\""::M) = "" |
	getchararg1 (x::M) = x^(getchararg1 M);

fun restchararg nil = nil |
	restchararg ("\""::M) = M |
	restchararg (x::M) = restchararg M;

val TEMPCHARARG = ref "bogus";


fun getchararg L = if (strip L) = nil orelse hd (strip L) <> "\""
	then (errormessage "Character argument in script not found";"")
	else (ARGUMENTS:=restchararg (tl(strip L));
		getchararg1 (tl(strip L)));


fun readalldigits2 L = evalnum(rev(getnumeral(L)));

fun getintarg L = if (strip L) = nil orelse
		(strip L) = ["~"] orelse
		(hd (strip L) = "~" andalso not (isdigit (hd(tl (strip L)))))
		orelse (hd (strip L) <> "~" 
		andalso not (isdigit (hd (strip L))))
	then (errormessage "Integer argument in script not found";0)
	else (ARGUMENTS:= (if hd(strip L) = "~"
	then restnumeral (tl(strip L))
	else restnumeral (strip L));
	if hd(strip L) = "~" then 
		(~1)*(readalldigits2(getnumeral(tl(strip L))))
	else readalldigits2(getnumeral (strip L)));


(* val TESTTH = ref([std_in]); *)

val SAVELINE = ref "bogus";

(* val DIAGNOSTIC = ref false; *)

val DEMO = ref false;

(* USER COMMANDS (2) *)

fun diagnostic() = (DIAGNOSTIC := not (!DIAGNOSTIC);
	nopausemessage ("Diagnostic mode is "
	^(if (!DIAGNOSTIC) then "on" else "off")));

(* June 25:  turning demo mode on causes speakup; turning it off
causes thmsonly; users should only have any occasion to turn demo
mode off inside scripts, since the end of the top level script
now turns it off *)

val TURNOFFPROMPT =ref false;

fun demo() = ((if (!DEMO) then thmsonly()
        else (speakup();TURNOFFPROMPT:=false));
        diagnostic(); DEMO:=not(!DEMO);
	nopausemessage ("Demo mode is "^(if (!DEMO) then "on" else "off")));


val SCRIPTFILE = ref std_out;

fun autoscript s = (
SCRIPTFILE:=open_out(s^".log.wat");
output((!SCRIPTFILE),(!AUTOSCRIPT));
flush_Out(!SCRIPTFILE);
close_out(!SCRIPTFILE));

val load_EXT = ref ".wat";

fun setloadext s = (load_EXT := s);

(* we prevent any activity during execution of a file from
being automatically scripted *)

val OLDSCRIPTING = ref false;

(* this is the latest GUI version.  It supports demo mode again.
The internals of how the prompt parameter is used are weird. *)

fun executelines prompt file =

(SAVELINE := lineinput file;
let val thecommand = implode(getalpha(explode(!SAVELINE))) in
if
not(foundin thecommand (!MENU)) then

	if thecommand = "quit" 
        orelse thecommand = "q"
        orelse thecommand = ""
	then ()
        else errormessage 
	(thecommand^" is not a "^(!MENUNAME)^" command")
else (
if (!DIAGNOSTIC) then (output(std_out,(!Returns)^(!SAVELINE)^";"^(!Returns));
flush_Out(std_out)) else ();
executeline (!SAVELINE);
if (strip(!ARGUMENTS))<>nil 
andalso 

(* implode(strip(!ARGUMENTS))<>"()" *)

(length(strip(!ARGUMENTS))<2 orelse hd(strip(!ARGUMENTS)) <> "(" orelse
hd(tl(strip(!ARGUMENTS))) <> ")" 
orelse strip(tl(tl(strip(!ARGUMENTS)))) <> nil)

then (ARGUMENTS2:=(!ARGUMENTS);ARGUMENTS:=nil;errormessage 
("Argument list not used up:  "^(implode(!ARGUMENTS2)))) else ();

if prompt = "" andalso (not(!DEMO)) then () 
else (output(std_out,"\nWatson> ");flush_Out(std_out));
if (!DEMO) andalso prompt <> "Watson> "
then suspend(fn()=>executelines prompt file) else
executelines prompt file) end)

and executefile prompt s = (
	TESTTH := ((if s = "std_in" then std_in else open_in (s^(!load_EXT)))
		::(!TESTTH));
	executelines (if s="std_in" then "Watson> " else "") (hd(!TESTTH)); 	
	if s <> "std_in" then close_in (hd(!TESTTH)) else ();
	TESTTH := tl(!TESTTH))

and suspend f = (nopausemessage "Paused";securemenu();
executefile "" "std_in";mainmenu();f()) handle Breakout => 
        (mainmenu();
	TESTTH := tl(!TESTTH));

(* dummy command here; it is an exit command in a script *)

fun quit() = ();

(* demo mode comment function *)

fun demoremark s = ();

fun showsometheorems filter nil = () |
showsometheorems filter ((na,x)::L) = 

		if filter na andalso hd(explode na) <> "}"

		then (thmdisplay na;suspend (fn ()=>showsometheorems filter L))

                else showsometheorems filter L;

fun showalltheorems() = (showsometheorems (fn x => true) (sortfun(!THEOREMS)));

(* shows axioms and definitions *)

fun showaxioms() = (showsometheorems (fn x => foundinset x (Deps x)) 
	(sortfun(!THEOREMS)));

(* definition facility *)

(* definitions require a second stratification function, whose 
object is to type free variables so that implicitly defined functions
behave correctly *)

(* list of all free variables (including infix variables) in
a given term *)

(* it is possible that some glitches will arise from including infix
variables *)

fun freevarlist  (FreeVar s) = [s] |

	freevarlist (Infix(u,VarOp s,v)) = addtoset s (union (freevarlist  u) 
		(freevarlist  v)) |

	freevarlist  (Infix(u,i,v)) = union (freevarlist  u) 
		(freevarlist  v) |

	freevarlist  (Function t) = freevarlist  t |

	freevarlist  (CaseExp(u,v,w)) = union
		(freevarlist  u) (union
		(freevarlist  v)(freevarlist  w)) |

	freevarlist  t = nil;

(* variant which does not include infix variables, introduced to support
autoformat built-in tactics *)

fun freevarlist2  (FreeVar s) = [s] |

	freevarlist2  (Infix(u,i,v)) = union (freevarlist2  u) 
		(freevarlist2  v) |

	freevarlist2  (Function t) = freevarlist2  t |

	freevarlist2  (CaseExp(u,v,w)) = union
		(freevarlist2  u) (union
		(freevarlist2  v)(freevarlist2  w)) |

	freevarlist2  t = nil;

fun strat2  localtype (Constant s) = [nil] |

	strat2  localtype (FreeVar s) = [[(s,localtype)]] |

	strat2  localtype (Numeral s) = [nil] |

	strat2  localtype (BoundVar s) = [nil] |

	strat2  localtype (Function s) = 
		(strat2 (localtype-1) s) |

	strat2  localtype (CaseExp(t,u,v)) =

		mergetypes((checkappend [nil] (strat2  localtype t)))
		(mergetypes(strat2  localtype u)
			(strat2  localtype v)) |

	strat2  localtype (Infix(t,ResOp":",u)) =

		mergetypes (strat2  (localtype+1) t) 
		(checkappend [nil] (strat2  localtype u)) |

	strat2 localtype (Infix(Constant f,ResOp "@",t)) =
		crushtypes(checkappend
		(if isscout f orelse isscinright f then [nil] else [])
		(strat2 localtype t)) |

	strat2  localtype (Infix(t,i,u)) =

		if istypedoperator (opdisplay i)

		then
		crushtypes(checkappend
		(if isscout (opdisplay i) then [nil] else [])
		(mergetypes

		(checkappend(if isscinleft (opdisplay i) then [nil] else [])
		(strat2  (lefttype(opdisplay i)+localtype) t))

		(checkappend(if isscinright (opdisplay i) then [nil] else [])
		(strat2  (righttype(opdisplay i)+localtype) u))))

		else (* case of opaque or undeclared variable operators *)

		if freevarlist  (Infix(t,i,u)) = nil
		andalso strat2 0 t <> nil
		andalso strat2 0 u <> nil
		then [nil] else nil;

fun isstrat2 t = strat2 0 t <> nil;

(* functions used to define format for left sides of definitions *)
(* other functions, used to define format for parameter lists of tactics,
are also given here *)

fun iterconvar (FreeVar s) = true |

	iterconvar (Function t) = iterconvar t |

	iterconvar t = false;

fun pairsovervars (Infix(u,ResOp ",",v)) = 
		(pairsovervars u) andalso (pairsovervars v) |

	pairsovervars t = iterconvar t;

fun atomdefinitionformat (Constant s) = s<>"" |

	atomdefinitionformat (Infix(u,ResOp"@",v)) = (atomdefinitionformat u)
		andalso (pairsovervars v) |

	atomdefinitionformat t = false;

fun opdefinitionformat (Infix(x,ConOp s,y)) = 
	s<>"" andalso (
	(x = (stringtocon (prefixof s)) orelse
	(pairsovervars x)) andalso (pairsovervars y)) |

	opdefinitionformat (Infix(u,ResOp"@",v)) = (opdefinitionformat u)
		andalso (pairsovervars v) |

	opdefinitionformat t = false;

fun opaqueopdefinitionformat (Infix(x,ConOp s,y)) = 
	s<>"" andalso (
	(x = (stringtocon (prefixof s)) orelse
	(pairsovervars x)) andalso (pairsovervars y)) |

	opaqueopdefinitionformat t = false;

fun atomhead (Constant s) = s |

	atomhead (Infix(x,ResOp"@",y)) = atomhead x |

	atomhead t = "";

fun ophead (Infix(u,ResOp"@",v)) = ophead u |

	ophead (Infix(x,ConOp s,y)) = s |

	ophead (Infix(x,ResOp s,y)) = s |

	ophead t = "";

fun eitherhead x = if atomhead x = "" then ophead x else atomhead x;

(* formats used by parameterized tactics *)

fun weakpairsovervars (Infix(u,ResOp ",",v)) = 
		(weakpairsovervars u) andalso (weakpairsovervars v) |

	weakpairsovervars (Infix(u,VarOp s,v)) = 
		if isstrictprefix s 
		then u = Constant "" andalso (weakpairsovervars v)
		else (weakpairsovervars u) andalso (weakpairsovervars v) |

	weakpairsovervars t = iterconvar t;

fun weakatomdefinitionformat (Constant s) = s<>"" |

	weakatomdefinitionformat (Infix(u,ResOp"@",v)) = 
	(weakatomdefinitionformat u)
		andalso (weakpairsovervars v) |

	weakatomdefinitionformat t = false;


fun weakopdefinitionformat (Infix(u,ResOp"@",v)) = 
		(weakopdefinitionformat u)
		andalso (weakpairsovervars v) |

	weakopdefinitionformat (Infix(x,i,y)) = 
	(((opdisplay i) <>"" andalso (
	(x = (stringtocon (prefixof (opdisplay i)))))) orelse
	(weakpairsovervars x)) andalso (weakpairsovervars y) |

	weakopdefinitionformat t = false;

(* a variation on the "head" functions allowing variables
and reserved operators where appropriate *)

(* also used for parameterized tactics rather than general
functions *)

fun varatomhead (Constant s) = s |

	varatomhead (FreeVar s) = s |

	varatomhead (Infix(x,ResOp"@",y)) = varatomhead x |

	varatomhead t = "";

fun varophead (Infix(x,ConOp s,y)) = s |

	varophead (Infix(x,ResOp s,y)) = if s = "@" then varophead x else s |

	varophead (Infix(x,VarOp s,y)) = s |

	varophead t = "";

fun eithervarhead t = 
	if varatomhead t = "" then varophead t else varatomhead t;

(* the list of defined constants and operators
with defining theorems *)

val DEFINITIONS = ref [("bogus","bogus")];

(* the converse of the definition list *)

val DEFINITIONS2 = ref [("bogus","bogus")];

(* DEFINITIONS:=nil;  DEFINITIONS2:= nil; *)

fun adddef name named = (DEFINITIONS:=addto name named (!DEFINITIONS);
			DEFINITIONS2:= addto named name (!DEFINITIONS2));

fun isdefinition name = foundin name (!DEFINITIONS);

fun isdefined name = foundin name (!DEFINITIONS2);

fun definitionof named = safefind "" named (!DEFINITIONS2);

(* USER COMMAND *)

fun showdef s = if isdefined s then thmdisplay (definitionof s)
                else errormessage (s^" is not defined.");


(* scin/scout functions *)

(* is the theorem s = t of the correct form to verify that an
operator or function is scout? *)

fun scoutform S (Infix(Constant s,ResOp"@",FreeVar x))
	(Infix(t,ResOp":",(Infix(Constant s2,ResOp"@",FreeVar x2)))) = 
	if S <> s orelse s<>s2 orelse x<>x2 then false else
	let val A = strat2 0 t in 
	if A = nil then false
	else (A = [nil]) end |

	scoutform S (Infix(t,ResOp":",(Infix(Constant s,ResOp"@",FreeVar x))))
	(Infix(Constant s2,ResOp"@",FreeVar x2)) =
	if S <> s orelse s<>s2 orelse x<>x2 then false else
	let val A = strat2 0 t in 
	if A = nil then false
	else (A = [nil]) end |

	scoutform  S (Infix(FreeVar s,i,FreeVar t))
	(Infix(T,ResOp":",(Infix(FreeVar s2,i2,FreeVar t2)))) =
	if S <> (opdisplay i) orelse s <> s2 orelse t <> t2 
	orelse i<>i2 then false else
	let val A = strat2 0 T in 
	if A = nil then false
	else (A = [nil]) end |

	scoutform S (Infix(T,ResOp":",(Infix(FreeVar s,i,FreeVar t))))
	(Infix(FreeVar s2,i2,FreeVar t2)) =
	if S <> (opdisplay i) orelse s <> s2 orelse t <> t2 
	orelse i <> i2 then false else
	let val A = strat2 0 T in 
	if A = nil then false
	else (A = [nil]) end |

	scoutform  S (Infix(Constant "",i,FreeVar t))
	(Infix(T,ResOp":",(Infix(Constant "",i2,FreeVar t2)))) =
	if S <> (opdisplay i) orelse t <> t2 
	orelse i<>i2 then false else
	let val A = strat2 0 T in 
	if A = nil then false
	else (A = [nil]) end |

	scoutform S (Infix(T,ResOp":",(Infix(Constant "",i,FreeVar t))))
	(Infix(Constant "",i2,FreeVar t2)) =
	if S <> (opdisplay i) orelse t <> t2 
	orelse i <> i2 then false else
	let val A = strat2 0 T in 
	if A = nil then false
	else (A = [nil]) end |

	scoutform S t u = false;

(* make an operator scout if given a theorem of the appropriate form *)

fun makescout s thm = if isscout s then errormessage (s^" is already scout")

	else if scoutform s (Leftside thm) (Rightside thm)

	then (SCOUT:=addto s thm (!SCOUT))
	else errormessage ("Scout declaration of "^s^" using "^thm^" failed");

(* is a theorem of the correct form to declare an operator "scin"
(both left and right)? *)

fun scinform S (Infix(Constant s,ResOp"@",t))

	(Infix(Constant s2,ResOp"@",Infix(T,ResOp":",t2))) = 

	if S <> s orelse s <> s2 orelse t <> t2 then false
	else let val A = strat2 0 T in
	if A = nil then false
	else (A = [nil]) end |

	scinform S (Infix(Constant s,ResOp"@",Infix(T,ResOp":",t)))

		(Infix(Constant s2,ResOp"@",t2)) =	
	if S <> s orelse s <> s2 orelse t <> t2 then false
	else let val A = strat2 0 T in
	if A = nil then false
	else (A = [nil]) end |

	scinform S (Infix(FreeVar x,i,FreeVar y))

		(Infix(Infix(T,ResOp":",FreeVar x2),i2,
			Infix(U,ResOp":",FreeVar y2))) =

	if S <> (opdisplay i) orelse x <> x2 orelse y <> y2
		then false
		else let val A = strat2 0 T and B = strat2 0 U in
		if A = nil orelse B = nil then false
		else (A = [nil]) andalso (B = [nil]) end  |

	scinform S (Infix(Infix(T,ResOp":",FreeVar x),i,
			Infix(U,ResOp":",FreeVar y)))

		(Infix(FreeVar x2,i2,FreeVar y2)) = 

		if S <> (opdisplay i) orelse x <> x2 orelse y <> y2
			orelse i <> i2
		then false
		else let val A = strat2 0 T and B = strat2 0 U in
		if A = nil orelse B = nil then false
		else (A = [nil]) andalso (B = [nil]) end  |

	scinform S (Infix(Constant "",i,FreeVar y))

		(Infix(Constant "",i2,
			Infix(U,ResOp":",FreeVar y2))) =	

		if S <> (opdisplay i) orelse y <> y2 orelse i <> i2
		then false
		else let val B = strat2 0 U in
		if B = nil then false
		else (B = [nil]) end  |

	scinform S (Infix(Constant "",i,
			Infix(U,ResOp":",FreeVar y)))

		(Infix(Constant "",i2,FreeVar y2)) =	
	
		if S <> (opdisplay i) orelse y <> y2 orelse i <> i2
		then false
		else let val B = strat2 0 U in
		if B = nil then false
		else (B = [nil]) end |

	scinform s t u = false;

fun scinleftform S (Infix(FreeVar x,i,FreeVar y))

		(Infix(Infix(T,ResOp":",FreeVar x2),i2,
			FreeVar y2)) =

	if S <> (opdisplay i) orelse x <> x2 orelse y <> y2
		then false
		else let val A = strat2 0 T in
		if A = nil then false
		else (A = [nil]) end  |

	scinleftform S (Infix(Infix(T,ResOp":",FreeVar x),i,
			FreeVar y))

		(Infix(FreeVar x2,i2,FreeVar y2)) = 

		if S <> (opdisplay i) orelse x <> x2 orelse y <> y2
			orelse i <> i2
		then false
		else let val A = strat2 0 T in
		if A = nil then false
		else (A = [nil]) end  |

	scinleftform s t u = false;


fun scinrightform S (Infix(FreeVar x,i,FreeVar y))

		(Infix(FreeVar x2,i2, Infix(T,ResOp":",FreeVar y2))) =

	if S <> (opdisplay i) orelse x <> x2 orelse y <> y2
		then false
		else let val A = strat2 0 T in
		if A = nil then false
		else (A = [nil]) end  |

	scinrightform S (Infix(FreeVar x,i, Infix(T,ResOp":",FreeVar y)))  
		(Infix(FreeVar x2,i2,FreeVar y2)) =

		if S <> (opdisplay i) orelse x <> x2 orelse y <> y2
			orelse i <> i2
		then false
		else let val A = strat2 0 T in
		if A = nil then false
		else (A = [nil]) end  |

	scinrightform s t u = false;

(* USER COMMANDS (3) *)

(* make an operator scin(left/right) if an appropriate 
witness theorem is given *)

fun makescin s thm = if isscinleft s andalso isscinright s

	then errormessage (s^" is already scin")

	else if scinform s (Leftside thm) (Rightside thm)

	then (SCINLEFT:= addto s thm (!SCINLEFT);
	SCINRIGHT:= addto s thm (!SCINRIGHT))

	else errormessage ("Scin declaration of "^s^" using "^thm^" failed");

fun makescinvar s = if s = "" orelse stringtoop s <> VarOp s orelse
	istypedoperator s orelse isopaque s

	then errormessage(s^" cannot be made a scin infix variable")

	else (declareinfix s;SCINLEFT:= addto s "" (!SCINLEFT);
	SCINRIGHT:= addto s "" (!SCINRIGHT));

fun makescinleft s thm = if isscinleft s

	then errormessage (s^" is already scinleft")

	else if scinleftform s (Leftside thm) (Rightside thm)

	then (SCINLEFT:= addto s thm (!SCINLEFT))

	else errormessage ("Scinleft declaration of "^s^" using "
		^thm^" failed");

fun makescinright s thm = if isscinright s

	then errormessage (s^" is already scinright")

	else if scinrightform s (Leftside thm) (Rightside thm)

	then (SCINRIGHT:= addto s thm (!SCINRIGHT))

	else errormessage ("Scinright declaration of "^s^" using "
		^thm^" failed");

(* is the equation of the second and third arguments a theorem to
the effect that Constant S is a retraction?   Used by typedefinition
below. *)

(* prove command and variations -- note that the prove command needs
to know about definition format! *)

(* the use of weak definition formats effectively allows operator
variable parameters to parameterized tactics *)

(* definition dependencies of a term can be read from the
term (no need to maintain in environment); if a defined term
does not appear in a theorem, then the proof of the theorem
could in principle have been carried out without reference
to the definition at all 

This indicates that definitions can go back to null axiom dependencies
if a separate definition dependency scheme is maintained; 

master definition dependency list needs references to all constants,
not just to theorems, so is naturally not part of the theorems list.
The master theorem-text dependency list will also be separate,
though it could more naturally be part of the theorem list *)

(* management of theorem text and definition dependencies of theorems,
which will support reaxiomatization, redefinition, 
and theorem export facilities *)

val DEFDEPS = ref [("bogus",["bogus"])];

val DEFDEPS2 = ref [("bogus",["bogus"])];  (* inverse list *)

fun defdeps s = safefind nil s (!DEFDEPS);

fun defdeps2 s = safefind nil s (!DEFDEPS2);

(* now should update inverse list correctly *)

fun adddefdep s L = (
	map(fn x=>let val A = find x (!DEFDEPS2) in
	DEFDEPS2:=strongadd x
	(if A = nil then nil else (dropfromset s (hd A)))(!DEFDEPS2)end)
	(defdeps s);
	DEFDEPS:= strongadd s L (!DEFDEPS);
	map(fn x => 
	DEFDEPS2:= strongadd x
	(let val A = find x (!DEFDEPS2) in
	if A = nil then [s] else addtoset s (hd A) end) (!DEFDEPS2)) L;());

(* lists defined constants and operators not appearing in embedded theorems *)
(* also picks up dependencies of defined terms from (!DEFDEPS) *)

(* the thm parameter is a technicality for blocking references to
the defining theorem (which is then the same as the defined object)
within the definition *)

fun conlist2 thm (Constant "") = nil |

	conlist2 thm (Constant s) = if isdefined s
				then if definitionof s = thm then [thm]
				else addtoset (definitionof s) 
					(defdeps (definitionof s))
				else nil |

	conlist2 thm (Function t) = conlist2 thm t |

	conlist2 thm (CaseExp(u,v,w)) = union (conlist2 thm u)
		(union(conlist2 thm v)(conlist2 thm w)) |

	conlist2 thm (Infix(x,ResOp "=>",y)) = conlist2 thm y |

	conlist2 thm (Infix(x,ResOp "<=",y)) = conlist2 thm y |

	conlist2 thm (Infix(x,i,y)) = union
		(if isdefined (opdisplay i) then if definitionof(opdisplay i)
					= thm then [thm]

					else addtoset 
					(definitionof (opdisplay i)) 
					(defdeps (definitionof (opdisplay i)))
				else nil)
		(union (conlist2 thm x) (conlist2 thm y)) |

	conlist2 thm t = nil;
	
fun makedefdeps thm = if isatheorem thm then

		let val (fo,rt,lt,dps) = Thm thm in

		(
		adddefdep thm
			(union(conlist2 thm lt)(conlist2 thm rt));

		map (fn (x) => if x <> thm
		then makedefdeps x else ()) (defdeps2 thm);())

		end

		else errormessage (thm^" is not a theorem");

(* list of all constants (including infixes) on which a term depends,
used by theorem text deps functions *)

fun conlist (Constant "") = nil |

	conlist (Constant s) = [s] |

	conlist (Infix(x,ConOp s,y)) = addtoset s 
			(union (conlist x) (conlist y)) |
	conlist (Infix(x,ResOp s,y)) = addtoset s 
			(union (conlist x) (conlist y)) |
	conlist (Infix(x,VarOp s,y)) = 
			(union (conlist x) (conlist y)) |
	conlist (Function s) = conlist s |
	conlist (CaseExp(u,v,w)) = union (conlist u) (union (conlist v)
							(conlist w)) |
	conlist t = nil;

val THMTEXTDEPS = ref [("bogus",["bogus"])];

val THMTEXTDEPS2 = ref [("bogus",["bogus"])];

fun thmtextdeps s = safefind nil s (!THMTEXTDEPS);

fun thmtextdeps2 s = safefind nil s (!THMTEXTDEPS2);

(* now should update inverse list correctly *)

fun addthmtextdep s L = (
	map(fn x=>let val A = find x (!THMTEXTDEPS2) in
	THMTEXTDEPS2:=strongadd x
	(if A = nil then nil else (dropfromset s (hd A)))(!THMTEXTDEPS2)end)
	(thmtextdeps s);
	THMTEXTDEPS:= strongadd s L (!THMTEXTDEPS);
	map(fn x => 
	THMTEXTDEPS2:= strongadd x
	(let val A = find x (!THMTEXTDEPS2) in
	if A = nil then [s] else addtoset s (hd A) end) (!THMTEXTDEPS2)) L;());

fun isatheorem2 s = isatheorem s orelse isapretheorem s;

(* determine the text dependencies of a term, L being a list
of known recursive dependencies *)

(* make this dynamic; it updates the text dependencies as it goes
and it short circuits the recursive process where it knows the work
has already been done *)

val DONELIST = ref ["bogus"];  
(* list of theorems whose text dependencies have
already been updated *)

fun conlist4 L (Constant "") = nil |

	conlist4 L (Constant s) = if (not (foundinset s L)) andalso
					foundinset s (!DONELIST)

				then thmtextdeps s  (* short circuit! *)

				
				else if isatheorem s 
				then if foundinset s L then thmtextdeps s
				else (
				let val LL =
				addtoset s (union (conlist4 (addtoset s L)
				(Leftside s))(conlist4 (addtoset s L)
				(Rightside s)))

				in (DONELIST:=addtoset s (!DONELIST);
					addthmtextdep s 
					(LL);LL)

				end)	
				else if isdefined s
				then if foundinset (definitionof s) L then 
					thmtextdeps (definitionof s)
				else
				(conlist4 L
				(Constant (definitionof s)))
				
				else if isapretheorem s then [s]
				else nil |

	conlist4 L (Function t) = conlist4 L t |

	conlist4 L (CaseExp(u,v,w)) = union (conlist4 L u)
		(union(conlist4 L v)(conlist4 L w)) |

	conlist4 L (Infix(x,i,y)) =

			union (conlist4 L x)

			(union (conlist4 L y)

			(conlist4 L (Constant (opdisplay i))))

			|

	conlist4 L t = nil;

fun makethmtextdeps1 thm = if isatheorem thm then

		let val LIST =
			(conlist4 nil (Constant thm)) in

		(
		addthmtextdep thm LIST;

		map (fn x => if (foundinset x (!DONELIST))
		then if foundinset thm (thmtextdeps x)

		then addthmtextdep x LIST else ()

		else makethmtextdeps1 x) (thmtextdeps2 thm);())

		end

		else errormessage (thm^" is not a theorem");

fun makethmtextdeps thm = (DONELIST:=nil;makethmtextdeps1 thm;
		DONELIST:=nil);


(* modification to note that definition deps of an axiom cannot
be removed from a theorem using the axiom *)

fun fixdeps thm = (makethmtextdeps thm;makedefdeps thm; if isatheorem thm then
	let val (fo,lt,rt,dps) = Thm thm in
	addtheorem thm fo lt rt
	(sortset((setminus dps 
	(setminus (separate isdefinition dps) 
	(union(defdeps thm)(union2(map defdeps 
	(separate (fn x => not(isdefinition x)) dps))))))))
	end
	else ());

(* USER COMMAND *)

(* see all dependencies of a theorem *)

fun showalldeps thm = if isatheorem thm then

	output(std_out,(!Returns)^"axiomatic:"^(!Returns)
	^(display(listtoterm (sortset(Deps thm))))
	^(!Returns)^"definition:"^(!Returns)
	^(display(listtoterm (sortset(defdeps thm))))^(!Returns)^
	"theorem text:"^(!Returns)
	^(display(listtoterm(sortset(thmtextdeps thm))))^(!Returns))
	
	else if isbuiltinthm thm 

	then errormessage (thm^" is a built-in tactic")

	else errormessage (thm^" is not a theorem");

(* USER COMMAND *)

(* see what theorems use a given theorem (in the theorem text sense) *)

fun whatuses thm = if isatheorem thm then

	output(std_out,
	(!Returns)^(display(listtoterm(sortset(thmtextdeps2 thm))))^(!Returns))
	else if isbuiltinthm thm

	then errormessage (thm^" is a built-in tactic")

	else errormessage (thm^" is not a theorem");

(* left sides of theorems may not have execution behaviour *)

(* the overloading of existing non-theorem constants as theorems
(except by definitions)
has been prevented -- it can be forced by hand by using pretheorems
(as it could be in the existing version) *)

(* commands for creating theorems *)

(* left sides of theorems may not have execution behaviour *)

(* USER COMMAND *)

(* command for declaring recursive tactics prior to their actual proof *)

fun declarepretheorem name = if isaconstant name orelse isoperator name
	then errormessage (name^" is already declared")
	else if name <> "" andalso stringtocon name = Constant name 
		then (declareconstant name; 
		PRETHEOREMS:=addtoset name (!PRETHEOREMS);
		addthmtextdep name [name])
	else if name <> "" andalso stringtoop name = ConOp name
		then (declareinfix name;
		PRETHEOREMS:=addtoset name (!PRETHEOREMS);
		addthmtextdep name [name])
	else errormessage (name^" is ill-formed"); 

(* USER COMMAND *)

(* a technicality, but someone might want it *)

fun declareunarypretheorem name = if name <> "" andalso stringtoop name
	= ConOp name then (declarepretheorem name;declarestrictprefix name)
	else errormessage 
	("Inappropriate argument "^name^" for unary pretheorem declaration");

(* should axioms have scin/scout induced deps? *)
(* axioms must be rule-free on both sides, or thm text deps must
be more complicated *)

(* it appears at this point that axioms and definitions can safely be
solely dependent on themselves:  any application of an axiom or definition
introduces its scin/scout deps.  Definition dependencies of axioms will not
be dropped by fixdeps.  In general, axioms and definitions are treated
specially by the prover in ways which are likely to avoid problems:
they cannot be reproven or forgotten *)

(* USER COMMAND *)

fun axiom na ls rs = if stringtocon na = Constant na andalso 
					not(isaconstant na)

	then let val LS = parse ls and RS = parse rs in

	if declarecheck false 0 LS andalso declarecheck false 0 RS (* andalso
	isstratified 0 LS andalso isstratified 0 RS *) andalso rulefree LS
	andalso rulefree RS
	

		then (addtheorem na (Constant na) LS RS [na]; fixdeps na;
			declareconstant na;thmdisplay na)

		else (errormessage 
	("Declaration or stratification error in proposed theorem "^na))
		end
	else errormessage 
	("Name of proposed theorem "^na^" is ill-formed or already declared");

(* USER COMMAND *)

(* axioms asserting truth of propositions *)

fun statement na ls = axiom na ls "true";

(* the definition commands require that the object being defined be
undeclared as yet, that no new variables or undeclared constants or
operators appear on the right side of the definition, and that the
whole definition be stratified *)

(* should definitions have scin/scout induced deps? *)
(* since thmtextdeps functions follow trail of definitions, it seems
safe to allow execution behavior on right side of a definition *)

(* in this case it might seem natural to allow definition theorems
to be pretheorems to allow definitions with recursive execution 
behavior -- not implemented *)

(* USER COMMAND *)

fun defineconstant ls rs = let val LS = parse ls and RS = parse rs in
	
	if atomdefinitionformat LS andalso not(isaconstant(atomhead LS))
	andalso declarecheck false 0 RS (* andalso isstratified 0 RS *)
	andalso subset (freevarlist RS) (freevarlist LS)
	andalso isstrat2 (Infix(LS,ResOp"=",RS))

	then (declareconstant (atomhead LS);
		addtheorem (atomhead LS) 
		(Constant(atomhead LS)) LS RS [atomhead LS]; 
		adddef (atomhead LS) (atomhead LS);
		fixdeps (atomhead LS);
		thmdisplay (atomhead LS))

	else errormessage 
("Format, declaration or stratification failure of proposed definition of "^ls)

	end;

(* this version now supports automatic declaration of unary
operators (as strict prefixes); the command will accept a 
left side in unary format *)

(* USER COMMAND *)

fun definetypedinfix name m n ls rs = 

	let val LS = parse ls and RS = parse rs in

	if opdefinitionformat LS andalso not(isoperator(ophead LS))
	andalso not(isatheorem name orelse isapretheorem name
	orelse isbuiltinthm name)
	andalso declarecheck false 0 RS (* andalso isstratified 0 RS *)
	andalso subset (freevarlist RS) (freevarlist LS)

	then if

	(declaretypedinfix m n (ophead LS);
		if not(declarecheck true 0 LS) 
		then declarestrictprefix (ophead LS)
			else ();
		isstrat2 (Infix(LS,ResOp"=",RS)))

		then (declareconstant name;
		addtheorem (name) 
		(Constant(name)) LS RS [name]; 
		adddef (name) (ophead LS);
		fixdeps (name);
		thmdisplay (name))

		else (OPERATORS:=drop (ophead LS) (!OPERATORS);
		PREFIX := drop (ophead LS) (!PREFIX);
		
		errormessage 

		("Stratification error in proposed definition of "^ls))

	else errormessage

	("Format or declaration error in proposed definition of "
	^ls)

	end;

(* USER COMMAND *)

(* command for defining opaque operators *)
(* for the December 1999 revisions, @! is excluded from the 
expressions defining opaque operators; otherwise we would have
paradoxes *)

fun metafree (Infix(x,ResOp t,y)) = t<>"@!" 
	andalso metafree x andalso metafree y |
	metafree (Infix(x,i,y)) = metafree x andalso metafree y |
	metafree (Function t) = metafree t |
	metafree (CaseExp(u,v,w)) = metafree u andalso metafree v
		andalso metafree w |
	metafree (Parenthesis t) = metafree t |
	metafree t = true;

fun defineopaque name ls rs = 

	let val LS = parse ls and RS = parse rs in

	if opaqueopdefinitionformat LS andalso not(isoperator(ophead LS))
	andalso not(isatheorem name orelse isapretheorem name
	orelse isbuiltinthm name)
	andalso declarecheck false 0 RS andalso metafree RS
		(* andalso isstratified 0 RS *)
	andalso subset (freevarlist RS) (freevarlist LS)

	then

	(declareopaque (ophead LS);
		if not(declarecheck true 0 LS) 
		then declarestrictprefix (ophead LS)
			else ();
		declareconstant name;
		addtheorem (name) 
		(Constant(name)) LS RS [name]; 
		adddef (name) (ophead LS);
		fixdeps (name);
		thmdisplay (name))

	else errormessage

	("Format or declaration error in proposed definition as opaque of "
	^ls)

	end;


(* USER COMMAND *)

(* define operators with flat typing *)

fun defineinfix name ls rs = definetypedinfix name 0 0 ls rs;

(* USER COMMAND *)

(* user command to bind a tactic to a function or operator *)

fun setprogram s thm = if thm <> "" andalso eitherhead (Leftside thm) = s

	then PROGRAMS := strongadd s thm (!PROGRAMS)
	
	else errormessage 
	("Inappropriate program "^thm^" cannot be bound to "^s);

(* USER COMMAND *)

(* see the program (if any) bound to a function or operator *)

fun seeprogram s = if hasprogram s then thmdisplay (programof s)
	else errormessage (s^" does not have a program bound to it");


(* USER COMMAND *)

fun prove fo = if (!ERRORFLAG)

        then errormessage "Proof aborted due to errors"

	else if declarecheck false 0 (leftside(!ENV)) 
	(* andalso 
		Isstratified 
		(Infix(leftside(!ENV),ResOp"=",rightside(!ENV))) *)
	andalso rulefree (leftside(!ENV))
	andalso declarecheck false 0 (rightside(!ENV)) 

	then let val FO = parse fo in
	if weakatomdefinitionformat FO 
	then let val NA = atomhead FO in
		if (isatheorem NA orelse isbuiltinthm NA
		orelse (isaconstant NA andalso (not (isapretheorem NA)))) then
			errormessage 
			("There is already a constant or theorem "^NA)
		else (if isaconstant NA then () else declareconstant NA;
			addtheorem NA FO (leftside(!ENV))
				(rightside(!ENV)) (deps(!ENV));
			fixdeps NA; 
			if (!SCRIPTING) then
			AUTOSCRIPT:=((!AUTOSCRIPT)^"\n(*\n"^(display FO)^
			":"^(!Returns)^(display(leftside(!ENV)))
			^"   ="^(!Returns)^
			(display(rightside(!ENV)))^(!Returns)^
			(display(listtoterm (deps(!ENV))))^"\n*)"^(!Returns)) 
			else ();
			thmdisplay NA)
		end

	else if weakopdefinitionformat FO 
	then let val NA = ophead FO in
		if (isatheorem NA orelse isbuiltinthm NA 
		orelse (isaconstant NA andalso (not (isapretheorem NA)))) then
			errormessage 
			("There is already an operator or theorem "^NA)
		else (if isoperator NA then () else declareinfix NA;
			if not(declarecheck true 0 FO) then
			if isapretheorem NA
			then errormessage 
		("Pretheorem "^NA^" cannot be automatically declared unary")
			else declarestrictprefix NA else ();
			addtheorem NA FO (leftside(!ENV))
				(rightside(!ENV)) (deps(!ENV));
			fixdeps NA;
			if (!SCRIPTING) then
			AUTOSCRIPT:=((!AUTOSCRIPT)^"\n(*\n"^(display FO)^
			":"^(!Returns)^(display(leftside(!ENV)))
			^"   ="^(!Returns)^
			(display(rightside(!ENV)))^(!Returns)^
			(display(listtoterm (deps(!ENV))))^"\n*)"^(!Returns)) 
			else ();
			thmdisplay NA)
		end

	else errormessage (fo^" cannot be a proof format")

	end

	else errormessage "Declaration or stratification error in environment";

(* environment saving commands *)

(* the environment desktop *)

val ENVS = ref [("bogus",(!ENV))];

(* USER COMMAND *)

(* save an environment *)

(* saved environments are stored both on the desktop and on the theorem
list with initial "}" (a character which cannot occur in a term) *)

fun saveenv s = if eitherhead (parse s) = "" 

	then errormessage ("Ill-formed proposed format "^s)

	else if declarecheck true 0 (leftside(!ENV)) andalso
		declarecheck true 0 (rightside(!ENV)) (* andalso
		Isstratified (Infix(leftside(!ENV),ResOp"=",rightside(!ENV)))*)

	then (envmod(changeename(eitherhead(parse s)));
		envmod(changeformatof(parse s));
		ENVS:=strongadd (eitherhead(parse s)) (!ENV) (!ENVS);
		addtheorem 
		("}"^(eitherhead(parse s))) (formatof(!ENV))
		(leftside(!ENV)) (rightside(!ENV)) (deps(!ENV));
		thmdisplay ("}"^(eitherhead(parse s))))

	else errormessage 
	("Cannot save "^s^" due to declaration errors");

(* USER COMMAND *)

(* display an environment *)

fun showenv s = if isatheorem ("}"^s) then thmdisplay ("}"^s)
		else errormessage ("Saved environment "^s^" not found");

(* display all (or selected) environments *)

fun showsomeenvs filter nil = () |

	showsomeenvs filter ((na,x)::L) = 

		if filter na andalso hd(explode na) = "}"

		then (thmdisplay na; suspend(fn()=>showsomeenvs filter L))
		else showsomeenvs filter L;

(* USER COMMAND *)

fun showallenvs() = (showsomeenvs (fn x => true) (sortfun(!THEOREMS)));

(* USER COMMAND *)

(* the name of the current environment; it is usually the null string,
unless an environment has been saved or invoked by autoedit *)

fun envname() = if (!VERBOSITY) = 2 then nopausemessage (ename(!ENV)) else ();

(* USER COMMAND *)

(* backup the current environment by name or as "backup" *)

fun backupenv() = if (formatof(!ENV)) = Constant ""
	then saveenv "backup"
	else saveenv (baredisplay(formatof(!ENV)));

(* USER COMMAND *)

(* retrieve a saved environment; if it is on the desktop, one gets 
complete information; if recovered from the theorem list, one loses
position information *)

(* getenv works by _name_, not format *)

fun getenv s = (if s = ename(!ENV) orelse (s = "backup"
	andalso formatof(!ENV) = Constant "")
	then () else backupenv();
	if foundin s (!ENVS)

		then

		(ENV:=hd(find s (!ENVS));look())

	else if isatheorem ("}"^s)

		then 

		(ENV:=(s,Formatof("}"^s),Leftside("}"^s),Rightside("}"^s),
			nil,0,0,nil,Deps("}"^s));look())

		else errormessage ("Environment "^s^" not found"));

(* USER COMMAND *)

(* drop an environment *)

fun dropenv s = if s = ename(!ENV) orelse (parse (ename(!ENV))) = Constant ""
andalso s = "backup" then errormessage "Cannot drop backup"

else (ENVS:=drop s (!ENVS); THEOREMS:=drop s (!THEOREMS));

(* ADD: a command for clearing saved environments *)

(* Commands for initializing the environment (starting work on
an equation *)

(* Moved here from above so that they can use the backupenv
command for safety *)

(* USER COMMAND *)

(* create the equation t = t to start working on *)

fun start t = (backupenv();ERRORFLAG:=false;
	ENV:=("",Constant"",(parse t),(parse t),nil,0,0,nil,nil);
	if declarecheck false 0 (leftside(!ENV)) 
		then (* if Isstratified (leftside(!ENV))

			then *) ()
			(* else errormessage "Term is not stratified" *)
	else errormessage "Undeclared identifiers or bound variables found"; 
	look());

(* supports modification of startover and starthere to preserve
environment name (as needed by getleftside and getrightside) *)

val OLDNAME = ref "bogus";  (* old name of environment *)

(* USER COMMAND *)

(* start over with left side *)

fun startover() = 
	(OLDNAME := ename(!ENV);
	start (baredisplay(leftside (!ENV)));
	envmod (changeename (!OLDNAME)));

(* USER COMMAND *)

(* start over with current term *)

fun starthere() = 
	(OLDNAME := ename(!ENV);
	start (baredisplay(rightside (!ENV)));
	envmod (changeename (!OLDNAME)));

(* USER COMMAND *)

(* convenient command for theorem editing -- use with reprove *)

fun autoedit thm = if isatheorem thm andalso isaconstant thm

	then (backupenv();ENV:=(thm,Formatof(thm),Leftside(thm),Rightside(thm),
			nil,0,0,nil,Deps(thm));look())

	else errormessage ("Cannot autoedit \"theorem\" "^thm);

(* USER COMMANDS (2) *)

(* start with left or right side of a theorem *)

fun getleftside thm = (autoedit thm; startover());

fun getrightside thm = (autoedit thm; starthere());

(* USER COMMAND *)

(* allows theorem to be proved in a new form.  Usually used for tactic
debugging and updating.  The dependency related restrictions found in Mark2
are no longer operative *)

fun reprove thm = let val THM = eitherhead (parse thm) in

	if isatheorem THM 

	then if foundinset THM (Deps THM) orelse foundin THM (!DEFINITIONS)

	then errormessage ("Cannot reprove axiom or definition "^THM)

	else (* if subset (deps(!ENV)) (Deps(THM))

	then *)  (THEOREMS:=drop THM (!THEOREMS);
		CONSTANTS:=dropfromset THM (!CONSTANTS);
		OPERATORS:=drop THM (!OPERATORS); 
		PREFIX:=drop THM (!PREFIX);
		declarepretheorem THM;
		prove thm)

	(* else errormessage ("Would add additional dependencies to "^THM) *)

	else errormessage ("Theorem "^thm^" not found to reprove") end;

(* USER COMMAND *)

(* reprove where theorem name and format are already known *)

fun autoreprove() = if (eitherhead(formatof(!ENV))) = "" 

	then errormessage "Autoprove information not available"

	else reprove (baredisplay(formatof(!ENV)));

(* matching, substitution, and use of theorems *)

(* functions implementing changes of level and hlevel ( = "hypothesis level"
in case expressions) *)

fun changelevelcheck source target term = if source = target then term
	else changelevel source target term;

(* the command to change "hypothesis level" of a term *)

fun changehlevel source target (Infix(x,ResOp "|-|" ,Numeral S)) = 
let val s = evalnum (map makestring S) in
	if s <= source andalso s <= target then
				(Infix(x,ResOp"|-|",Numeral S))
	else if s <= source andalso s > target then Constant ""
	else(Infix(x,ResOp"|-|",Numeral 
	(map numvalue (rev (explode (makestring (target + (s - source)))))))) 
		end |
	changehlevel source target (Function t) =

		let val TRY = changehlevel source target t in
		if TRY = Constant "" then Constant "" else Function TRY end |
	changehlevel source target (Infix(x,i,y)) =

		let val TRY1 = changehlevel source target x
		and TRY2 = changehlevel source target y in
		if (TRY1 = Constant "" andalso ((not(hasprefix (opdisplay i)))
			orelse prefixof (opdisplay i) <> ""))
		orelse TRY2 = Constant ""
		then Constant "" else Infix(TRY1,i,TRY2)  end |
	changehlevel source target (CaseExp(u,v,w)) =

		let val TRY1 = changehlevel source target u
		and TRY2 = changehlevel source target v
		and TRY3 = changehlevel source target w in

		if TRY1 = Constant "" orelse TRY2 = Constant "" 
			orelse TRY3 = Constant ""
		then Constant ""
		else (CaseExp(TRY1,TRY2,TRY3))
		end |

	changehlevel source target (Parenthesis u) =

		let val TRY = changehlevel source target u in

		if TRY = Constant "" then Constant "" else Parenthesis TRY 

		end |

	changehlevel source target t = t;

fun changehlevelcheck source target term = if source = target then term
	else changehlevel source target term;

(* command for displaying the local hypothesis list *)
(* inserted here because changelevel is needed *)

(* also now displays the local variable binding situation *)

fun prelookhyps n level nil = 

		(if n = 1 andalso level <> 0
		then ("\nBound variables locally free up to ?"
			^(makestring level)^(!Returns))
		else "") |

	prelookhyps n level ((t,u,p,s,l)::L) =

		(if n = 1 andalso level <> 0
		then ("\nBound variables locally free up to ?"
			^(makestring level)^(!Returns))
		else "")^

		(makestring n)^

			(if s = 0 then " (inactive):  "^(!Returns)
			else if s = 1 then " (positive):  "^(!Returns)
			else if s = 2 then " (negative):  "^(!Returns)
			else "(bogus):  ")

		^(if u = Constant "true" andalso (!STATEMENTDISPLAY) then

		"|-"^(display (changelevel l level t))

		else if t = Constant "true" andalso (!STATEMENTDISPLAY) then

		"$|-"^(display (changelevel l level u))

		else (display (changelevel l level t))^"  =  "^(!Returns)
		^(display (changelevel l level u)))
		^(!Returns)^(prelookhyps (n+1) level L);

fun guiprelookhyps n l h =

(if (!GUIMODE) then "\nHypothesis display:"^(!Returns) else "")^
(prelookhyps n l h)^(if (!GUIMODE) then ". . ."^(!Returns) else "");

(* USER COMMAND *)

(* view list of local hypotheses *)

fun lookhyps() = output(std_out,

guiprelookhyps 1 (level(!ENV)) (hypslist(!ENV)));

(* text replacement in terms -- takes level changes into account *)
(* replace t with u in last argument at given level and hlevel *)

(* utilities for handling replacement of operator variables *)

fun isphonyconstant (Parenthesis(Constant t)) = t <> "" andalso
		(explode t) = getspecial(explode t) |

	isphonyconstant t = false;

fun isphonyvariable (FreeVar t) = t <> "" 
		andalso stringtoop t = VarOp t  |

	isphonyvariable t = false;

fun replace level hlevel t u (Function s) =

	if t = Function s then u 

	else Function (replace level hlevel (changelevel level (level+1) t)
		(changelevel level (level+1) u) s) |

	replace level hlevel t u (CaseExp(a,b,c)) =

	if t = CaseExp(a,b,c) then u 

	else  let val T = changehlevel hlevel (hlevel+1) t 
		and U = changehlevel hlevel (hlevel+1) u in

		CaseExp(replace level hlevel t u a,
		replace level hlevel T U b,
                replace level hlevel T U c) end |

	replace level hlevel t u (Infix(x,i,y)) =

	(* handle substitution for operator variables *)
	(* this is strictly a hack for the internal consumption
	of the substitution operation below *)

	if isphonyvariable t andalso isphonyconstant u
	andalso (opdisplay i) = (baredisplay t)

	then Infix(replace level hlevel t u x,ParOp(baredisplay 
		(deparenthesize1 u)),
		replace level hlevel t u y)

	else if t = (Infix(x,i,y)) then u 

	else Infix(replace level hlevel t u x,i,replace level hlevel t u y) |

	replace level hlevel t u v =

	if t = v then u else v;

(* eval and bind functions *)

val STRATWARNING = ref false;

fun stratwarning() = (STRATWARNING:= not (!STRATWARNING);
	nopausemessage ("Stratification warning is "^(if (!STRATWARNING) then
	"on" else "off")));

(* eval determines the value of Function t at u *)

(* hlevel will not be an issue *)

fun eval level (Function t) u = 
	changelevel (level+1) level (replace (level+1) 0
		(BoundVar (level+1)) (changelevel level (level+1) u) t) |

	eval level t u = Infix(t,ResOp"@!",u);

fun morevals level (Infix(t,ResOp"@!",u)) v = 
		eval level (morevals level t u) v |

	morevals level t u = eval level t u;

(* depairprep handles evaluation of the automatic projection operators
p1 and p2 and of constant functions at ?0 *)

fun depairprep level (Infix(Constant"p1",ResOp"@",(Infix(x,ResOp",",y)))) = 
	depairprep level x |

	depairprep level (Infix(Constant"p2",ResOp"@",
		(Infix(x,ResOp",",y)))) = 
	depairprep level y |

	depairprep level (Infix(Function t,ResOp"@",BoundVar 0)) =

	if changelevel (level + 1) level t = Constant "" then 
		(Infix(Function (depairprep (level+1) t),ResOp"@",BoundVar 0))
		else depairprep level (changelevel (level+1) level t) |

	depairprep level (Function t) = Function(depairprep (level+1) t) |

	depairprep level (Infix(x,i,y)) = 
	Infix(depairprep level x,i,depairprep level y) |

	depairprep level (CaseExp(u,v,w)) =
        CaseExp(depairprep level u,depairprep level v,depairprep level w) |

        depairprep level u = u;

(* this is eval strengthened to post scin/scout deps *)

(* now strengthened to automatically evaluate p1, p2, constant
functions at ?0 *)

fun strongeval level (Function t) u = if Isstratified1 level (Function t)
	then depairprep level 
	(changelevel (level+1) level (replace (level+1) 0
		(BoundVar (level+1)) (changelevel level (level+1) u) t))

	else (if (!STRATWARNING) then 
	errormessage "Evaluation at unstratified abstract attempted" else ();
	Infix(Function t,ResOp"@",u)) |

	strongeval level t u = Infix(t,ResOp"@",u);

fun morestrongevals level (Infix(t,ResOp"@",u)) v =

	strongeval level (morestrongevals level t u) v |

	morestrongevals level t u = strongeval level t u;

(* prebind expresses t as a function of u without checking for
stratification *)

fun prebind level t u = Function(replace (level+1) 0
	(changelevel level (level+1) u) 
	(BoundVar (level+1)) (changelevel level (level+1) t));

(* this is list binding, and it looks at the grouping of
the comma to decide which way to go! *)

(* it now handles constant functions as well as pairs *)

fun pairprep level (Infix(x,ResOp",",y)) t =
	deparenthesize(
	replace level 0 x 
	(Parenthesis(Infix(Constant "p1",ResOp"@",Infix(x,ResOp",",y))))
	(replace level 0 y 
	(Parenthesis(Infix(Constant "p2",ResOp"@",Infix(x,ResOp",",y))))
	(replace level 0 (Infix(x,ResOp",",y)) 
	(Parenthesis (Infix(x,ResOp",",y))) 
	(pairprep level x (pairprep level y t))))) |

	pairprep level (Function u)  t = let val U =
	changelevel (level-1) level u in
	
	if U = Constant "" then t else

	deparenthesize(
	replace level 0 U
		(Infix(Function u,ResOp"@",BoundVar 0))
		(replace level 0 (Function u) (Parenthesis(Function u))
		(pairprep level u t))) end |

	pairprep level u t = t;
									

(* bind incorporates stratification check *)
(* and now incorporates fun with pairs*)

fun bind level t u = let val A = prebind level (pairprep level u t) u in

	if Isstratified1 level A then A else 

	(if (!STRATWARNING) then 
	errormessage "Attempt to form unstratified abstract" else ();
	Constant "")	end;

(* the match function returns a list containing a finite function
matching free variables of its first term argument with terms in the
second term argument, if such a match is possible; otherwise it returns
nil *)

(* there is a hack for matches to operator variables; matching operators are
"repackaged" as constants *)

(* the "higher order matching" refinement provides that if a term
T@?n matches a term U at level n, and T is meaningful at our working
level, that T will match [U] *)

(* machine for merging matches *)

fun mergematches nil L = nil |

	mergematches M nil = nil |

	mergematches (a::L) (b::M) = merge a b;


(* it is presumed that terms of the same level and hlevel are
being matched *)

(* level is the level of the top-level terms being matched; n is the 
level of the current subterm being examined *)

(* match has been modified so that terms with execution behaviour
will not match anything *)


(* fun hyptoeq (Infix(x,ResOp"=",y))(Infix(z,ResOp"=",w))=(Infix(z,ResOp"=",w))|
	hyptoeq (Infix(x,ResOp"=",y)) t = Infix(Constant"true",ResOp"=",t)|
	hyptoeq t u = u; *)

fun aptoeq (Infix(x,ResOp"@",y)) = (Infix(x,ResOp"bogus",y)) |

	aptoeq t = t;

fun iterboundvar (BoundVar n) = n |

	iterboundvar (Function u) = iterboundvar u |

	iterboundvar t = ~1;

fun itervalue (Function u) t = Infix(itervalue u t,ResOp"@",BoundVar 0) |

	itervalue u t = t;

fun match level n (Constant s) (Constant t) = if s=t then [nil] else nil |

	match level n (Numeral s) (Numeral t) = if s=t then [nil] else nil |

	match level n (FreeVar s) t = let val T = changelevel n level t in
				if declarecheck true level T then
					[[(s,T)]] else nil end |

	match level n (Infix(t,ResOp"@",BoundVar 0)) u =

	match level n t (Function(changelevel n (n+1) u))

	|

	match level n (Infix(Function t,ResOp "@",u)) 
		(Infix(Function t1,ResOp"@",u1)) =

        let val M = match level n (Infix(Function t,ResOp "=",u)) 
		(Infix(Function t1,ResOp"=",u1)) in

	if M = nil andalso (strongeval n (Function t) u) <> 
	(Infix(Function t,ResOp "@",u))

        then match level n (strongeval n (Function t) u) 
		(Infix(Function t1,ResOp"@",u1))

        else M

        end |

	match level n (Infix(Function t,ResOp "@",u)) v =

	if (strongeval n (Function t) u) <> (Infix(Function t,ResOp "@",u))
	then match level n (strongeval n (Function t) u) v else nil |

	match level n (Infix(t,ResOp"@",u))(Infix(t1,ResOp"@",u1)) =

	let val M = match level n (Infix(t,ResOp"=",u))(Infix(t1,ResOp"=",u1))

	in 

	if M = nil 

	then let val SE = morestrongevals n t u in

	if SE <> (Infix(t,ResOp"@",u))

	then match level n SE (Infix(t1,ResOp"@",u1))

	else let val v = (Infix(t1,ResOp"@",u1)) in

	match level n t (bind n v u) end end

	else M end |

	match level n (Infix(t,ResOp"@",u)) v =

	let val SE = morestrongevals n t u in

	if SE <> (Infix(t,ResOp"@",u))

	then match level n SE v

	else match level n t (bind n v u) end |


	match level n (Infix(Function t,ResOp "@!",u)) 
		(Infix(Function t1,ResOp"@!",u1)) =

        let val M = match level n (Infix(Function t,ResOp "=",u)) 
		(Infix(Function t1,ResOp"=",u1)) in

	if M = nil andalso (eval n (Function t) u) <> 
		(Infix(Function t,ResOp "@!",u))

        then match level n (eval n (Function t) u) 
		(Infix(Function t1,ResOp"@!",u1))

        else M

        end |

	match level n (Infix(Function t,ResOp "@!",u)) v =

	if (eval n (Function t) u) <> (Infix(Function t,ResOp "@!",u))

	then match level n (eval n (Function t) u) v else nil |



	match level n (Infix(t,ResOp"@!",u))(Infix(t1,ResOp"@!",u1)) =

	let val M = match level n (Infix(t,ResOp"=",u))(Infix(t1,ResOp"=",u1))

	in if M = nil 

	then let val EV = morevals n t u in

	if EV <> (Infix(t,ResOp"@!",u))

	then match level n EV (Infix(t1,ResOp"@!",u1))

	else let val v = (Infix(t1,ResOp"@!",u1)) in

	match level n t (prebind n v u) end end

	else M end |

	match level n (Infix(t,ResOp"@!",u)) v =

	let val EV = morevals n t u in

	if EV <>  (Infix(t,ResOp"@!",u))

	then match level n EV v

	else match level n t (prebind n v u) end |

	match level n (BoundVar s) (BoundVar t) = if s=t then [nil] else nil |

	match level n (Function s) (Function t) = match level (n+1) s t |

	match level n (Infix(x,VarOp s,y)) (Infix(z,i,w)) =

		if istypedoperator s andalso (((not(istypedoperator 
		(opdisplay i))) orelse 
		((lefttype (opdisplay i),righttype (opdisplay i)) <>
		(lefttype s,righttype s))))  then nil

		else if (isscinleft s andalso not (isscinleft (opdisplay i)))
		orelse (isscinright s andalso not (isscinright (opdisplay i)))
		orelse (isscout s andalso not (isscout (opdisplay i))) then nil

		(* a phony term is used here to represent a
		matched operator *)

		else mergematches [[(s,Constant (opdisplay i))]]
		(mergematches (match level n x z) (match level n y w)) |

	match level n (Infix(Numeral a,ResOp s,Numeral b)) 
				(Infix(x,ResOp t,y)) =

		if arithop s then nil
		else if s = t andalso x = Numeral a andalso y = Numeral b
			then [nil]
			else nil |

	match level n (Infix(x,ResOp s,y)) (Infix(z,ResOp t,w)) =

		if ruleinfix s orelse s <> t
		then nil
		else
		(mergematches (match level n x z) (match level n y w)) |

	match level n (Infix(x,i,y)) (Infix(z,j,w)) = 

		if i <> j then nil

		else (mergematches (match level n x z) (match level n y w)) |

	match level n (CaseExp(Infix(Constant "true",ResOp"=",t),u,v))
		w =nil |

	match level n (CaseExp(u,v,w)) (CaseExp(a,b,c)) =

		if u = Constant "true" orelse u = Constant "false" then nil
		else mergematches (match level n u ((* hyptoeq u *) a)) (
		mergematches (match level n v b) (match level n w c)) |

	match level n t u = nil;


(* sophisticated navigation commands are added here *)

(* these commands move to terms which match their arguments;
a version which looks for terms literally would also sometimes be useful *)

(* literal versions are now provided *)

val MATCHES = ref true;

fun preitmatches level s t = if match level level 
	(changelevel 0 (level) s) t = nil then 
				(MATCHES := false;t) else (MATCHES := true;t);

fun itmatches s = exec (preitmatches (level(!ENV)) s);

fun preitsequal level s t = if s = t then 
				(MATCHES := true;t) else (MATCHES := false;t);

fun itsequal s = exec (preitsequal (level(!ENV)) s);

(* USER COMMAND *)

(* moves up to a term matching its argument *)

(* performance slightly changed; it will always move up (so it can
be repeated effectively *)

fun upto s = (sup(); itmatches (parse s); if (!MATCHES) 
		then look()
		else if position(!ENV) = nil
		then (errormessage ("No match found for "^s);look())
		else upto s);

fun litupto s = (sup(); itsequal (parse s); if (!MATCHES) 
		then look()
		else if position(!ENV) = nil
		then (errormessage ("No match found for "^s);look())
		else litupto s);

(* USER COMMANDS (2) *)

(* move to places where theorems can be applied *)

fun uptols thm = if isatheorem thm then upto (baredisplay(Leftside thm))
		else errormessage ("No theorem "^thm^" found");
fun uptors thm = if isatheorem thm then upto (baredisplay(Rightside thm))
		else errormessage ("No theorem "^thm^" found");

fun atomic (Constant t) = true |

	atomic (FreeVar s) = true |

	atomic (BoundVar n) = true |

	atomic (Numeral n) = true |

	atomic t = false;

fun noleftsubterm (Function t) = true |

	noleftsubterm (Infix(Constant "",i,y)) = true |

	noleftsubterm t = false;

(* like the upto command, the downtoleft and downtoright functions
behave differently here; they always go to subterms if there are any,
unlike the original function, which would stick where it was if it
found a match *)

(* there still may be need to tinker with this family of commands *)

fun predowntoleft s = (getcurrent(); if atomic (!CURRENTTERM)
		then () 
		else if noleftsubterm (!CURRENTTERM)

		then (sright(); predowntoleft s; itmatches (parse s);
		if (!MATCHES) = true then () else sup())

		else (sleft(); predowntoleft s; itmatches (parse s);
		if (!MATCHES) = true then () else 
		(sup(); sright(); predowntoleft s; itmatches (parse s);
		if (!MATCHES) = true then () else sup())));

(* USER COMMANDS (4) *)

fun downtoleft s = (predowntoleft s; itmatches (parse s);
		if (!MATCHES) = true then look() else
		(errormessage ("No match found for "^s);look()));

fun litpredowntoleft s = (getcurrent(); if atomic (!CURRENTTERM)
		then () 
		else if noleftsubterm (!CURRENTTERM)

		then (sright(); litpredowntoleft s; itsequal (parse s);
		if (!MATCHES) = true then () else sup())

		else (sleft(); litpredowntoleft s; itsequal (parse s);
		if (!MATCHES) = true then () else 
		(sup(); sright(); litpredowntoleft s; itsequal (parse s);
		if (!MATCHES) = true then () else sup())));

fun litdowntoleft s = (litpredowntoleft s; itsequal (parse s);
		if (!MATCHES) = true then look() else
		(errormessage ("No match found for "^s);look()));


(* move to places where theorems can be applied *)

fun dlls thm = if isatheorem thm then downtoleft (baredisplay(Leftside thm))
		else errormessage ("No theorem "^thm^" found");
fun dlrs thm = if isatheorem thm then downtoleft (baredisplay(Rightside thm))
		else errormessage ("No theorem "^thm^" found");

(* literal versions of the previous commands are not appropriate *)

fun predowntoright s = (getcurrent(); if atomic (!CURRENTTERM)
		then () else (sright(); predowntoright s; itmatches (parse s);
		if (!MATCHES) = true then () else
 
		(sup(); getcurrent(); if noleftsubterm (!CURRENTTERM) 
		then () else (sleft(); predowntoright s; itmatches (parse s);
		if (!MATCHES) = true then () else sup()))));

(* USER COMMANDS (4) *)

fun downtoright s = (predowntoright s; itmatches (parse s);
		if (!MATCHES) = true then look() else
		(errormessage ("No match found for "^s);look()));

fun litpredowntoright s = (getcurrent(); if atomic (!CURRENTTERM)
		then () else (sright(); litpredowntoright s; 
			itsequal (parse s);
		if (!MATCHES) = true then () else
 
		(sup(); getcurrent(); if noleftsubterm (!CURRENTTERM) 
		then () else (sleft(); litpredowntoright s; itsequal (parse s);
		if (!MATCHES) = true then () else sup()))));

fun litdowntoright s = (litpredowntoright s; itsequal (parse s);
		if (!MATCHES) = true then look() else
		(errormessage ("No match found for "^s);look()));


(* move to places where theorems can be applied *)

fun drls thm = if isatheorem thm then downtoright (baredisplay(Leftside thm))
		else errormessage ("No theorem "^thm^" found");
fun drrs thm = if isatheorem thm then downtoright (baredisplay(Rightside thm))
		else errormessage ("No theorem "^thm^" found");

(* the substitution function *)

(* implements the automatic eval used by the substitution function
to implement the substitution side of "higher-order matching"  *)

(* requires some reasonable assumptions to avoid need to talk about
hlevel, which probably need to be enforced *)

fun changedtofunction (Function t) (Function u) = false |

	changedtofunction t (Function u) = true |

	changedtofunction u v = false;

fun autoeval level (Infix(Parenthesis(Function u),ResOp"@",v))

	= (strongeval level (Function u) (autoeval level v)) |

	autoeval level (Infix(Parenthesis(Function u),ResOp"@!",v))

	= (eval level (Function u) (autoeval level v)) |

	autoeval level (Infix(t,ResOp"@",u)) =

	let val T = autoeval level t in

	if changedtofunction t T 

	then reautoeval level (Infix(T,ResOp"@",autoeval level u)) 

	else (Infix(T,ResOp"@",autoeval level u)) end |

	autoeval level (Infix(t,ResOp"@!",u)) =

	let val T = autoeval level t in

	if changedtofunction t T

	then reautoeval level (Infix(T,ResOp"@!",autoeval level u)) 

	else (Infix(T,ResOp"@!",autoeval level u)) end |

	autoeval level (Infix(x,i,y)) = 

	Infix(autoeval level x,i,autoeval level y) |

	autoeval level (CaseExp(u,v,w)) =

	CaseExp(autoeval level u,autoeval level v, autoeval level w) |

	autoeval level (Function t) =

	Function (autoeval (level +1) t) |

	autoeval level t = t

and reautoeval level (Infix(Function u,ResOp"@",v)) =

	(strongeval level (Function u) v) |

	reautoeval level (Infix(Function u,ResOp"@!",v)) =

	(eval level (Function u) v) |

	reautoeval level t = t;

(* the substitution function itself *)

(* presubs keeps stuff in parentheses so that simultaneous 
substitutions don't interfere *)

fun presubs level hlevel t nil = t |

	presubs level hlevel t ((s,u)::L) = replace level hlevel

			(FreeVar s) (Parenthesis u) (

			presubs level hlevel t L);

exception BadSub;

fun baresubs level hlevel L t = presubs level hlevel t L;

fun subs level hlevel L t =
	let val T = presubs level hlevel t L in
	(* deparenthesize(autoeval level (presubs level hlevel t L)) in *)
	if metastrat level (deparenthesize T) then
	deparenthesize(autoeval level T) else
	(errormessage "Substitution abuses predicates";raise BadSub) end;

(* new type definition commands *)

(* they appear here because they need substitution *)

(* format of left side of a type definition *)

fun atomtypedefinitionformat (Infix(t1,ResOp":",FreeVar x)) =

	atomdefinitionformat t1 andalso not (foundinset x (freevarlist t1))|

	atomtypedefinitionformat x = false;

fun optypedefinitionformat (Infix(t1,ResOp":",FreeVar x)) =

	opdefinitionformat t1 andalso not (foundinset x (freevarlist t1)) |

	optypedefinitionformat x = false;

fun opaqueoptypedefinitionformat (Infix(t1,ResOp":",FreeVar x)) =

	opaqueopdefinitionformat t1 andalso not (foundinset x (freevarlist t1)) |

	opaqueoptypedefinitionformat x = false;


fun atomtypehead (Infix(t1,ResOp":",FreeVar x)) =

	atomhead t1 |

	atomtypehead x = "";

fun optypehead (Infix(t1,ResOp":",FreeVar x)) =

	ophead t1 |

	optypehead x = "";

fun typedarg (Infix(t1,ResOp":",FreeVar x)) = x |

	typedarg y = "";

(* USER COMMAND *)

(* declare a constant as a type label *)

fun defineconstanttype retractionthm ls rs =

	let val LS = parse ls and RS = parse rs in

	(* standard conditions on definitions *)

	if atomtypedefinitionformat LS andalso 
		not(isaconstant(atomtypehead LS))
	andalso declarecheck false 0 RS (* andalso isstratified 0 RS *)
	andalso subset (freevarlist RS) (freevarlist LS)
	andalso isstrat2 (Infix(LS,ResOp"=",RS))

	(* the argument being typed is not assigned a type
	in the stratification of this theorem (relative to free
	variables) *)

	andalso not (foundinset (typedarg LS) (map (fn (y,z) => y)
		(hd(strat2 0 (Infix(LS,ResOp"=",RS))))))

	(* the retraction theorem says the right thing *)
	(* we require a quite literal relationship down to
	names of variables between the retraction theorem and the
	definition:  the left side of the retraction theorem
	should be the right side of the proposed definition, and the
	right side should be the result of substituting the left side
	into itself for the parameter being typed (establishing
	that we have a retraction). *)

	andalso (Leftside retractionthm = RS andalso Rightside
		retractionthm = subs 0 0 [(typedarg LS,RS)] RS)
		orelse (Rightside retractionthm = RS andalso Leftside
		retractionthm = subs 0 0 [(typedarg LS,RS)] RS)


	then (declareconstant (atomtypehead LS);
		addtheorem (atomtypehead LS) 
		(Constant(atomtypehead LS)) LS RS 
		(addtoset (atomtypehead LS) (Deps retractionthm)); 
		adddef (atomtypehead LS) (atomtypehead LS);
		fixdeps (atomtypehead LS);
		thmdisplay (atomtypehead LS))

	else errormessage 
("Format, declaration or stratification failure of proposed definition of type "^ls)

	end;

(* USER COMMAND *)

(* type constructors are now declared as opaque operators *)

fun defineinfixtype name retractionthm ls rs = 

	let val LS = parse ls and RS = parse rs in

	if opaqueoptypedefinitionformat LS 
		andalso not(isoperator(optypehead LS))
	andalso not(isatheorem name orelse isapretheorem name
	orelse isbuiltinthm name)
	andalso declarecheck false 0 RS (* andalso isstratified 0 RS *)
	andalso subset (freevarlist RS) (freevarlist LS)

	(* the retraction theorem says the right thing *)
	(* we require a quite literal relationship down to
	names of variables between the retraction theorem and the
	definition *)

	andalso (Leftside retractionthm = RS andalso Rightside
		retractionthm = subs 0 0 [(typedarg LS,RS)] RS)
		orelse (Rightside retractionthm = RS andalso Leftside
		retractionthm = subs 0 0 [(typedarg LS,RS)] RS)

	andalso strat2 0 (subs 0 0 (map(fn x => (x,Numeral [0])) 
	(setminus (freevarlist RS) [typedarg LS])) RS) = [nil]

	then

	(declareopaque (optypehead LS);
		if not(declarecheck true 0 LS) 
		then declarestrictprefix (optypehead LS)
			else ();
		declareconstant name;
		addtheorem (name) 
		(Constant(name)) LS RS (addtoset name (Deps retractionthm));
		adddef (name) (optypehead LS);
		fixdeps (name);
		thmdisplay (name))

	else errormessage

	("Format or declaration error in proposed definition of type "
	^ls)

	end;


(*  BEGIN development of unification *)

(*

let apply_subst l t = rev_itlist (\pair term.subst[pair]term) l t;;

% Find a substitution to unify two terms (lambda-terms not dealt with) %

Thomas's HOL algorithm

letrec find_unifying_subst t1 t2 = 
 if t1=t2
  then []
 if is_var t1
  then if not(mem t1 (frees t2)) then [t2,t1] else fail
 if is_var t2
  then if not(mem t2 (frees t1)) then [t1,t2] else fail
 if is_comb t1 & is_comb t2
  then
   (let rat1,rnd1 = dest_comb t1
    and rat2,rnd2 = dest_comb t2
    in
    let s = find_unifying_subst rat1 rat2
    in s@find_unifying_subst(apply_subst s rnd1)(apply_subst s rnd2)
   )else fail;;



*)

(* an auxiliary hack for substitutions into match keys *)


(* this algorithm ignores hlevel; thus, it should only be applied in
rule-free contexts *)

(* it forbids matches to terms of nonzero intrinsic level *)

fun unify n (Constant s) (Constant t) = if s=t then [nil]
	else nil |

	unify n (Numeral s) (Numeral t) = 
		if s=t then [nil] else nil |

	unify n (FreeVar s) t = 
			if t = FreeVar s then [nil] else
			let val T = changelevel n 0 t in
				if declarecheck true 0 T 
				andalso not (foundinset s (freevarlist t))
					then [[(s,T)]] else nil end |

	unify n t (FreeVar s) = 
			let val T = changelevel n 0 t in
				if declarecheck true 0 T 
				andalso not (foundinset s (freevarlist t))
					then
					[[(s,T)]] else nil end |

	unify n (Infix(FreeVar s,ResOp"@",BoundVar p))

		(Infix(x,ResOp"@",BoundVar m))  = 

		let val X = changelevel n 0 x in
		if m = p 
		andalso declarecheck true 0 X 
		andalso not (foundinset s (freevarlist x))
		then
		if X = FreeVar s then [nil] else
		[[(s,X)]] else  

		let val T = changelevel (n-1) 0 
		(Function (Infix(x,ResOp"@",BoundVar m))) in

		if p=n andalso declarecheck true 0 T

		(* andalso isstratified 0  T *)

		then [[(s,T)]] 

		else nil end
		end |

	unify n (Infix(x,ResOp"@",BoundVar m))
 
		(Infix(FreeVar s,ResOp"@",BoundVar p))

		  = 

		let val X = changelevel n 0 x in
		if m = p 
		andalso declarecheck true 0 X 
		andalso not (foundinset s (freevarlist x))
		then
		[[(s,X)]] else  

		let val T = changelevel (n-1) 0 
		(Function (Infix(x,ResOp"@",BoundVar m))) in

		if p=n andalso declarecheck true 0 T

		(* andalso isstratified 0  T *)

		then [[(s,T)]] 

		else nil end
		end |

	unify n t (Infix(FreeVar s,ResOp"@",BoundVar m)) =

		let val T = changelevel (n-1) 0 (Function t) in

		if m=n andalso declarecheck true 0 T

		andalso not (foundinset s (freevarlist t))

		(* andalso isstratified 0  T *)

		then [[(s,T)]] 

		else nil end |

	unify n (Infix(FreeVar s,ResOp"@",BoundVar m)) t =

		let val T = changelevel (n-1) 0 (Function t) in

		if m=n andalso declarecheck true 0 T

		andalso not (foundinset s (freevarlist t))

		(* andalso isstratified 0  T *)

		then [[(s,T)]] 

		else nil end |

	unify n (BoundVar s) (BoundVar t) = if s=t then
		[nil] else nil |

	unify n (Function s) (Function t) = 
		unify (n+1) s t |

	unify n (Infix(x,VarOp s,y)) (Infix(z,i,w)) =

		if istypedoperator s andalso (((not(istypedoperator 
		(opdisplay i))) orelse 
		((lefttype (opdisplay i),righttype (opdisplay i)) <>
		(lefttype s,righttype s))))  
		orelse foundinset s (freevarlist (Infix(z,i,w)))
		then nil

		(* a phony term is used here to represent a
		matched operator *)

		else (mergeunifs n (mergeunifs n 
		(if s = opdisplay i then [nil] else 
			[[(s,Constant (opdisplay i))]])
		x z) y w) |

	unify n (Infix(z,i,w)) (Infix(x,VarOp s,y))  =

		if istypedoperator s andalso (((not(istypedoperator 
		(opdisplay i))) orelse 
		((lefttype (opdisplay i),righttype (opdisplay i)) <>
		(lefttype s,righttype s))))  
		orelse foundinset s (freevarlist (Infix(z,i,w)))
		then nil

		(* a phony term is used here to represent a
		matched operator *)

		else (mergeunifs n 
		(mergeunifs n [[(s,Constant (opdisplay i))]]
		x z) y w) |

	unify n (Infix(Numeral a,ResOp s,Numeral b)) 
				(Infix(x,ResOp t,y)) =

		if arithop s then nil
		else if s = t andalso x = Numeral a andalso y = Numeral b
			then [nil]
			else nil |

	unify n (Infix(x,ResOp s,y)) (Infix(z,ResOp t,w)) =

		if ruleinfix s orelse s <> t
		then nil
		else
		(mergeunifs n (unify n x z) y w) |

	unify n (Infix(x,i,y)) (Infix(z,j,w)) = 

		if i <> j then nil

		else (mergeunifs n (unify n x z) y w) |

	unify n (CaseExp(Infix(Constant "true",ResOp"=",t),u,v))
		w =nil |

	unify n (CaseExp(u,v,w)) (CaseExp(a,b,c)) =

		if u = Constant "true" orelse u = Constant "false" then nil
		else (mergeunifs n 
		(mergeunifs n (unify n u a) v b) w c) |

	unify n t u = nil

and mergeunifs n M t u = if M = nil then nil else

	let val M2 = map (fn (s,t) => (s,changelevel 0 n t)) (hd M) in

	mergematches M
	(unify n (subs n 0 M2 t) (subs n 0 M2 u)) end;


(* END development of unification *)

(* machinery for labelling all variables in a term with a counter,
used by the use function below *)

val COUNTER = ref 0;

fun initializecounter () = COUNTER:=0;

fun bumpcounter () = COUNTER := (!COUNTER)+1;

fun labelvars (FreeVar s) = FreeVar (s^"_"^(makestring(!COUNTER)))|

	labelvars (Function s) = Function(labelvars s) |

	labelvars (Infix(x,i,y)) = Infix(labelvars x,i,labelvars y) |

	labelvars (CaseExp(x,y,z)) = 
		CaseExp(labelvars x,labelvars y,labelvars z) |
	labelvars t = t;

(* precursor function for UNEVAL *)

(* it will output a list of arguments to which the argument (Function u)
is to be applied to obtain the term t *)

(* we want to attempt a sequence of substitutions *)

fun modellist 0 = nil |

modellist n = (modellist (n-1))@[n];

fun evals level t [u] = eval level t u |

evals level t (m::n) = evals level (eval level t m) n; 

fun evalsterm t [u] = Infix(t,ResOp"@!",u) |

evalsterm t (m::n) = evalsterm (Infix(t,ResOp"@!",m)) n;

fun unevals n level (Function u) (Function v) t =

let val U = changelevel (level+1) level (replace (level+1) 0
(BoundVar(level+1)) (FreeVar(makestring n)) v)  in

let val M = match level level U t in

if M = nil then unevals (n+1) level (Function u) U t

else let val L = map (fn m =>safefind (FreeVar "?x") (makestring m)
(hd(match level level U t))) (modellist n) in

if evals level (Function u) L = t then L else nil

end

end

end |

unevals n level u v t = nil;

fun strongevals level t [u] = strongeval level t u |

strongevals level t (m::n) = strongevals level (strongeval level t m) n; 

fun strongevalsterm t [u] = Infix(t,ResOp"@",u) |

strongevalsterm t (m::n) = strongevalsterm (Infix(t,ResOp"@",m)) n;

fun strongunevals n level (Function u) (Function v) t =

let val U = changelevel (level+1) level (replace (level+1) 0
(BoundVar(level+1)) (FreeVar(makestring n)) v)  in

let val M = match level level U t in

if M = nil then strongunevals (n+1) level (Function u) U t

else let val L = map (fn m =>safefind (FreeVar "?x") (makestring m)
(hd(match level level U t))) (modellist n) in

if strongevals level (Function u) L = t then L else nil

end

end

end |

strongunevals n level u v t = nil;


(* machinery for making "new" variables introduced by a theorem
depend on local bound variables *)

(* it is very conservative (more so than the old implementation)
but still not safe; this may introduce stratification errors in which
case use of a reverse tactic with parameters through which new
values can be supplied is indicated *)

(* what we need to know to make this work better is the relative
type of the subterm relative to the smallest bracket term containing it *)

fun varstofuns L n (FreeVar s) = if foundinset s L andalso n>0

		then Infix(FreeVar s, ResOp"@",BoundVar n)
		else (FreeVar s) |

	varstofuns L  n (Function s) = Function(varstofuns L n s) |

	varstofuns L  n (Infix(x,i,y)) = Infix(varstofuns L n x,i,
		varstofuns L n y) |

	varstofuns L n  (CaseExp(x,y,z)) = 
		CaseExp(varstofuns L n x,varstofuns L n y,varstofuns L n z) |
	varstofuns L n t = t;

(* fixvars s t fixes variables in t so that new variables introduced
by the theorem s=t are made dependent on local bound variables
if this is easily verified to be possible *)

fun fixvars n fo s t = let val A = strat2 0 t in  if A = nil then t 

	else varstofuns (separate (fn x=>find x (hd A) = [0]) 
	(setminus (setminus (freevarlist t) (freevarlist s))
	(freevarlist fo))) n t
	end;

(* apply a presumed equational theorem s = t to the term u *)
(* the labelvars operation with a new counter is applied to
both sides of the equational theorem *)

(* some new variables introduced by theorems will be introduced
so as to depend on the highest index locally free bound variable;
this only happens under restrictions which ensure stratification locally
but may still cause stratification problems globally *)

(* USE also posts dependency changes *)

(* an auxiliary function for dependency posting *)

fun StrongDeps s = let val S = find s (!THEOREMS) in 
	if S = nil then Deps ("}"^s) else PreDeps (hd S) end;


fun USE level hlevel fo s t fo2 u = (bumpcounter();

(let val FO = (changehlevel 0 hlevel (changelevel 0 level (labelvars fo))) 

in

let val M0 = match level level FO fo2 in 

if M0 = nil then u else

let val S = (subs level hlevel (hd M0) 
	(changehlevel 0 hlevel (changelevel 0 level (labelvars s))))

and T = (subs level hlevel (hd M0) 
	(changehlevel 0 hlevel (changelevel 0 level (labelvars t))))

in

let val M = mergematches (match level level fo2 fo2)(match level level S u) in

if M = nil then u

else ((NEWDEPS:=union(StrongDeps(eithervarhead fo))(!NEWDEPS));

	subs level hlevel (hd M) (fixvars level fo2 S T))

end end end end));


val OLDENV = ref (!ENV);

(* USER COMMANDS (2) *)

fun applyenv s = if isatheorem ("}"^(eitherhead (parse s)))

	then (OLDENV:=(!ENV); exec(USE (level(!ENV)) (hlevel(!ENV)) 
	(Formatof ("}"^(eitherhead (parse s))))
	(Leftside ("}"^(eitherhead (parse s))))
	(Rightside ("}"^(eitherhead (parse s)))) (parse s));
	(* if (Isstratified(Infix(leftside(!ENV),ResOp"=",rightside(!ENV)))) 
		then *)
		(postdeps();look()) (*
	else (dropdeps(); errormessage "Introduces stratification error";
		ENV:=(!OLDENV);look())*)) handle BadSub =>
	(errormessage "Command aborted due to predicate abuse")

	else errormessage ("No environment "^s^" found to apply");

fun applyconvenv s = if isatheorem ("}"^(eitherhead (parse s)))

	then (exec(USE (level(!ENV)) (hlevel(!ENV)) 
	(Formatof ("}"^(eitherhead (parse s))))
	(Rightside ("}"^(eitherhead (parse s))))
	(Leftside ("}"^(eitherhead (parse s)))) (parse s));
	(* if (Isstratified(Infix(leftside(!ENV),ResOp"=",rightside(!ENV)))) 
		then *)
		(postdeps();look())
	(* else (dropdeps(); errormessage "Introduces stratification error";
		ENV:=(!OLDENV);look())*))handle BadSub =>
	(errormessage "Command aborted due to predicate abuse")

	else errormessage ("No environment "^s^" found to apply");

(* USER COMMAND *)

(* the global assignment command -- this uses a match to make substitutions
on both the left and right side of the equation under construction *)

fun assign S T = 

let val s = parse S and t = parse T in

if declarecheck false 0 s andalso declarecheck false 0 t (* andalso
Isstratified s andalso Isstratified t *)

then let val M = (* cmatch old *) match 0 0 s t in

		if M = nil
		then errormessage ("No match in assignment of "
		^(baredisplay t)^" to "^(baredisplay s))

		else if declarecheck false 0 (subs 0 0 (hd M)
		(Infix(leftside(!ENV),ResOp"=",rightside(!ENV))))

		then (envmod(changerightside2 (subs 0 0 (hd M)));
			envmod(changeleftside2 (subs 0 0 (hd M))); look())

		else errormessage "Introduces predicate error"  end
		handle BadSub =>
		(errormessage "Command aborted due to predicate abuse") 

else errormessage 
("Declaration or stratification errors found in assignment of "^(baredisplay t)^" to "^(baredisplay s))

end;

(* USER COMMANDS (3) *)

fun unification t =

	let val T = parse t in

	if declarecheck false (level(!ENV)) T (* andalso 
	Isstratified T *) andalso rulefree T

	then (getcurrent(); 
	let val M = unify (level(!ENV)) T (!CURRENTTERM) in
	if M = nil 
	then errormessage ("No match in unification of "
	^(baredisplay T)^" with "^(baredisplay (!CURRENTTERM)))

		else (OLDENV:= (!ENV);
		envmod(changerightside2 (subs 0 0 (hd M)));
		envmod(changeleftside2 (subs 0 0 (hd M))); 
		if declarecheck true 0 (leftside(!ENV))
		andalso declarecheck true 0 (rightside (!ENV))
		(* andalso Isstratified (leftside(!ENV))
		andalso Isstratified (rightside(!ENV)) *)

		then look()

		else (errormessage ("Unification of "
	^(baredisplay T)^" with "^(baredisplay (!CURRENTTERM))^
	" produces declaration or stratification errors");
	ENV:=(!OLDENV); look())) end )

	else errormessage 
("Level, declaration, stratification or embedded theorem error in unification with "
	^t) end;

val u = unification;

fun ul thm = (bumpcounter();
	unification (baredisplay (labelvars (Leftside thm))));

fun ur thm = (bumpcounter();
	unification (baredisplay (labelvars (Rightside thm))));

(* USER COMMAND *)

(* assignit sets the second parameter of assign to the current subterm *)

fun assignit s = (getcurrent(); if rulefree (!CURRENTTERM) andalso
changelevel (level(!ENV)) 0 (!CURRENTTERM) <> Constant "" then 
assign s (baredisplay(!CURRENTTERM)) else
errormessage "Cannot assign the current subterm";look());

(* assigninto "does the same things to both sides of the current equation";
it substitutes both sides of the equation for a given variable in a given
term, and uses the results as the new equation.  It destroys position
information *)

fun subinto s t u  = subs 0 0 [(s,u)] t;

(* USER COMMAND *)

fun assigninto s t = if stringtocon s = FreeVar s 

		then 
		if declarecheck false 0 (parse t) (* andalso 
			Isstratified (parse t) *)

		then if declarecheck false 0 (subinto s (parse t) 
		(Infix(leftside(!ENV),ResOp"=",rightside(!ENV))))

		then (top();envmod(changerightside2 (subinto s (parse t)));
			envmod(changeleftside2 (subinto s (parse t))); 
			look()) handle BadSub =>
		(errormessage "Command aborted due to predicate abuse")

		else errormessage "Introduces predicate error"

		else errormessage ("Declaration or stratification error in "^t)

		else errormessage (s^" is not a free variable");

(* machinery for finding theorems which match given equations in
the theorem list; also see targetruleintro below *)

(* the underlying function for finding matching theorems *)

fun prematchtheorem level s t nil = Constant "" |

	prematchtheorem level s t ((NA,x)::L) =

	let val (fo,lt,rt,dps) = (Thm NA) in

	let val FO = changelevel 0 level fo 
	and LT = changelevel 0 level lt
	and RT = changelevel 0 level rt in

	let val M =
	(* cmatch old *) match level level 
		((Infix(LT,ResOp"=",RT))) ((Infix(s,ResOp"=",t))) in

	if M = nil orelse NA = "" orelse hd (explode NA) = "}"

	then prematchtheorem level s t L

	else subs level 0 (hd M) FO

	end
	end
	end;

(* a variant *)

val RESTOFLIST = ref (!THEOREMS);

val RESTOFLIST2 = ref (!THEOREMS);

fun prematchtheorem2 b level s t nil = (if b then RESTOFLIST := nil
		else RESTOFLIST2:=nil;Constant "") |

	prematchtheorem2 b level s t ((NA,x)::L) =

	let val (fo,lt,rt,dps) = (Thm NA) in

	let val FO = changelevel 0 level fo
	and LT = if b then changelevel 0 level lt else changelevel 0 level rt
	and RT = if b then changelevel 0 level rt 
		else changelevel 0 level lt in

	let val M =
	(match level level LT s)
	and N = (match level level t RT) in
	let val P = mergematches M N 
		in

	if M = nil orelse N = nil orelse NA = "" orelse hd (explode NA) = "}"

	then prematchtheorem2 b level s t L

	else (if b then RESTOFLIST:=L else RESTOFLIST2:=L;
	(if P = nil then FO else subs level 0 (hd P) FO))

	end end
	end
	end;


(* USER COMMAND *)

(* showmatchtheorem takes the two sides of an equation as separate arguments,
unlike the analogous function in Mark2 *)

fun showmatchtheorem s t = let val T =
(* cmatch weak *) prematchtheorem 0 (parse s) (parse t) (!THEOREMS) in

if T = Constant ""
then errormessage "Theorem not found"

else (errormessage(display (T)); thmdisplay (eitherhead T)) end;

(* utility for showrelevantthms *)
(* prevents completely generic theorems from matching *)

fun isgeneric (FreeVar t) = true |

	isgeneric (Infix(FreeVar s,VarOp t,FreeVar u)) = true |

	isgeneric (Infix(Constant "",VarOp s,FreeVar t)) = true |

	isgeneric (CaseExp(FreeVar s,FreeVar t,FreeVar u)) = true |

	isgeneric t = false;

(* USER COMMAND *)

(* shows all theorems which nontrivially match
the current subterm *)

fun showrelevantthms() = (showsometheorems (fn na =>
		(getcurrent(); ((match (level(!ENV)) (level(!ENV))
		(Leftside na) (!CURRENTTERM) <> nil) andalso
		(not(isgeneric (Leftside na))))
		orelse (match (level(!ENV)) (level(!ENV))
		(Rightside na)(!CURRENTTERM) <> nil) andalso
		not(isgeneric (Rightside na)))) (sortfun(!THEOREMS)));

(* functions for automatic formatting to assist the automatic
parameterization tactics !@ and !$ *)

(* the list of free variables found in s and not in t *)

fun autoformatlist s t = sortset(setminus (freevarlist2 s) (freevarlist2 t));

fun freevarlisttoterm nil = Constant "" |

	freevarlisttoterm [s] = FreeVar s |

	freevarlisttoterm (s::L) = 
		Infix(FreeVar s,ResOp",",freevarlisttoterm L);

fun autoformat na s t = let val L = freevarlisttoterm (
	(autoformatlist s t)) in

	if L = Constant ""

	then Constant na

	else Infix(Constant na,ResOp"@",L) end;

fun comesbefore x y = (baredisplay x) < (baredisplay y);


(* installation of user commands *)

fun addtomenu s x = MAINMENU:=listaddto s x (!MAINMENU);

fun addtomenusecure s x = (MAINMENU:=listaddto s x
(!MAINMENU);SECUREMENU:=listaddto s x (!SECUREMENU));

fun addtocurrentmenu s x = (MENUNAME:="script";MENU := listaddto s x (!MENU));

(* installation of commands for loading save files *)

fun addtoothermenu s x = LOADMENU := listaddto s x (!LOADMENU);

(* USER COMMAND *)

(* something to run after breaking out of a script with Control-C *)

fun reset() = (setnopause(); speakup(); NORULES:=false;
DEMO:=false;DIAGNOSTIC:=false; 
TESTTH := [std_in];TURNOFFPROMPT:=false;
mainmenu());


(* USER COMMAND *)

(* an ML-free user interface of sorts *)

(* now fixed to avert breakout due to I/O errors *)

fun noml() = (output(std_out,"\nWatson>  ");flush_Out(std_out);
	DEMO:=false;DIAGNOSTIC:=false;TURNOFFPROMPT:=false;
	executelines "Watson>  " std_in) handle _ => (reset();
		errormessage ("Uncaught exception -- probably I/O");
	        mainmenu(); 
	noml());

(* utility for breaking out of suspended processes *)

fun exit() = raise Breakout;

(* tactic engine(s) *)

(* implemented the alternative rule infixes quite differently:
what was ?x =>> ?y => ?t is now (?y =>> ?x) => ?t *)

(* applybuiltinthm and thmresult handle all individual theorem
applications.  all axiomatic dependencies will be posted by thmresult
(or deduced from scin/scout data) *)

val STOPINPUT = ref false;  (* toggle for stopping INPUT tactic *)

(* val SHELLENVS = ref([!ENV]); (* used to check for illicit environment
				changes under SHELL *) *)

fun applybuiltin level hlevel hyps 
		(Infix(Constant "FLIP",ResOp"@",thm)) s
		(Infix(x,t,y)) =

	if comesbefore y x

	then thmresult level hlevel hyps thm s (Infix(x,t,y))

	else (Infix(x,t,y)) |

	(* crash out of an INPUT environment *)

	applybuiltin level hlevel hyps (Constant "STOPINPUT") s t =

		(STOPINPUT:=true;Constant "") |

	(* shell out of an INPUT environment; crashes if any changes made in
	environment during the shelled out period *)

	(* admits stacked SHELL environments formally, but don't do it!!! *)

(*	applybuiltin level hlevel hyps (Constant "SHELL") s t =

		((SHELLENVS:=(!ENV)::(!SHELLENVS));
		noml(); 
		if (!ENV) = hd (!SHELLENVS) then
		(SHELLENVS:=tl (!SHELLENVS);t)
		else
		(SHELLENVS:=tl (!SHELLENVS);
		errormessage "Environment changed in SHELL command";
		Constant "")) | *)

	applybuiltin level hlevel hyps (Constant "INPUT") s t

	= (if (!VERBOSITY)=2 then (output(std_out,(!Returns));
	output(std_out,guiprelookhyps 1 level hyps); 
	showterm "INPUT term display" t;
	output(std_out,(!Returns));
	if s = "=>" then output(std_out,"INPUT:  ")
                    else output(std_out,"INPUT (converse):  ");
	flush_Out(std_out)) else ();
	if (!STOPINPUT) then Constant "" else
	(thmresult level hlevel hyps
	(if length(!TESTTH)=1 then 
	(if (!GUIMODE) then (suspend(fn ()=>());
        parse (!SAVEINPUT)) else parse (stringinput std_in)) else
	(SAVEINPUT:=(stringinput(hd(!TESTTH)));
	if (!DIAGNOSTIC) andalso length(!TESTTH)>1
	then (output(std_out,(!SAVEINPUT)^(!Returns));
		flush_Out(std_out);
		if input(std_in,1) = "q" then raise Breakout else ();())
	else (); parse (!SAVEINPUT)))) s t) |

	applybuiltin level hlevel hyps (Infix(Constant "OUTPUT",ResOp"@",t))
		s x =

	(output(std_out, if (!PROMPT) then "" else (!Returns)^"OUTPUT:\n");
	showterm "OUTPUT term display" t;
	flush_Out(std_out);

	x) |


	applybuiltin level hlevel hyps 
		(Infix(Constant "BIND",ResOp"@",t)) "=>" y

	= let val A = bind level y t in
	if A = Constant "" then y
	else (Infix(A,ResOp"@",t)) end |

	applybuiltin level hlevel hyps 
		(Infix(Constant "BINDM",ResOp"@",t)) "=>" y

	= let val A = prebind level y t in
	if A = Constant "" then y
	else (Infix(A,ResOp"@!",t)) end |

	applybuiltin level hlevel hyps (Constant "EVAL") "=>" 
		(Infix(Function t,ResOp"@",u)) =

	strongeval level (Function t) u |
	applybuiltin level hlevel hyps (Constant "EVALM") "=>" 
		(Infix(Function t,ResOp"@!",u)) =

	eval level (Function t) u |

	applybuiltin level hlevel hyps 
		(Infix(Constant "UNEVAL",ResOp"@",Function t)) "=>" y =

	let val A = strongunevals 1 level (Function t) (Function t) y in

		if A = nil then y

		else strongevalsterm (Function t) A  end |

	applybuiltin level hlevel hyps 
		(Infix(Constant "UNEVALM",ResOp"@",Function t)) "=>" y =

	let val A = unevals 1 level (Function t) (Function t) y in

		if A = nil then y

		else evalsterm (Function t) A  end |

	applybuiltin level hlevel hyps 
		(Infix(Numeral [0],ResOp"|-|",Numeral n)) s y =

	let val N = listtoint n in

	if listindex N hyps = nil then y

	else let val (lt,rt,po,se,lv) = hd(listindex N hyps) in

	if se <> 1 orelse not(rulefree lt) orelse not(rulefree rt) then y

	else if s = "=>" andalso y = (changelevel lv level lt) then 
		(changelevel lv level rt)
	else if s = "<=" andalso y = (changelevel lv level rt) then 
		(changelevel lv level lt)
	else y

	end
	end |
	applybuiltin level hlevel hyps 
		(Infix(Numeral [1],ResOp"|-|",Numeral n)) "=>"
		 (CaseExp(x,y,z)) =

	let val N = listtoint n in

	if listindex N hyps = nil then (CaseExp(x,y,z))

	else let val (lt,rt,po,se,lv) = hd(listindex N hyps) in

	if x = Infix(changelevel lv level lt,ResOp"=",
		changelevel lv level rt) orelse lt = Constant "true"
		andalso changelevel lv level rt = x

	then if se = 1 then y else z

	else (CaseExp(x,y,z))
	
	end
	end |
	applybuiltin level hlevel hyps 
		(Infix(Numeral [1],ResOp"|-|",Numeral n)) "<="
		 y =

	let val N = listtoint n in

	if listindex N hyps = nil then y

	else let val (lt,rt,po,se,lv) = hd(listindex N hyps) in

	let val Var = if level = 0 then 
		(bumpcounter();FreeVar ("?x_"^(makestring (!COUNTER))))

		else (bumpcounter();
		Infix(FreeVar (("?x_"^(makestring (!COUNTER)))),ResOp"@",
			BoundVar level))

	and Hyp = Infix(changelevel lv level lt,ResOp"=",
		changelevel lv level rt)

	in  if not (rulefree Hyp) then y


	else if se = 1 then CaseExp(Hyp,y,Var) else CaseExp(Hyp,Var,y)

	end
	
	end
	end |
	applybuiltin level hlevel hyps 
		(Infix((Infix(Numeral [2],ResOp"|-|",Numeral n)),ResOp"@",x))
		"<=" y =

	let val N = listtoint n in

	if listindex N hyps = nil then y

	else let val (lt,rt,po,se,lv) = hd(listindex N hyps) in

	let val Hyp = Infix(changelevel lv level lt,ResOp"=",
		changelevel lv level rt)

	in if not (rulefree Hyp) then y 

	else if se = 1 then CaseExp(Hyp,y,x) else CaseExp(Hyp,x,y)

	end
	
	end
	end |

	applybuiltin level hlevel hyps 
		(Infix(x,ResOp"=>>",y)) s z =

	let val NA = eithervarhead x in

	if Isatheorem NA

	then let val (FO,LT,RT,DPS) = Thm NA in
	if s = "=>"

	then 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel LT)) z) = nil

	then thmresult level hlevel hyps y "=>" z

	else thmresult level hlevel hyps x "=>" z

	else 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel RT)) z) = nil

	then thmresult level hlevel hyps y "=>" z

	else thmresult level hlevel hyps x "<=" z
	

	end 

	else if isbuiltinthm NA

	(* not very subtle -- it just checks to see if any change in 
	the term happens; it will for example regard a trivial hyp
	x = x as failing even if it applies *)

	then let val step1 = applybuiltin level hlevel hyps x s z in

		if step1 = z then thmresult level hlevel hyps y "=>" z

		else step1 end

	else z

	end |

	applybuiltin level hlevel hyps 
		(Infix(x,ResOp"<<=",y)) s z =

	let val NA = eithervarhead x in

	if Isatheorem NA

	then let val (FO,LT,RT,DPS) = Thm NA in
	if s = "=>"

	then 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel LT)) z) = nil

	then thmresult level hlevel hyps y "<=" z

	else thmresult level hlevel hyps x "=>" z

	else 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel RT)) z) = nil

	then thmresult level hlevel hyps y "<=" z

	else thmresult level hlevel hyps x "<=" z

	end 

	else if isbuiltinthm NA

	(* not very subtle -- it just checks to see if any change in 
	the term happens; it will for example regard a trivial hyp
	x = x as failing even if it applies *)

	then let val step1 = applybuiltin level hlevel hyps x s z in

		if step1 = z then thmresult level hlevel hyps y "<=" z

		else step1 end

	else z

	end |
	applybuiltin level hlevel hyps 
		(Infix(x,ResOp"*>",y)) s z =

	let val NA = eithervarhead x in

	if Isatheorem NA

	then let val (FO,LT,RT,DPS) = Thm NA in
	if s = "=>"

	then 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel LT)) z) = nil

	then z

	else thmresult level hlevel hyps y "=>" 
		(thmresult level hlevel hyps x "=>" z)

	else 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel RT)) z) = nil

	then  z

	else thmresult level hlevel hyps y "=>"
		(thmresult level hlevel hyps x "<=" z)
	

	end 

	else if isbuiltinthm NA

	(* not very subtle -- it just checks to see if any change in 
	the term happens; it will for example regard a trivial hyp
	x = x as failing even if it applies *)

	then let val step1 = applybuiltin level hlevel hyps x s z in

		if step1 = z then  z

		else thmresult level hlevel hyps y "=>" step1 end

	else z

	end |

	applybuiltin level hlevel hyps 
		(Infix(x,ResOp"<*",y)) s z =

	let val NA = eithervarhead x in

	if Isatheorem NA

	then let val (FO,LT,RT,DPS) = Thm NA in
	if s = "=>"

	then 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel LT)) z) = nil

	then  z

	else thmresult level hlevel hyps y "<=" 
		(thmresult level hlevel hyps x "=>" z)

	else 
	if mergematches
(match level level (changelevel 0 level(changehlevel 0 hlevel FO))
	x) 
(match level level (changelevel 0 level(changehlevel 0 hlevel RT)) z) = nil

	then  z

	else thmresult level hlevel hyps y "<=" 
		(thmresult level hlevel hyps x "<=" z)

	end 

	else if isbuiltinthm NA

	(* not very subtle -- it just checks to see if any change in 
	the term happens; it will for example regard a trivial hyp
	x = x as failing even if it applies *)

	then let val step1 =  applybuiltin level hlevel hyps x s z in

		if step1 = z then z

		else thmresult level hlevel hyps y "<=" step1 end

	else z

	end |
	(* modified to allow application of converse theorems *)
	applybuiltin level hlevel hyps (Infix(x,ResOp"=",y)) s z =
		if s = "=>" then let val T = 
		prematchtheorem level x y (!THEOREMS) in
		if T = Constant "" then
		thmresult level hlevel hyps 
		(prematchtheorem level y x (!THEOREMS)) "<=" z
		else thmresult level hlevel hyps
		(prematchtheorem level x y (!THEOREMS)) s z end
		else let val T = 
		prematchtheorem level x y (!THEOREMS) in
		if T = Constant "" then
		thmresult level hlevel hyps 
		(prematchtheorem level y x (!THEOREMS)) "=>" z
		else thmresult level hlevel hyps
		(prematchtheorem level x y (!THEOREMS)) s z end
		|

	applybuiltin level hlevel hyps 
	(Infix(Infix(x,ResOp"!@",Constant Na),ResOp"@",y)) s z =
	
	let val leftfun  = (if s = "=>" then Leftside else Rightside)

	and rightfun = (if s = "=>" then Rightside else Leftside) in

		if  Isatheorem Na 
		then USE level hlevel 
		(autoformat Na (Rightside Na) (Leftside Na)) (leftfun Na)
			(rightfun Na) (Infix(Constant Na,ResOp"@",y)) z

		else z

		end

		|

	applybuiltin level hlevel hyps 
	(Infix(Infix(x,ResOp"!$",Constant Na),ResOp"@",y)) s z =
	
	let val leftfun  = (if s = "=>" then Leftside else Rightside)

	and rightfun = (if s = "=>" then Rightside else Leftside) in

		if  Isatheorem Na 
		then USE level hlevel 
		(autoformat Na (Leftside Na) (Rightside Na)) (rightfun Na)
			(leftfun Na) (Infix(Constant Na,ResOp"@",y)) z

		else z

		end

		|

	applybuiltin level hlevel hyps x s y = y


and thmresult level hlevel hyps x s y =

	let val leftfun  = (if s = "=>" then Leftside else Rightside)

	and rightfun = (if s = "=>" then Rightside else Leftside) in

	let val NA = eithervarhead x in

	if  Isatheorem NA 
		then USE level hlevel 
		(Formatof NA) (leftfun NA) (rightfun NA) x y 

	else if isbuiltinthm NA then 

	applybuiltin level hlevel hyps x s y

	else (* not a valid theorem at all! *) y

	end end;

(* built in arithmetic operations *)

fun lastdigit n = n mod 10;

fun restofdigits n = inttolist(n div 10)

and inttolist 0 = nil |

	inttolist n = (lastdigit n)::(restofdigits n);

fun addlistints nil L = L |

	addlistints L nil = L |

	addlistints (head1::L) (head2::M) =

		(lastdigit(head1 + head2))::
		(addlistints (restofdigits (head1+head2))
		(addlistints L M));

fun multiplyints nil L = nil |

	multiplyints L nil = nil |

	multiplyints (head1::tail1) (head2::tail2) =

		rev(stripzeroes(rev(addlistints (inttolist (head1*head2))

		(addlistints (0::((multiplyints [head1] tail2)))

		(addlistints (0::((multiplyints [head2] tail1)))

		(0::(0::(multiplyints tail1 tail2))))))));

fun 

	lessints L nil = false |

	lessints nil L = true |

	lessints (head1::tail1) (head2::tail2) =

		(lessints tail1 tail2) orelse ((tail1 = tail2) 
			andalso ((head1:int) < head2));

(* This is subtraction of unsigned integers; it returns zero *)
(* when a negative answer would normally be expected *)

fun subtractints L M = if lessints L M orelse L=M then nil 
	else if M = nil then L
	else if hd L >= hd M then ((hd L - hd M)::
		(subtractints (tl L) (tl M)))

	else ((10 + hd L - hd M)::(subtractints (tl L) 
		(addlistints [1] (tl M))));

fun divideints L M = if lessints M [1] 
		then (nil) 

	else if lessints L M then nil

	else if lessints (tl L) M then addlistints [1] 
		(divideints (subtractints L M) M)

	else addlistints (0::divideints (tl L) M)

		(divideints (addlistints (0::
			(remainder (tl L) M)) [hd L]) M)

and remainder L M = if lessints M [1] 
		then (L) 

	else if lessints L M then L

	else if lessints (tl L) M then remainder (subtractints L M) M

	else remainder (addlistints (0::(remainder (tl L) M)) [hd L]) M;

(* evaluates a single arithmetic expression *)

fun aritheval (Infix(Numeral m,ResOp"+!",Numeral n)) =

Numeral (stripzeroes2(addlistints m n)) |
aritheval (Infix(Numeral m,ResOp"-!",Numeral n)) =

Numeral (stripzeroes2(subtractints m n)) |
aritheval (Infix(Numeral m,ResOp"*!",Numeral n)) =

Numeral (stripzeroes2(multiplyints m n)) |
aritheval (Infix(Numeral m,ResOp"/!",Numeral n)) =

Numeral (stripzeroes2(divideints m n)) |
aritheval (Infix(Numeral m,ResOp"%!",Numeral n)) =

Numeral (stripzeroes2(remainder m n)) |
aritheval (Infix(Numeral m,ResOp"=!",Numeral n)) =

if m = n then Constant "true" else Constant "false" |
aritheval (Infix(Numeral m,ResOp"<!",Numeral n)) =

if lessints m n then Constant "true" else Constant "false" |
aritheval (Infix(Numeral m,ResOp">!",Numeral n)) =

if lessints n m then Constant "true" else Constant "false" |

aritheval t = t;

(* function for automatic reduction of hypotheses true=?p to ?p *)

fun oddchoice (Infix(Constant"true",ResOp"=",x)) = oddchoice x |

	oddchoice t = t;

(* the tactic engine itself.  It follows a depth-first strategy,
applying innermost embedded theorems, including those introduced
in the course of execution *)

fun isupterm (Infix(Infix(Constant"UP",ResOp"@",th),ResOp"=>",
            rest)) = true |

    isupterm t = false;

fun upthm (Infix(Infix(Constant"UP",ResOp"@",th),ResOp"=>",
            rest))  = th |

    upthm t = t;

fun upterm (Infix(Infix(Constant"UP",ResOp"@",th),ResOp"=>",
            rest)) = rest |

    upterm t = t;

fun upterms t = if upterm t = t then t else upterms (upterm t);

fun preexecuteargs level hlevel hyps (Infix(x,ResOp "@",y)) =

	Infix(preexecuteargs level hlevel hyps x,ResOp "@",
		preexecute level hlevel hyps y) |

	preexecuteargs level hlevel hyps (Infix(x,ResOp "=>",y)) =

		preexecute level hlevel hyps (Infix(x,ResOp "=>",y))|

	preexecuteargs level hlevel hyps (Infix(x,ResOp "<=",y)) =

		preexecute level hlevel hyps (Infix(x,ResOp "<=",y))|

	preexecuteargs level hlevel hyps (Infix(x,i,y)) =

		Infix(preexecute level hlevel hyps x,i,
			preexecute level hlevel hyps y) |

	preexecuteargs level hlevel hyps t = t

and   preexecute level hlevel hyps (Infix(x,ResOp"@",y)) =

	let val X = preexecute level hlevel hyps x
	and Y = preexecute level hlevel hyps y in

      if isupterm X then preexecute level hlevel hyps
      (Infix(upthm X,ResOp"=>",Infix(upterm X,ResOp"@",Y)))

      else if isupterm Y then preexecute level hlevel hyps
      (Infix(upthm Y,ResOp"=>",Infix(X,ResOp"@",upterm Y)))

	else if hasprogram (eitherhead X)
	andalso match level level (Leftside (programof (eitherhead X)))
		(Infix(X,ResOp"@",Y)) <> nil

	then preexecute level hlevel hyps
	(thmresult level hlevel hyps 
	(Constant (programof(eitherhead X))) "=>" (Infix(X,ResOp"@",Y)))

	else (Infix(X,ResOp"@",Y))  end |

	preexecute level hlevel hyps (Infix(x,ResOp s,y)) =

      if isupterm (Infix(x,ResOp s,y))

      then (Infix(x,ResOp s,preexecute level hlevel hyps y))

	else if ruleinfix s

		then 
		preexecute level hlevel hyps 
		(thmresult level hlevel hyps 
			(preexecuteargs level hlevel hyps x)
			s 
			(upterms(preexecute level hlevel hyps y)))

	else if arithop s andalso (not(isupterm x))
      andalso (not (isupterm y))

		then aritheval((Infix(preexecute level hlevel hyps x,ResOp s,

		preexecute level hlevel hyps y)))

	else let val X = preexecute level hlevel hyps x
		and Y = preexecute level hlevel hyps y in

            if isupterm X then preexecute level hlevel hyps
                   (Infix(upthm X,ResOp"=>",Infix(upterm X,ResOp s,Y)))

            else if isupterm Y then preexecute level hlevel hyps
                   (Infix(upthm Y,ResOp"=>",Infix(X,ResOp s,upterm Y)))

		else if hasprogram (s)
		andalso match level level (Leftside (programof (s)))
			(Infix(X,ResOp s,Y)) <> nil

		then preexecute level hlevel hyps
		(thmresult level hlevel hyps 
		(Constant(programof(s))) "=>"
		(Infix(X,ResOp s,Y)))

		else (Infix(X,ResOp s,Y)) end |

	preexecute level hlevel hyps (Infix(x,i,y)) =

		let val X = preexecute level hlevel hyps x
		and Y = preexecute level hlevel hyps y in

            if isupterm X then preexecute level hlevel hyps
                   (Infix(upthm X,ResOp"=>",Infix(upterm X,i,Y)))

            else if isupterm Y then preexecute level hlevel hyps
                   (Infix(upthm Y,ResOp"=>",Infix(X,i,upterm Y)))

		else 

		if hasprogram (opdisplay i)
		andalso match level level (Leftside (programof (opdisplay i)))
			(Infix(X,i,Y)) <> nil

		then preexecute level hlevel hyps
		(thmresult level hlevel hyps 
		(Constant(programof(opdisplay i))) "=>"
		(Infix(X,i,Y)))

		else (Infix(X,i,Y)) end |

	preexecute level hlevel hyps (Function t) =

            let val T = preexecute (level+1) hlevel hyps t in

            if isupterm T andalso 
            changelevel (level+1) level (upthm T) <> Constant ""

            then preexecute level hlevel hyps 
            (Infix(upthm T,ResOp"=>",Function(upterm T))) 

		else if (isupterm T) then preexecute level hlevel hyps
            (Function (upterm T))

            else Function T

            end |

	preexecute level hlevel hyps (CaseExp(u,v,w)) =

		let val U = oddchoice(preexecute level hlevel hyps u) in

		if U = Constant "true" then preexecute level hlevel hyps v

		else if U = Constant "false" then 
				preexecute level hlevel hyps w

            else let val V = preexecute level (hlevel+1)
 		(rev ((coercehypslistsense 1 level
		(equationfromterm U))::(rev hyps)))
		 v 

            and W = preexecute level (hlevel+1)  
		(rev ((coercehypslistsense 2 level
		(equationfromterm U))::(rev hyps)))
		 w in

            if isupterm U then

            preexecute level hlevel hyps
            (Infix(upthm U,ResOp"=>",CaseExp(upterm U,V,W)))

            else if isupterm V then
            preexecute level hlevel hyps
            (Infix(upthm V,ResOp"=>",CaseExp(U,upterm V,W)))

            else if isupterm W then
            preexecute level hlevel hyps
            (Infix(upthm W,ResOp"=>",CaseExp(U,V,upterm W)))

		else CaseExp(U,V,W) end end |

	preexecute level hlevel hyps t = t;

(* USER COMMAND *)

(* the tactic interpreter *)

fun execute() = (STOPINPUT:=false;
	OLDENV:=(!ENV);
	exec (preexecute 
	(level(!ENV)) (hlevel(!ENV)) (hypslist(!ENV)));
	if (* Isstratified (Infix(leftside(!ENV),ResOp"=",rightside(!ENV))) 
	andalso *) declarecheck true 0 (leftside(!ENV))
	andalso declarecheck true 0 (rightside(!ENV))

	then postdeps()
	else (dropdeps();
		errormessage "Introduces declaration or stratification error";
		ENV:=(!OLDENV));
	look()) handle BadSub =>
	(errormessage "Command aborted due to predicate abuse");

(* functions for fine trace control *)

val TRACE = ref 0;

val TRACELEVELS = ref ([("bogus",0)]);

fun tracelevel s = safefind 0 s (!TRACELEVELS);

(* USER COMMANDS (2) *)

(* user command to set trace level for a particular tactic *)

fun settracelevel s n = TRACELEVELS := addto s n (!TRACELEVELS);

(* user command to set the level at which the trace function steps()
starts executing tactics completely instead of stepping through them *)

fun settrace n = if n>0 then (TRACE:=n) else (TRACE:=0);

(* the trace facility; it carries out the same operations as thmresult,
one step at a time; all innermost embedded theorems (or other executable
terms) are handled at the same time *)

(* new version of rulefree needed for clean handling of functional
programming by the trace function *)

fun rulefree2 level (Infix(x,ResOp"@",y)) = rulefree2 level x 
	andalso rulefree2 level y andalso not(isupterm x)
      andalso not(isupterm y)
	andalso ((not (hasprogram (eitherhead x))) orelse
	(match level level (Leftside (programof (eitherhead x))) 
	(Infix(x,ResOp"@",y)) = nil)) |

	rulefree2 level (Infix(Numeral m,ResOp s,Numeral n)) = not(arithop s) |

	rulefree2 level (Infix(x,ResOp s, y)) = 

      (isupterm (Infix(x,ResOp s,y)) andalso rulefree2 level y)
      orelse ((not (ruleinfix s)) andalso rulefree2 level x
      andalso rulefree2 level y andalso (not(isupterm x))
      andalso (not(isupterm y))) |

	rulefree2 level 
		(CaseExp(Infix(Constant"true",ResOp"=",x),y,z)) = false |

	rulefree2 level (CaseExp (u,v,w)) = u <> Constant "true" andalso
	u <> Constant "false" andalso rulefree2 level u 
	andalso rulefree2 level v andalso rulefree2 level w 
      andalso (not(isupterm u)) andalso (not(isupterm v))
      andalso (not(isupterm w))|

	rulefree2 level (Function t) = rulefree2 (level+1) t 
      andalso (not (isupterm t))|

	rulefree2 level (Infix(x,i,y)) = rulefree2 level x 
			andalso rulefree2 level y 
            andalso (not (isupterm x)) andalso (not(isupterm y))

		andalso not (hasprogram (opdisplay i)) |

	rulefree2 level t = true;


fun preonestepargs level hlevel hyps (Infix(x,ResOp "@",y)) =

	Infix(preonestepargs level hlevel hyps x,ResOp "@",
		preonestep level hlevel hyps y) |

	preonestepargs level hlevel hyps (Infix(x,ResOp "=>",y)) =

		preonestep level hlevel hyps (Infix(x,ResOp "=>",y)) |

	preonestepargs level hlevel hyps (Infix(x,ResOp "<=",y)) =

		preonestep level hlevel hyps (Infix(x,ResOp "<=",y)) |

	preonestepargs level hlevel hyps (Infix(x,i,y)) =
		Infix(preonestep level hlevel hyps x,i,
			preonestep level hlevel hyps y) |

	preonestepargs level hlevel hyps t = t

and preonestep level hlevel hyps (Infix(x,ResOp"@",y)) =

      if isupterm x andalso rulefree2 level y andalso rulefree2 level x
      then preonestep level hlevel hyps
      (Infix(upthm x,ResOp"=>",Infix(upterm x,ResOp"@",y)))

      else if isupterm y andalso rulefree2 level x andalso rulefree2 level y
      then preonestep level hlevel hyps
      (Infix(upthm y,ResOp"=>",Infix(x,ResOp"@",upterm y)))

	else if rulefree2 level y andalso rulefree2 level x
	andalso hasprogram (eitherhead x)
	andalso match level level (Leftside (programof (eitherhead x)))
		(Infix(x,ResOp"@",y)) <> nil

	then thmresult level hlevel hyps 
	(Constant(programof(eitherhead x))) "=>"
	(Infix(x,ResOp"@",y))

	else (Infix(preonestep level hlevel hyps x,ResOp"@",
		preonestep level hlevel hyps y)) |

	preonestep level hlevel hyps (Infix(x,ResOp s,y)) =

      if rulefree2 level x andalso rulefree2 level y
      andalso isupterm (Infix(x,ResOp s,y))

      then Infix(x,ResOp s,y)

	else if ruleinfix s andalso rulefree2 level y andalso rulefree2 level x

		then 

		if (tracelevel (eitherhead x) > (!TRACE))

		then (preexecute level hlevel hyps (Infix(x,ResOp s,y)))

		else (thmresult level hlevel hyps x s (upterms y))

	else if ruleinfix s then

		Infix(preonestepargs level hlevel hyps x, ResOp s,
			preonestep level hlevel hyps y)

	else if arithop s 
      andalso rulefree2 level x andalso rulefree2 level y
      andalso (not(isupterm x)) andalso (not(isupterm y))

		then aritheval((Infix(preonestep level hlevel hyps x,ResOp s,

		preonestep level hlevel hyps y)))

	else 	if rulefree2 level x andalso rulefree2 level y
            andalso isupterm x then

            (Infix(upthm x,ResOp"=>",(Infix(upterm x,ResOp s,y))))

            else if rulefree2 level x andalso rulefree2 level y
            andalso isupterm y then

            (Infix(upthm y,ResOp"=>",(Infix(x,ResOp s,upterm y))))

            else if hasprogram (s) andalso rulefree2 level x
		andalso rulefree2 level y andalso match level level
		(Leftside(programof(s))) (Infix(x,ResOp s,y)) <> nil

		then thmresult level hlevel hyps 
		(Constant(programof(s))) "=>" (Infix(x,ResOp s,y))

		else

		(Infix(preonestep level hlevel hyps x,ResOp s,
		preonestep level hlevel hyps y)) |

	preonestep level hlevel hyps (Infix(x,i,y)) =

		if rulefree2 level x andalso rulefree2 level y
            andalso isupterm x then

            (Infix(upthm x,ResOp"=>",(Infix(upterm x,i,y))))

            else if rulefree2 level x andalso rulefree2 level y
            andalso isupterm y then

            (Infix(upthm y,ResOp"=>",(Infix(x,i,upterm y))))

            else if  

            hasprogram (opdisplay i) andalso rulefree2 level x
		andalso rulefree2 level y andalso match level level
		(Leftside(programof(opdisplay i))) (Infix(x,i,y)) <> nil

		then thmresult level hlevel hyps 
		(Constant(programof(opdisplay i))) "=>" (Infix(x,i,y))

		else

		(Infix(preonestep level hlevel hyps x,i,
		preonestep level hlevel hyps y)) |

	preonestep level hlevel hyps (Function t) =

            let val T = preonestep (level+1) hlevel hyps t in

            if isupterm T andalso changelevel (level+1) level T <> Constant ""
            then preonestep level hlevel hyps
            (Infix(upthm T,ResOp"=>",Function(upterm T)))
		else Function (upterm T) end |

	preonestep level hlevel hyps (CaseExp(u,v,w)) =

		if not(rulefree2 level u)

		then 
		CaseExp( preonestep level hlevel hyps u ,v,w) 

		else  

		if u = Constant "true" then v

		else if u = Constant "false" then w

		else if u<>oddchoice u then CaseExp(oddchoice u,v,w)

		else 

             if isupterm u andalso rulefree2 level v
             andalso rulefree2 level w

             then preonestep level hlevel hyps 
             (Infix(upthm u,ResOp"=>",
             CaseExp(upterm u,v,w)))

            else if isupterm v andalso rulefree2 level v
            andalso rulefree2 level w

             then preonestep level hlevel hyps
             (Infix(upthm v,ResOp"=>",CaseExp(u,upterm v,w)))

            else if isupterm w andalso rulefree2 level v
            andalso rulefree2 level w

            then preonestep level hlevel hyps
            (Infix(upthm w,ResOp"=>",CaseExp(u,v,upterm w)))

		else CaseExp(u,preonestep level (hlevel+1)
 		(rev ((coercehypslistsense 1 level
		(equationfromterm u))::(rev hyps)))
		 v,
			preonestep level (hlevel+1)  
		(rev ((coercehypslistsense 2 level
		(equationfromterm u))::(rev hyps)))
		 w) |

	preonestep level hlevel hyps t = t;


(* this command carries out one trace step *)

(* onestep has been removed as a user command; stratification checking
has been moved to presteps.  The idea is to preserve parallelism
with execute, which can pass through temporary failures of global
stratification *)

(* but this is no longer true with the introduction of @! *)

val CHECKDISPLAY = ref "";

val CHECKDISPLAY2 = ref "";

fun precheckdisplay t = (CHECKDISPLAY := display t;t);

fun checkdisplay() = exec precheckdisplay;

fun onestep() = (

	checkdisplay(); CHECKDISPLAY2:=(!CHECKDISPLAY);

	exec (preonestep (level(!ENV)) (hlevel(!ENV)) 
	(hypslist(!ENV)));

	(* if Isstratified (rightside(!ENV)) then postdeps()
	else (dropdeps();
	errormessage "Introduces stratification error";ENV:=(!OLDENV)); *)

	checkdisplay(); if 
	((not(!NORULES)) orelse (!CHECKDISPLAY)<>(!CHECKDISPLAY2))

	then lookhere() else ());

fun presteps() = (

	checkdisplay(); CHECKDISPLAY2:=(!CHECKDISPLAY);

	exec (preonestep (level(!ENV)) (hlevel(!ENV)) 
	(hypslist(!ENV)));

	checkdisplay(); if 
	((not(!NORULES)) orelse (!CHECKDISPLAY)<>(!CHECKDISPLAY2))

	then (lookhere();if rulefree2 0 (rightside(!ENV)) then (()) else 
        suspend(presteps))

  	else (if rulefree2 0 (rightside(!ENV)) 
             then (()) else presteps()) );


(* USER COMMAND *)

(* this is the user command for many trace steps *)

fun steps() = (STOPINPUT:=false;
	OLDENV := (!ENV); 
		look(); presteps();
		postdeps();look())
		handle BadSub =>
	(errormessage "Command aborted due to predicate abuse");

fun stepsnorules() = (NORULES:=true;steps();NORULES:=false);

fun predroprule (Infix(x,ResOp"=>",y)) = y |
	predroprule (Infix(x,ResOp"<=",y)) = y |
	predroprule t = (errormessage "No rule to drop!";t);

(* USER COMMAND *)

(* user command to eliminate an embedded theorem *)

fun droprule() = (exec(predroprule);look());

(* commands to introduce embedded theorems *)

fun preruleintro level tm s t = 

	let val NA = eithervarhead tm in

	if NA = "" 
	then 
	((errormessage ((baredisplay tm)^" cannot be an embedded theorem"));t)

	else if (stringtocon NA = FreeVar NA orelse stringtoop NA = VarOp NA
		orelse isatheorem NA
		orelse isapretheorem NA
		orelse isbuiltinthm NA) andalso declarecheck true level tm

	then Infix(tm,ResOp s,t)

	else (errormessage 
	("Declaration error in proposed embedded theorem "^(baredisplay tm));t)

	end;

(* USER COMMANDS (2) *)

(* introduce tm =>... *)

fun ruleintro tm = (exec(preruleintro (level(!ENV)) (parse tm) "=>");look());

(* introduce tm <=... *)

fun revruleintro tm = 
	(exec(preruleintro (level(!ENV)) (parse tm) "<=");look());

fun altruleinfix s = s = "=>>" orelse s = "<<=";

(* function to fix tortured syntax of lists of alternative rules
(change from leftward grouping to rightward grouping); alternative is
to introduce alternatives in reverse order! *)

fun rectifyalts (Infix(Infix(x,i,y),j,z)) =

	if altruleinfix (opdisplay i) andalso altruleinfix (opdisplay j)

	then Infix(x,i,rectifyalts(Infix(y,j,z)))

	else (Infix(Infix(x,i,y),j,z)) |

	rectifyalts t = t;

fun prealtruleintro level tm s (Infix(x,ResOp i,t)) = 

	if not(ruleinfix i) then 
	(errormessage "No rule to which to add an alternative";
		(Infix(x,ResOp i,t)))

	else let val NA = eithervarhead tm in

	if NA = "" 
	then 
	((errormessage ((baredisplay tm)^" cannot be an embedded theorem"));
		(Infix(x,ResOp i,t)))

	else if (stringtocon NA = FreeVar NA orelse stringtoop NA = VarOp NA
		orelse isatheorem NA
		orelse isapretheorem NA
		orelse isbuiltinthm NA) andalso declarecheck true level tm

	then Infix((rectifyalts(Infix(x,ResOp s,tm))),ResOp i,t)

	else (errormessage 
	("Declaration error in proposed embedded theorem "^(baredisplay tm));
		(Infix(x,ResOp i,t)))

	end |

	prealtruleintro level tm s t = 
	(errormessage "No rule to which to add an alternative";t);

(* USER COMMANDS (2) *)

(* introduce a direct alternative embedded theorem *)

fun altruleintro tm = (exec (prealtruleintro (level(!ENV)) (parse tm) "=>>");
			look());

(* introduce a converse alternative embedded theorem *)

fun altrevruleintro tm = (exec 
		(prealtruleintro (level(!ENV)) (parse tm) "<<=");look());

(* introduce a theorem which will get you to a target term *)

fun pretargetruleintro level t u = 
	let val T = (* cmatch weak *) prematchtheorem level u t (!THEOREMS)

	in 

	if T = Constant "" then let val T2 =

		(* cmatch weak *) prematchtheorem level t u (!THEOREMS) in

		if T2 = Constant "" then u

		else preruleintro level T2 "<=" u end

	else preruleintro level T "=>" u end;

(* USER COMMAND *)

(* introduce a theorem which will get you to a target term *)

fun targetruleintro t = (exec (pretargetruleintro (level(!ENV)) (parse t));
			look());

fun prematchtri level L1 L2 t u = 
	let val T = (* cmatch weak *) prematchtheorem2 false level u t L2

	in 

	if T = Constant "" then let val T2 =

		(* cmatch weak *) prematchtheorem2 true level u t L1 in

		if T2 = Constant "" then u

		else preruleintro level T2 "=>" u end

	else preruleintro level T "<=" u end;

(* USER COMMAND *)

(* introduce a theorem which will get you to something matching a target term*)

val ANOTHERMATCHTERM = ref (Constant "");

fun matchtri t = (RESTOFLIST:=(!THEOREMS);RESTOFLIST2:=(!THEOREMS);
		exec (prematchtri (level(!ENV)) (!THEOREMS)(!THEOREMS) 
			(parse t));
			ANOTHERMATCHTERM:=parse t;
			look());

(* USER COMMAND *)

(* tries matchtri again on the tail of the list *)

fun anothermatchtri() = (droprule();
			exec (prematchtri (level(!ENV)) (!RESTOFLIST)
			(!RESTOFLIST2)
			(!ANOTHERMATCHTERM)); look());

(* utility for iteration of search *)

(* lists of all nontrivial results that can be obtained from a term
using existing theorems *)

fun resultlist1 level hlevel hyps x = 
separate (fn (z,y) => rulefree2 level y andalso y <> x) 
(map (fn (thm,a) => (thm,
thmresult level hlevel hyps (Formatof thm) "=>" x)) (!THEOREMS));

fun resultlist2 level hlevel hyps x = 
separate (fn (z,y) => rulefree2 level y andalso y <> x) 
(map (fn (thm,a) => (thm,
thmresult level hlevel hyps (Formatof thm) "<=" x)) (!THEOREMS));

fun safehead nil = ("", Constant "") |

	safehead L = hd L;

(* cmatch all occurrences of prematchtheorem are weak *)

fun thmpair1 L level hlevel hyps x w = safehead 
(separate2 (fn (y,z) => z <> Constant "")
(map (fn (y,z) => (y,prematchtheorem level z w (!THEOREMS))) L));

(* fun thmpair2 level hlevel hyps x w = safehead 
(separate (fn (y,z) => z <> Constant "")
(map (fn (y,z) => (y,prematchtheorem level z w (!THEOREMS)))
(resultlist2 level hlevel hyps x))); *)

fun thmpair3 L level hlevel hyps x w = safehead 
(separate2 (fn (y,z) => z <> Constant "")
(map (fn (y,z) => (y,prematchtheorem level w z (!THEOREMS))) L));

(* fun thmpair4 level hlevel hyps x w = safehead 
(separate (fn (y,z) => z <> Constant "")
(map (fn (y,z) => (y,prematchtheorem level w z (!THEOREMS)))
(resultlist2 level hlevel hyps x))); *)

fun pretri2 level hlevel hyps y x = 

	let val L1 = resultlist1 level hlevel hyps x in

	let val (A,B) = thmpair1 L1 level hlevel hyps x y in

	if A <> "" andalso B <> Constant "" 

	then Infix(B,ResOp "=>",Infix(Formatof A,ResOp "=>",x)) 

	else let val (A,B) = thmpair3 L1 level hlevel hyps x y in

	if A <> "" andalso B <> Constant "" 

	then Infix(B,ResOp "<=",Infix(Formatof A,ResOp "=>",x)) 

	else let val L2 = resultlist2 level hlevel hyps x in

	let val (A,B) = thmpair1 L2 level hlevel hyps x y in

	if A <> "" andalso B <> Constant "" 

	then Infix(B,ResOp "=>",Infix(Formatof A,ResOp "<=",x)) 

	else let val (A,B) = thmpair3 L2 level hlevel hyps x y in

	if A <> "" andalso B <> Constant "" 

	then Infix(B,ResOp "<=",Infix(Formatof A,ResOp "<=",x)) 

	else x
	end

	end
	end

	end
	end

	end; 

(* USER COMMAND *)

(* look for a two step proof *)

fun tri2 t = (exec (pretri2 (level(!ENV)) (hlevel(!ENV)) (hypslist(!ENV))
		(parse t));look());

(* development of theorem search using a metric *)

fun premetricresultlist1 metric target level hlevel hyps X nil 
	= nil |
premetricresultlist1 metric target level hlevel hyps X ((thm,a)::x)
= let val T = thmresult level hlevel hyps (Formatof thm) "=>" X in
if rulefree2 level T andalso (T <> X) 
andalso (((metric T target):real) <= metric X target)
then ((thm,T)::premetricresultlist1 metric target level hlevel hyps X x) 
else premetricresultlist1 metric target level hlevel hyps X x end;

fun metricresultlist1 metric target level hlevel hyps X = 
premetricresultlist1 metric target level hlevel hyps X (!THEOREMS);

fun premetricresultlist2 metric target level hlevel hyps X nil 
	= nil |
premetricresultlist2 metric target level hlevel hyps X ((thm,a)::x)
= let val T = thmresult level hlevel hyps (Formatof thm) "=>" X in
if rulefree2 level T andalso (T <> X) 
andalso (((metric T target):real) <= metric X target)
then ((thm,T)::premetricresultlist2 metric target level hlevel hyps X x) 
else premetricresultlist2 metric target level hlevel hyps X x end;

fun metricresultlist2 metric target level hlevel hyps X =
premetricresultlist2 metric target level hlevel hyps X (!THEOREMS);


(* the operation we want should take a list of terms and return the list
of terms closer to the target obtained by applying theorems to terms on
the original list *)

(* the function also needs to keep a list of theorems applied on hand! *)

(* this takes a pair of a theorem,sense list and a term and generates
a list of terms and theorem,sense pairs to which one can go *)

fun closerliststep metric target level hlevel hyps (L,t) =
	union
	(map (fn (thm,term) => ((L@[(thm,"=>")]),term))
	(metricresultlist1 metric target level hlevel hyps t))(
	map (fn (thm,term) => ((L@[(thm,"<=")]),term))
	(metricresultlist2 metric target level hlevel hyps t));

(* this applies closerliststep to look for further approaches, but
stops if the desired term has actually been reached *)

fun closerlist n metric target level hlevel hyps L =

	if n <=0 then map (fn x => (nil,x)) L else

	let val testlist = separate (fn (list,term) => term = target)
	(closerlist (n-1) metric target level hlevel hyps L)

	in

	if testlist <> nil then testlist

	else let val M = union2 
	(map (closerliststep metric target level hlevel hyps)
	(closerlist (n-1) metric target level hlevel hyps L)) in

	let val testlist2 = separate (fn (list,term) => term = target) M

	in

	if testlist2 = nil then M else testlist2

	end

	end

	end;

fun safehead2 nil = (nil,Constant "") |

	safehead2 L = hd L;

fun resultterm (nil,t) = t |

	resultterm (((thm,s)::list),t) = resultterm 
		(list,Infix(Formatof thm,ResOp s,t));

fun pretrimetric n metric target level hlevel hyps x =

	let val (list,term) = safehead2 
	(closerlist n metric target level hlevel hyps [x]) in

	if term = target then resultterm (list,x)

	else x

	end;

(* what remains is to develop mymetric *)

fun topsymbol (Constant s) = s |

	topsymbol (FreeVar s) = s |

	topsymbol (BoundVar s) = (baredisplay (BoundVar s)) |

	topsymbol (Numeral s) = (baredisplay (Numeral s)) |

	topsymbol (Function s) = "[]" |

	topsymbol (Parenthesis s) = "{}" |

	topsymbol (CaseExp (u,v,w)) = "||" |

	topsymbol (Infix(x,s,y)) = (opdisplay s);

fun leftsubterm (Constant s) = Constant ""  |

	leftsubterm (FreeVar s) = Constant "" |

	leftsubterm (Numeral s) = Constant "" |

	leftsubterm (BoundVar s) = Constant "" |

	leftsubterm (Function s) = s |

	leftsubterm (Parenthesis s) = s |

	leftsubterm (CaseExp (u,v,w)) = u |

	leftsubterm (Infix(x,s,y)) = x;

fun rightsubterm (Constant s) = Constant ""  |

	rightsubterm (FreeVar s) = Constant "" |

	rightsubterm (Numeral s) = Constant "" |

	rightsubterm (BoundVar s) = Constant "" |

	rightsubterm (Function s) = s |

	rightsubterm (Parenthesis s) = s |

	rightsubterm (CaseExp (u,v,w)) = Infix(v,ResOp",",w) |

	rightsubterm (Infix(x,s,y)) = y;

fun mymetric (Constant "") (Constant "") = 0.0 |

	mymetric (Constant "") x = 1.0 |

	mymetric x (Constant "") = 1.0 |

	mymetric x y = if x = y then 0.0 else

	(if topsymbol x = topsymbol y then 0.25 else 0.5) +

	(0.125*((mymetric x (leftsubterm y)) + (mymetric x (rightsubterm y))
	+ (mymetric y (leftsubterm x)) + (mymetric y (rightsubterm x))
	));

(* USER COMMAND *)

(* a dumb routine for multistep proof search *)

fun trimetric n target = (exec (pretrimetric n mymetric (parse target) 
	(level(!ENV)) (hlevel(!ENV)) (hypslist(!ENV)));look());

(* resume developmment of scripting *)

fun makescript scriptname = if (!SCRIPTING) then () else

(SCRIPTING:=true;
AUTOSCRIPT:="";noml();autoscript scriptname;SCRIPTING:=false);


(* Theory handling *)

(* Theory components:

CONSTANTS OPERATORS OPAQUE SCOUT SCINLEFT SCINRIGHT PREFIX VARTYPES
THEOREMS PRETHEOREMS DEFINITIONS DEFINITIONS2 (ENVS on desktop only)
DEFDEPS THMTEXTDEPS SCRIPTS
*)

val SCRIPTS = ref ["bogus"];  (* list of scripts that have been run *)
(* this appears early so that it can be a theory
component *)

(* registry of theory dependencies *)

val REGISTRY = ref [("bogus",["bogus"])];

(* SCRIPTS:=nil; *)

val THEORIES = ref [("scratch",(!CONSTANTS,! OPERATORS,! OPAQUE,! SCOUT,
! SCINLEFT,! SCINRIGHT,! PREFIX,! VARTYPES
,!THEOREMS,! PRETHEOREMS,! DEFINITIONS,! DEFINITIONS2,
!DEFDEPS,!DEFDEPS2,!THMTEXTDEPS,!THMTEXTDEPS2,! ENVS,!ENV,!SCRIPTS,
!TRACE,!TRACELEVELS,!PRECEDENCES,!DEFAULTPREC,!PROGRAMS))];


fun wholetheory s  =

let val (co,ope,opa,sco,scil,scir,pre,var,the,preth,def1,def2,defd,defd2,
thd,thd2,envs,
env,scr,trac,traclev,precs,defprec,progs) =

hd (find s (!THEORIES)) in

if scr = nil orelse (tl scr = nil) then 
(co,ope,opa,sco,scil,scir,pre,var,the,preth,def1,def2,defd,defd2,
thd,thd2,envs,
env,scr,trac,traclev,precs,defprec,progs (* cmatch ,comm *))

else

let val 
(co_2,ope_2,opa_2,sco_2,scil_2,scir_2,
pre_2,var_2,the_2,preth_2,def1_2,def2_2,defd_2,defd2_2,
thd_2,thd2_2,envs_2,
env_2,scr_2,trac_2,traclev_2,precs_2,defprec_2,progs_2) =

wholetheory (hd (tl scr)) in

(union co co_2,strongunion ope_2 ope,union opa opa_2,
strongunion sco_2 sco,strongunion scil_2 scil, strongunion scir_2 scir,
strongunion pre_2 pre, strongunion var_2 var, strongunion the_2 the,
preth, strongunion def1_2 def1, 
strongunion def2_2 def2, strongunion defd_2 defd,
strongunion defd2_2 defd2, strongunion thd_2 thd, strongunion thd2_2 thd2,
envs, env, scr, trac, traclev,
precs, defprec, progs)

end

end;

(* reference to name of current theory *)

val NAME = ref "";

(* reference to name of just previous theory *)

val LASTNAME = ref "";

(* we define the function which generates the "new" part of the
current theory *)

fun newsegment() =

let val (co,ope,opa,sco,scil,scir,pre,var,the,preth,def1,def2,defd,defd2,
thd,thd2,envs,
env,scr,trac,traclev,precs,defprec,progs (* cmatch ,comm *)) =

(!CONSTANTS,! OPERATORS,! OPAQUE,! SCOUT,
! SCINLEFT,! SCINRIGHT,! PREFIX,! VARTYPES
,!THEOREMS,! PRETHEOREMS,! DEFINITIONS,! DEFINITIONS2,
!DEFDEPS,!DEFDEPS2,!THMTEXTDEPS,!THMTEXTDEPS2,! ENVS,!ENV,
!SCRIPTS,
!TRACE,!TRACELEVELS,!PRECEDENCES,!DEFAULTPREC,!PROGRAMS) in

if  (!LASTNAME) = ""

then (co,ope,opa,sco,scil,scir,pre,var,the,preth,def1,def2,defd,defd2,
thd,thd2,envs,
env,scr,trac,traclev,precs,defprec,progs (* cmatch ,comm *))

else

let val (co_2,ope_2,opa_2,sco_2,scil_2,scir_2,pre_2,var_2,the_2,preth_2,def1_2,def2_2,defd_2,defd2_2,
thd_2,thd2_2,envs_2,
env_2,scr_2,trac_2,traclev_2,precs_2,defprec_2,progs_2 (* cmatch ,comm *)) =

wholetheory (!LASTNAME) in

(setminus co co_2,strongdiff ope ope_2,setminus opa opa_2,
strongdiff sco sco_2,strongdiff scil scil_2, strongdiff scir scir_2,
strongdiff pre pre_2, strongdiff var var_2, strongdiff the the_2,
preth, strongdiff def1 def1_2, strongdiff def2 def2_2, strongdiff defd defd_2,
strongdiff defd2 defd2_2, strongdiff thd thd_2, strongdiff thd2 thd2_2,
envs, env, scr, trac, traclev,
precs, defprec, progs)

end

end;

(* segments: each structural element here gets a "NEW_" variant? or
just the theorem list? or maybe also the large -deps2 structures?
The cross-referencing in general presents a problem here. *)


(* USER COMMAND *)

fun theoryname() = if (!VERBOSITY)=2 then nopausemessage (!NAME) else ();

(* USER COMMAND *)

(* back up theory onto desktop *)

fun backuptheory() = if (!NAME) = "" 
     orelse (!LASTNAME) = (!NAME) then () else

     if  find (!NAME) (!REGISTRY) = nil orelse
     find (!NAME) (!REGISTRY) = [(!SCRIPTS)] 
     then (REGISTRY:=addto (!NAME) (!SCRIPTS) (!REGISTRY); 
           THEORIES:=strongadd (!NAME) (newsegment()) (!THEORIES))
     else errormessage 
	("Theory "^(!NAME)^" cannot be backed up due to change in precursors");


(* declarations of reserved constants and theorems *)

(* function for restoring declarations of built-in constants *)

fun preamble0() = map declareconstant ["true","false",
	"BIND","EVAL","UNEVAL","BINDM","EVALM","UNEVALM","UP",
	"FLIP","INPUT","OUTPUT","STOPINPUT"];

(* function for declaring primitive logical axioms *)

fun preamble() = ( 

axiom "TYPES" "?t:?t:?x" "?t:?x";  (* type labels are retractions *)

defineinfix "COMP"  "(?f@@?g)@?x" "?f@?g@?x";

defineconstant  "P1@?x,?y"  "?x";

defineconstant "P2@?x,?y"  "?y";

defineconstant "p1@?x,?y" "?x";

defineconstant "p2@?x,?y" "?y";

setprogram "p1" "p1";

setprogram "p2" "p2";

defineconstant  "Id@?x"  "?x";

axiom "FNDIST" "?f@?x||?y,?z" "?x||(?f@?y),(?f@?z)";

axiom "CASEINTRO" "?x" "?y||?x,?x";  (* can be proven from FNDIST;
					FNDIST can also be proven from
					CASEINTRO using built- in logic 
					of || *)

axiom "REFLEX" "?a=?a" "true";

axiom "NONTRIV" "true=false" "false";

axiom "EQUATION"  "?a=?b" "(?a=?b)||true,false";

axiom "ODDCHOICE"  "?x" "?x";  (* original form of this axiom is now
				illegal; it is preserved for reverse
				compatibility *)

axiom "HYP" "(?a=?b)||(?f@?a),?c" "(?a=?b)||(?f@?b),?c"

);

(* preamble(); *)


(* fast forget function *)

(* it should be noted that until I fix the updating of the inverse
lists, this will drop any theorem that ever depended on thm, even if
it no longer does!  It drops all saved environments and restarts 
the current one (because it is harder to do dependency checking on these) *)

(* a theorem is not likely to be scin, scout or opaque at the moment;
if this ceases to be a reasonable expectation, one would also
need to drop s from the scin/scout lists *)

(* au contraire, there are theorems which are scout in the current
omnibus theory, such as forall -- but they are axioms or definitions,
so still OK *)

(* there ought to be a fix for the cmatch version *)

fun fulldroptheorem s = (droptheorem s; DEFDEPS:=drop s (!DEFDEPS);
THMTEXTDEPS:=drop s (!THMTEXTDEPS);
DEFDEPS2:=map (fn (t,x) => (t,dropfromset s x)) (drop s (!DEFDEPS2));
THMTEXTDEPS2:=map (fn (t,x) => (t,dropfromset s x)) (drop s (!THMTEXTDEPS2)); 
CONSTANTS:=dropfromset s (!CONSTANTS);
OPERATORS:=drop s (!OPERATORS); PREFIX:=drop s (!PREFIX));

(* it will not drop axioms or definitions *)
(* it will not post names of theorems dropped if run inside a script *)

(* it does not automatically back up theory on desktop -- user needs
to do this.  Its internal use in theorem exportthm is compromised if it
does backups *)

(* corrected fulldroptheorem so that forget will handle inverse lists
as well *)

(* USER COMMAND *)

(* forget a theorem *)

fun forget thm = if isatheorem thm then

	if foundinset thm (Deps thm)

	then errormessage (thm^" is an axiom or definition")

	else let val L = thmtextdeps2 thm 
		and M = thmtextdeps thm in (
		map (fn (s,(fo,lt,rt,dps)) => 
		if foundinset s L
		then (if (!VERBOSITY)=2 then nopausemessage s else ();
		fulldroptheorem s) else 
		if hd (explode s) = "}" then droptheorem s
		else () ) (!THEOREMS);
		start "?x") end

	else if isbuiltinthm thm

	then errormessage (thm^" is a built-in tactic")

	else errormessage (thm^" is not a theorem");


(* USER COMMAND *)

(* retrieve a theory from the desktop *)

fun gettheory s = 

if find s (!THEORIES) = nil then
errormessage ("Theory "^s^" not found")
else (if s = (!NAME) then (backuptheory()) else (
let val (co,ope,opa,sco,scil,scir,pre,var,the,preth,def1,def2,defd,defd2,
thd,thd2,envs,
env,scr,trac,traclev,precs,defprec,progs (* cmatch ,comm *)) =

(hd(find s (!THEORIES))) in

if scr = nil orelse (tl scr) = nil then

 (backuptheory(); start "?x"; NAME:=s; LASTNAME := "";
 CONSTANTS:= co; OPERATORS:= ope; OPAQUE:=opa;SCOUT:=sco;SCINLEFT:=scil;
 SCINRIGHT:=scir;PREFIX:=pre;VARTYPES:=var;THEOREMS:=the;PRETHEOREMS:=preth;
 DEFINITIONS:=def1;DEFINITIONS2:=def2;DEFDEPS:=defd;THMTEXTDEPS:=thd;
 DEFDEPS2:=defd2;THMTEXTDEPS2:=thd2;
 ENVS:=envs;ENV:=env;SCRIPTS:=scr;
 TRACE:=trac;TRACELEVELS:=traclev;
 PRECEDENCES:=precs;DEFAULTPREC:=defprec;PROGRAMS:=progs; 
	(* cmatch COMMUTATIVE:=comm; *)theoryname();envname();look())

else (gettheory (hd (tl scr));NAME:=s;LASTNAME:=(hd (tl scr));
(CONSTANTS:= union (!CONSTANTS) co; 
OPERATORS:= strongunion (!OPERATORS) ope; 
OPAQUE:=union (!OPAQUE) opa;SCOUT:=strongunion (!SCOUT) sco;SCINLEFT:=
strongunion (!SCINLEFT) scil; SCINRIGHT:=strongunion (!SCINRIGHT) scir;
PREFIX:=strongunion (!PREFIX) pre;VARTYPES:=strongunion (!VARTYPES) var;
THEOREMS:=strongunion (!THEOREMS) the;PRETHEOREMS:=preth;
 DEFINITIONS:=strongunion (!DEFINITIONS) def1;
DEFINITIONS2:=strongunion (!DEFINITIONS2) def2;
DEFDEPS:=strongunion (!DEFDEPS) defd;
THMTEXTDEPS:=strongunion (!THMTEXTDEPS) thd;
 DEFDEPS2:=strongunion (!DEFDEPS2) defd2;
THMTEXTDEPS2:=strongunion (!THMTEXTDEPS2) thd2;
 ENVS:=envs;ENV:=env;SCRIPTS:=scr;
 TRACE:=trac;TRACELEVELS:=traclev;
 PRECEDENCES:=precs;DEFAULTPREC:=defprec;PROGRAMS:=progs; 

 theoryname();envname();look())) end));

(* development of the load/save facility *)

(* this function strips all the "old" stuff out of the current
theory preparatory to the theory save operation *)

fun loadnewsegment() = (backuptheory(); let val 
(co,ope,opa,sco,scil,scir,pre,var,the,preth,def1,def2,defd,defd2,
thd,thd2,envs,
env,scr,trac,traclev,precs,defprec,progs (* cmatch ,comm *)) = newsegment()

in (CONSTANTS:= co; 
OPERATORS:= ope; 
OPAQUE:=opa;SCOUT:=sco;SCINLEFT:=scil; SCINRIGHT:=scir;
PREFIX:=pre;VARTYPES:=var;
THEOREMS:=the;PRETHEOREMS:=preth;
 DEFINITIONS:=def1;
DEFINITIONS2:=def2;
DEFDEPS:=defd;
THMTEXTDEPS:=thd;
 DEFDEPS2:=defd2;
THMTEXTDEPS2:=thd2;
 ENVS:=envs;ENV:=env;SCRIPTS:=scr;
 TRACE:=trac;TRACELEVELS:=traclev;
 PRECEDENCES:=precs;DEFAULTPREC:=defprec;PROGRAMS:=progs) end);


fun saveset readername nil = "" |

	saveset readername (s::L) = (readername)^
					" \""^s^"\";\n"^(saveset readername L);

fun revsaveset readername nil = "" |

	revsaveset readername (s::L) = (revsaveset readername L)^(readername)^
					" \""^s^"\";\n";

fun savefun readername displayfun nil = "" |

	savefun readername displayfun ((s,x)::L) =
	(readername)^" \""^s^"\" \""^(displayfun x)^"\";\n"
	^(savefun readername displayfun L);

fun saveconstants() = saveset "declareconstant" (!CONSTANTS);

fun prefixreader s t = if t = "" then declarestrictprefix s else
	declareprefix s t;

fun saveprefixes() = savefun "prefixreader" (fn x=> x) (!PREFIX);


fun saveprograms() = savefun "setprogram" (fn x => x) (!PROGRAMS);

fun saveprecedences() = savefun "precedencereader" makestring (!PRECEDENCES);

fun precedencereader s n = setprecedence s (evalnum (rev (explode n)));

fun savetracelevels() = savefun "tracelevelreader" makestring (!TRACELEVELS);

fun tracelevelreader s n = settracelevel s (evalnum (rev (explode n)));

fun savedefaultprec() = "setdefaultprec "^(makestring(!DEFAULTPREC))^";\n";

fun saveopaque() = saveset "addopaque" (!OPAQUE);

fun addopaque s = OPAQUE:=addtoset s (!OPAQUE);

fun savescinleft() = savefun "addscinleft" (fn x => x) (!SCINLEFT);

fun addscinleft s t = SCINLEFT:=addto s t (!SCINLEFT);

fun savescinright() = savefun "addscinright" (fn x => x) (!SCINRIGHT);

fun addscinright s t = SCINRIGHT:=addto s t (!SCINRIGHT);

fun savescout() = savefun "addscout" (fn x => x) (!SCOUT);

fun addscout s t = SCOUT:=addto s t (!SCOUT);

fun numpair1 (Infix(Numeral m,ResOp",",Numeral n)) =

	(listtoint m,listtoint n) |

	numpair1 (Infix(Infix(x,ConOp"~",Numeral m),ResOp",",Numeral n)) =

	(0-(listtoint m),listtoint n) |

	numpair1 (Infix(Numeral n,ResOp",",Infix(x,ConOp"~",Numeral m))) =
	(listtoint n,0-(listtoint m)) |

	numpair1 (Infix(Infix(x,ConOp"~",Numeral m),ResOp",",
	Infix(y,ConOp"~",Numeral n))) = (0-(listtoint m),0-(listtoint n)) |

	numpair1 t = (0,0);

fun numpair2 (m:int,n:int) = ("("^(makestring m)^") , "^(makestring n));

fun saveoperators() = savefun "addoperator" numpair2 (!OPERATORS);

fun addoperator s t = declaretypedinfix (p1 (numpair1 (parse t)))
		(p2(numpair1 (parse t))) s;

fun readthm1 (Infix(x,ResOp",",Infix(y,ResOp",",Infix(z,ResOp",",w))))
	 = (x,y,z,termtolist w);

fun readthm2 (x,y,z,w) = 
	baredisplay((Infix(x,ResOp",",Infix(y,ResOp",",
		Infix(z,ResOp",",listtoterm w)))));

(* the reversal is to preserve the order of the theorem list *)

fun savetheorems() = savefun "forcetheorem" readthm2 (rev(!THEOREMS));

fun forcetheorem s t = let val (fo,lt,rt,dp) = readthm1(parse t) in

	addtheorem s fo lt rt dp end;

fun savepretheorems() = saveset "addpretheorem" (!PRETHEOREMS);

fun addpretheorem s = PRETHEOREMS:= addtoset s (!PRETHEOREMS);

fun savevartypes() = savefun "addvartype" baredisplay (!VARTYPES);

fun addvartype s t = VARTYPES := addto s (parse t) (!VARTYPES);

(* DEFINITIONS2 does not need to be saved; it can be constructed from
DEFINITIONS *)

fun savedefinitions() = savefun "adddef" (fn x => x) (!DEFINITIONS);

fun savedefdeps() = savefun "adddefdep2" listtoterm2 (!DEFDEPS); 

fun adddefdep2 s t = adddefdep s (termtolist2 t);

fun savethmtextdeps() = savefun "addthmtextdep2" listtoterm2 (!THMTEXTDEPS); 

fun addthmtextdep2 s t = addthmtextdep s (termtolist2 t);

fun savescripts() = if (!SCRIPTS)=nil orelse (tl(!SCRIPTS)) = nil
		then "" else "addscript "^"\""^(hd(tl(!SCRIPTS)))^"\";\n";

val OLDTHEORYNAME = ref "bogus";

fun savefile() = (savescripts())^(saveconstants())
	^(saveoperators())^(savescout())
	^(savescinleft())^(savescinright())
	^(saveprecedences())^(savedefaultprec())^(saveprefixes())
	^(savevartypes())^(saveopaque())
	^(savetheorems())^(savepretheorems())^(savedefinitions())
	(* ^(savesimplifier()) *) ^(savetracelevels())
	^(saveprograms())^(savedefdeps())^(savethmtextdeps())^"quit();\n";

val THEORY = ref(open_out("dummy"));

val SAVE_EXT = ref ".wat";

(* USER COMMAND *)

fun setsaveext s = SAVE_EXT := s;

(* USER COMMANDS (2) *)

(* save theory files *)


fun storeall name = if find name (!REGISTRY) = nil
                    orelse find name (!REGISTRY) =
                    [if name = (!NAME) 
                    then (!SCRIPTS) 
                    else addtoset name (!SCRIPTS)] then

		(if (name <> (!NAME))
		then (LASTNAME:=(!NAME);
			NAME:=name;
			SCRIPTS:=addtoset name (!SCRIPTS)
			(* ;backuptheory() *)) else ();
		start "?x"; loadnewsegment();
		THEORY:=open_out(name^".sav"^(!SAVE_EXT));
		output((!THEORY),savefile());
		close_out(!THEORY);
		NAME:="";gettheory name)

                else errormessage 
     "Theory cannot be stored with this name due to precursor errors";

fun clearfor s = (backuptheory();
PROGRAMS:=nil;
PRECEDENCES:=nil; DEFAULTPREC := 0;
TRACE:=0; TRACELEVELS:= nil;
DEMO:=false; DIAGNOSTIC:= false; LASTNAME := "";
NAME:= s; start "?x"; CONSTANTS := nil;
OPERATORS := nil; 
OPAQUE := nil; SCOUT := nil; 
SCINLEFT := nil; SCINRIGHT := nil; PREFIX := nil; VARTYPES := nil;
THEOREMS := nil; PRETHEOREMS := nil; DEFINITIONS := nil; DEFINITIONS2 := nil;
DEFDEPS:=nil; THMTEXTDEPS:=nil; SCRIPTS:=nil; DEFDEPS2:=nil;
THMTEXTDEPS2:=nil; (* cmatch COMMUTATIVE := nil; *)
ENVS := nil; 
declarestrictprefix "!@"; declarestrictprefix "!$";
SCINLEFT:=addto "=>" "" (!SCINLEFT);SCINLEFT:=addto "<=" "" (!SCINLEFT);
if s = "" then (preamble0(); preamble(); storeall "preamble") else ());

(* USER COMMAND *)

fun clear() = clearfor "";

(* USER COMMAND *)

(* total destruction *)

fun cleartheories () = (clear(); THEORIES:=nil; REGISTRY:=nil);

fun droptheory s = (clear(); THEORIES:=drop s (!THEORIES); 
                             REGISTRY := drop s (!REGISTRY);
                   map (fn (x,y) => if foundinset s y then (droptheory x)
                    else ()) (!REGISTRY);());


fun safesave() = storeall (!NAME);

(* USER COMMAND *)

(* load uses a different menu of commands from script; they check
to see whether the appropriate menu is present and swap if necessary *)

fun preload name = if name = "preamble" then () else
		(
		loadmenu();
                nopausemessage ("Now preloading "^name);
		executefile "" (name^".sav");
                nopausemessage ("Done preloading "^name);
		PRECEDENCES:=nil; PROGRAMS:=nil);

fun addscript name = 	(preload name;

                        if find name (!REGISTRY) = nil
                        orelse find name (!REGISTRY) = 
				[addtoset name (!SCRIPTS)]
			then
			(LASTNAME:=(!NAME); 
			NAME:=name; SCRIPTS:=addtoset name (!SCRIPTS);
                        backuptheory())

			else errormessage ("Precursor error at theory"^name)
			);

fun load name = (backuptheory(); clear(); 
		loadmenu();
		executefile "" (name^".sav");mainmenu();LASTNAME:=(!NAME);
                if find name (!REGISTRY) = nil
                     orelse find name (!REGISTRY) = 
                     [addtoset name (!SCRIPTS)] then
		(NAME:=name; SCRIPTS:=addtoset name (!SCRIPTS); backuptheory())
   else errormessage ("Precursor error at theory "^name));

(* development of the script command *)

fun scriptinscript s = (if foundinset s (!SCRIPTS) then 
(setnopause();errormessage
("Script "^s^" already run");setpause()) 

else (
LASTNAME:=(!NAME);
executefile (if (!DEMO) then "Watson>  " else "") s;storeall s));


(* June 25 modification: coming out of the top level script will always
turn off demo and diagnostic modes *)

fun setlastname() = if (!SCRIPTS) = nil orelse (tl(!SCRIPTS)) = nil
then LASTNAME:="" else LASTNAME:= hd(tl(!SCRIPTS));

(* USER COMMAND *)

fun script s = (backuptheory();OLDSCRIPTING:=(!SCRIPTING);
SCRIPTING:=false;
(if (!DEMO) then () else thmsonly(); setpause(); mainmenu();
addtocurrentmenu "script" (fn () => scriptinscript (getchararg(!ARGUMENTS)));
scriptinscript s; setnopause(); speakup();DEMO:=false;DIAGNOSTIC:=false;
  TURNOFFPROMPT:=false;mainmenu();setlastname();
SCRIPTING:=(!OLDSCRIPTING))
handle Breakout => (setnopause(); speakup(); TESTTH:=[std_in];DEMO:=false;
DIAGNOSTIC:=false; TURNOFFPROMPT:=false;mainmenu();setlastname();
SCRIPTING:=(!OLDSCRIPTING);
errormessage ("User escape from script "^s)));


(* BEGIN theorem export under construction *)

(* theorem export system -- under construction *)

(* basic idea is that the user may define a "view" (a translation table
for constants and operators) of one theory in another.  This view can then be
used to translate theorems of the source theory into theorems of the target
theory.  The prover checks the validity of views.  *)

(* the master list of views:  this will need
to be declared earlier when this feature is fully installed *)

val VIEWS = ref [("bogus",[("bogus","bogus")])];

(* a view which sees all the predeclared constants as themselves *)

val basicview = ref [("bogus","bogus")];

fun setbasicview() = basicview := union (map (fn x=>(x,x)) (!CONSTANTS))
		(map (fn (x,y)=>(x,x)) (!OPERATORS));

(* functions for handling views *)

(* USER COMMAND *)

fun declareview s = if foundin s (!VIEWS)

		then errormessage ("View "^s^" already exists")

		else VIEWS:=addto s (!basicview) (!VIEWS);

(* USER COMMANDS (2) *)

(* restoreview and backupview are provided as user commands;
backupview is also invoked automatically by exportthmlist, and
restoreview may be used to restore a damaged view after a failed
export *)

fun restoreview s = if foundin ("~"^s) (!VIEWS)

		then VIEWS:=strongadd s (hd(find ("~"^s) (!VIEWS))) (!VIEWS)

		else errormessage ("No backup of view "^s^" to restore");

fun backupview s = if foundin s (!VIEWS)

		then VIEWS := strongadd ("~"^s) (hd(find s (!VIEWS))) (!VIEWS)

		else errormessage ("No view "^s^" found to back up");

fun isaview s = foundin s (!VIEWS);

fun theview s = safefind nil s (!VIEWS);

fun foundinview s t = foundin t (theview s);

fun viewof s t = safefind "" t (theview s);

fun viewof2 s t = let val A = find t (theview s) in

	if A = nil then if t <> ""

	then (errormessage ("Can't translate "^t^" using view "^s);"")

	else ""

	else hd A end;

(* USER COMMAND *)

fun addtoview s t u = if isaview s andalso not(foundinview s t)

	then VIEWS:=strongadd s (addto t u (theview s)) (!VIEWS)

	else errormessage (s^" is not a view or "^t^" is already found in it");

(* USER COMMAND *)

fun dropfromview s t = if isaview s andalso (foundinview s t)

	then VIEWS:=strongadd  s (drop t (theview s)) (!VIEWS)

	else errormessage (s^" is not a view or "^t^" is not found in it");

(* USER COMMAND *)

fun dropview s = if isaview s then VIEWS := drop s (!VIEWS)
	else ();

fun preshowview nil = (!Returns) |

	preshowview ((s,t)::L) = s^"\t"^t^"\n"^(preshowview L);

fun preshowview2 L = (if (!GUIMODE) then "Table display:"^(!Returns) else "")
                     ^(preshowview L)
                     ^(if (!GUIMODE) then ". . ."^(!Returns) else "");

(* USER COMMANDS (3) *)

(* all these have in command is a tabular form *)

fun showview s = if isaview s

	then output(std_out,preshowview2 (hd (find s (!VIEWS))))

	else errormessage ("There is no view "^s);

fun showprecedences() = (output(std_out,
"The default precedence is "^(makestring(!DEFAULTPREC))^(!Returns)^
	(preshowview2 (map (fn(x,y)=>(x,makestring y)) (!PRECEDENCES))));
	flush_Out(std_out));
	

fun showprograms() = (output(std_out,preshowview2 (!PROGRAMS));
	flush_Out(std_out));

(* make substitutions into a term using a view as a translation table *)

fun viewsub s (Constant t)  = Constant (viewof2 s t) |

	viewsub s (Function t) = Function (viewsub s t) |

	viewsub s (CaseExp(u,v,w)) = 
		CaseExp(viewsub s u,viewsub s v,viewsub s w) |

	viewsub s (Infix(x,ConOp t,y)) = (Infix(viewsub s x,
		ConOp (viewof2 s t),
		viewsub s y)) |

	(* Infix variables require view information because they may
		be typed *)

	viewsub s (Infix(x,VarOp t,y)) = (Infix(viewsub s x,
		VarOp (viewof2 s t),
		viewsub s y)) |

	viewsub s (Infix(x,ResOp t,y)) = Infix(viewsub s x,ResOp t,
		viewsub s y) |

	viewsub s t = t;

(*  strip variables out of a match produced by supermatch below *)

(* stripvars modified July 14 to recognize bogus free variables 
introduced in the "reversal" of infix variable matching *)

fun stripvars1 nil = nil |

	stripvars1 ((s,t)::L) = if t <> "" andalso hd(explode t) = "?" then
		stripvars1 L else ((s,t)::stripvars1 L);

(* it is to be expected that L will actually be nil in all cases *)

fun stripvars nil = nil |

	stripvars (a::L) = (stripvars1 a)::L;

(* builds matches between theories *)

(* design points:

free variables only match free variables; this is just to check identical
form of theorems.

reserved operators only match themselves

constants, operators, and operator variables match constants, operators,
operator variables with the following conditions:

	matches between theorem names require matches between the
associated theorems.  matches to defined concepts require matches of the
defining theorems (and defined concepts can only match defined concepts).
Matches of theorems have free variable matches stripped out (hence
the stripvars function above).
matches to scin/scout operators require matches of the corresponding theorems
as well.  operators only match other operators with the same relative
type and opacity information.
operator variables only match if their declaration status is
the same (treating undeclared as equivalent to opaque as usual).

	making these matches requires access to declaration lists
from other theories?

	Build small lists of relevant declarations from the material
to be matched, and label these declarations with an impossible prefix?

Alternatively, put the old declaration lists in special places in the
environment and swap them for the current declaration lists when necessary?

*)

val OLDTHEOREMS = ref (!THEOREMS);
val OLDOPERATORS = ref (!OPERATORS);
val OLDDEFINITIONS = ref (!DEFINITIONS);
val OLDDEFINITIONS2 = ref (!DEFINITIONS2);
val OLDOPAQUE = ref (!OPAQUE);
val OLDSCOUT = ref (!SCOUT);
val OLDSCINLEFT = ref (!SCINLEFT);
val OLDSCINRIGHT = ref (!SCINRIGHT);
val OLDPREFIX = ref (!PREFIX);

val TEMPTHEOREMS = ref (!THEOREMS);
val TEMPOPERATORS = ref (!OPERATORS);
val TEMPDEFINITIONS = ref (!DEFINITIONS);
val TEMPDEFINITIONS2 = ref (!DEFINITIONS2);
val TEMPOPAQUE = ref (!OPAQUE);
val TEMPSCOUT = ref (!SCOUT);
val TEMPSCINLEFT = ref (!SCINLEFT);
val TEMPSCINRIGHT = ref (!SCINRIGHT);
val TEMPPREFIX = ref (!PREFIX);

(* copy declaration lists of source theory before moving to target theory *)

fun getoldlists() = (OLDTHEOREMS := (!THEOREMS);
 OLDOPERATORS :=  (!OPERATORS);
 OLDDEFINITIONS := (!DEFINITIONS); 
 OLDDEFINITIONS2 := (!DEFINITIONS2);
 OLDOPAQUE := (!OPAQUE); 
 OLDSCOUT := (!SCOUT);
 OLDSCINLEFT :=(!SCINLEFT);
 OLDSCINRIGHT := (!SCINRIGHT);
 OLDPREFIX := (!PREFIX));

(* interchange definition lists with the "old" ones *)

fun swapoldlists() = (TEMPTHEOREMS := (!THEOREMS);
 TEMPOPERATORS :=  (!OPERATORS);
 TEMPDEFINITIONS := (!DEFINITIONS); 
 TEMPDEFINITIONS2 := (!DEFINITIONS2);
 TEMPOPAQUE := (!OPAQUE); 
 TEMPSCOUT := (!SCOUT);
 TEMPSCINLEFT :=(!SCINLEFT);
 TEMPSCINRIGHT := (!SCINRIGHT);
 TEMPPREFIX := (!PREFIX);

 THEOREMS:=(!OLDTHEOREMS);
 OPERATORS:=(!OLDOPERATORS);
 DEFINITIONS:=(!OLDDEFINITIONS);
 DEFINITIONS2:=(!OLDDEFINITIONS2);
 OPAQUE:=(!OLDOPAQUE);
 SCOUT:=(!OLDSCOUT);
 SCINLEFT:=(!OLDSCINLEFT);
 SCINRIGHT:=(!OLDSCINRIGHT);
 PREFIX := (!OLDPREFIX);

OLDTHEOREMS := (!TEMPTHEOREMS);
 OLDOPERATORS :=  (!TEMPOPERATORS);
 OLDDEFINITIONS := (!TEMPDEFINITIONS); 
 OLDDEFINITIONS2 := (!TEMPDEFINITIONS2);
 OLDOPAQUE := (!TEMPOPAQUE); 
 OLDSCOUT := (!TEMPSCOUT);
 OLDSCINLEFT :=(!TEMPSCINLEFT);
 OLDSCINRIGHT := (!TEMPSCINRIGHT);
 OLDPREFIX := (!TEMPPREFIX));

(* a hack for using the old lists without writing new commands;
we'll see if it works! *)

fun oldlists f x = (swapoldlists(); 
	let val y = f x in (swapoldlists();y) end );

(* list argument L is needed to avert circular searches for theorems? 
it contains matches already established between theorems, not to be
checked again! *)

(* definition is repeated here to avoid problems for cmatch version *)

(* machine for merging matches *)

fun verboseisfun nil = true |

	verboseisfun ((s,x)::L) = let val A = find s L in 
			if A = nil orelse A = [x]
				then isfun L
				else 
	(errormessage((hd A)^" conflicts with "^x^" as match for "^s);
		false) end;

(* merge function used with match lists; it returns nil as an
error object, and packages resultant lists in a unit list *)

fun verbosemerge L M = if verboseisfun (union L M) then [union L M] else nil;


fun mergematches nil L = nil |

	mergematches M nil = nil |

	mergematches (a::L) (b::M) = verbosemerge a b;


(* supermatch could send helpful error messages *)

fun supermatch L (Constant "") (Constant s) = if s = "" then [nil] else 
		(errormessage ("Bad match "^s^" for null prefix");nil) |

	supermatch L (Constant s) (Constant t) = if foundin s L 
		then if (hd (find s L) = t) then [nil] else 
		(errormessage ("Bad match "^t^" for "^s);nil)

	else mergematches [[(s,t)]] (mergematches 

	(* match of any theorems s and t may name *)

	(if oldlists Isatheorem s

	then if not (Isatheorem t) then 
		(errormessage 
		("Bad match "^t^" for "^s^" (not a theorem)");nil) 

	else let val (fo,lt,rt,dps) = oldlists Thm s and
	(fo2,lt2,rt2,dps2) = Thm t in 
	let val M =
	stripvars(mergematches ((supermatch ((s,t)::L) fo fo2))
	(mergematches ((supermatch ((s,t)::L) lt lt2))
		((supermatch ((s,t)::L) rt rt2))))

	in if M = nil 
	then (errormessage ("Match of theorems "^s^" and "^t^" failed");nil) 
	else M  end end

	else [nil])

	(* match between any definitions *)

	(mergematches (if oldlists isdefined s 

	then if not (isdefined t) then 
		(errormessage 
		("Bad match "^t^" for "^s^" (not a defined notion)");nil)

	else
	stripvars (supermatch ((s,t)::L) (Constant(oldlists definitionof s))
		(Constant(definitionof t)))

	else [nil])

	(* match between any scout, scinleft, scinright witness theorems *)

	(mergematches (if oldlists isscout s 

	then if not (isscout t) then

		(errormessage 
		("Bad match "^t^" for "^s^" (not scout)");nil)


	else stripvars (supermatch ((s,t)::L) (Constant(oldlists scoutof s))
		(Constant(scoutof t)))

	else [nil])

	(mergematches (if oldlists isscinleft s 

	then if not (isscinleft t) then

		(errormessage 
		("Bad match "^t^" for "^s^" (not scinleft)");nil)

	else stripvars (supermatch ((s,t)::L) 
		(Constant(oldlists scinleftof s))
		(Constant(scinleftof t)))

	else [nil])

	(if oldlists isscinright s 

	then if not (isscinright t) then

		(errormessage 
		("Bad match "^t^" for "^s^" (not scinright)");nil)

	else stripvars (supermatch ((s,t)::L) 
		(Constant(oldlists scinrightof s))
		(Constant(scinrightof t)))

	else [nil]))))) |

(* reversal of order here is a subtle logical point --
one does not want stronger theorems in source theory to
match weaker theories in the target theory! *)

	supermatch L (FreeVar s) (FreeVar t) = [[(t,s)]] |

	supermatch L (Function t) (Function u) = supermatch L t u |

	supermatch L (CaseExp(u,v,w)) (CaseExp(u2,v2,w2)) =

		mergematches (supermatch L u u2) (mergematches 
		(supermatch L v v2) (supermatch L w w2)) |

	supermatch L (Infix(x,ResOp t,y)) (Infix(x2,ResOp t2,y2)) =

		if t <> t2 then 

		(errormessage ("Bad match "^t2^" for "^t);nil)

		else mergematches (supermatch L x x2) (supermatch L y y2) |

	supermatch L (Infix(x,i,y)) (Infix(x2,j,y2)) =

		(* types of operator (constant or variable) match *)

		if ((stringtoop (opdisplay i) = ConOp (opdisplay i)
		andalso stringtoop (opdisplay j) = ConOp (opdisplay j))

		orelse (stringtoop (opdisplay i) = VarOp (opdisplay i)
		andalso stringtoop (opdisplay j) = VarOp (opdisplay j)))

		(* relative type and opacity information matches *)

		andalso ((oldlists istypedoperator (opdisplay i) andalso
		istypedoperator (opdisplay j) andalso 
		oldlists opof (opdisplay i) = opof (opdisplay j))

		orelse (not (oldlists istypedoperator (opdisplay i)) andalso
		not (istypedoperator (opdisplay j))))

		(* the handling of the operators themselves is precisely
		like the handling of constants (it involves references
		to possible theorems and definitions); then merge in
		the matches of the operands *)

		(* the first clause here expresses the same reversal
		of matching found in the case of free variables above *)

		then mergematches (if 
		((stringtoop (opdisplay i) = VarOp (opdisplay i)
		andalso stringtoop (opdisplay j) = VarOp (opdisplay j)))

		then [[(("?"^(opdisplay j)),("?"^(opdisplay i)))]]
		else [nil])

		(mergematches (supermatch L (Constant (opdisplay i))
			(Constant (opdisplay j)))
		(mergematches (supermatch L x x2) (supermatch L y y2)))


		else 

		(errormessage ("Bad match "^(opdisplay j)^
		" for "^(opdisplay i)
		^" (relative types or opacity fail to match)");nil) |

	(* other atomic terms need to match precisely *)

	supermatch L t u = if t=u then [nil] else 

	(errormessage ((baredisplay t)^" doesn't match "^(baredisplay u));nil);


(* supermatch can be run on a term constructed by listtoterm from the
view *)

(* then the viewsub function should do the work of old supersubs;
the outcome of supermatch is actually a view (extending the skeleton
provided by the "official" view); the theorems to which viewsub is
to be applied can be read from THMTEXTDEPS (actually, need to have
been read from there in advance!) *)

(* this is an internal command; the user command will call this
on the theorem text dependencies of its single theorem argument *)

(* utility for generating new theorem names; add a suffix repeatedly
until new name is formed.  Prefix # is always used for operators *)

(* this utility does allow pretheorems to be overwritten; required by
the internal structure of the exportthmlist command *)

fun newtheoremname suffix name = if isatheorem name orelse isbuiltinthm name

	then if opdisplay(stringtoop name) = name then 
		newtheoremname suffix("#"^name) 

	else newtheoremname suffix (name^"_"^suffix)

	else name;

(* utility for fixing declarations of the new theorems to be added *)

(* we rely here on theorems not having nontrivial relative type,
opacity, scin/scout, or any such properties *)

fun fixdec suffix s = if s <> "" andalso stringtocon s = Constant s

	then declarepretheorem (newtheoremname suffix s)

	else let val S = newtheoremname suffix s in

	(if oldlists isstrictprefix s then declareunarypretheorem S 
	else declarepretheorem S)

	end;

(* lists all constants, operators, and operator variables (other than reserved
operators; used for declaration checking by exportthmlist) *)

fun conlist3 (Constant "") = nil |

	conlist3 (Constant s) = [s] |

	conlist3 (Infix(x,ConOp s,y)) = addtoset s 
			(union (conlist3 x) (conlist3 y)) |
	conlist3 (Infix(x,VarOp s,y)) = addtoset s 
			(union (conlist3 x) (conlist3 y)) |
	conlist3 (Infix(x,ResOp s,y)) = 
			(union (conlist3 x) (conlist3 y)) |
	conlist3 (Function s) = conlist3 s |
	conlist3 (CaseExp(u,v,w)) = union (conlist3 u) (union (conlist3 v)
							(conlist3 w)) |
	conlist3 t = nil;

(* the same for theorems *)

fun thmconlist thm = union(conlist3 (Formatof thm)) 
	(union (conlist3 (Leftside thm)) (conlist3 (Rightside thm)));

(* exportthmlist now does declaration checking *)

fun exportthmlist view target suffix thmlist = 

 (* check that all axioms on which theorems in thmlist depend
are found in view *)

if let val A =(union2(map Deps thmlist)) in (map (viewof2 view) A; 
   (map (foundinview view) A = map (fn x => true) A)) end 

then

let val L2 =
	(map (fn s => (s,Thm s))) thmlist in (* build theorem list *)

(getoldlists();  (* save declaration info from source theory *)

gettheory target; backuptheory();  (* go to target theory and back it up
					against disaster *)

let val M = stripvars(supermatch nil 
	(listtoterm (map (fn (a,b) => a) (theview view)))
	(listtoterm (map (fn (a,b) => b) (theview view)))) in 

if M = nil then  (* don't go any further! *)
(errormessage "Construction of match list failed")

else(backupview view; VIEWS:=strongadd view 
	(union (hd M) 
(map (fn x => (x,
	(newtheoremname suffix x)))

		(separate (fn x => not (foundin x (hd M))) thmlist)))
		(!VIEWS);  (* replace the original view with
				its extension plus names for the
				new theorems to be proved *)

(* check that all constants, operators and variable operators present
are found in view *)

if let val A = union2(map (oldlists thmconlist) thmlist) in 
(map (viewof2 view) A;
(map (foundinview view)
A = map (fn x => true) A)) end

then(

map (fn (name,x) => fixdec suffix name) 
	(separate (fn (x,y) => not (foundin x (hd M))) L2);

map (fn (name,(fo,lt,rt,dps)) => (let val T = newtheoremname suffix name in

(addtheorem T

	(viewsub view fo) (viewsub view lt) (viewsub view rt) (sortset(union2 
(map Deps (map (fn x => (hd(termtolist(viewsub view (listtoterm [x]))))) dps))))); 
fixdeps T; 

(* this error check should no longer be triggered *)

if declarecheck false 0 (Leftside T) andalso declarecheck false 0 (Rightside T)
andalso declarecheck false 0 (Formatof T) then thmdisplay T 
else (errormessage ("Declaration failure in export of "^T);forget T) end)) 
(separate (fn (x,y) => not (foundin x (hd M))) L2)  ; ())

else errormessage "Not all constants and operators are found in view"

) end ) end

else errormessage "Required axioms not covered by view";

(* USER COMMAND *)

(* this command should be invoked in the source theory from which a
theorem is to be exported.  view is the view used.  target is the
name of the target theory.  suffix is a suffix to be attached when
name collisions are to be avoided (alphanumeric).  thm is the name
of the theorem to be exported. *)

(* this command will issue many messages, which should be examined
to see if anything went wrong.  It remains unstable. *)

(* points to remember:  one does need to include operator variables
in views; the system does not accept them automatically, because operator
variables do have user-declarable properties.  This command extends
the view being used.  When the view is not adequate to support the 
export of the theorem, the view will need to be repaired to eliminate
any theorems that were not exported successfully. *)

fun exportthm view target suffix thm = if not(foundin target (!THEORIES))

	then errormessage ("Target theory "^target^" not found")

	else if not (isatheorem thm)

	then errormessage ("Theorem "^thm^" not found")

	else if not (foundin view (!VIEWS))

	then errormessage ("View "^view^" not found")

	else exportthmlist view target suffix (thmtextdeps thm);
	

(* END theorem export under construction *)

(* ADD:  reaxiomatization and redefinition commands *)

(* these are needed to make theorem export more flexible, by making
it possible to change axiomatization and definition structures *)

(* proveanaxiom and makeanaxiom together support full reaxiomatization
capability with respect to non-definitions *)

(* USER COMMAND *)

(* this reaxiomatization function supports the introduction of lemmas
as axioms to be proved later; it is to be issued in a proof environment
in which the axiom has been re-proved using other axioms *)

fun proveanaxiom thm = if isatheorem thm andalso
	not(isdefinition thm) andalso foundinset thm (Deps thm)

	then if leftside(!ENV) = Leftside thm andalso
		rightside(!ENV) = Rightside thm
		andalso not (foundinset thm (deps(!ENV)))

	then THEOREMS := map (fn (na,(fo,lt,rt,dps)) =>
	(na,(fo,lt,rt,if foundinset thm dps 
		then sortset(union (deps (!ENV)) (dropfromset thm dps)) 
		else dps))) (!THEOREMS)

	else errormessage 
	("Environment not appropriate for proof of axiom "^thm)

	else errormessage ("Axiom "^thm^" not found");

(* USER COMMAND *)

(* make a non-definition into an axiom *)

fun makeanaxiom thm = if isatheorem thm andalso not(foundinset thm (Deps thm))

	then addtheorem thm (Formatof thm) (Leftside thm) (Rightside thm) [thm]

	else errormessage
	("Theorem "^thm^" either does not exist or is an axiom or definition");

(* redefinition commands *)

(* USER COMMAND *)

(* coerce a definition to an axiom *)

fun undefine s = if isdefined s then (let val thm = definitionof s in
	addtheorem thm (Formatof thm) (Leftside thm) (Rightside thm) [thm];
			DEFINITIONS := drop (thm) (!DEFINITIONS);
			DEFINITIONS2 := drop s (!DEFINITIONS2);
			fixdeps (thm) end)

	else errormessage (s^" is not a defined notion"); 

(* USER COMMAND *)

(* make the axiom thm into a definition, if possible *)

fun makeadefinition thm =

	if not (isatheorem thm) orelse not (foundinset thm (Deps thm))
	orelse isdefinition thm

	then errormessage (thm^" is not an axiom")

	else if ((not (atomdefinitionformat (Leftside thm)))
	andalso (not (opdefinitionformat (Leftside thm)))) orelse
	isdefined (eitherhead (Leftside thm)) orelse 
	stringtoop (eitherhead (Leftside thm)) = 
		ResOp (eitherhead (Leftside thm))
	orelse not (subset (freevarlist (Rightside thm)) 
		(freevarlist (Leftside thm)))
	then errormessage 
	("Format error in "^thm^" or relevant definition already exists")

	else if foundinset thm (union2 (map thmconlist 
		(conlist2 thm (Rightside thm))))

	then errormessage (thm^" would be a circular definition")

	else (adddef thm (eitherhead (Leftside thm));fixdeps thm);

(* for completeness, a version for type definitions would seem desirable,
but not until the type definition facility is complete; otherwise, this
should complete the redefinition functions by making it possible to 
map back and forth between axiom and definition status.  Complete redefinition
would be achieved by undefining the first definition, making the new
definition an axiom then a definition, then reproving the original
definition and using proveanaxiom; a full redefine command would still
be nice, but is not strictly needed *)

(* signals to GUI *)

fun guidone() = output(std_out,"\n\nGUIDONE\n");

fun guistart() = output(std_out,"\n\nGUISTART\n");




(* Standard abbreviations *)

val a = axiom;

val s = start;

val e = exit;

val q = quit;

val wb = workback;

val ri = ruleintro;

val rri = revruleintro;

val ari = altruleintro;

val iri = inputri;

val arri = altrevruleintro;

val ex = execute;

val td = thmdisplay;

val dpt = declarepretheorem;

val dupt = declareunarypretheorem;

val p = prove;

val smt = showmatchtheorem;

val tri = targetruleintro;

val ae = autoedit;

val rp = reprove;

val sat = showalltheorems;

val srt = showrelevantthms;

val dti = defaulttypeinfo;

val nti = notypeinfo;

(* new on July 13, 1999 *)

val ut = upto;

val dtl = downtoleft;

val dtr = downtoright;

val lut = litupto;

val ldtl = litdowntoleft;

val ldtr = litdowntoright;

val mtri = matchtri;

val amtri = anothermatchtri;

(* user commands installed on the script menu *)

(* these should be classified and comments added *)


fun setupmenu () = (

(* internals of load command *)

addtoothermenu "setprogram" (fn () => setprogram 
	(getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));	
addtoothermenu "precedencereader" (fn () => precedencereader 
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));
addtoothermenu "tracelevelreader" (fn () => tracelevelreader 
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));
addtoothermenu "setdefaultprec" 
	(fn () => setdefaultprec (getintarg (!ARGUMENTS)));


addtoothermenu "prefixreader" (fn () => prefixreader (getchararg (!ARGUMENTS)) 
	(getchararg(!ARGUMENTS)));
addtoothermenu "addopaque" (fn () => addopaque (getchararg(!ARGUMENTS)));
addtoothermenu "addscinleft" (fn () => addscinleft (getchararg(!ARGUMENTS))
		(getchararg(!ARGUMENTS)));
addtoothermenu "addscinright" (fn () => addscinright (getchararg(!ARGUMENTS))
		(getchararg(!ARGUMENTS)));
addtoothermenu "addscout" (fn () => addscout (getchararg(!ARGUMENTS))
		(getchararg(!ARGUMENTS)));
addtoothermenu "addoperator" (fn ()=>addoperator(getchararg(!ARGUMENTS))
	(getchararg(!ARGUMENTS)));
addtoothermenu "forcetheorem" (fn () => forcetheorem (getchararg(!ARGUMENTS)) 
		(getchararg(!ARGUMENTS)));
addtoothermenu "addpretheorem" (fn () => addpretheorem 
(getchararg(!ARGUMENTS)));
addtoothermenu "addvartype" (fn () => addvartype (getchararg (!ARGUMENTS))
	(getchararg(!ARGUMENTS)));
addtoothermenu "adddef" (fn () => adddef (getchararg (!ARGUMENTS)) 
(getchararg (!ARGUMENTS)) );
addtoothermenu "adddefdep2" (fn () => adddefdep2 (getchararg (!ARGUMENTS)) 
(getchararg (!ARGUMENTS)) );
addtoothermenu "addthmtextdep2" (fn () => addthmtextdep2 
(getchararg (!ARGUMENTS)) 
(getchararg (!ARGUMENTS)) );
addtoothermenu "addscript" (fn () => addscript (getchararg(!ARGUMENTS)));

(* environment management commands *)

addtomenusecure "exit" exit;
addtomenusecure "e" exit;

	(* create new environment *)

addtomenu "start" (fn () => start (getchararg (!ARGUMENTS)));
addtomenu "s" (fn () => start (getchararg (!ARGUMENTS)));

	(* conversions of existing environment *)

addtomenu "workback" workback;
addtomenu "wb" workback;

addtomenu "startover" startover;
addtomenu "starthere" starthere;

	(* environment desktop commands *)

addtomenu "getenv" (fn () => getenv (getchararg (!ARGUMENTS)));

addtomenu "saveenv" (fn () => saveenv (getchararg (!ARGUMENTS)));
addtomenu "backupenv" backupenv;

addtomenu "dropenv" (fn () => dropenv (getchararg (!ARGUMENTS)));

	(* environments from theorems *)

addtomenu "autoedit" (fn () => autoedit (getchararg (!ARGUMENTS)));
addtomenu "ae" (fn () => ae (getchararg (!ARGUMENTS)));

addtomenu "getleftside" (fn () => getleftside (getchararg(!ARGUMENTS)));
addtomenu "getrightside" (fn () => getrightside (getchararg(!ARGUMENTS)));

(* navigation commands *)

	(* basic movement commands *)

addtomenu "right" right;
addtomenu "left" left;
addtomenu "up" up;
addtomenu "top" top;

	(* powerful movement commands *)

addtomenu "upto" (fn ()=>upto (getchararg (!ARGUMENTS)));
addtomenu "ut" (fn ()=>upto (getchararg (!ARGUMENTS)));
addtomenu "litupto" (fn ()=>litupto (getchararg (!ARGUMENTS)));
addtomenu "lut" (fn ()=>litupto (getchararg (!ARGUMENTS)));
addtomenu "uptols" (fn ()=>uptols (getchararg (!ARGUMENTS)));
addtomenu "uptors" (fn ()=>uptors (getchararg (!ARGUMENTS)));

addtomenu "downtoleft" (fn () => downtoleft (getchararg (!ARGUMENTS)));
addtomenu "dtl" (fn () => downtoleft (getchararg (!ARGUMENTS)));
addtomenu "litdowntoleft" (fn () => litdowntoleft (getchararg (!ARGUMENTS)));
addtomenu "ldtl" (fn () => litdowntoleft (getchararg (!ARGUMENTS)));
addtomenu "dlls" (fn ()=>dlls (getchararg (!ARGUMENTS)));
addtomenu "dlrs" (fn ()=>dlrs (getchararg (!ARGUMENTS)));

addtomenu "downtoright" (fn () => downtoright (getchararg (!ARGUMENTS)));
addtomenu "dtr" (fn () => downtoright (getchararg (!ARGUMENTS)));
addtomenu "litdowntoright" (fn () => litdowntoright (getchararg (!ARGUMENTS)));
addtomenu "ldtr" (fn () => litdowntoright (getchararg (!ARGUMENTS)));
addtomenu "drls" (fn ()=>drls (getchararg (!ARGUMENTS)));
addtomenu "drrs" (fn ()=>drrs (getchararg (!ARGUMENTS)));

(* display commands *)

	(* version *)

addtomenusecure "versiondate" versiondate;

	(* verbosity control *)

addtomenu "bequiet" bequiet;
addtomenu "thmsonly" thmsonly;
addtomenu "speakup" speakup;
addtomenu "diagnostic" diagnostic;
addtomenu "demo" demo;

addtomenu "termprompts" termprompts;
addtomenu "localdisplayoff" localdisplayoff;
addtomenu "globaldisplayoff" globaldisplayoff;
addtomenu "bothdisplays" bothdisplays;

	(* margin control *)

addtomenusecure "setline" (fn () => setline (getintarg(!ARGUMENTS)));

	(* vertical compression *)

addtomenusecure "compress" compress;
addtomenusecure "expand" expand;

	(* error message control *)

addtomenu "setpause" setpause;
addtomenu "setnopause" setnopause;

	(* demo remark function *)

addtomenu "demoremark" (fn()=> demoremark (getchararg(!ARGUMENTS)));

	(* identify environment and theory *)

addtomenusecure "envname" envname;
addtomenusecure "theoryname" theoryname;

	(* term display *)

addtomenusecure "look" look;
addtomenusecure "lookback" lookback;
addtomenusecure "lookhere" lookhere;

	(* declaration display *)

addtomenusecure "showdec" (fn()=>showdec (getchararg(!ARGUMENTS)));


	(* theorem and saved environment display *)

addtomenusecure "thmdisplay" (fn () => thmdisplay (getchararg(!ARGUMENTS)));
addtomenusecure "td" (fn () => thmdisplay (getchararg(!ARGUMENTS)));
addtomenusecure "showenv" (fn () => showenv (getchararg (!ARGUMENTS)));
addtomenusecure "showmatchtheorem" (fn () => 
showmatchtheorem (getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenusecure "smt" (fn () => 
showmatchtheorem (getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenusecure "lookhyps" lookhyps;
addtomenusecure "seeprogram" (fn()=>seeprogram(getchararg(!ARGUMENTS)));
addtomenusecure "showdef" (fn()=>showdef (getchararg(!ARGUMENTS)));

	(* dependency display *)

addtomenusecure "seedeps" seedeps;
addtomenusecure "showalldeps" (fn () => showalldeps (getchararg (!ARGUMENTS)));
addtomenusecure "whatuses" (fn () => whatuses (getchararg (!ARGUMENTS)));

	(* theorem list display *)

(* these cannot be secure at the moment because they themselves
invoke the secure menu *)

addtomenu "showalltheorems" showalltheorems;
addtomenu "sat" sat;
addtomenu "showrelevantthms" showrelevantthms;
addtomenu "srt" srt;
addtomenu "showaxioms" showaxioms;
addtomenusecure "statementdisplay" statementdisplay;

	(* view display *)

addtomenusecure "showview" (fn () => showview (getchararg (!ARGUMENTS)));

(* display operator precedences *)

addtomenusecure "showprecedences" showprecedences;

(* tabulate program bindings *)

addtomenusecure "showprograms" showprograms;

(* declaration commands *)

	(* operators *)

addtomenu "declaretypedinfix" (fn () => declaretypedinfix 
(getintarg (!ARGUMENTS)) (getintarg (!ARGUMENTS)) (getchararg(!ARGUMENTS)));
addtoothermenu "declaretypedinfix" (fn () => declaretypedinfix 
(getintarg (!ARGUMENTS)) (getintarg (!ARGUMENTS)) (getchararg(!ARGUMENTS)));
addtomenu "declareinfix" (fn () => declareinfix (getchararg (!ARGUMENTS)));

	(* opaque and unary operators *)

addtomenu "declareopaque" (fn () => declareopaque (getchararg (!ARGUMENTS)));
addtomenu"declareprefix" (fn () => declareprefix (getchararg(!ARGUMENTS)) 
(getchararg(!ARGUMENTS)));
addtomenu "declaretypedunary" 
(fn() => declaretypedunary (getintarg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "dtu" 
(fn() => declaretypedunary (getintarg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "declareunaryopaque" (fn () => declareunaryopaque
(getchararg(!ARGUMENTS)));
addtomenu "declareunary" (fn() => declareunary (getchararg(!ARGUMENTS)));
addtomenu "du" (fn() => declareunary (getchararg(!ARGUMENTS)));

	(* default types *)

addtomenu "defaulttypeinfo" (fn () => defaulttypeinfo (getchararg (!ARGUMENTS))
	(getchararg (!ARGUMENTS)));
addtomenu "dti" (fn () => defaulttypeinfo (getchararg (!ARGUMENTS))
	(getchararg (!ARGUMENTS)));
addtomenu "notypeinfo" (fn () => notypeinfo (getchararg (!ARGUMENTS)));
addtomenu "nti" (fn () => notypeinfo (getchararg (!ARGUMENTS)));

	(* precedence *)

addtomenu "setprecedence" (fn () => setprecedence (getchararg(!ARGUMENTS))
	(getintarg (!ARGUMENTS)));
addtomenu "setdefaultprec" (fn () => setdefaultprec (getintarg (!ARGUMENTS)));
addtomenu "clearprecs" clearprecs;
addtomenu "sameprec" 
(fn () =>sameprec (getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "defaultprecsame" (fn()=>defaultprecsame(getchararg(!ARGUMENTS)));
addtomenu "leftprecabove"
(fn () =>leftprecabove (getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "rightprecabove"
(fn () =>rightprecabove (getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "leftprecbelow"
(fn () =>leftprecbelow (getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "rightprecbelow"
(fn () =>rightprecbelow (getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));

	(* constants *)

addtomenu "declareconstant" (fn () => declareconstant 
(getchararg (!ARGUMENTS)));
addtoothermenu "declareconstant" (fn () => declareconstant 
(getchararg (!ARGUMENTS)));

	(* pretheorems *)

addtomenu "declarepretheorem" 
(fn () => declarepretheorem (getchararg (!ARGUMENTS)));
addtomenu "dpt" 
(fn () => declarepretheorem (getchararg (!ARGUMENTS)));
addtomenu "declareunarypretheorem" 
(fn () => declareunarypretheorem (getchararg (!ARGUMENTS)));
addtomenu "dupt" 
(fn () => declareunarypretheorem (getchararg (!ARGUMENTS)));

	(* scin/scout *)

addtomenu "makescout" (fn ()=>makescout (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS)));
addtomenu "makescin" (fn ()=>makescin (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS)));
addtomenu "makescinvar" (fn ()=>makescinvar (getchararg (!ARGUMENTS)));
addtomenu "makescinleft" (fn ()=>makescinleft (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS)));
addtomenu "makescinright" (fn ()=>makescinright (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS)));

	(* functional programming *)
	
addtomenu "setprogram" (fn () => setprogram (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS)));
addtomenu "deprogram" (fn()=>deprogram (getchararg (!ARGUMENTS)));

(* Environment modification commands *)

	(* assignment commands *)

addtomenu "assign"
(fn () => assign (getchararg(!ARGUMENTS)) (getchararg(!ARGUMENTS)));

addtomenu "assignit" (fn () => assignit (getchararg (!ARGUMENTS)));
addtomenu "assigninto" (fn () => assigninto (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS)));

addtomenu "unification" (fn () => unification (getchararg (!ARGUMENTS)));
addtomenu "u" (fn () => unification (getchararg (!ARGUMENTS)));
addtomenu "ul" (fn () => ul (getchararg (!ARGUMENTS)));
addtomenu "ur" (fn () => ur (getchararg (!ARGUMENTS)));

addtomenu "initializecounter" initializecounter;

	(* embedded theorem introduction *) 

addtomenu "ruleintro" (fn () => ruleintro (getchararg (!ARGUMENTS)));
addtomenu "ri" (fn () => ruleintro (getchararg (!ARGUMENTS)));
addtomenu "revruleintro" (fn () => revruleintro (getchararg (!ARGUMENTS)));
addtomenu "rri" (fn () => revruleintro (getchararg (!ARGUMENTS)));

addtomenusecure "inputri" (fn () => inputri (getchararg (!ARGUMENTS)));
addtomenusecure "iri" (fn () => inputri (getchararg (!ARGUMENTS)));

addtomenu "targetruleintro" 
	(fn () => targetruleintro (getchararg (!ARGUMENTS)));
addtomenu "tri" (fn () => targetruleintro (getchararg (!ARGUMENTS)));
addtomenu "tri2" (fn () => tri2 (getchararg (!ARGUMENTS)));
addtomenu "matchtri" (fn () => matchtri (getchararg (!ARGUMENTS)));
addtomenu "mtri" (fn () => matchtri (getchararg (!ARGUMENTS)));
addtomenu "anothermatchtri" anothermatchtri;
addtomenu "amtri" anothermatchtri;

addtomenu "droprule" droprule;

	(* alternative embedded theorem introduction *)

addtomenu "altruleintro" (fn () => altruleintro (getchararg (!ARGUMENTS)));
addtomenu "ari" (fn () => altruleintro (getchararg (!ARGUMENTS)));
addtomenu "altrevruleintro" (fn () => altrevruleintro 
(getchararg (!ARGUMENTS)));
addtomenu "arri" (fn () => altrevruleintro (getchararg (!ARGUMENTS)));

	(* tactic interpreters *)

addtomenu "execute" execute;
addtomenu "ex" ex;
addtomenu "steps" steps;
addtomenu "stepsnorules" stepsnorules;
(* addtomenu "onestep" onestep; *)

(* cmatch

	(* matching strength *)

addtomenu "cmatch" cmatch;

*)

addtomenu "settrace" (fn () => settrace (getintarg (!ARGUMENTS)));
addtomenu "settracelevel" (fn () => settracelevel (getchararg (!ARGUMENTS))
	(getintarg (!ARGUMENTS)));

	(* use of saved environments *)

addtomenu "applyenv" (fn () => applyenv (getchararg (!ARGUMENTS)));
addtomenu "applyconvenv" (fn () => applyconvenv (getchararg (!ARGUMENTS)));

(* Proof commands *)

	(* definition commands *)

addtomenu "defineconstant" (fn () => defineconstant (getchararg(!ARGUMENTS)) 
(getchararg(!ARGUMENTS)));
addtomenu "definetypedinfix" (fn ()=> definetypedinfix (getchararg(!ARGUMENTS))
(getintarg(!ARGUMENTS))(getintarg(!ARGUMENTS))(getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "defineinfix" (fn () => defineinfix (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));
addtomenu "defineconstanttype" (fn () => defineconstanttype 
(getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));
addtomenu "defineinfixtype" (fn () => defineinfixtype (getchararg(!ARGUMENTS))
(getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS))(getchararg(!ARGUMENTS)));

	(* axiom commands *)

addtomenu "axiom" (fn () => axiom (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));
addtomenu "a" (fn () => axiom (getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));
addtomenu "statement" (fn () => statement(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));

	(* rexiomatization *)

addtomenu "proveanaxiom" (fn () => proveanaxiom (getchararg (!ARGUMENTS)));
addtomenu "makeanaxiom" (fn () => makeanaxiom (getchararg (!ARGUMENTS)));
addtomenu "undefine" (fn () => undefine (getchararg (!ARGUMENTS)));
addtomenu "makeadefinition" (fn () => 
	makeadefinition (getchararg (!ARGUMENTS)));

	(* proof commands proper *)

addtomenu "prove" (fn () => prove (getchararg (!ARGUMENTS)));
addtomenu "p" (fn () => prove (getchararg (!ARGUMENTS)));

addtomenu "reprove" (fn () => reprove (getchararg (!ARGUMENTS)));
addtomenu "rp" (fn () => rp (getchararg (!ARGUMENTS)));
addtomenu "autoreprove" autoreprove;

addtomenu "verify" (fn () => verify (getchararg (!ARGUMENTS)));
addtomenu "clearerrorflag" clearerrorflag;

	(* oops *)

addtomenu "forget" (fn () => forget (getchararg (!ARGUMENTS)));

(* theory handling commands *)

	(* clear commands *)

addtomenu "clear" clear;
addtomenu "cleartheories" cleartheories;

	(* theory desktop commands *)

addtomenu "backuptheory" backuptheory;
addtomenu "gettheory" (fn () => gettheory(getchararg(!ARGUMENTS)));
addtomenu "droptheory" (fn () => droptheory(getchararg(!ARGUMENTS)));

	(* theory file commands *)

addtomenu "storeall" (fn () => storeall (getchararg (!ARGUMENTS)));
addtomenu "safesave" safesave;
addtomenu "load" (fn () => load (getchararg (!ARGUMENTS)));

	(* script command *)

addtomenu "script" (fn () => script (getchararg(!ARGUMENTS)));
addtomenu "truescript" (fn () => script (getchararg(!ARGUMENTS)));
addtomenu "Script" (fn () => script (getchararg(!ARGUMENTS)));
addtomenu "makescript" (fn () => makescript (getchararg(!ARGUMENTS)));

(* GUI stuff *)

addtomenusecure "guistart" guistart;
addtomenusecure "guidone" guidone;

(* View management and theorem export *)

addtomenu "declareview" (fn () => declareview (getchararg (!ARGUMENTS)));
addtomenu "restoreview" (fn () => restoreview (getchararg (!ARGUMENTS)));
addtomenu "backupview" (fn () => backupview (getchararg (!ARGUMENTS)));

addtomenu "addtoview" (fn () => addtoview 
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));

addtomenu "dropfromview" (fn () => dropfromview 
	(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS)));

addtomenu "dropview" (fn () => dropview (getchararg (!ARGUMENTS)));

addtomenu "exportthm" (fn () => exportthm 
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS))
(getchararg (!ARGUMENTS))(getchararg (!ARGUMENTS))));

(* more setup functions for compiled version *)

(* reserved new operators !@ and !$ for automatic parameterization of
theorems *)

fun reserveflat () = map (reserveop 0 0) ["<*","*>","<<=","=>>","|-|",
"=",":","=!",
">!","<!","%!","/!","*!","-!","+!","<=","=>",",","||","!@","!$"];


fun setup () = ((* RESERVED:=nil; *)reserveflat();
	reserveop 1 0 "@";
	reserveop 1 0 "@!";
	reserveop 1 0 "@`"; (* a dummy operation with 
				same type as @ for matching *)
	NEWDEPS:=nil;
	SCINSCOUT := nil;
	SCRIPTS:=nil;
	setupmenu(); mainmenu(); cleartheories(); setbasicview());

(* val _ = addtomenu "guidone" guidone;
val _ = addtomenu "guistart" guistart; *)

(* the following line eliminates the need to run setup() *)

val _ = setup();