diff --git a/contrib/CATALOG.TXT b/contrib/CATALOG.TXT
new file mode 100644
index 0000000000000000000000000000000000000000..99796fae142834636fd18b2701fdbca03039f6cb
--- /dev/null
+++ b/contrib/CATALOG.TXT
@@ -0,0 +1,291 @@
+Package Name:
+   DEMOS
+
+Description:
+   Graphics demonstration programs for CMU Common Lisp using version 11 of the
+X Window System.
+
+Author:
+   CMU Common Lisp Group.
+
+Maintainer:
+   CMU Common Lisp Group.
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   slisp-group@b
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   demos.lisp, demos.fasl, demos.catalog.
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>:
+   cp /afs/cs.cmu.edu/project/slisp/library/demos/* <spec>
+
+Portability:
+   Should run in any Common Lisp supporting CLX V11R3.
+
+Instructions:
+   The function DEMOS:DO-ALL-DEMOS will run through each of the demos once, and
+the function DEMOS:DEMO will present a menu of all the demos.
+
+
+Name:
+   Follow Mouse.
+
+Package Name:
+   HEMLOCK
+
+Description:
+   This Hemlock customization causes Hemlock's current window to be set to
+whatever Hemlock window the mouse enters, except the echo area.
+
+Author:
+   Todd Kaufmann, modified by Dave Touretzky.
+
+Maintainer:
+   Todd Kaufmann.
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   Todd.Kaufmann@CS.CMU.EDU
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   follow-mouse.lisp, follow-mouse.fasl, follow-mouse.catalog.
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>:
+   cp /afs/cs.cmu.edu/project/slisp/library/follow-mouse/* <spec>
+
+Portability:
+   This should work in any Common Lisp supporting Hemlock and CLX V11R3.
+
+Instructions:
+   Load the fasl file into your editor Lisp.  A value of T for the hemlock
+variable "Follow Mouse To Read-Only Buffers", which is the default, means
+follow mouse is on.  Anything else means hemlock will behave normally.
+
+Bugs:
+   A few more PROMPT-FOR-... functions need to be modified.  They are mentioned
+in the source code.
+
+
+Package Name:
+   HIST
+
+Description:
+   Simple histogram facility using Format strings for output.
+
+Author:
+   Scott E. Fahlman
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   Scott.Fahlman@CS.CMU.EDU
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   hist.lisp, hist.fasl, hist.catalog
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>.
+   cp /afs/cs.cmu.edu/project/slisp/library/hist/* <spec>
+
+Portability:
+   Should run in any legal Common Lisp.
+
+Instructions:
+   Hist is a macro of form (HIST (min max [bucket-size]) . body)
+
+Creates a histogram with buckets of the specified size (defaults to 1),
+spanning the range from Low (inclusive) to High (exclusive), with two
+additional buckets to catch values below and above this range.  The body is
+executed as a progn, and every call to Hist-Record within the body provides a
+value for the histogram to count.  When Body exits, the histogram is printed
+out and Hist returns Nil.
+
+A simple example:
+   (hist (0 10) (dotimes (i 1000) (random 10)))
+This example may make the RANDOM distribution look more normal:
+   (hist (0 10 2) (dotimes (i 1000) (random 10)))
+This example will show you overflow buckets:
+   (hist (2 12) (dotimes (i 1000) (random 15)))
+
+Wish List:
+   Some sort of automatic scaling for the number and size of buckets would be
+nice, if the user chooses not to supply these.  This would probably require
+running the body twice, once to determine the spread of values, and again to
+actually produce the histogram.
+
+
+Name:
+   OPS
+
+Package Name:
+   OPS
+
+Description:
+   Interpreter for Ops5, a programming language for production systems.
+
+Author:
+   Charles L. Forgy.  Ported to Common lisp by George Wood and Jim Kowalski.
+CMU Common Lisp mods by Dario Guise, Skef Wholey, and Dan Kuokka.
+
+Maintainer:
+   CMU Common Lisp Group.
+
+Net Address:
+   slisp-group@b
+
+Copyright Status:
+   Public domain.
+
+Files:
+   ops.lisp, ops-backup.lisp, ops-compile.lisp, ops-io.lisp, ops-main.lisp,
+ops-match.lisp, ops-rhs.lisp, ops-util.lisp, ops.catalog, ops-demo-mab.lisp,
+ops-demo-ttt.lisp, and binaries.
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>.
+   cp /afs/cs.cmu.edu/project/slisp/library/ops/* <spec>
+
+Portability:
+   Should run in any legal Common Lisp implementation.
+
+Instructions:
+   From Lisp, load "ops" and then go into the OPS package with (in-package
+'ops).  Now you can load your OPS5 code or start typing in productions.
+
+There are two demos -- interactive tic-tac-toe and the monkey and banana
+problem.  To run the former just load it and call RUN.  For the latter, first
+enter "(make start 1)" and then call RUN.
+
+See the OPS5 User's Manual, July 1981, by Forgy, CMU CSD.
+
+Bugs:
+   This has been put in its own package, but only a few interfaces have been
+exported.  You must run in the ops package.
+
+
+Package Name:
+   PROFILE
+
+Description:
+   Provides macros to do simple code profiling things.
+
+Author:
+   Skef Wholey
+   Rob MacLachlan
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   ram@cs.cmu.edu
+
+Copyright Status:
+   Public Domain
+
+Files:
+   profile.lisp, profile.fasl, profile.doc, profile.catalog
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>:
+   cp /afs/cs.cmu.edu/project/slisp/library/profile/* <spec>
+
+Portability:
+   Should run in any Common Lisp.  Someone porting this may want to change a
+few things mentioned in profile.lisp to tune it to another implementation.
+
+Instructions:
+   See the file profile.doc for details.
+
+
+Name:
+   PSgrapher
+
+Description:
+   The PSgrapher is a set of Lisp routines that can be called to produce
+Postscript commands that display a directed acyclic graph.
+
+Author:
+   Joseph Bates.  Skef put the whole thing in the PSGRPAPH package and added
+functionality which allows the user to specify EQ, EQUAL, or EQUALP as the
+node equivalence function.  Bill made all exported symbols have stars on them.
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   Joseph.Bates@CS.CMU.EDU
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>.
+   cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec>
+
+Portability:
+   Should run in any legal Common Lisp.  Requires Postscript for printing.
+
+Instructions:
+   See psgraph.doc.
+
+Bugs:
+   This code blindly outputs what the user gives it as node labels.  It should
+run through the output escaping any PS control characters.  For example, if
+node labels contain parentheses, your output PS file will not print.
+
+Examples:
+   Skef Wholey submitted this as a reasonable example:
+
+;;; I use this in my compiler so I can look at code trees without
+;;; crawling around them in the inspector.  The postsript previewer
+;;; groks the generated ps file, which is bitchin' marvy.
+
+   (defun code-graph-to-file (s file &optional shrink insert)
+     (let ((psgraph:*fontname* "Times-Roman")
+	   (psgraph:*fontsize* 8)
+	   (psgraph:*second-fontname* "Times-BoldItalic")
+	   (psgraph:*second-fontsize* 6)
+	   (psgraph:*boxgray* "0")
+	   (psgraph:*edgegray* "0")
+	   (psgraph:*extra-x-spacing* 30))
+       (with-open-file (*standard-output* file
+					  :direction :output
+					  :if-exists :supersede)
+	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
diff --git a/contrib/READ-ME.TXT b/contrib/READ-ME.TXT
new file mode 100644
index 0000000000000000000000000000000000000000..7e9800b6a4fbd091f4be8251362436f415fc927a
--- /dev/null
+++ b/contrib/READ-ME.TXT
@@ -0,0 +1,132 @@
+DESCRIPTION OF THE CMU COMMON LISP LIBRARY AND CATALOG ENTRY FORMAT.
+
+The CMU Common Lisp library contains a variety of useful or interesting
+software packages written by users of CMU Common Lisp.  Each entry is contained
+in its own subdirectory.  The CATALOG.TXT describes every entry in the library.
+Two subdirectories are for library maintainers, library-broken and
+library-maintenance.
+
+To submit a program for inclusion in the library, send mail to Gripe
+pointing to the relevant files and providing the information for the
+catalog entry in the format described below.  The library maintainers will
+verify that the program runs as documented in the current Lisp, has no
+crippling bugs, and that the functionality is not duplicated in some other
+program; then we will add the program to the library.  Programs that are
+made obsolete by later submissions may be dropped from the library, after
+due notice is given to the user community.  Some programs may be deemed so
+useful that they will be included in the standard CMU Common Lisp system.
+
+All source files must be included for each software package in the library.
+Whenever possible, a program should be submitted as a single large file
+rather than as a collection of smaller files; this will help to minimize
+version-control problems.
+
+Note: We plan to distribute this software freely over the Arpanet and we
+may set up some mechanism to provide non-arpanet users with tapes.  We can
+in general accept only public-domain code (anything with no copyright
+notice in the source will be assumed to be in the public domain) and code
+for which Carnegie-Mellon University holds the copyright.  If you have any
+code of commercial value, the copyright system provides little real
+protection in any case.
+
+Bugs in library programs not listed in the "bugs" section of the program's
+description should be reported to the maintainer listed below (or to the
+author if there is no maintainer), with CC to Gripe.
+
+Send any questions or comments to Gripe.
+
+
+CATALOG ENTRY FORMAT FOR CATALOG.TXT.
+
+Each entry is on a separate page, separated by the page mark Control-L.
+
+Each entry consists of fields.  Each new field begins on a fresh line with a
+field name terminated by a colon.  Then on a new line, indented at least one
+space, is an arbitrary amount of text.  This somewhat rigid format is designed
+to make it easy to build various sorts of software to automatically manipulate
+catalogs, but the indentation is simply a convenience for paragraph
+manipulation and filling commands in the editor.  The field names are sensitive
+to spelling, but insensitive to case and extra whitespace.
+
+The following is a specification of the possible fields in the catalog format:
+
+Name:		or
+Module Name:
+   This specifies the name of the program or set of programs.  If the supplier
+of the entry does not specify a Package Name, then this is the package in which
+the code lives.
+
+Package Name:
+   If the programs are loaded into a package of their own, this is the name of
+that package.  If the supplier of the entry does not specify a Name or Module
+Name, the package name will be used as the name for everything.
+
+Description:
+   This is a brief description of what the program does.
+
+Author:
+   This is the name of the author, or "anonymous".
+
+Maintainer:
+   This is the name of the current maintainer, if different from the author.
+If a program is not being maintained by anyone, the Maintainer is "none".
+
+Address:		or
+Address of Author:	or
+Address of Maintainer:
+   This is the physical mailing address of the author or maintainer.  If the
+field is just "address", it is assumed to be the maintainer if one is
+specified, and the author otherwise.
+
+Net Address:			or
+Net Address of Author:		or
+Net Address of Maintainer:
+   This is a network address that can be reached from the arpanet.
+
+Copyright Status:
+   This is "Public domain.", or some sort of copyright notice.
+
+Files:
+   This is a list of the files that constitute this facility.  For example, a
+system named "Foo" may be distributed as files "foo.lisp", "foo.fasl", and
+(optionally) "foo.doc" or "foo.PS" for documentation.  In order to minimize
+maintenance headaches and encourage people to build on the work of others, we
+want all programs in the library to include complete sources.
+
+How to Get:
+   This can either be a shell command using such programs as lcp or cp, or
+there may be a .cmd file that will copy all the sources, binaries, catalog, and
+log files to the user's current directory.  This .cmd file will try to preserve
+write date (such as using -p with cp).
+
+Portability:
+   If the program will run in any legal Common Lisp, say so.  If there are
+known dependencies on CMU Common Lisp specific or Mach/RT specific features,
+describe them here.  Programs relying on CLX, CLOS, etc. should be considered
+to have a high expectation of portability.
+
+Dependencies:
+   If the program requires other library packages not built into the standard
+CMU Common Lisp core image, list those other packages here.
+
+Instructions:
+   Place here any instructions for use that are too lengthy to be mere
+documentation strings, but that are not lengthy enough to deserve a separate
+document.
+
+Recent Changes:
+   What is different between this version and the one that preceded it, if any.
+(May go back several versions at the author's discretion.)
+
+Bugs:
+   Describe here any known bugs or treacherous features.
+
+Future Plans:
+   Describe here any improvements planned by the author.
+
+Wish List:
+   Describe here any desirable features that the author does not plan to work
+on in the near future.
+
+Notes:
+   This is anything else that users or potential users ought to know about.
diff --git a/contrib/defsystem/defsystem.lisp b/contrib/defsystem/defsystem.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..33c2541f89dfeee4b06fde241dd9424d4a54137b
--- /dev/null
+++ b/contrib/defsystem/defsystem.lisp
@@ -0,0 +1,1217 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp -*-
+ 
+;;; ********************************************************************
+;;; Portable Mini-DefSystem ********************************************
+;;; ********************************************************************
+;;; Fri Feb  2 10:24:17 1990 by Mark Kantrowitz <mkant@GS8.SP.CS.CMU.EDU>
+
+;;; This is a portable system definition facility for Common Lisp. 
+;;; Though home-grown, the syntax was inspired by fond memories of the
+;;; defsystem facility on Symbolics 3600's. The exhaustive lists of
+;;; filename extensions for various lisps and the idea to have one
+;;; "operate-on-system" function instead of separate "compile-system"
+;;; and "load-system" functions were taken from Xerox Corp.'s PCL 
+;;; system.
+
+;;; This system improves on both PCL and Symbolics defsystem utilities
+;;; by performing a topological sort of the graph of file-dependency 
+;;; constraints. Thus, the components of the system need not be listed
+;;; in any special order, because the defsystem command reorganizes them
+;;; based on their constraints. It includes all the standard bells and
+;;; whistles, such as not recompiling a binary file that is up to date
+;;; (unless the user specifies that all files should be recompiled).
+
+;;; Written by Mark Kantrowitz, School of Computer Science, 
+;;; Carnegie Mellon University, October 1989.
+
+;;; Copyright (c) 1989 by Mark Kantrowitz. All rights reserved.
+
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted, so long as the following
+;;; conditions are met:
+;;;      o no fees or compensation are charged for use, copies, or
+;;;        access to this software
+;;;      o this copyright notice is included intact.
+;;; This software is made available AS IS, and no warranty is made about 
+;;; the software or its performance. 
+
+;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. 
+
+
+;;; ********************************************************************
+;;; How to Use this System *********************************************
+;;; ********************************************************************
+
+;;; To use this system,
+;;; 1. If you want to have a central registry of system definitions, 
+;;;    modify the value of the variable *central-registry* below.
+;;; 2. Load this file (defsystem.lisp) in either source or compiled form,
+;;; 3. Load the file containing the "defsystem" definition of your system,
+;;; 4. Use the function "operate-on-system" to do things to your system.
+
+;;; For more information, see the documentation and examples in defsystem.text.
+
+;;; ****************************************************************
+;;; Lisp Code ******************************************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Set up Package *****************
+;;; ********************************
+
+(in-package "DEFSYSTEM" 
+	    :nicknames '("DEFSYS" "MAKE")
+	    :use '("USER"
+		   "LISP")
+	    )
+
+(provide 'defsystem)
+
+(defvar *exports*
+   '(defsystem operate-on-system oos afs-binary-directory files-in-system))
+
+(defvar *other-exports* 
+  '(*central-registry* *bin-subdir* 
+     machine-type-translation software-type-translation
+					;require
+     allegro-make-system-fasl files-which-need-compilation 
+     ))
+
+(export (append *exports* *other-exports*))
+#|
+;(import *exports* "LISP")
+;(import *exports* "USER")
+|#
+
+#-(OR CMU :CCL)
+(import *exports* "USER")
+#+(OR CMU :CCL)
+(progn
+  (import (cdr *exports*) "USER")
+  (shadowing-import (car *exports*) "USER"))
+
+#-PCL(when (find-package "PCL") (push :pcl *modules*)(push :pcl *features*))
+
+
+
+;;; ********************************
+;;; Customizable System Parameters *
+;;; ********************************
+
+;;; Change this variable to set up the location of a central
+;;; repository for system definitions if you want one.
+(defvar *central-registry* "/afs/cs.cmu.edu/project/oz/oz2/system/Registry/" 
+  "Central directory of system definitions" )
+
+(defvar *bin-subdir* ".bin/"
+  "The subdirectory of an AFS directory where the binaries are really kept.")
+
+;;; These variables set up defaults for operate-on-system, and are used 
+;;; for communication in lieu of parameter passing. Yes, this is bad,
+;;; but it keeps the interface small. Also, in the case of the -if-no-binary
+;;; variables, parameter passing would require multiple value returns
+;;; from some functions. Why make life complicated?
+(defvar *tell-user-when-done* nil
+  "If T, system will print ...DONE at the end of an operation")
+(defvar *oos-verbose* nil 
+  "Operate on System Verbose Mode")
+(defvar *oos-test* nil 
+  "Operate on System Test Mode")
+(defvar *load-source-if-no-binary* nil
+  "If T, system will try loading the source if the binary is missing")
+(defvar *bother-user-if-no-binary* t
+  "If T, the system will ask the user whether to load the source if the binary is missing")
+(defvar *load-source-instead-of-binary* nil
+  "If T, the system will load the source file instead of the binary.")
+
+;;; Particular to CMULisp
+(defvar *compile-error-file-type* "err"
+  "File type of compilation error file in cmulisp")
+(defvar *cmu-errors-to-terminal* t
+  "Argument to :errors-to-terminal in compile-file in cmulisp")
+(defvar *cmu-errors-to-file* t
+  "If T, cmulisp will write an error file during compilation")
+
+;;; ********************************
+;;; Global Variables ***************
+;;; ********************************
+
+;;; Massage people's *features* into better shape.
+(eval-when (compile load eval)  
+  (dolist (feature *features*)
+    (when (and (symbolp feature)   ; 3600
+               (equal (symbol-name feature) "CMU"))
+      (pushnew :CMU *features*)))
+  
+  #+Lucid
+  (when (search "IBM RT PC" (machine-type))
+    (pushnew :ibm-rt-pc *features*))
+  )
+
+;;; *filename-extensions* is a cons of the source and binary extensions.
+(defvar *filename-extensions*
+  (car '(#+(and Symbolics Lispm)              ("lisp" . "bin")
+         #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
+         #+(and dec common vax ultrix)        ("lsp"  . "fas")
+         #+KCL                                ("lsp"  . "o")
+         #+IBCL                               ("lsp"  . "o")
+         #+Xerox                              ("lisp" . "dfasl")
+         #+(and Lucid MC68000)                ("lisp" . "lbin")
+         #+(and Lucid Vax)                    ("lisp" . "vbin")   
+         #+(and Lucid Prime)                  ("lisp" . "pbin")
+         #+(and Lucid SUNRise)                ("lisp" . "sbin")
+         #+(and Lucid SPARC)                  ("lisp" . "sbin")
+         #+(and Lucid :IBM-RT-PC)              ("lisp" . "bbin")
+         #+excl                               ("cl"   . "fasl")
+         #+:CMU                               ("lisp" . "fasl")
+	 #+PRIME                              ("lisp" . "pbin")
+         #+HP                                 ("l"    . "b")
+         #+TI ("lisp" . #.(string (si::local-binary-file-type)))
+         #+:gclisp                            ("LSP"  . "F2S")
+         #+pyramid                            ("clisp" . "o")
+         #+:coral                             ("lisp" . "fasl")
+         
+         ;; Otherwise,
+         ("lisp" . "lbin")))
+  "Filename extensions for Common Lisp. A cons of the form
+   (Source-Extension . Binary-Extension). If the system is 
+   unknown (as in *features* not known), defaults to lisp and lbin.")
+
+;;; There is no real support for this variable being nil, so don't change it.
+;;; Note that in any event, the toplevel system (defined with defsystem)
+;;; will have its dependencies delayed. Not having dependencies delayed
+;;; might be useful if we define several systems within one defsystem.
+(defvar *system-dependencies-delayed* t 
+  "If T, system dependencies are expanded at run time")
+
+(defun non-empty-listp (list)
+  (and list (listp list)))
+
+;;; ********************************
+;;; Alist Manipulation *************
+;;; ********************************
+(defun alist-lookup (name alist &key test test-not key)
+  (cdr (assoc name alist :test test :test-not test-not :key key)))
+
+(defmacro set-alist-lookup ((name alist &key test test-not key) value)
+  (let ((pair (gensym)))
+    `(let ((,pair (assoc ,name ,alist :test ,test :test-not ,test-not :key ,key)))
+       (if ,pair
+	   (rplacd ,pair ,value)
+	 (push (cons ,name ,value) ,alist)))))
+
+(defvar *component-operations* nil
+  "Alist of (operation-name function) pairs" )
+(defun component-operation (name &optional operation)
+  (if operation
+      (set-alist-lookup (name *component-operations*) operation)
+    (alist-lookup name *component-operations*)))
+
+;;; ********************************
+;;; AFS @sys immitator *************
+;;; ********************************
+(defun afs-binary-directory (root-directory)
+  ;; Function for obtaining the directory AFS's @sys feature would have
+  ;; chosen when we're not in AFS. This function is useful as the argument
+  ;; to :binary-pathname in defsystem.
+  (let ((machine (machine-type-translation (machine-type)))
+	(software (software-type-translation (software-type))))
+    ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
+    (format nil "~A~@[~A~]~@[~A/~]" 
+	    (namestring root-directory)
+	    *bin-subdir*
+	    (afs-component machine software)
+	    )))
+
+(defun afs-component (machine software)
+  (format nil "~@[~A~]~@[_~A~]" 
+	    machine 
+	    (or software "mach")))
+
+(defvar *machine-type-alist* nil
+  "Alist for retrieving the machine-type")
+(defun machine-type-translation (name &optional operation)
+  (if operation
+      (set-alist-lookup (name *machine-type-alist* :test #'string-equal) operation)
+    (alist-lookup name *machine-type-alist* :test #'string-equal)))
+
+(machine-type-translation "IBM RT PC"   "rt")
+(machine-type-translation "DEC 3100"    "pmax")
+(machine-type-translation "DEC VAX-11"  "vax")
+(machine-type-translation "Sun3"        "sun3")
+
+(defvar *software-type-alist* nil
+  "Alist for retrieving the software-type")
+(defun software-type-translation (name &optional operation)
+  (if operation
+      (set-alist-lookup (name *software-type-alist* :test #'string-equal) operation)
+    (alist-lookup name *software-type-alist* :test #'string-equal)))
+
+(software-type-translation "BSD UNIX" "mach") ; "unix"
+(software-type-translation "Ultrix" "mach") ; "ultrix"
+(software-type-translation "SunOS" "SunOS")
+(software-type-translation "MACH/4.3BSD" "mach")
+
+;;; ********************************
+;;; System Names *******************
+;;; ********************************
+(defun canonicalize-system-name (name)
+  ;; Names of modules or files may be symbols or strings, but
+  ;; names of systems must be symbols for accessing the system.
+  (if (symbolp name)
+      name
+      (intern (string-upcase (string name)))))
+
+(defun get-system (name)
+  ;; The system definition is stored under the
+  ;; 'system property of the system name.
+  (get (canonicalize-system-name name) 'system))
+
+(defsetf get-system (name) (value)
+  `(setf (get (canonicalize-system-name ,name) 'system) ,value))
+
+;;; ********************************
+;;; Directory Pathname Hacking *****
+;;; ********************************
+
+;;; There is no CL primitive for tacking a subdirectory onto a directory.
+;;; Such a primitive is needed since we use both absolute and relative 
+;;; directories. The merge-directories function was a try that failed
+;;; (we're keeping it around to prevent future mistakes of that sort),
+;;; while the append-directories function seems to work right most
+;;; of the time (i.e., it gets the pathname delimiters right).
+
+;;; Unix example: An absolute directory starts with / while a 
+;;; relative directory doesn't. A directory ends with /, while
+;;; a file's pathname doesn't. This is important 'cause
+;;; (pathname-directory "foo/bar") will return "foo" and not "foo/".
+
+(defun append-directories (absolute-directory relative-directory)
+  ;; Assumptions: Absolute-directory is a directory, with no
+  ;; filename stuck on the end. Relative-directory, however, may
+  ;; have a filename stuck on the end.
+  (when (or absolute-directory relative-directory)
+	#+ExCL(when (and (stringp absolute-directory)
+			 (null-string absolute-directory))
+		    (setq absolute-directory nil))
+	#+CMU(when (pathnamep absolute-directory) 
+		   (setq absolute-directory (namestring absolute-directory)))
+	#+CMU(when (pathnamep relative-directory) 
+		   (setq relative-directory (namestring relative-directory)))
+	(namestring (make-pathname :directory absolute-directory 
+				   :name relative-directory))))
+
+(defun null-string (s)
+  (string-equal s ""))
+
+#|
+<cl> (defun d (d n) (namestring (make-pathname :directory d :name n)))
+
+D
+<cl> (d "/foo/bar/" "baz/barf.lisp")
+
+"/foo/bar/baz/barf.lisp"
+<cl> (d "foo/bar/" "baz/barf.lisp")
+
+"foo/bar/baz/barf.lisp"
+<cl> (d "foo/bar" "baz/barf.lisp")
+
+"foo/bar/baz/barf.lisp"
+<cl> (d "foo/bar" "/baz/barf.lisp")
+
+"foo/bar//baz/barf.lisp"
+<cl> (d "foo/bar" nil)
+
+"foo/bar/"
+<cl> (d nil "baz/barf.lisp")
+
+"baz/barf.lisp"
+<cl> (d nil nil)
+
+""
+
+|#
+
+#|
+(defun merge-directories (absolute-directory relative-directory)
+	  ;; replace concatenate with something more intelligent
+	  ;; i.e., concatenation won't work with some directories.
+	  ;; it should also behave well if the parent directory 
+	  ;; has a filename at the end, or if the relative-directory ain't relative
+	  (when absolute-directory 
+	    (setq absolute-directory (pathname-directory absolute-directory)))
+	  (concatenate 'string 
+		       (or absolute-directory "")
+		       (or relative-directory "")))
+|#
+
+(defun namestring-or-nil (pathname)
+  (when pathname
+    (namestring pathname)))
+
+(defun new-file-type (pathname type)
+  (make-pathname
+   :host (pathname-host pathname)
+   :device (pathname-device pathname)
+   :directory (pathname-directory pathname)
+   :name (pathname-name pathname)
+   :type type
+   :version (pathname-version pathname)))
+
+;;; ********************************
+;;; Component Defstruct ************
+;;; ********************************
+(defstruct (topological-sort-node (:conc-name topsort-))
+  color
+  time)
+
+(defstruct (component (:include topological-sort-node)
+                      (:print-function print-component))
+  type                ; :system, :module, or :file, or :private-file
+  name                ; a symbol or string
+  indent              ; number of characters of indent in verbose output to the user.
+  host                ; the pathname host (i.e., "/../a")
+  device              ; the pathname device
+  source-root-dir
+  source-pathname     ; relative or absolute (starts with "/"), directory or file (ends with "/")
+  source-extension    ; a string, e.g., "lisp". If nil, uses default for machine-type
+  binary-pathname
+  binary-root-dir
+  binary-extension    ; a string, e.g., "fasl". If nil, uses default for machine-type
+  package             ; package for use-package
+  components          ; a list of components comprising this component's definition
+  depends-on          ; a list of the components this one depends on. may refer only
+                      ; to the components at the same level as this one.
+  initially-do        ; form to evaluate before the operation
+  finally-do          ; form to evaluate after the operation
+  compile-form        ; for foreign libraries
+  load-form           ; for foreign libraries
+)
+
+(defun print-component (component stream depth)
+  (declare (ignore depth))
+  (format stream "#<~:(~A~) ~A>"
+          (component-type component)
+          (component-name component)))
+
+(defun canonicalize-component-name (component)
+  ;; Within the component, the name is a string.
+  (if (typep (component-name component) 'string)
+      ;; Unnecessary to change it, so just return it, same case
+      (component-name component)
+    ;; Otherwise, make it a downcase string
+    (setf (component-name component) 
+	  (string-downcase (string (component-name component))))))
+
+(defun component-pathname (component type)
+  (when component
+    (case type
+      (:source (component-source-pathname component))
+      (:binary (component-binary-pathname component))
+      (:error  (component-error-pathname component)))))
+(defun component-error-pathname (component)
+  (let ((binary (component-pathname component :binary)))
+    (new-file-type binary *compile-error-file-type*)))
+(defsetf component-pathname (component type) (value)
+  `(when ,component
+     (case ,type
+       (:source (setf (component-source-pathname ,component) ,value))
+       (:binary (setf (component-binary-pathname ,component) ,value)))))
+
+(defun component-root-dir (component type)
+  (when component
+    (case type
+      (:source (component-source-root-dir component))
+      ((:binary :error) (component-binary-root-dir component))
+      )))
+(defsetf component-root-dir (component type) (value)
+  `(when ,component
+     (case ,type
+       (:source (setf (component-source-root-dir ,component) ,value))
+       (:binary (setf (component-binary-root-dir ,component) ,value)))))
+
+(defvar *version-dir* nil
+  "The version subdir. bound in oos.")
+(defvar *version-replace* nil
+  "The version replace. bound in oos.")
+(defvar *version* nil
+  "Default version")
+(defun component-full-pathname (component type &optional (version *version*)
+					  &aux version-dir replace)
+  (when component
+    ;; If the pathname-type is :binary and the root pathname is null,
+    ;; distribute the binaries among the sources (= use :source pathname).
+    ;; This assumes that the component's :source pathname has been set
+    ;; before the :binary one.
+    (if version
+	(multiple-value-setq (version-dir replace) (translate-version version))
+      (setq version-dir *version-dir* replace *version-replace*))
+    (let ((pathname
+	   (append-directories 
+	    (if replace
+		version-dir
+	      (append-directories (component-root-dir component type)
+				  version-dir))
+	    (component-pathname component type))))
+      (make-pathname :name (pathname-name pathname)
+		     :type (component-extension component type)
+		     :host (pathname-host (component-host component))
+		     :device #+CMU :absolute
+		             #-CMU (pathname-device (component-device component))
+		     ;; :version :newest
+		     ;; Use :directory instead of :defaults
+		     :directory (pathname-directory pathname)))))
+
+(defun translate-version (version)
+  ;; Value returns the version directory and whether it replaces 
+  ;; the entire root (t) or is a subdirectory.
+  ;; Version may be nil to signify no subdirectory,
+  ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
+  ;; specifies a subdirectory of the root, or
+  ;; a string, which replaces the root.
+  (cond ((null version) 
+	 (values "" nil))
+	((symbolp version)
+	 (values (string-downcase (string version)) nil))
+	((stringp version)
+	 (values version t))
+	(t (error "~&; Illegal version ~S" version))))
+
+(defun component-extension (component type)
+  (case type
+    (:source (component-source-extension component))
+    (:binary (component-binary-extension component))
+    (:error  *compile-error-file-type*)))
+(defsetf component-extension (component type) (value)
+  `(case ,type
+     (:source (setf (component-source-extension ,component) ,value))
+     (:binary (setf (component-binary-extension ,component) ,value))
+     (:error  (setf *compile-error-file-type* ,value))))
+
+;;; ********************************
+;;; System Definition **************
+;;; ********************************
+(defmacro defsystem (name &rest definition-body)    
+  `(create-component :system ',name ',definition-body nil 0))
+
+(defun create-component (type name definition-body &optional parent (indent 0))
+  (let ((component (apply #'make-component :type type :name name :indent indent definition-body)))
+    ;; Initializations/after makes
+    (canonicalize-component-name component)
+
+    ;; Type specific setup:
+    (when (eq type :system)
+      (setf (get-system name) component))
+
+    ;; Set up the component's pathname
+    (create-component-pathnames component parent)
+
+    ;; If there are any components of the component, expand them too.
+    (expand-component-components component (+ indent 2))
+
+    ;; Make depends-on refer to structs instead of names.
+    (link-component-depends-on (component-components component))
+
+    ;; Design Decision: Topologically sort the dependency graph at
+    ;; time of definition instead of at time of use. Probably saves a
+    ;; little bit of time for the user.
+
+    ;; Topological Sort the components at this level.
+    (setf (component-components component)
+          (topological-sort (component-components component)))
+
+    ;; Return the component.
+    component))
+
+(defun create-component-pathnames (component parent)
+  ;; Evaluate the root dir arg
+  (setf (component-root-dir component :source)
+	(eval (component-root-dir component :source)))
+  (setf (component-root-dir component :binary)
+	(eval (component-root-dir component :binary)))
+  ;; Evaluate the pathname arg
+  (setf (component-pathname component :source)
+	(eval (component-pathname component :source)))
+  (setf (component-pathname component :binary)
+	(eval (component-pathname component :binary)))
+  ;; Pass along the host and devices
+  (setf (component-host component)
+	(or (component-host component)
+	    (when parent (component-host parent))))
+  (setf (component-device component)
+	(or (component-device component)
+	    (when parent (component-device parent))))
+  ;; Set up extension defaults
+  (setf (component-extension component :source)
+	(or (component-extension component :source) ; for local defaulting
+	    (when parent		; parent's default
+	      (component-extension parent :source))
+	    (car *filename-extensions*))) ; system default
+  (setf (component-extension component :binary)
+	(or (component-extension component :binary) ; for local defaulting
+	    (when parent		; parent's default
+	      (component-extension parent :binary))
+	    (cdr *filename-extensions*))) ; system default
+  ;; Set up pathname defaults -- expand with parent
+  ;; We must set up the source pathname before the binary pathname
+  ;; to allow distribution of binaries among the sources to work.
+  (generate-component-pathname component parent :source)
+  (generate-component-pathname component parent :binary))
+
+;; maybe file's inheriting of pathnames should be moved elsewhere?
+(defun generate-component-pathname (component parent pathname-type)
+  ;; Pieces together a pathname for the component based on its component-type.
+  ;; Assumes source defined first.
+  ;; Null binary pathnames inherit from source instead of the component's
+  ;; name. This allows binaries to be distributed among the source if
+  ;; binary pathnames are not specified. Or if the root directory is
+  ;; specified for binaries, but no module directories, it inherits
+  ;; parallel directory structure.
+  (case (component-type component)
+    (:system				; Absolute Pathname
+     ;; Set the root-dir to be the absolute pathname
+     (setf (component-root-dir component pathname-type)
+	   (or (component-pathname component pathname-type)
+	       (when (eq pathname-type :binary)
+		 ;; When the binary root is nil, use source.
+		 (component-root-dir component :source))) )
+     ;; Set the relative pathname to be nil
+     (setf (component-pathname component pathname-type) 
+	   nil));; should this be "" instead?
+    ;; If the name of the component-pathname is nil, it
+    ;; defaults to the name of the component. Use "" to
+    ;; avoid this defaulting.
+    (:private-file                      ; Absolute Pathname
+     ;; Root-dir is the directory part of the pathname
+     (setf (component-root-dir component pathname-type)
+	   ""
+	   #+ignore(or (when (component-pathname component pathname-type)
+			 (pathname-directory 
+			  (component-pathname component pathname-type)))
+		       (when (eq pathname-type :binary)
+			 ;; When the binary root is nil, use source.
+			 (component-root-dir component :source)))
+	   )
+     ;; The relative pathname is the name part
+     (setf (component-pathname component pathname-type)
+	   (or (when (and (eq pathname-type :binary)
+			  (null (component-pathname component :binary)))
+		 ;; When the binary-pathname is nil use source.
+		 (component-pathname component :source))
+	       (or (when (component-pathname component pathname-type)
+;		     (pathname-name )
+		     (component-pathname component pathname-type))
+		   (component-name component)))))
+    (:module				; Pathname relative to parent.
+     ;; Inherit root-dir from parent
+     (setf (component-root-dir component pathname-type)
+	   (component-root-dir parent pathname-type))
+     ;; Tack the relative-dir onto the pathname
+     (setf (component-pathname component pathname-type)
+	   (or (when (and (eq pathname-type :binary)
+			  (null (component-pathname component :binary)))
+		 ;; When the binary-pathname is nil use source.
+		 (component-pathname component :source))
+	       (append-directories
+		(component-pathname parent pathname-type)
+		(or (component-pathname component pathname-type)
+		    (component-name component))))))
+    (:file				; Pathname relative to parent.
+     ;; Inherit root-dir from parent
+     (setf (component-root-dir component pathname-type)
+	   (component-root-dir parent pathname-type))
+     ;; Tack the relative-dir onto the pathname
+     (setf (component-pathname component pathname-type)
+	   (or (append-directories
+		(component-pathname parent pathname-type)
+		(or (component-pathname component pathname-type)
+		    (component-name component)
+		    (when (eq pathname-type :binary)
+		      ;; When the binary-pathname is nil use source.
+		      (component-pathname component :source)))))))
+    ))	   
+
+(defun expand-component-components (component &optional (indent 0)) 
+  (setf (component-components component)
+        (mapcar #'(lambda (definition)
+                    (expand-component-definition definition component indent))
+                (component-components component))))
+
+(defun expand-component-definition (definition parent &optional (indent 0))
+  ;; Should do some checking for malformed definitions here.
+  (cond ((null definition) nil)
+        ((stringp definition) 
+         ;; Strings are assumed to be of type :file
+         (create-component :file definition nil parent indent))
+        ((and (listp definition)
+              (not (member (car definition) 
+			   '(:system :module :file :private-file))))
+         ;; Lists whose first element is not a component type
+         ;; are assumed to be of type :file
+         (create-component :file (car definition) (cdr definition) parent indent))
+        ((listp definition)
+         ;; Otherwise, it is (we hope) a normal form definition
+         (create-component (car definition)   ; type
+                           (cadr definition)  ; name
+                           (cddr definition)  ; definition body
+                           parent             ; parent
+			   indent)            ; indent
+         )))
+
+(defun link-component-depends-on (components)
+  (dolist (component components)
+    (unless (and *system-dependencies-delayed*
+                 (eq (component-type component) :system))
+      (setf (component-depends-on component)
+            (mapcar #'(lambda (dependency)
+                        (find (string dependency) components :key #'component-name 
+                              :test #'string-equal)) 
+                    (component-depends-on component))))))
+
+;;; ********************************
+;;; Topological Sort the Graph *****
+;;; ********************************
+(defun topological-sort (list &aux (time 0))
+  ;; The algorithm works by calling depth-first-search to compute the
+  ;; blackening times for each vertex, and then sorts the vertices into
+  ;; reverse order by blackening time.
+  (labels ((dfs-visit (node)
+             (setf (topsort-color node) 'gray)
+             (unless (and *system-dependencies-delayed*
+                          (eq (component-type node) :system))
+               (dolist (child (component-depends-on node))
+                 (cond ((eq (topsort-color child) 'white)
+                        (dfs-visit child))
+                       ((eq (topsort-color child) 'gray)
+                        (format t "~&Detected cycle containing ~A" child)))))
+             (setf (topsort-color node) 'black)
+             (setf (topsort-time node) time)
+             (incf time)))
+    (dolist (node list)
+      (setf (topsort-color node) 'white))
+    (dolist (node list)
+      (when (eq (topsort-color node) 'white)
+        (dfs-visit node)))
+    (sort list #'< :key #'topsort-time)))
+
+;;; ********************************
+;;; Output to User *****************
+;;; ********************************
+;;; All output to the user is via the tell-user functions.
+
+(defun split-string (string &key (item #\space) (test #'char=))
+  ;; Splits the string into substrings at spaces.
+  (let ((len (length string))
+	(index 0) result)
+    (dotimes (i len
+		(progn (unless (= index len)
+			 (push (subseq string index) result))
+		       (reverse result)))
+      (when (funcall test (char string i) item)
+	(unless (= index i);; two spaces in a row
+	  (push (subseq string index i) result))
+	(setf index (1+ i))))))
+
+(defun prompt-string (component)
+  (format nil "; ~:[~;TEST:~]~V,@T "
+	  *oos-test*
+	  (component-indent component)))
+
+(defun format-justified-string (prompt contents)
+  (format t (concatenate 'string "~%" prompt "-~{~<~%" prompt " ~1,80:; ~A~>~^~}")
+	  (split-string contents))
+  (finish-output *standard-output*))
+
+(defun tell-user (what component &optional type no-dots force)
+  (when (or *oos-verbose* force)
+    (format-justified-string (prompt-string component)
+     (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]"
+	     (case what 
+	       ((compile :compile) "Compiling")
+	       ((load :load) "Loading")
+	       (otherwise what))
+	     (component-type component)
+	     (or (when type
+		   (namestring-or-nil (component-full-pathname
+				       component type)))
+		 (component-name component))
+	     (and *tell-user-when-done*
+		  (not no-dots))))))
+
+(defun tell-user-done (component &optional force no-dots)
+  ;; test is no longer really used, but we're leaving it in.
+  (when (and *tell-user-when-done*
+	     (or *oos-verbose* force))
+    (format t "~&~A~:[~;...~] Done."
+	    (prompt-string component) (not no-dots))
+    (finish-output *standard-output*)))
+
+(defmacro with-tell-user ((what component &optional type no-dots force) &body body)
+  `(progn
+     (tell-user ,what ,component ,type ,no-dots ,force)
+     ,@body
+     (tell-user-done ,component ,force ,no-dots)))
+
+(defun tell-user-no-files (component &optional force)
+  (when (or *oos-verbose* force)
+    (format-justified-string (prompt-string component)
+      (format nil "Binary file ~A ~
+             ~:[and source file ~A do~;does~] not exist, not loading."
+	      (namestring (component-full-pathname component :binary))
+	      (or *load-source-if-no-binary* *load-source-instead-of-binary*)
+	      (namestring (component-full-pathname component :source))))))
+
+(defun tell-user-require-system (name parent)
+  (when *oos-verbose*
+    (format t "~&; ~:[~;TEST:~] - System ~A requires ~S"
+	    *oos-test* (component-name parent) name)
+    (finish-output *standard-output*)))
+
+(defun tell-user-generic (string)
+  (when *oos-verbose*
+    (format t "~&; ~:[~;TEST:~] - ~A"
+	    *oos-test* string)
+    (finish-output *standard-output*)))
+
+;;; ********************************
+;;; Y-OR-N-P-WAIT ******************
+;;; ********************************
+;;; y-or-n-p-wait is like y-or-n-p, but will timeout
+;;; after a specified number of seconds
+(defun internal-real-time-in-seconds ()
+  (float (/ (get-internal-real-time) 
+	    internal-time-units-per-second)))
+
+(defun read-char-wait (&optional (timeout 20) input-stream &aux char)
+  (do ((start (internal-real-time-in-seconds)))
+      ((or (setq char (read-char-no-hang input-stream)) ;(listen *query-io*)
+	   (< (+ start timeout) (internal-real-time-in-seconds)))
+       char)))
+
+(defun y-or-n-p-wait (&optional (default #\y) (timeout 20) 
+				format-string &rest args)
+  (clear-input *query-io*)
+  (format *query-io* "~&~?" (or format-string "") args)
+  (finish-output *query-io*);; needed for CMU and other places
+  (let* ((read-char (read-char-wait timeout *query-io*))
+	 (char (or read-char default)))
+    (clear-input *query-io*)
+    (when (null read-char) (format *query-io* "~@[~A~]" default))
+    (cond ((null char)  t)
+	  ((find char '(#\y #\Y #\space) :test #'char=) t)
+	  ((find char '(#\n #\N) :test #'char=) nil)
+	  (t (y-or-n-p-wait default timeout 
+			    "Type \"y\" for yes or \"n\" for no. ")))))
+
+(defvar *use-timeouts* t)
+
+(defun y-or-n-p-wait-optional (&optional (default #\y) (timeout 20) 
+					 format-string &rest args)
+  (cond ((and default
+	      *use-timeouts*)
+	 (apply 'y-or-n-p-wait default timeout format-string args))
+	(t       (apply 'y-or-n-p format-string args))))
+
+#|
+(y-or-n-p-wait #\y 20 "What? ")
+(progn (format t "~&hi")
+       (y-or-n-p-wait #\y 10 "1? ")
+       (y-or-n-p-wait #\n 10 "2? "))
+|#
+;;; ********************************
+;;; Operate on System **************
+;;; ********************************
+;;; Operate-on-system
+;; Operation is :compile, 'compile, :load or 'load
+;; Force is :all or :new-source or :new-source-and-dependents or a list of
+;; specific modules.
+;;    :all (or T) forces a recompilation of every file in the system
+;;    :new-source-and-dependents compiles only those files whose
+;;          sources have changed or who depend on recompiled files.
+;;    :new-source compiles only those files whose sources have changed
+;;    A list of modules means that only those modules and their dependents are recompiled.
+;; Test is T to print out what it would do without actually doing it. 
+;;      Note: it automatically sets verbose to T if test is T.
+;; Verbose is T to print out what it is doing (compiling, loading of
+;;      modules and files) as it does it.
+;; Dribble should be the pathname of the dribble file if you want to 
+;; dribble the compilation.
+;; Load-source-instead-of-binary is T to load .lisp instead of binary files.
+;; Version may be nil to signify no subdirectory,
+;; a symbol, such as alpha, beta, omega, :alpha, mark, which
+;; specifies a subdirectory of the root, or
+;; a string, which replaces the root.
+(defun operate-on-system (name operation &key force
+			       (version *version*)
+			       (test *oos-test*) (verbose *oos-verbose*)
+                               (load-source-instead-of-binary *load-source-instead-of-binary*)
+                               (load-source-if-no-binary *load-source-if-no-binary*) 
+			       (bother-user-if-no-binary *bother-user-if-no-binary*)
+			       dribble)
+  (when dribble (dribble dribble))
+  (when test (setq verbose t))
+  (when (null force);; defaults
+    (case operation
+      ((load :load) (setq force :all))
+      ((compile :compile) (setq force :new-source-and-dependents))))
+  ;; Some CL implementations have a variable called *compile-verbose*
+  (multiple-value-bind (*version-dir* *version-replace*) 
+      (translate-version version)
+    (let ((*load-verbose* nil);; CL implementations may uniformly default this to nil
+	  (*version* version)
+	  (*oos-verbose* verbose)
+	  (*oos-test* test)
+	  (*load-source-if-no-binary* load-source-if-no-binary)
+	  (*bother-user-if-no-binary* bother-user-if-no-binary)
+	  (*load-source-instead-of-binary* load-source-instead-of-binary)
+	  (system (get-system name)))
+      (unless system (error "Can't find system named ~A." name))
+      (unless (component-operation operation) (error "Operation ~A undefined." operation))
+      (operate-on-component system operation force)))
+  (when dribble (dribble)))
+
+(defun operate-on-component (component operation force &aux changed)
+  ;; Returns T if something changed and had to be compiled.
+  (let ((type (component-type component))
+	;; Use the correct package.
+	#+ignore(*package*
+		 (or (when (component-package component)
+		       (tell-user-generic (format nil "Using package ~A" 
+						  (component-package component)))
+		       (cond (*oos-test* *package*)
+			     (t (find-package (component-package component)))))
+		     *package*))
+)
+    (when (component-package component)
+      (tell-user-generic (format nil "Using package ~A" 
+				 (component-package component)))
+      (cond (*oos-test* *package*)
+	    (t (unless (find-package (component-package component))
+		 (require (component-package component)))
+	       (use-package (component-package component)))))
+
+    ;; Load any required systems
+    (when (eq type :system)
+      (operate-on-system-dependencies component))
+
+    ;; Do any initial actions
+    (when (component-initially-do component)
+      (tell-user-generic (format nil "Doing initializations for ~A"
+				 (component-name component)))
+      (or *oos-test*
+	  (eval (component-initially-do component))))
+
+    ;; Do operation and set changed flag if necessary.
+    (setq changed 
+	  (case type
+	    ((:file :private-file)
+	     (funcall (component-operation operation) component force))
+	    ((:module :system)
+	     (operate-on-components component operation force changed))))
+
+    ;; Do any final actions
+    (when (component-finally-do component)
+      (tell-user-generic (format nil "Doing finalizations for ~A"
+				 (component-name component)))
+      (or *oos-test*
+	  (eval (component-finally-do component))))
+
+    ;; Provide the loaded system
+    (when (eq type :system)
+      (tell-user-generic (format nil "Providing system ~A"
+				 (component-name component)))
+      (or *oos-test*
+	  (provide (canonicalize-system-name (component-name component))))))
+
+  ;; Return t if something changed in this component and hence had to be recompiled.
+  changed)
+
+(defun operate-on-system-dependencies (component)
+  (when *system-dependencies-delayed*
+    (dolist (system (component-depends-on component))
+      ;; For each system that this system depends on,
+      ;; runs require (my version) on that system to load it.
+      ;; Explores the system tree in a DFS manner.
+      (cond ((listp system)
+	     (tell-user-require-system 
+	      (cond ((and (null (car system)) (null (cadr system)))
+		     (caddr system))
+		    (t system))
+	      component)
+	     (or *oos-test* (require (car system) nil
+				     (eval (cadr system))
+				     (caddr system) 
+				     (or (car (cdddr system))
+					 *version*))))
+	    (t
+	     (tell-user-require-system system component)
+	     (or *oos-test* (require system))))
+      )))
+
+(defun operate-on-components (component operation force changed)
+  (with-tell-user (operation component)
+    (if (component-components component)
+	(dolist (module (component-components component))
+	  (when (operate-on-component module operation
+		  (cond ((and (some #'(lambda (dependent)
+					(member dependent changed))
+				    (component-depends-on module))
+			      (or (non-empty-listp force)
+				  (eq force :new-source-and-dependents)))
+			 ;; The component depends on a changed file 
+			 ;; and force agrees.
+			 (if (eq force :new-source-and-dependents)
+			     :new-source-all
+			   :all))
+			((and (non-empty-listp force)
+			      (member (component-name module) force
+				      :test #'string-equal :key #'string))
+			 ;; Force is a list of modules 
+			 ;; and the component is one of them.
+			 :all)
+			(t force)))
+	    (push module changed)))
+	(case operation
+	  ((compile :compile)
+	   (eval (component-compile-form component)))
+	  ((load :load)
+	   (eval (component-load-form component))))))
+  changed)
+
+;;; ********************************
+;;; Component Operations ***********
+;;; ********************************
+;;; Define :compile/compile and :load/load operations
+(component-operation :compile  'compile-and-load-operation)
+(component-operation 'compile  'compile-and-load-operation)
+(component-operation :load     'load-file-operation)
+(component-operation 'load     'load-file-operation)
+
+(defun compile-and-load-operation (component force)
+  (let ((changed (compile-file-operation component force)))
+    (load-file-operation component changed)
+    changed))
+
+(defun compile-file-operation (component force)
+  ;; Returns T if the file had to be compiled.
+  (let ((must-compile
+	 (or (find force '(:all :new-source-all t) :test #'eq) 
+	     (and (find force '(:new-source :new-source-and-dependents)
+			:test #'eq)
+		  (needs-compilation component)))))
+
+    (cond ((and must-compile
+		(probe-file (component-full-pathname component :source)))
+	   (with-tell-user ("Compiling source" component :source)
+	       (or *oos-test*
+		   (compile-file (component-full-pathname component :source)
+		       :output-file (component-full-pathname component :binary)
+		       #+CMU :error-file #+CMU (and *cmu-errors-to-file* 
+						    (component-full-pathname component :error))
+		       #+CMU :errors-to-terminal #+CMU *cmu-errors-to-terminal*
+		       )))
+	   must-compile)
+	  (must-compile
+	   (tell-user "Source file not found. Not compiling"
+		      component :source :no-dots :force)
+	   nil)
+	  (t nil))))
+
+(defun needs-compilation (component)
+  ;; If there is no binary, or it is older than the source
+  ;; file, then the component needs to be compiled.
+  ;; Otherwise we only need to recompile if it depends on a file that changed.
+  (or
+   ;; no binary
+   (null (probe-file (component-full-pathname component :binary))) 
+   ;; old binary
+   (< (file-write-date (component-full-pathname component :binary)) 
+      (file-write-date (component-full-pathname component :source)))))
+
+(defun load-file-operation (component force)
+  ;; Returns T if the file had to be loaded
+  (let ((load-source
+	 (or *load-source-instead-of-binary*
+	     (and (find force '(:new-source :new-source-and-dependents
+					    :new-source-all)
+			:test #'eq)
+		  (needs-compilation component))))
+	(load-binary
+	 (or (find force '(:all :new-source-all t) :test #'eq) ; Force load. 
+	     ;; :new-source* and binary up to date
+	     (find force '(:new-source :new-source-and-dependents)
+		   :test #'eq))))
+
+    (cond ((and load-source
+		(probe-file (component-full-pathname component :source)))
+	   (with-tell-user ("Loading source" component :source)
+	       (or *oos-test*
+		   (load (component-full-pathname component :source))))
+	   T)
+	  ((and load-binary 
+		(probe-file (component-full-pathname component :binary)))
+	   (with-tell-user ("Loading binary"   component :binary)
+	       (or *oos-test*
+		   (load (component-full-pathname component :binary))))
+	   T)
+	  ((and load-binary
+		(probe-file (component-full-pathname component :source))
+		(load-source-if-no-binary component))
+	   (with-tell-user ("Loading source"   component :source)
+	       (or *oos-test*
+		   (load (component-full-pathname component :source))))
+	   T)
+	  ((or load-source load-binary)
+	   (tell-user-no-files component :force)
+	   nil)
+	  (t nil))))
+
+	
+;; when the operation = :compile, we can assume the binary exists in test mode.
+;;	((and *oos-test*
+;;	      (eq operation :compile)
+;;	      (probe-file (component-full-pathname component :source)))
+;;	 (with-tell-user ("Loading binary"   component :binary)))
+
+(defun load-source-if-no-binary (component)
+  (and (not *load-source-instead-of-binary*)
+       (or *load-source-if-no-binary*
+	   (when *bother-user-if-no-binary*
+	     (let* ((prompt (prompt-string component))
+		    (load-source
+		     (y-or-n-p-wait-optional
+		      #\y 30
+		      "~A- Binary file ~A does not exist. ~
+                       ~&~A  Load source file ~A instead? "
+		      prompt
+		      (namestring (component-full-pathname component :binary))
+		      prompt
+		      (namestring (component-full-pathname component :source)))))
+	       (setq *bother-user-if-no-binary*
+		     (y-or-n-p-wait-optional 
+		      #\n 30
+		      "~A- Should I bother you if this happens again? "
+		      prompt ))
+	       (unless *bother-user-if-no-binary*
+		 (setq *load-source-if-no-binary* load-source))
+	       load-source)))))
+
+;;; ********************************
+;;; New Require ********************
+;;; ********************************
+(defun compute-system-path (module-name definition-pname)
+  (let* ((filename (format nil "~A.system" 
+			   (if (symbolp module-name)
+			       (string-downcase (string module-name))
+			     module-name))))
+    (or (when definition-pname		; given pathname for system def
+	  (probe-file definition-pname))
+	(probe-file filename)		; try current dir
+	(probe-file (append-directories *central-registry* filename))) ; central registry
+    ))
+
+(unless (fboundp 'old-require)
+  (setf (symbol-function 'old-require) (symbol-function 'lisp:require))
+
+  (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil))
+    (defun lisp:require (module-name &optional pathname definition-pname
+				     default-action (version *version*)
+				     &aux system-path)
+      ;; If the pathname is present, this behaves like the old require.
+      (unless (and module-name 
+		   (find #-CMU (string module-name)
+			 #+CMU (string-downcase (string module-name))
+			 *modules* :test #'string=)) 
+	(cond (pathname
+	       (funcall 'old-require module-name pathname))
+	      ;; If the system is defined, load it.
+	      ((or (get-system module-name)
+		   (and (setq system-path 
+			      (compute-system-path module-name definition-pname))
+			(load system-path)
+			(get-system module-name)))
+	       (operate-on-system module-name :load
+				  :version version
+				  :test *oos-test*
+				  :verbose *oos-verbose*
+				  :load-source-if-no-binary *load-source-if-no-binary*
+				  :bother-user-if-no-binary *bother-user-if-no-binary*
+				  :load-source-instead-of-binary *load-source-instead-of-binary*))
+	      ;; If there's a default action, do it. This could be a progn which
+	      ;; loads a file that does everything. 
+	      ((and default-action
+		    (eval default-action)))
+	      ;; If no system definition file, try regular require.
+	      ((funcall 'old-require module-name pathname))
+	      ;; If no default action, print a warning or error message.
+	      (t
+	       (format t "~&Warning: System ~A doesn't seem to be defined..." module-name))
+	      )))))
+
+;;; ********************************
+;;; Allegro Make System Fasl *******
+;;; ********************************
+#+:excl
+(defun allegro-make-system-fasl (system destination)
+  (excl:shell
+   (format nil "rm -f ~A; cat~{ ~A~} > ~A" 
+	   destination
+	   (mapcar #'namestring
+		   (files-in-system system :all :binary)))))
+
+(defun files-which-need-compilation (system)
+  (mapcar #'(lambda (comp) (namestring (component-full-pathname comp :source)))
+	  (remove nil
+		  (file-components-in-component
+		   (get-system system) :new-source))))
+
+(defun files-in-system (name &optional (force :all) (type :source) version
+			     &aux system)
+  ;; Returns a list of the pathnames in system in load order.
+  (setq system (get-system name))
+  (unless system (error "Can't find system named ~A." name))
+  (multiple-value-bind (*version-dir* *version-replace*) 
+      (translate-version version)
+  (let ((*version* version))
+    (file-pathnames-in-component system type force))))
+
+(defun file-pathnames-in-component (component type &optional (force :all))
+  (mapcar #'(lambda (comp) (component-full-pathname comp type))
+	  (file-components-in-component component force)))
+
+(defun file-components-in-component (component &optional (force :all) 
+					       &aux result changed)
+  (case (component-type component)
+    ((:file :private-file)
+     (when (setq changed 
+		 (or (find force '(:all t) :test #'eq) 
+		     (and (not (non-empty-listp force))
+			  (needs-compilation component))))
+       (setq result
+	     (list component))))
+    ((:module :system)
+     (dolist (module (component-components component))
+       (multiple-value-bind (r c)
+	   (file-components-in-component 
+	    module 
+	    (cond ((and (some #'(lambda (dependent)
+				  (member dependent changed))
+			      (component-depends-on module))
+			(or (non-empty-listp force)
+			    (eq force :new-source-and-dependents)))
+		   ;; The component depends on a changed file and force agrees.
+		   :all)
+		  ((and (non-empty-listp force)
+			(member (component-name module) force
+				:test #'string-equal :key #'string))
+		   ;; Force is a list of modules and the component is one of them.
+		   :all)
+		  (t force)))
+	 (when c
+	   (push module changed)
+	   (setq result (append result r)))))))
+  (values result changed))
+
+(setf (symbol-function 'oos) (symbol-function 'operate-on-system))
+
+;;; *END OF FILE*
diff --git a/contrib/defsystem/defsystem.ps b/contrib/defsystem/defsystem.ps
new file mode 100644
index 0000000000000000000000000000000000000000..a6daf15fac2a874bfd015fd51e6c60e97d78258c
--- /dev/null
+++ b/contrib/defsystem/defsystem.ps
@@ -0,0 +1,1118 @@
+%!PS-Adobe-1.0
+%%Title: defsystem.mss
+%%DocumentFonts: (atend)
+%%Creator: Mark Kantrowitz and Scribe 6(1600)
+%%CreationDate: 31 January 1990 12:40
+%%Pages: (atend)
+%%EndComments
+% PostScript Prelude for Scribe.
+/BS {/SV save def 0.0 792.0 translate .01 -.01 scale} bind def
+/ES {showpage SV restore} bind def
+/SC {setrgbcolor} bind def
+/FMTX matrix def
+/RDF {WFT SLT 0.0 eq 
+  {SSZ 0.0 0.0 SSZ neg 0.0 0.0 FMTX astore}
+  {SSZ 0.0 SLT neg sin SLT cos div SSZ mul SSZ neg 0.0 0.0 FMTX astore}
+  ifelse makefont setfont} bind def
+/SLT 0.0 def
+/SI { /SLT exch cvr def RDF} bind def
+/WFT /Courier findfont def
+/SF { /WFT exch findfont def RDF} bind def
+/SSZ 1000.0 def
+/SS { /SSZ exch 100.0 mul def RDF} bind def
+/AF { /WFT exch findfont def /SSZ exch 100.0 mul def RDF} bind def
+/MT /moveto load def
+/XM {currentpoint exch pop moveto} bind def
+/UL {gsave newpath moveto dup 2.0 div 0.0 exch rmoveto
+   setlinewidth 0.0 rlineto stroke grestore} bind def
+/LH {gsave newpath moveto setlinewidth
+   0.0 rlineto
+   gsave stroke grestore} bind def
+/LV {gsave newpath moveto setlinewidth
+   0.0 exch rlineto
+   gsave stroke grestore} bind def
+/BX {gsave newpath moveto setlinewidth
+   exch
+   dup 0.0 rlineto
+   exch 0.0 exch neg rlineto
+   neg 0.0 rlineto
+   closepath
+   gsave stroke grestore} bind def
+/BX1 {grestore} bind def
+/BX2 {setlinewidth 1 setgray stroke grestore} bind def
+/PB {/PV save def newpath translate
+    100.0 -100.0 scale pop /showpage {} def} bind def
+/PE {PV restore} bind def
+/GB {/PV save def newpath translate rotate
+    div dup scale 100.0 -100.0 scale /showpage {} def} bind def
+/GE {PV restore} bind def
+/FB {dict dup /FontMapDict exch def begin} bind def
+/FM {cvn exch cvn exch def} bind def
+/FE {end /original-findfont /findfont load def  /findfont
+   {dup FontMapDict exch known{FontMapDict exch get} if
+   original-findfont} def} bind def
+/BC {gsave moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath clip} bind def
+/EC /grestore load def
+/SH /show load def
+/MX {exch show 0.0 rmoveto} bind def
+/W {0 32 4 -1 roll widthshow} bind def
+/WX {0 32 5 -1 roll widthshow 0.0 rmoveto} bind def
+%%EndProlog
+%%Page: 1 1
+BS
+0 SI
+15 /Helvetica-Bold AF
+11090 8294 MT
+(Defsystem: A Portable Make Facility for Common Lisp)SH
+13 SS 
+24641 15620 MT
+(by Mark Kantrowitz)SH
+21752 19236 MT
+(School of Computer Science)SH
+22256 22852 MT
+(Carnegie Mellon University)SH
+26480 26468 MT
+(January 1990)SH
+12 SS 
+7200 32344 MT
+(Introduction)SH
+10 /Helvetica AF
+7200 35777 MT
+(This document describes the defsystem system definition macro, a portable "Make" facility for)
+87 W( Common)86 W
+7200 37297 MT
+(Lisp.)SH
+7200 40793 MT
+(Support is provided for organizing systems into hierarchical layers of modules, with matching directory)133 W
+7200 42313 MT
+(structure. Moreover, the components of the system may be listed in any order)
+49 W( the user desires, because)48 W
+7200 43833 MT
+(the defsystem command reorganizes them according)
+69 W( to the file-dependency constraints specified by the)70 W
+7200 45353 MT
+(user. Since it accomplishes this by performing a topological sort of the constraint-graph,)
+351 W( cyclical)350 W
+7200 46873 MT
+(dependencies are not supported \050the graph must be a DAG\051.)SH
+7200 50369 MT
+(Only two operations, compile and load, are currently defined. The)
+87 W( interface for defining new operations,)88 W
+7200 51889 MT
+(however, is simple and extendible.)SH
+7200 55385 MT
+(Though home-grown, the syntax was inspired by fond)
+108 W( memories of the defsystem facility on Symbolics)107 W
+7200 56905 MT
+(3600 series lisp)
+100 W( machines. The exhaustive lists of filename extensions for various lisps and the idea to)101 W
+7200 58425 MT
+(have one)240 W
+/Helvetica-Oblique SF
+12072 XM
+(operate-on-system)SH
+/Helvetica SF
+20925 XM
+(function instead of separate)239 W
+/Helvetica-Oblique SF
+34444 XM
+(compile-system)SH
+/Helvetica SF
+41906 XM
+(and)SH
+/Helvetica-Oblique SF
+44091 XM
+(load-system)SH
+/Helvetica SF
+49998 XM
+(functions)SH
+7200 59945 MT
+(were taken from Xerox Corporation's PCL \050Portable Common Loops\051 system.)SH
+7200 63441 MT
+(The code for the defsystem facility and this documentation may be found in the files)SH
+11648 65030 MT
+(/afs/cs.cmu.edu/user/mkant/Defsystem/defsystem.{text,lisp})SH
+7200 68526 MT
+(Please send bug reports, comments and suggestions to mkant@cs.cmu.edu.)SH
+ES
+%%Page: 2 2
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(2)SH
+12 SS 
+7200 8075 MT
+(Using the System)SH
+10 /Helvetica AF
+7200 11508 MT
+(To use this system,)SH
+9424 12909 MT
+(1.)SH
+10536 XM
+(If you want to have a central)
+55 W( directory where system definition files will be kept, modify the)56 W
+10536 14052 MT
+(value of *central-registry* in defsystem.lisp to be the pathname of that directory.)SH
+9424 15867 MT
+(2.)SH
+10536 XM
+(Save and load the file defsystem.lisp)SH
+9424 17682 MT
+(3.)SH
+10536 XM
+(Load the)
+235 W( file containing the defsystem form defining your system. If the name of your)234 W
+10536 18825 MT
+(system is foo, the)
+43 W( file will be named "foo.system".  [If you are going to load the system and)44 W
+10536 19968 MT
+(not compile it, you can use \050require "foo"\051)
+10 W( to load it if the definition file is in either the current)9 W
+10536 21111 MT
+(directory or the central registry.])SH
+9424 22926 MT
+(4.)SH
+10536 XM
+(Use the function)60 W
+/Helvetica-Oblique SF
+18220 XM
+(operate-on-system)SH
+/Helvetica SF
+26894 XM
+(to do things to your system.)
+60 W( For example \050operate-on-)61 W
+10536 24069 MT
+(system "foo" 'load\051 will load the system, while \050operate-on-system "foo" 'compile\051 will)306 W
+10536 25212 MT
+(compile it.)SH
+12 /Helvetica-Bold AF
+7200 29013 MT
+(External Interface)SH
+10 /Helvetica AF
+7200 32446 MT
+(The external interface to)
+226 W( the defsystem facility are the defsystem macro and the operate-on-system)227 W
+7200 33966 MT
+(function. Defsystem is used to define a new system and operate-on-system)
+43 W( to compile it and load it. The)42 W
+7200 35486 MT
+(definition of require has been modified to mesh well with systems)
+104 W( defined using defsystem, and is fully)105 W
+7200 37006 MT
+(backward-compatible.)SH
+7200 40502 MT
+(In addition, the function)
+107 W( afs-binary-directory has been provided for immitating the behavior of the @sys)106 W
+7200 42022 MT
+(feature of the Andrew File System on systems not)
+123 W( running AFS. The @sys feature allows soft links to)124 W
+7200 43542 MT
+(point to different directories depending on)
+86 W( which platform is accessing the files. A common setup would)85 W
+7200 45062 MT
+(be to have the bin directory soft linked to .bin/@sys and to have subdirectories of .bin corresponding)
+84 W( to)85 W
+7200 46582 MT
+(each platform \050.bin/vax_mach, .bin/unix, .bin/pmax_mach, etc.\051. The afs-binary-directory)
+81 W( function returns)80 W
+7200 48102 MT
+(the appropriate binary directory for use as the :binary-pathname)
+99 W( argument in the defsystem macro. For)100 W
+7200 49622 MT
+(example, if we evaluate \050afs-binary-directory)
+220 W( "foodir/"\051 on a vax running the Mach operating system,)219 W
+7200 51142 MT
+("foodir/.bin/vax_mach/" would be returned.)SH
+12 /Helvetica-Bold AF
+7200 54485 MT
+(Defining Systems with Defsystem)SH
+10 /Helvetica AF
+7200 57918 MT
+(A system is a set of components with associated properties. These properties include the type,)
+126 W( name,)127 W
+7200 59438 MT
+(source and binary pathnames,)
+523 W( package, component-dependencies, initializations, and a set of)522 W
+7200 60958 MT
+(components.)SH
+7200 64454 MT
+(Components may be of three types: :system, :module, or)
+259 W( :file.  Components of type :system have)260 W
+7200 65974 MT
+(absolute pathnames and are used to define a multi-system system. The)
+93 W( toplevel system defined by the)92 W
+7200 67494 MT
+(defsystem macro)
+174 W( is implicitly of type :system. Components of type :module have pathnames that are)175 W
+7200 69014 MT
+(relative to their containing system or module,)
+89 W( and may contain a set of files and modules. This enables)88 W
+7200 70534 MT
+(one to define subsystems, subsubsystems, submodules, and so on.)SH
+ES
+%%Page: 3 3
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(3)SH
+/Helvetica SF
+7200 7929 MT
+(Foreign systems \050systems defined using some other system definition tool\051, may be)
+16 W( included by providing)17 W
+7200 9449 MT
+(separate compile and load forms for them \050using)
+189 W( the :compile-form and :load-form keywords\051. These)188 W
+7200 10969 MT
+(forms will be run if and only if they are included in)
+33 W( a module with no components. [In some future version)34 W
+7200 12489 MT
+(of the defsystem)
+120 W( facility there will be new component types corresponding to each possible operation.])119 W
+7200 14009 MT
+(This is useful if it isn't possible to convert these systems to the defsystem format all at once.)SH
+7200 17505 MT
+(The name of a component may be a symbol or a string. For ease of access the definition)
+29 W( of a system \050its)30 W
+7200 19025 MT
+(component\051 is stored under the system properties of the symbol corresponding to its uppercase name.)
+28 W( If)332 W
+7200 20545 MT
+(the system name is a symbol, for all other purposes the name is converted to)
+34 W( a lowercase string \050system)35 W
+7200 22065 MT
+(names that are strings are left alone\051. It is usually best to)
+20 W( use the string version of a system's name when)19 W
+7200 23585 MT
+(defining or referring to it. A system defined as 'foo will)
+16 W( have an internal name of "foo" and will be stored in)17 W
+7200 25105 MT
+(the file "foo.system". A system defined as "Foo" will have an internal name of "Foo" and)
+52 W( will be stored in)51 W
+7200 26625 MT
+(the file "Foo.system".)SH
+7200 30121 MT
+(The absolute \050for components of type :system\051 and relative)
+70 W( \050for all other components\051 pathnames of the)71 W
+7200 31641 MT
+(binary and source files may be specified using the :source-pathname and :binary-pathname keywords in)60 W
+7200 33161 MT
+(the component definition. The pathnames associated with a module correspond to subdirectories of the)94 W
+7200 34681 MT
+(containing module or system. If)
+86 W( no binary pathname is specified, the binaries are distributed among the)85 W
+7200 36201 MT
+(sources. If no source pathname is given for a component, it defaults to the name of the)
+9 W( component. Since)10 W
+7200 37721 MT
+(the names are converted to lowercase, pathnames must be provided for each component if)
+26 W( the operating)25 W
+7200 39241 MT
+(system is)
+244 W( case sensitive \050unless the pathnames are all lowercase\051. Similarly, if a module does not)245 W
+7200 40761 MT
+(correspond to a subdirectory, a null-string pathname \050""\051 must be provided.)SH
+7200 44257 MT
+(File types \050e.g., "lisp" and "fasl"\051 for source and binary files may be specified using the)
+40 W( :source-extension)39 W
+7200 45777 MT
+(and :binary-extension keywords. If)
+27 W( these are not specified or given as nil, the makes a reasonable choice)28 W
+7200 47297 MT
+(of defaults based on the machine type and underlying operating system. These)
+28 W( file types are inherited by)27 W
+7200 48817 MT
+(the components of the system.)SH
+7200 52313 MT
+(At system definition time, every relative directory is replaced with the corresponding cumulative)
+103 W( relative)104 W
+7200 53833 MT
+(pathname with all the components incorporated.)SH
+7200 57329 MT
+(One may also specify the package)
+219 W( to be used and any initializations and finalizations. Initializations)218 W
+7200 58849 MT
+(\050specified with the keyword :initially-do\051 are)
+210 W( evaluated before the system is loaded or compiled, and)211 W
+7200 60369 MT
+(finalizations \050specified with the keyword :finally-do\051 are evaluated after)
+92 W( the system is finished loading or)91 W
+7200 61889 MT
+(compiling. The argument to the keyword is a form which is evaluated. Multiple forms may be evaluated)
+10 W( by)11 W
+7200 63409 MT
+(wrapping a progn around the forms.)SH
+7200 66905 MT
+(The components of a system, module or file are specified with the :components keyword, and are)
+14 W( defined)13 W
+7200 68425 MT
+(in a manner analogous to the way in which a system is defined.)SH
+7200 71921 MT
+(The dependencies of a system, module or file are specified with the :depends-on keyword,)
+45 W( followed by a)46 W
+ES
+%%Page: 4 4
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(4)SH
+/Helvetica SF
+7200 7929 MT
+(list of the names of the components the system, module)
+56 W( or file depends on. The components referred to)55 W
+7200 9449 MT
+(must exist at the same level of the hierarchy as the referring component.  This enforces the modularity of)31 W
+7200 10969 MT
+(the defined system. If module A depends on a file)
+25 W( contained within module B, then module A depends on)24 W
+7200 12489 MT
+(module B)
+175 W( and should be specified as such. Any other use would make a mockery of the concept of)176 W
+7200 14009 MT
+(modularity. This requirement is not enforced in the software, but)
+216 W( any use contrary to it will produce)215 W
+7200 15529 MT
+(unpredictable results.)SH
+7200 19025 MT
+(Thus the only requirement in how the files are organized is that at the)
+8 W( level of each module or system, the)9 W
+7200 20545 MT
+(dependency graph)
+312 W( of the components must be a DAG \050directed)311 W
+/Helvetica-Bold SF
+38659 XM
+(acyclic)SH
+/Helvetica SF
+42584 XM
+(graph\051. If there are any)311 W
+7200 22065 MT
+(dependency cycles \050i.e., module A uses definitions from module)
+96 W( B, and module B uses definitions from)97 W
+7200 23585 MT
+(module A\051, the defsystem macro will not be)
+48 W( able to compute a total ordering of the files \050a linear order in)47 W
+7200 25105 MT
+(which they should be compiled and loaded\051. Usually the defsystem will detect such cycles and halt)
+80 W( with)81 W
+7200 26625 MT
+(an error.)SH
+7200 30121 MT
+(If no dependencies are provided for the system, modules and files, it may load them in)
+229 W( any order.)228 W
+7200 31641 MT
+(Currently, however, it loads them in serial order. In a future version of defsystem this will)
+233 W( probably)234 W
+7200 33161 MT
+(become a supported feature. [In other words, this)
+56 W( feature hasn't been tested to make sure that they files)55 W
+7200 34681 MT
+(are not)
+2 W( accidentally loaded in the opposite order in some cases. It all depends on whether the definition of)3 W
+7200 36201 MT
+(topological-sort used is a stable sort or not.])SH
+7200 39697 MT
+(The basic algorithm used is to topologically sort the DAG at each level)
+195 W( of abstraction \050system level,)194 W
+7200 41217 MT
+(module level, submodule)
+45 W( level, etc.\051 to insure that the system's files are compiled and loaded in the right)46 W
+7200 42737 MT
+(order. This occurs at system)
+86 W( definition time, rather than at system use time, since it probably saves the)85 W
+7200 44257 MT
+(user some time.)SH
+12 /Helvetica-Bold AF
+7200 47600 MT
+(BNF for Components)SH
+10 /Helvetica AF
+7200 51033 MT
+(The general format of a component's definition is:)SH
+/Courier-Bold SF
+7200 52838 MT
+(<definition> ::= \050<type> <name> [:host <host>] [:device <device>])SH
+26400 53969 MT
+([:source-pathname <pathname>])SH
+26400 55100 MT
+([:source-extension <extension>])SH
+26400 56231 MT
+([:binary-pathname <pathname>])SH
+26400 57362 MT
+([:binary-extension <extension>])SH
+26400 58493 MT
+([:package <package>])SH
+26400 59624 MT
+([:initially-do <form>])SH
+26400 60755 MT
+([:finally-do <form>])SH
+26400 61886 MT
+([:components \050<definition>*\051])SH
+26400 63017 MT
+([:depends-on \050<name>*\051])SH
+26400 64148 MT
+([:compile-form <form>])SH
+26400 65279 MT
+([:load-form <form>]\051)SH
+7200 66410 MT
+(<type> ::= :system | :module | :file)SH
+/Helvetica SF
+7200 69906 MT
+(The toplevel defsystem form substitutes defsystem for :system.)SH
+ES
+%%Page: 5 5
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(5)SH
+12 SS 
+7200 8075 MT
+(Using Systems with Operate-on-System)SH
+10 /Helvetica AF
+7200 11508 MT
+(The function operate-on-system is used)
+166 W( to compile or load a system, or do any other operation on a)167 W
+7200 13028 MT
+(system. At present only compile and load operations are defined, but other operations such as edit,)200 W
+7200 14548 MT
+(hardcopy, or applying arbitrary functions \050e.g., enscript, lpr\051 to every file in the system)
+125 W( could be added)126 W
+7200 16068 MT
+(easily.)SH
+7200 19564 MT
+(The syntax of operate-on-system is as follows:)SH
+/Helvetica-Bold SF
+7200 23060 MT
+(OPERATE-ON-SYSTEM)SH
+/Helvetica-Oblique SF
+18640 XM
+(system-name operation)50 W
+/Helvetica SF
+29466 XM
+(&key)SH
+/Helvetica-Oblique SF
+32017 XM
+(force test)
+50 W( verbose dribble load-source-instead-of-)49 W
+7200 24580 MT
+(binary load-source-if-no-binary bother-user-if-no-binary)SH
+/Symbol SF
+9242 26052 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(system-name)SH
+/Helvetica SF
+16649 XM
+(is the name of the system and may be a symbol or string.)SH
+/Symbol SF
+9242 27867 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(operation)SH
+/Helvetica SF
+14940 XM
+(is 'compile \050or :compile\051 or 'load \050or :load\051 or any new operation)
+126 W( defined by the)127 W
+9980 29010 MT
+(user.)SH
+/Symbol SF
+9242 30825 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(force)SH
+/Helvetica SF
+12703 XM
+(determines what files are operated on:)SH
+7 /Symbol AF
+12160 32076 MT
+(\267)SH
+10 /Helvetica-Oblique AF
+12760 32226 MT
+(:all)SH
+/Helvetica SF
+14316 XM
+(\050or T\051 specifies that all files in the system should be used)SH
+7 /Symbol AF
+12160 33891 MT
+(\267)SH
+10 /Helvetica-Oblique AF
+12760 34041 MT
+(:new-source)SH
+/Helvetica SF
+18573 XM
+(If the operation is 'compile, compiles only those files whose sources are)88 W
+12760 35184 MT
+(more recent than the binaries. If the operation is)
+114 W( 'load, loads the source if it is more)115 W
+12760 36327 MT
+(recent than the binaries. This allows you to load the most up)
+139 W( to date version of the)138 W
+12760 37470 MT
+(system even if it isn't compiled.)SH
+7 /Symbol AF
+12160 39135 MT
+(\267)SH
+10 /Helvetica-Oblique AF
+12760 39285 MT
+(:new-sources-and-dependents)SH
+/Helvetica SF
+26688 XM
+(uses all files used by :new-source,)
+144 W( plus any files that)145 W
+12760 40428 MT
+(depend on the those files or their dependents \050recursively\051.)SH
+7 /Symbol AF
+12160 42093 MT
+(\267)SH
+10 /Helvetica AF
+12760 42243 MT
+(Force may also be a list)
+289 W( of the specific modules or files to be used \050plus their)288 W
+12760 43386 MT
+(dependents\051.)SH
+9980 44787 MT
+(The default for 'load is :all and for 'compile is :new-source-and-dependents.)SH
+/Symbol SF
+9242 46602 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(version)SH
+/Helvetica SF
+13989 XM
+(indicates which version of the system should be used. If nil, then the usual root)174 W
+9980 47745 MT
+(directory is)
+101 W( used. If a symbol, such as 'alpha, 'beta, 'omega, :alpha, or 'mark, it substitutes)100 W
+9980 48888 MT
+(the appropriate)
+19 W( \050lowercase\051 subdirectory of the root directory for the root directory. If a string,)20 W
+9980 50031 MT
+(it replaces the entire root directory with the given directory. \050default *version*, which is nil\051)SH
+/Symbol SF
+9242 51846 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(verbose)SH
+/Helvetica SF
+14146 XM
+(is T to print out what it is doing)
+53 W( \050compiling, loading of modules and files\051 as it does)52 W
+9980 52989 MT
+(it. \050default nil\051)SH
+/Symbol SF
+9242 54804 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(test)SH
+/Helvetica SF
+12051 XM
+(is T)
+15 W( to print out what it would do without actually doing it.  If test is T it automatically sets)16 W
+9980 55947 MT
+(verbose to T. \050default nil\051)SH
+/Symbol SF
+9242 57762 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(dribble)SH
+/Helvetica SF
+13873 XM
+(should be the pathname of a dribble file if you want to keep a record of)
+281 W( the)280 W
+9980 58905 MT
+(compilation. \050default nil\051)SH
+/Symbol SF
+9242 60720 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(load-source-instead-of-binary)SH
+/Helvetica SF
+24392 XM
+(is T to force)
+21 W( the system to load source files instead of binary)22 W
+9980 61863 MT
+(files. \050default nil\051)SH
+/Symbol SF
+9242 63678 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(load-source-if-no-binary)SH
+/Helvetica SF
+22022 XM
+(is T to have the)
+263 W( system load source files if the binary file is)262 W
+9980 64821 MT
+(missing. \050default nil\051)SH
+/Symbol SF
+9242 66636 MT
+(\267)SH
+/Helvetica-Bold SF
+9980 XM
+(bother-user-if-no-binary)SH
+/Helvetica SF
+21818 XM
+(is T to)
+171 W( have the system bother the user about missing binaries)172 W
+9980 67779 MT
+(before it goes ahead and loads them if load-source-if-no-binary is T. \050default)
+67 W( t\051 Times out in)66 W
+9980 68922 MT
+(60 seconds unless *use-timeouts* is set to nil.)SH
+ES
+%%Page: 6 6
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(6)SH
+/Helvetica SF
+7200 7929 MT
+(An implicit assumption is that if we need to)
+10 W( load a file for some reason, then we should be able to compile)11 W
+7200 9449 MT
+(it immediately before we need to)
+138 W( load it. This obviates the need to specify separate load and compile)137 W
+7200 10969 MT
+(dependencies in the modules.)SH
+7200 14465 MT
+(Files which must not)
+117 W( be compiled should be loaded in the initializations or finalizations of a module by)118 W
+7200 15985 MT
+(means of an explicit load form.)SH
+7200 19481 MT
+(Note that under this assumption, the example given)
+207 W( in the PCL defsystem becomes quite ludicrous.)206 W
+7200 21001 MT
+(Those constraints are of the form:)SH
+9424 22402 MT
+(1.)SH
+10536 XM
+(C must be loaded before A&B are loaded)SH
+9424 24217 MT
+(2.)SH
+10536 XM
+(A&B must be loaded before C is compiled)SH
+7200 25737 MT
+(When you add in the reasonable assumption that before you load C, you must compile C, you get a cycle.)SH
+7200 29233 MT
+(The only case is which this might not be true is in a system which worked on)
+86 W( the dependency graph of)87 W
+7200 30753 MT
+(individual definitions. But we have restricted)
+112 W( ourselves to file dependencies and will stick with that.  \050In)111 W
+7200 32273 MT
+(situations where a file defining macros must have the sources loaded before compiling them, most often)
+7 W( it)8 W
+7200 33793 MT
+(is because the macros are used before they are defined, and)
+82 W( hence assumed to be functions. This can)81 W
+7200 35313 MT
+(be fixed by organizing the macros better, or including them in a separate file.\051)SH
+12 /Helvetica-Bold AF
+7200 38656 MT
+(Defining New Operations)SH
+10 /Helvetica AF
+7200 42089 MT
+(To define a new)
+203 W( operation, write a function with parameters component and force that performs the)204 W
+7200 43609 MT
+(operation. The)
+82 W( function component-pathname may be used to extract the source and binary pathnames)81 W
+7200 45129 MT
+(from the component. [Component-pathname takes parameters component and file-type,)
+10 W( where file-type is)11 W
+7200 46649 MT
+(either :source or :binary,)
+120 W( and returns the appropriate pathname.] If the component has "changed" as a)119 W
+7200 48169 MT
+(result of the operation, T should)
+3 W( be returned; otherwise nil. See the definition of compile-file-operation and)4 W
+7200 49689 MT
+(load-file-operation for examples.)SH
+7200 53185 MT
+(Then install the definition using component-operation, which takes as)
+99 W( parameters the symbol which will)98 W
+7200 54705 MT
+(be used)
+58 W( to name the operation in operate-on-system, and the name of the function. For example, here's)59 W
+7200 56225 MT
+(the definition of the 'compile and :compile operations:)SH
+/Courier-Bold SF
+13200 58030 MT
+(\050component-operation :compile  'compile-and-load-operation\051)SH
+13200 59161 MT
+(\050component-operation 'compile  'compile-and-load-operation\051)SH
+/Helvetica SF
+7200 61021 MT
+(Eventually this system will include portable definitions of 'hardcopy and 'edit.)SH
+12 /Helvetica-Bold AF
+7200 64364 MT
+(Changes to Require)SH
+10 /Helvetica AF
+7200 67797 MT
+(This defsystem interacts smoothly)
+138 W( with the require and provide facilities of Common Lisp. Operate-on-)137 W
+7200 69317 MT
+(system automatically provides the name of any system it loads, and uses the new definition of)
+49 W( require to)50 W
+7200 70837 MT
+(load any dependencies of the toplevel system.)SH
+ES
+%%Page: 7 7
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(7)SH
+/Helvetica SF
+7200 7929 MT
+(To facilitate this, three new optional arguments have been added)
+174 W( to require. Thus the new syntax of)173 W
+7200 9449 MT
+(require is as follows:)SH
+/Helvetica-Bold SF
+7200 12945 MT
+(REQUIRE)SH
+/Helvetica-Oblique SF
+12034 XM
+(system-name)SH
+/Helvetica SF
+18313 XM
+(&optional)SH
+/Helvetica-Oblique SF
+22760 XM
+(pathname definition-pname default-action version)SH
+/Helvetica SF
+7200 16441 MT
+(If pathname is provided, the new require behaves just like the old)
+46 W( definition. Otherwise it first tries to find)47 W
+7200 17961 MT
+(the definition of the system-name \050if it is not already defined it will load the definition file if it is in the)143 W
+7200 19481 MT
+(current-directory, the central-registry directory, or the directory specified by definition-pname\051 and)
+147 W( runs)148 W
+7200 21001 MT
+(operate-on-system on the system definition. If no definition is to be found, it)
+160 W( will evaluate the default-)159 W
+7200 22521 MT
+(action if there)
+52 W( is one. Otherwise it will try running the old definition of require on just the system name. If)53 W
+7200 24041 MT
+(all else fails, it will print out a warning.)SH
+12 /Helvetica-Bold AF
+7200 27384 MT
+(A Sample System Definition and Its Use)SH
+10 /Helvetica AF
+7200 30817 MT
+(Here's a system definition for the files in the following directory structure:)SH
+/Courier-Bold SF
+8400 32622 MT
+(% du -a test)SH
+8400 33753 MT
+(1 test/fancy/macros.lisp)3600 W
+8400 34884 MT
+(1 test/fancy/primitives.lisp)3600 W
+8400 36015 MT
+(3 test/fancy)3600 W
+8400 37146 MT
+(1 test/macros.lisp)3600 W
+8400 38277 MT
+(1 test/primitives.lisp)3600 W
+8400 39408 MT
+(1 test/graphics/macros.lisp)3600 W
+8400 40539 MT
+(1 test/graphics/primitives.lisp)3600 W
+8400 41670 MT
+(3 test/graphics)3600 W
+8400 42801 MT
+(1 test/os/macros.lisp)3600 W
+8400 43932 MT
+(1 test/os/primitives.lisp)3600 W
+8400 45063 MT
+(3 test/os)3600 W
+8400 46194 MT
+(12 test)3000 W
+8400 49587 MT
+(\050defsystem test)SH
+9600 50718 MT
+(:source-pathname "/afs/cs.cmu.edu/user/mkant/Defsystem/test/")SH
+9600 51849 MT
+(:source-extension "lisp")SH
+9600 52980 MT
+(:binary-pathname nil)SH
+9600 54111 MT
+(:binary-extension nil)SH
+9600 55242 MT
+(:components \050\050:module basic)SH
+22800 56373 MT
+(:source-pathname "")SH
+22800 57504 MT
+(:components \050\050:file "primitives"\051)SH
+30600 58635 MT
+(\050:file "macros")SH
+34800 59766 MT
+(:depends-on \050"primitives"\051\051\051\051)SH
+17400 60897 MT
+(\050:module graphics)SH
+22800 62028 MT
+(:source-pathname "graphics")SH
+22800 63159 MT
+(:components \050\050:file "macros")SH
+34800 64290 MT
+(:depends-on \050"primitives"\051\051)SH
+30600 65421 MT
+(\050:file "primitives"\051\051)SH
+22800 66552 MT
+(:depends-on \050basic\051\051)SH
+17400 67683 MT
+(\050:module fancy-stuff)SH
+22800 68814 MT
+(:source-pathname "fancy")SH
+22800 69945 MT
+(:components \050\050:file "macros")SH
+34800 71076 MT
+(:depends-on \050"primitives"\051\051)SH
+ES
+%%Page: 8 8
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(8)SH
+/Courier-Bold SF
+30600 7874 MT
+(\050:file "primitives"\051\051)SH
+22800 9005 MT
+(:depends-on \050graphics operating-system\051\051)SH
+17400 10136 MT
+(\050:module operating-system)SH
+22800 11267 MT
+(:source-pathname "os")SH
+22800 12398 MT
+(:components \050\050:file "primitives"\051)SH
+30600 13529 MT
+(\050:file "macros")SH
+34800 14660 MT
+(:depends-on \050"primitives"\051\051\051)SH
+22800 15791 MT
+(:depends-on \050basic\051\051\051)SH
+9600 16922 MT
+(:depends-on nil\051)SH
+8400 19184 MT
+(<cl> \050operate-on-system 'test 'compile :verbose t\051)SH
+8400 21446 MT
+(; -)
+600 W( Compiling system "test")SH
+8400 22577 MT
+(; -)
+1800 W( Compiling module "basic")SH
+8400 23708 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 24839 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.lisp")4200 W
+8400 25970 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 27101 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W
+8400 28232 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 29363 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.lisp")4200 W
+8400 30494 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 31625 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W
+8400 32756 MT
+(; -)
+1800 W( Compiling module "graphics")SH
+8400 33887 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 35018 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.lisp)4200 W
+8400 36149 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 37280 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W
+8400 38411 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 39542 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.lisp")4200 W
+8400 40673 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 41804 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W
+8400 42935 MT
+(; -)
+1800 W( Compiling module "operating-system")SH
+8400 44066 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 45197 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.lisp")4200 W
+8400 46328 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 47459 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W
+8400 48590 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 49721 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.lisp")4200 W
+8400 50852 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 51983 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W
+8400 53114 MT
+(; -)
+1800 W( Compiling module "fancy-stuff")SH
+8400 54245 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 55376 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.lisp")4200 W
+8400 56507 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 57638 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W
+8400 58769 MT
+(; -)
+3000 W( Compiling source file)SH
+8400 59900 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.lisp")4200 W
+8400 61031 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 62162 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W
+8400 63293 MT
+(; -)
+600 W( Providing system test)SH
+8400 64424 MT
+(NIL)SH
+8400 66686 MT
+(<cl> \050operate-on-system 'test 'load :verbose t\051)SH
+8400 68948 MT
+(; -)
+600 W( Loading system "test")SH
+8400 70079 MT
+(; -)
+1800 W( Loading module "basic")SH
+8400 71210 MT
+(; -)
+3000 W( Loading binary file)SH
+ES
+%%Page: 9 9
+BS
+0 SI
+10 /Helvetica-Bold AF
+30322 4329 MT
+(9)SH
+/Courier-Bold SF
+8400 7874 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W
+8400 9005 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 10136 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W
+8400 11267 MT
+(; -)
+1800 W( Loading module "graphics")SH
+8400 12398 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 13529 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W
+8400 14660 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 15791 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W
+8400 16922 MT
+(; -)
+1800 W( Loading module "operating-system")SH
+8400 18053 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 19184 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W
+8400 20315 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 21446 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W
+8400 22577 MT
+(; -)
+1800 W( Loading module "fancy-stuff")SH
+8400 23708 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 24839 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W
+8400 25970 MT
+(; -)
+3000 W( Loading binary file)SH
+8400 27101 MT
+(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W
+8400 28232 MT
+(; -)
+600 W( Providing system test)SH
+8400 29363 MT
+(NIL)SH
+12 /Helvetica-Bold AF
+7200 33623 MT
+(Miscellaneous Notes)SH
+10 /Helvetica AF
+7200 37056 MT
+(Macintosh pathnames are)
+27 W( not fully supported at this time because of irregularities in the Allegro Common)26 W
+7200 38576 MT
+(Lisp definition of the pathname functions. Thus)
+92 W( system definitions will not be portable to the Macintosh.)93 W
+7200 40096 MT
+(To convert them, include the device in the toplevel pathname and include trailing colons in)
+7 W( the pathnames)6 W
+7200 41616 MT
+(of each module.)SH
+7200 45112 MT
+(We currently assume that)
+205 W( compilation-load dependencies and if-changed dependencies are identical.)206 W
+7200 46632 MT
+(However, in some cases this might not be true. For example, if we change)
+21 W( a macro we have to recompile)20 W
+7200 48152 MT
+(functions that depend on it, but not if we change)
+239 W( a function. Splitting these apart \050with appropriate)240 W
+7200 49672 MT
+(defaulting\051 would be nice, but not worth doing immediately since it may save only a)
+252 W( couple of file)251 W
+7200 51192 MT
+(recompilations, while making the defsystem much)
+222 W( more complex. And if someone has such a large)223 W
+7200 52712 MT
+(system that this matters, they've got more important problems.)SH
+ES
+%%Trailer
+%%Pages: 9 
+%%DocumentFonts: Helvetica Helvetica-Bold Helvetica-Oblique Courier-Bold Symbol
diff --git a/contrib/demos/demos.catalog b/contrib/demos/demos.catalog
new file mode 100644
index 0000000000000000000000000000000000000000..c38ec9a8fa1633008d4de8c329cb99ba794a279f
--- /dev/null
+++ b/contrib/demos/demos.catalog
@@ -0,0 +1,38 @@
+Package Name:
+   DEMOS
+
+Description:
+   Graphics demonstration programs for CMU Common Lisp using version 11 of the
+X Window System.
+
+Author:
+   CMU Common Lisp Group.
+
+Maintainer:
+   CMU Common Lisp Group.
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   slisp-group@b
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   demos.lisp, demos.fasl, demos.catalog.
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>:
+   cp /afs/cs.cmu.edu/project/slisp/library/demos/* <spec>
+
+Portability:
+   Should run in any Common Lisp supporting CLX V11R3.
+
+Instructions:
+   The function DEMOS:DO-ALL-DEMOS will run through each of the demos once, and
+the function DEMOS:DEMO will present a menu of all the demos.
diff --git a/contrib/demos/demos.lisp b/contrib/demos/demos.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..91aa7e7b1067eecf839f5cb2d5203ea2606e24ff
--- /dev/null
+++ b/contrib/demos/demos.lisp
@@ -0,0 +1,1038 @@
+;;; -*- Mode: Lisp; Package: Demos -*-
+;;;
+;;; This file contains various graphics hacks written and ported over the
+;;; years by various and numerous persons.
+;;;
+;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88.
+;;;
+
+(in-package "DEMOS" :use '("LISP"))
+
+(export '(do-all-demos demo))
+
+
+
+;;;; Graphic demos wrapper macro.
+
+;;; This wrapper macro should be reconsidered with respect to its property
+;;; list usage.  Possibly a demo structure should be used with *demos*
+;;; pointing to these instead of function names.  Also, something should
+;;; be done about a title window that displays the name of the demo while
+;;; it is running.
+
+(defparameter *demos* nil)
+
+(defvar *display* nil)
+(defvar *screen* nil)
+(defvar *root* nil)
+(defvar *black-pixel* nil)
+(defvar *white-pixel* nil)
+(defvar *window* nil)
+
+(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms)
+  `(progn
+     (defun ,fun-name ,args
+       ,doc
+       (cond (*display*
+	      (xlib:with-state (*window*)
+		(setf (xlib:drawable-x *window*) ,x)
+		(setf (xlib:drawable-y *window*) ,y)
+		(setf (xlib:drawable-width *window*) ,width)
+		(setf (xlib:drawable-height *window*) ,height)))
+	     (t
+	      #+:cmu
+	      (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
+	      #-:cmu
+	      (progn
+		;; Portable method
+		(setf *display* (xlib:open-display (machine-instance)))
+		(setf *screen* (xlib:display-default-screen *display*)))
+	      (setf *root* (xlib:screen-root *screen*))
+	      (setf *black-pixel* (xlib:screen-black-pixel *screen*))
+	      (setf *white-pixel* (xlib:screen-white-pixel *screen*))
+	      (setf *window* (xlib:create-window :parent *root*
+						 :x ,x :y ,y
+						 :event-mask nil
+						 :width ,width :height ,height
+						 :background *white-pixel*
+						 :border *black-pixel*
+						 :border-width 2
+						 :override-redirect :on))))
+       (xlib:map-window *window*)
+       ;; 
+       ;; I hate to do this since this is not something any normal
+       ;; program should do ...
+       (setf (xlib:window-priority *window*) :above)
+       (xlib:display-finish-output *display*)
+       (unwind-protect
+	   (progn ,@forms)
+	 (xlib:unmap-window *window*)
+	 (xlib:display-finish-output *display*)))
+     (setf (get ',fun-name 'demo-name) ',demo-name)
+     (setf (get ',fun-name 'demo-doc) ',doc)
+     (export ',fun-name)
+     (pushnew ',fun-name *demos*)
+     ',fun-name))
+
+
+;;;; Main entry points.
+
+(defun do-all-demos ()
+  (dolist (demo *demos*)
+    (funcall demo)
+    (sleep 3)))
+
+;;; DEMO is a hack to get by.  It should be based on creating a menu.  At
+;;; that time, *name-to-function* should be deleted, since this mapping will
+;;; be manifested in the menu slot name cross its action.  Also the
+;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for
+;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi".
+;;;
+
+(defvar *name-to-function* (make-hash-table :test #'eq))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+(defun demo ()
+  (macrolet ((read-demo ()
+	       `(let ((*package* *keyword-package*))
+		  (read))))
+    (dolist (d *demos*)
+      (setf (gethash (intern (string-upcase (get d 'demo-name))
+			     *keyword-package*)
+		     *name-to-function*)
+	    d))
+    (loop
+      (fresh-line)
+      (dolist (d *demos*)
+	(write-string "   ")
+	(write-line (get d 'demo-name)))
+      (write-string "   ")
+      (write-line "Help <demo name>")
+      (write-string "   ")
+      (write-line "Quit")
+      (write-string "Enter demo name: ")
+      (let ((demo (read-demo)))
+	(case demo
+	  (:help
+	   (let* ((demo (read-demo))
+		  (fun (gethash demo *name-to-function*)))
+	     (fresh-line)
+	     (if fun
+		 (format t "~&~%~A~&~%" (get fun 'demo-doc))
+		 (format t "Unknown demo name -- ~A." demo))))
+	  (:quit (return t))
+	  (t
+	   (let ((fun (gethash demo *name-to-function*)))
+	     (if fun
+		 (funcall fun)
+		 (format t "~&~%Unknown demo name -- ~A.~&~%" demo)))))))))
+
+
+;;;; Shared demo utilities.
+
+(defun full-window-state (w)
+  (xlib:with-state (w)
+    (values (xlib:drawable-width w) (xlib:drawable-height w)
+	    (xlib:drawable-x w) (xlib:drawable-y w)
+	    (xlib:window-map-state w))))
+
+
+;;;; Greynetic.
+
+;;; GREYNETIC displays random sized and shaded boxes in a window.  This is
+;;; real slow.  It needs work.
+;;; 
+(defun greynetic (window duration)
+  (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1
+				     :drawable window))
+	 (gcontext (xlib:create-gcontext :drawable window
+					 :background *white-pixel*
+					 :foreground *black-pixel*
+					 :tile pixmap
+					 :fill-style :tiled)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (dotimes (i duration)
+	(let* ((pixmap-data (greynetic-pixmapper))
+	       (image (xlib:create-image :width 32 :height 32
+					 :depth 1 :data pixmap-data)))
+	  (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32)
+	  (xlib:draw-rectangle window gcontext
+			       (- (random width) 5)
+			       (- (random height) 5)
+			       (+ 4 (random (truncate width 3)))
+			       (+ 4 (random (truncate height 3)))
+			       t))
+	(xlib:display-force-output *display*)))
+    (xlib:free-gcontext gcontext)
+    (xlib:free-pixmap pixmap)))
+
+(defvar *greynetic-pixmap-array*
+  (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel))
+
+(defun greynetic-pixmapper ()
+  (let ((pixmap-data *greynetic-pixmap-array*))
+    (dotimes (i 4)
+      (declare (fixnum i))
+      (let ((nibble (random 16)))
+	(setf nibble (logior nibble (ash nibble 4))
+	      nibble (logior nibble (ash nibble 8))
+	      nibble (logior nibble (ash nibble 12))
+	      nibble (logior nibble (ash nibble 16)))
+	(dotimes (j 32)
+	  (let ((bit (if (logbitp j nibble) 1 0)))
+	    (setf (aref pixmap-data i j) bit
+		  (aref pixmap-data (+ 4 i) j) bit
+		  (aref pixmap-data (+ 8 i) j) bit
+		  (aref pixmap-data (+ 12 i) j) bit
+		  (aref pixmap-data (+ 16 i) j) bit
+		  (aref pixmap-data (+ 20 i) j) bit
+		  (aref pixmap-data (+ 24 i) j) bit
+		  (aref pixmap-data (+ 28 i) j) bit)))))
+    pixmap-data))
+
+(defdemo greynetic-demo "Greynetic" (&optional (duration 300))
+  100 100 600 600
+  "Displays random grey rectangles."
+  (greynetic *window* duration))
+
+
+;;;; Qix.
+
+(defstruct qix
+  buffer
+  (dx1 5)
+  (dy1 10)
+  (dx2 10)
+  (dy2 5))
+
+(defun construct-qix (length)
+  (let ((qix (make-qix)))
+    (setf (qix-buffer qix) (make-circular-list length))
+    qix))
+
+(defun make-circular-list (length)
+  (let ((l (make-list length)))
+    (rplacd (last l) l)))
+
+
+(defun qix (window lengths duration)
+  "Each length is the number of lines to put in a qix, and that many qix
+  (of the correct size) are put up on the screen.  Lets the qix wander around
+  the screen for Duration steps."
+  (let ((histories (mapcar #'construct-qix lengths)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (declare (fixnum width height))
+      (xlib:clear-area window)
+      (xlib:display-force-output *display*)
+      (do ((h histories (cdr h))
+	   (l lengths (cdr l)))
+	  ((null h))
+	(do ((x (qix-buffer (car h)) (cdr x))
+	     (i 0 (1+ i)))
+	    ((= i (car l)))
+	  (rplaca x (make-array 4))))
+      ;; Start each qix at a random spot on the screen.
+      (dolist (h histories)
+	(let ((x (random width))
+	      (y (random height)))
+	  (rplaca (qix-buffer h)
+		  (make-array 4 :initial-contents (list x y x y)))))
+      (rplacd (last histories) histories)
+      (let (x1 y1 x2 y2 dx1 dy1 dx2 dy2 tem line next-line qix
+	       (gc (xlib:create-gcontext :drawable window
+					 :foreground *white-pixel*
+					 :background *black-pixel*
+					 :line-width 0 :line-style :solid
+					 :function boole-c2)))
+	(declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2))
+	(dotimes (i duration)
+	  ;; Line is the next line in the next qix. Rotate this qix and
+	  ;; the qix ring.
+	  (setq qix (car histories))
+	  (setq line (car (qix-buffer qix)))
+	  (setq next-line (cadr (qix-buffer qix)))
+	  (setf (qix-buffer qix) (cdr (qix-buffer qix)))
+	  (setq histories (cdr histories))
+	  (setf x1 (svref line 0))
+	  (setf y1 (svref line 1))
+	  (setf x2 (svref line 2))
+	  (setf y2 (svref line 3))
+	  (xlib:draw-line window gc x1 y1 x2 y2)
+	  (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1))
+	  (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1))
+	  (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1))
+	  (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1))
+	  (cond ((> dx1 10) (setq dx1 10))
+		((< dx1 -10) (setq dx1 -10)))
+	  (cond ((> dy1 10) (setq dy1 10))
+		((< dy1 -10) (setq dy1 -10)))
+	  (cond ((> dx2 10) (setq dx2 10))
+		((< dx2 -10) (setq dx2 -10)))
+	  (cond ((> dy2 10) (setq dy2 10))
+		((< dy2 -10) (setq dy2 -10)))
+	  (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem))
+		 (setq dx1 (- dx1))))
+	  (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem))
+		 (setq dx2 (- dx2))))
+	  (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem))
+		 (setq dy1 (- dy1))))
+	  (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem))
+		 (setq dy2 (- dy2))))
+	  (setf (qix-dy2 qix) dy2)
+	  (setf (qix-dx2 qix) dx2)
+	  (setf (qix-dy1 qix) dy1)
+	  (setf (qix-dx1 qix) dx1)
+	  (when (svref next-line 0)
+	    (xlib:draw-line window gc
+			    (svref next-line 0) (svref next-line 1)
+			    (svref next-line 2) (svref next-line 3)))
+	  (setf (svref next-line 0) (+ x1 dx1))
+	  (setf (svref next-line 1) (+ y1 dy1))
+	  (setf (svref next-line 2) (+ x2 dx2))
+	  (setf (svref next-line 3) (+ y2 dy2))
+	  (xlib:display-force-output *display*))))))
+
+
+(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000))
+  0 0 700 700
+  "Hypnotic wandering lines."
+  (qix *window* lengths duration))
+
+
+
+;;;; Petal.
+
+;;; Fast sine constants:
+
+(defconstant d360 #o5500)
+(defconstant d270 #o4160)
+(defconstant d180 #o2640)
+(defconstant d90 #o1320)
+(defconstant vecmax 2880)
+
+(defconstant sin-array
+  '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 
+     #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145
+     #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 
+     #o12743 #o13357 #o13771 #o14401 #o15007 #o15414
+     #o16016 #o16416 #o17013 #o17407 #o20000 #o20366
+     #o20752 #o21333 #o21711 #o22265 #o22636 #o23204
+     #o23546 #o24106 #o24443 #o24774 #o25323 #o25645
+     #o26165 #o26501 #o27011 #o27316 #o27617 #o30115
+     #o30406 #o30674 #o31156 #o31434 #o31706 #o32154
+     #o32416 #o32654 #o33106 #o33333 #o33554 #o33771
+     #o34202 #o34406 #o34605 #o35000 #o35167 #o35351
+     #o35526 #o35677 #o36043 #o36203 #o36336 #o36464
+     #o36605 #o36721 #o37031 #o37134 #o37231 #o37322
+     #o37407 #o37466 #o37540 #o37605 #o37646 #o37701
+     #o37730 #o37751 #o37766 #o37775 #o40000))
+
+(defmacro psin (val)
+  `(let* ((val ,val)
+	  neg
+	  frac
+	  sinlo)
+     (if (>= val d180)
+	 (setq neg t
+	       val (- val d180)))
+     (if (>= val d90)
+	 (setq val (- d180 val)))
+     (setq frac (logand val 7))
+     (setq val (ash val -3))
+     ;; 
+     (setq sinlo (if (>= val 90)
+		     (svref sin-array 90)
+		     (svref sin-array val)))
+     ;; 
+     (if (< val 90)
+	 (setq sinlo
+	       (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo))
+			     -3))))
+     ;; 
+     (if neg
+	 (- sinlo)
+	 sinlo)))
+
+(defmacro pcos (x)
+  `(let ((tmp (- ,x d270)))
+     (psin (if (minusp tmp) (+ tmp d360) tmp))))
+
+
+;;;; Miscellaneous petal hackery.
+
+(defmacro high-16bits-* (a b)
+  `(let ((a-h (ash ,a -8))
+	 (b-h (ash ,b -8)))
+     (+ (* a-h b-h)
+	(ash (* a-h (logand ,b 255)) -8)
+	(ash (* b-h (logand ,a 255)) -8))))
+
+(defun complete (style petal)
+  (let ((repnum 1)
+	factor cntval needed)
+    (dotimes (i 3)
+      (case i
+	(0 (setq factor 2 cntval 6)) 
+	(1 (setq factor 3 cntval 2))
+	(2 (setq factor 5 cntval 1)))
+      (do ()
+	  ((or (minusp cntval) (not (zerop (rem style factor)))))
+	(setq repnum (* repnum factor))
+	(setq cntval (1- cntval))
+	(setq style (floor style factor))))
+    (setq needed (floor vecmax repnum))
+    (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed)))
+
+
+;;;; Petal Parameters and Petal itself
+
+(defparameter continuous t)
+(defparameter styinc 2)
+(defparameter petinc 1)
+(defparameter scalfac-fac 8192)
+
+(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0))
+  (let ((width 512)
+	(height 512))
+    (xlib:clear-area petal-window)
+    (xlib:display-force-output *display*)
+    (let ((veccnt 0)
+	  (nustyle 722)
+	  (nupetal 3)
+	  (scalfac (1+ (floor scalfac-fac (min width height))))
+	  (ctrx (floor width 2))
+	  (ctry (floor height 2))
+	  (tt 0)
+	  (s 0)
+	  (lststyle 0)
+	  (lstpetal 0)
+	  (petstyle 0)
+	  (vectors 0)
+	  (r 0)
+	  (x1 0)
+	  (y1 0)
+	  (x2 0)
+	  (y2 0)
+	  (i 0)
+	  (gc (xlib:create-gcontext :drawable petal-window
+				    :foreground *black-pixel*
+				    :background *white-pixel*
+				    :line-width 0 :line-style :solid)))
+      (loop
+	(when (zerop veccnt)
+	  (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal
+		style nustyle petstyle (rem (* petal style) d360)
+		vectors (complete style petal))
+	  (when continuous
+	    (setq nupetal  (+ nupetal petinc)
+		  nustyle (+ nustyle styinc)))
+	  (when (or (/= lststyle style) (/= lstpetal petal))
+	    (xlib:clear-area petal-window)
+	    (xlib:display-force-output *display*)))
+	(when (or (/= lststyle style) (/= lstpetal petal))
+	  (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2
+		tt (rem (+ tt style) d360)
+		s (rem (+ s petstyle) d360)
+		r (pcos s))
+	  (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac))
+		y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac)))
+	  (when (/= i 1)
+	    (xlib:draw-line petal-window gc x1 y1 x2 y2)
+	    (xlib:display-force-output *display*)))
+	(when (> veccnt vectors)
+	  (setq veccnt 0)
+	  (setq how-many (1- how-many))
+	  (sleep 2)
+	  (when (zerop how-many) (return)))))))
+
+(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0))
+  100 100 512 512
+  "Flower-like display."
+  (petal *window* how-many style petal))
+
+
+;;;; Hanoi.
+
+;;; Random parameters:
+
+(defparameter disk-thickness 15 "The thickness of a disk in pixels.")
+(defparameter disk-spacing (+ disk-thickness 3)
+  "The amount of vertical space used by a disk on a needle.")
+(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.")
+(defvar *vertical-velocity* 12 "The speed at which disks move up and down.")
+
+;;; These variables are bound by the main function.
+
+(defvar *hanoi-window* () "The window that Hanoi is happening on.")
+(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.")
+(defvar *transfer-height* () "The height at which disks are transferred.")
+(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.")
+
+;;; Needle Functions
+
+(defstruct disk
+  size)
+
+(defstruct needle
+  position
+  disk-stack)
+
+;;; Needle-Top-Height returns the height of the top disk on NEEDLE.
+
+(defun needle-top-height (needle)
+  (- *hanoi-window-height*
+     (* disk-spacing (length (the list (needle-disk-stack needle))))))
+
+(defvar available-disks
+  (do ((i 10 (+ i 10))
+       (dlist () (cons (make-disk :size i) dlist)))
+      ((> i 80) dlist)))
+
+(defvar needle-1 (make-needle :position 184))
+(defvar needle-2 (make-needle :position 382))
+(defvar needle-3 (make-needle :position 584))
+
+;;; Graphic interface abstraction:
+
+;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p"
+;;; set to T.  Update-Screen forces the display output.
+;;; 
+(defmacro invert-rectangle (x y height width)
+  `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext*
+			,x ,y ,width ,height t))
+
+(defmacro update-screen ()
+  `(xlib:display-force-output *display*))
+
+
+;;;; Moving disks up and down
+
+;;; Slide-Up slides the image of a disk up from the coordinates X,
+;;; START-Y to the point X, END-Y.  DISK-SIZE is the size of the disk to
+;;; move.  START-Y must be greater than END-Y
+
+(defun slide-up (start-y end-y x disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- start-y end-y) *vertical-velocity*)
+    (do ((x (- x disk-size))
+	 (width (* disk-size 2))
+	 (old-y start-y (- old-y *vertical-velocity*))
+	 (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (invert-rectangle x (- old-y pixels-left) disk-thickness width)
+	   (invert-rectangle x old-y disk-thickness width)
+	   (update-screen)))
+      ;; Loop body writes disk at new height & erases at old height.
+      (invert-rectangle x old-y disk-thickness width)
+      (invert-rectangle x new-y disk-thickness width)
+      (update-screen))))
+
+;;; Slide-Down slides the image of a disk down from the coordinates X,
+;;; START-Y to the point X, END-Y.  DISK-SIZE is the size of the disk to
+;;; move.  START-Y must be less than END-Y.
+
+(defun slide-down (start-y end-y x disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- end-y start-y) *vertical-velocity*)
+    (do ((x (- x disk-size))
+	 (width (* disk-size 2))
+	 (old-y start-y (+ old-y *vertical-velocity*))
+	 (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (invert-rectangle x (+ old-y pixels-left) disk-thickness width)
+	   (invert-rectangle x old-y disk-thickness width)
+	   (update-screen)))
+      ;; Loop body writes disk at new height & erases at old height.
+      (invert-rectangle X old-y disk-thickness width)
+      (invert-rectangle X new-y disk-thickness width)
+      (update-screen))))
+
+
+;;;; Lifting and Droping Disks
+
+;;; Lift-disk pops the top disk off of needle and raises it up to the
+;;; transfer height.  The disk is returned.
+
+(defun lift-disk (needle)
+  "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it."
+  (let* ((height (needle-top-height needle))
+	 (disk (pop (needle-disk-stack needle))))
+    (slide-up height
+	      *transfer-height*
+	      (needle-position needle)
+	      (disk-size disk))
+    disk))
+
+;;; Drop-disk drops a disk positioned over needle at the transfer height
+;;; onto needle.  The disk is pushed onto needle.
+
+(defun drop-disk (disk needle)
+  "DISK must be positioned above NEEDLE.  It is dropped onto NEEDLE."
+  (push disk (needle-disk-stack needle))
+  (slide-down *transfer-height*
+	      (needle-top-height needle)
+	      (needle-position needle)
+	      (disk-size disk))
+  t)
+
+
+;;; Drop-initial-disk is the same as drop-disk except that the disk is
+;;; drawn once before dropping.
+
+(defun drop-initial-disk (disk needle)
+  "DISK must be positioned above NEEDLE.  It is dropped onto NEEDLE."
+  (let* ((size (disk-size disk))
+	 (lx (- (needle-position needle) size)))
+    (invert-rectangle lx *transfer-height* disk-thickness (* size 2))
+    (push disk (needle-disk-stack needle))
+    (slide-down *transfer-height*
+		(needle-top-height needle)
+		(needle-position needle)
+		(disk-size disk))
+    t))
+
+
+;;;; Sliding Disks Right and Left
+
+;;; Slide-Right slides the image of a disk located at START-X, Y to the
+;;; position END-X, Y.  DISK-SIZE is the size of the disk.  START-X is
+;;; less than END-X.
+
+(defun slide-right (start-x end-x Y disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- end-x start-x) *horizontal-velocity*)
+    (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*))
+	 (left-x  (- start-x disk-size) (+ left-x  *horizontal-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (invert-rectangle right-x Y disk-thickness pixels-left)
+	   (invert-rectangle left-x  Y disk-thickness pixels-left)
+	   (update-screen)))
+      ;; Loop body adds chunk *horizontal-velocity* pixels wide to right
+      ;; side of disk, then chops off left side.
+      (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
+      (invert-rectangle left-x Y disk-thickness *horizontal-velocity*)
+      (update-screen))))
+
+;;; Slide-Left is the same as Slide-Right except that START-X is greater
+;;; than END-X.
+
+(defun slide-left (start-x end-x Y disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- start-x end-x) *horizontal-velocity*)
+    (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*)
+		  (- right-x *horizontal-velocity*))
+	 (left-x  (- (- start-x disk-size) *horizontal-velocity*)
+		  (- left-x  *horizontal-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (setq left-x  (- (+ left-x  *horizontal-velocity*) pixels-left))
+	   (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left))
+	   (invert-rectangle left-x  Y disk-thickness pixels-left)
+	   (invert-rectangle right-x Y disk-thickness pixels-left)
+	   (update-screen)))
+      ;; Loop body adds chunk *horizontal-velocity* pixels wide to left
+      ;; side of disk, then chops off right side.
+      (invert-rectangle left-x  Y disk-thickness *horizontal-velocity*)
+      (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
+      (update-screen))))
+
+
+;;;; Transferring Disks
+
+;;; Transfer disk slides a disk at the transfer height from a position
+;;; over START-NEEDLE to a position over END-NEEDLE.  Modified disk is
+;;; returned.
+
+(defun transfer-disk (disk start-needle end-needle)
+  "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE."
+  (let ((start (needle-position start-needle))
+	(end (needle-position end-needle)))
+    (if (< start end)
+	(slide-right start end *transfer-height* (disk-size disk))
+	(slide-left start end *transfer-height* (disk-size disk)))
+    disk))
+
+
+;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE.
+
+(defun move-one-disk (start-needle end-needle)
+  "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE."
+  (drop-disk (transfer-disk (lift-disk start-needle)
+			    start-needle
+			    end-needle)
+	     end-needle)
+  t)
+
+;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE
+;;; obeying the rules of the towers of hannoi problem.  To move the
+;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage.
+
+(defun move-n-disks (n start-needle end-needle temp-needle)
+  "Moves the top N disks from START-NEEDLE to END-NEEDLE.  
+   Uses TEMP-NEEDLE for temporary storage."
+  (cond ((= n 1)
+	 (move-one-disk start-needle end-needle))
+	(t
+	 (move-n-disks (1- n) start-needle temp-needle end-needle)
+	 (move-one-disk start-needle end-needle)
+	 (move-n-disks (1- n) temp-needle end-needle start-needle)))
+  t)
+
+
+;;;; Hanoi itself.
+
+(defun hanoi (window n)
+  (multiple-value-bind (width height) (full-window-state window)
+    (declare (ignore width))
+    (let* ((*hanoi-window* window)
+	   (*hanoi-window-height* height)
+	   (*transfer-height* (- height (* disk-spacing n)))
+	   (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window*
+						   :foreground *white-pixel*
+						   :background *black-pixel*
+						   :fill-style :solid
+						   :function boole-c2)))
+      (xlib:clear-area *hanoi-window*)
+      (xlib:display-force-output *display*)
+      (setf (needle-disk-stack needle-1) ())
+      (setf (needle-disk-stack needle-2) ())
+      (setf (needle-disk-stack needle-3) ())
+      (do ((n n (1- n))
+	   (available-disks available-disks (cdr available-disks)))
+	  ((zerop n))
+	(drop-initial-disk (car available-disks) needle-1))
+      (move-n-disks n needle-1 needle-3 needle-2)
+      t)))
+
+;;; Change the names of these when the DEMO loop isn't so stupid.
+;;; 
+(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4))
+  0 100 768 300
+  "Solves the Towers of Hanoi problem before your very eyes."
+  (let ((*horizontal-velocity* 3)
+	(*vertical-velocity* 1))
+    (hanoi *window* how-many)))
+;;;
+(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7))
+  0 100 768 300
+  "Solves the Towers of Hanoi problem before your very eyes."
+  (hanoi *window* how-many))
+
+
+
+;;;; Bounce window.
+
+;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of
+;;; the screen.  Optionally, the window can have an initial x velocity,
+;;; screen border elasticity, and gravity value.  The outer loop is
+;;; entered the first time with the window at its initial height, but
+;;; each iteration after this, the loop starts with the window at the
+;;; bottom of the screen heading upward.  The inner loop, except for the
+;;; first execution, carries the window up until the negative velocity
+;;; becomes positive, carrying the window down to bottom when the
+;;; velocity is positive.  Due to number lossage, ROUND'ing and
+;;; TRUNC'ing when the velocity gets so small will cause the window to
+;;; head upward with the same velocity over two iterations which will
+;;; cause the window to bounce forever, so we have prev-neg-velocity and
+;;; number-problems to check for this.  This is not crucial with the x
+;;; velocity since the loop terminates as a function of the y velocity.
+;;; 
+(defun bounce-window (window &optional
+			     (x-velocity 0) (elasticity 0.85) (gravity 2))
+  (unless (< 0 elasticity 1)
+    (error "Elasticity must be between 0 and 1."))
+  (unless (plusp gravity)
+    (error "Gravity must be positive."))
+  (multiple-value-bind (width height x y mapped) (full-window-state window)
+    (when (eq mapped :viewable)
+      (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height))
+	    (left-of-window-at-right (- (xlib:drawable-width *root*) width))
+	    (y-velocity 0)
+	    (prev-neg-velocity most-negative-fixnum)
+	    (number-problems nil))
+	(declare (fixnum top-of-window-at-bottom left-of-window-at-right
+			 y-velocity))
+	(loop
+	  (when (= prev-neg-velocity 0) (return t))
+	  (let ((negative-velocity (minusp y-velocity)))
+	    (loop
+	      (let ((next-y (+ y y-velocity))
+		    (next-y-velocity (+ y-velocity gravity)))
+		(declare (fixnum next-y next-y-velocity))
+		(when (> next-y top-of-window-at-bottom)
+		  (cond
+		   (number-problems
+		    (setf y-velocity (incf prev-neg-velocity)))
+		   (t
+		    (setq y-velocity
+			  (- (truncate (* elasticity y-velocity))))
+		    (when (= y-velocity prev-neg-velocity)
+		      (incf y-velocity)
+		      (setf number-problems t))
+		    (setf prev-neg-velocity y-velocity)))
+		  (setf y top-of-window-at-bottom)
+		  (setf (xlib:drawable-x window) x
+			(xlib:drawable-y window) y)
+		  (xlib:display-force-output *display*)
+		  (return))
+		(setq y-velocity next-y-velocity)
+		(setq y next-y))
+	      (when (and negative-velocity (>= y-velocity 0))
+		(setf negative-velocity nil))
+	      (let ((next-x (+ x x-velocity)))
+		(declare (fixnum next-x))
+		(when (or (> next-x left-of-window-at-right)
+			  (< next-x 0))
+		  (setq x-velocity (- (truncate (* elasticity x-velocity)))))
+		(setq x next-x))
+	      (setf (xlib:drawable-x window) x
+		    (xlib:drawable-y window) y)
+	      (xlib:display-force-output *display*))))))))
+
+;;; Change the name of this when DEMO is not so stupid.
+;;; 
+(defdemo shove-bounce-demo "Shove-bounce" ()
+  100 100 300 300
+  "Drops the demo window with an inital X velocity which bounces off
+  screen borders."
+  (bounce-window *window* 30))
+
+(defdemo bounce-demo "Bounce" ()
+  100 100 300 300
+  "Drops the demo window which bounces off screen borders."
+  (bounce-window *window*))
+
+
+;;;; Recurrence Demo
+
+;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu)
+
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify, and distribute this software, provided that this complete
+;;; copyright and permission notice is maintained, intact, in all copies and
+;;; supporting documentation.  
+
+;;; The author provides this software "as is" without express or
+;;; implied warranty.
+
+;;; This routine plots the recurrence 
+;;;      x <- y(1+sin(0.7x)) - 1.2(|x|)^.5
+;;;      y <- .21 - x
+;;; As described in a ?? 1983 issue of the Mathematical Intelligencer
+
+(defun recurrence (display window &optional (point-count 10000))
+  (let ((gc (xlib:create-gcontext :drawable window
+				  :background *white-pixel*
+				  :foreground *black-pixel*)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (xlib:clear-area window)
+      (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5))
+      (xlib:display-force-output display)
+      (sleep 4))
+    (xlib:free-gcontext gc)))
+
+;;; Draw points.  X assumes points are in the range of width x height,
+;;; with 0,0 being upper left and 0,H being lower left.
+;;; hw and hh are half-width and half-height of screen
+
+(defun draw-ppict (win gc count x y hw hh)
+  "Recursively draw pretty picture"
+  (unless (zerop count)
+    (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture
+          (yf (floor (* (+ 0.7 y) hh ))))
+      (xlib:draw-point win gc xf yf)
+      (draw-ppict win gc (1- count) 
+                  (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x))))
+                  (- 0.21 x)
+                  hw
+                  hh))))
+
+(defdemo recurrence-demo "Recurrence" ()
+  10 10 700 700
+  "Plots a cool recurrence relation."
+  (recurrence *display* *window*))
+
+
+;;;; Plaid
+
+;;; 
+;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover.
+;;; 
+
+(defmacro rect-x (rects n)
+  `(svref ,rects (ash ,n 2)))
+(defmacro rect-y (rects n)
+  `(svref ,rects (+ (ash ,n 2) 1)))
+(defmacro rect-width (rects n)
+  `(svref ,rects (+ (ash ,n 2) 2)))
+(defmacro rect-height (rects n)
+  `(svref ,rects (+ (ash ,n 2) 3)))
+
+(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10))
+  (let ((gcontext (xlib:create-gcontext :drawable window
+					:function boole-c2
+					:plane-mask (logxor *white-pixel*
+							    *black-pixel*)
+					:background *white-pixel*
+					:foreground *black-pixel*
+					:fill-style :solid))
+	(rectangles (make-array (* 4 num-rectangles)
+				:element-type 'number
+				:initial-element 0)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (let ((center-x (ash width -1))
+	    (center-y (ash height -1))
+	    (x-dir -2)
+	    (y-dir -2)
+	    (x-off 2)
+	    (y-off 2))
+	(dotimes (iter (truncate num-iterations num-rectangles))
+	  (dotimes (i num-rectangles)
+	    (setf (rect-x rectangles i) (- center-x x-off))
+	    (setf (rect-y rectangles i) (- center-y y-off))
+	    (setf (rect-width rectangles i) (ash x-off 1))
+	    (setf (rect-height rectangles i) (ash y-off 1))
+	    (incf x-off x-dir)
+	    (incf y-off y-dir)
+	    (when (or (<= x-off 0) (>= x-off center-x))
+	      (decf x-off (ash x-dir 1))
+	      (setf x-dir (- x-dir)))
+	    (when (or (<= y-off 0) (>= y-off center-y))
+	      (decf y-off (ash y-dir 1))
+	      (setf y-dir (- y-dir))))
+	  (xlib:draw-rectangles window gcontext rectangles t)
+	  (xlib:display-force-output display))))
+    (xlib:free-gcontext gcontext)))
+
+(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10))
+  10 10 101 201
+  "Plaid, man."
+  (plaid *display* *window* iterations num-rectangles))
+
+
+;;;; Bball demo
+
+;;; 
+;;; Ported to CLX by Blaine Burks
+;;; 
+
+(defvar *ball-size-x* 38)
+(defvar *ball-size-y* 34)
+
+(defmacro xor-ball (pixmap window gcontext x y)
+  `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y*
+		   ,window ,x ,y))
+
+(defconstant bball-gravity 1)
+(defconstant maximum-x-drift 7)
+
+(defvar *max-bball-x*)
+(defvar *max-bball-y*)
+
+(defstruct ball
+  (x (random (- *max-bball-x* *ball-size-x*)))
+  (y (random (- *max-bball-y* *ball-size-y*)))
+  (dx (if (zerop (random 2)) (random maximum-x-drift)
+	  (- (random maximum-x-drift))))
+  (dy 0))
+
+(defun get-bounce-image ()
+  "Returns the pixmap to be bounced around the screen."
+  (xlib::bitmap-image   #*000000000000000000000000000000000000
+			#*000000000000000000000000000000000000
+			#*000000000000000000001000000010000000
+			#*000000000000000000000000000100000000
+			#*000000000000000000000100001000000000
+			#*000000000000000010000000010000000000
+			#*000000000000000000100010000000000000
+			#*000000000000000000001000000000000000
+			#*000000000001111100000000000101010000
+			#*000000000010000011000111000000000000
+			#*000000000100000000111000000000000000
+			#*000000000100000000000000000100000000
+			#*000000000100000000001000100010000000
+			#*000000111111100000010000000001000000
+			#*000000111111100000100000100000100000
+			#*000011111111111000000000000000000000
+			#*001111111111111110000000100000000000
+			#*001111111111111110000000000000000000
+			#*011111111111111111000000000000000000
+			#*011111111111111111000000000000000000
+			#*111111111111110111100000000000000000
+			#*111111111111111111100000000000000000
+			#*111111111111111101100000000000000000
+			#*111111111111111101100000000000000000
+			#*111111111111111101100000000000000000
+			#*111111111111111111100000000000000000
+			#*111111111111110111100000000000000000
+			#*011111111111111111000000000000000000
+			#*011111111111011111000000000000000000
+			#*001111111111111110000000000000000000
+			#*001111111111111110000000000000000000
+			#*000011111111111000000000000000000000
+			#*000000111111100000000000000000000000
+			#*000000000000000000000000000000000000))
+
+
+(defun bounce-1-ball (pixmap window gcontext ball)
+  (let ((x (ball-x ball))
+	(y (ball-y ball))
+	(dx (ball-dx ball))
+	(dy (ball-dy ball)))
+    (xor-ball pixmap window gcontext x y)
+    (setq x (+ x dx))
+    (setq y (+ y dy))
+    (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*)))
+	(setq x (- x dx)
+	      dx (- dx)))
+    (if (> y (- *max-bball-y* *ball-size-y*))
+	(setq y (- y dy)
+	      dy (- dy)))
+    (setq dy (+ dy bball-gravity))
+    (setf (ball-x ball) x)
+    (setf (ball-y ball) y)
+    (setf (ball-dx ball) dx)
+    (setf (ball-dy ball) dy)
+    (xor-ball pixmap window gcontext x y)))
+
+(defun bounce-balls (display window how-many duration)
+  (xlib:clear-area window)
+  (xlib:display-force-output display)
+  (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window)
+    (let* ((balls (do ((i 0 (1+ i))
+		       (list () (cons (make-ball) list)))
+		      ((= i how-many) list)))
+	   (gcontext (xlib:create-gcontext :drawable window
+					   :foreground *white-pixel*
+					   :background *black-pixel*
+					   :function boole-xor
+					   :exposures :off))
+	   (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1
+					      :drawable window))
+	   (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap
+					    :foreground *white-pixel*
+					    :background *black-pixel*)))
+      (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image)
+		      :x 0 :y 0 :width 38 :height 34)
+      (xlib:free-gcontext pixmap-gc)
+      (dolist (ball balls)
+	(xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball)))
+      (xlib:display-force-output display)
+      (dotimes (i duration)
+	(dolist (ball balls)
+	  (bounce-1-ball bounce-pixmap window gcontext ball))
+	(xlib:display-force-output display))
+      (xlib:free-pixmap bounce-pixmap)
+      (xlib:free-gcontext gcontext))))
+
+(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500))
+  34 34 700 500
+  "Bouncing balls in space."
+  (bounce-balls *display*  *window* how-many duration))
diff --git a/contrib/follow-mouse/follow-mouse.catalog b/contrib/follow-mouse/follow-mouse.catalog
new file mode 100644
index 0000000000000000000000000000000000000000..dfc32e7579b1797371920e8ba8bd4fbd7884f2d5
--- /dev/null
+++ b/contrib/follow-mouse/follow-mouse.catalog
@@ -0,0 +1,46 @@
+Name:
+   Follow Mouse.
+
+Package Name:
+   HEMLOCK
+
+Description:
+   This Hemlock customization causes Hemlock's current window to be set to
+whatever Hemlock window the mouse enters, except the echo area.
+
+Author:
+   Todd Kaufmann, modified by Dave Touretzky.
+
+Maintainer:
+   Todd Kaufmann.
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   Todd.Kaufmann@CS.CMU.EDU
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   follow-mouse.lisp, follow-mouse.fasl, follow-mouse.catalog.
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>:
+   cp /afs/cs.cmu.edu/project/slisp/library/follow-mouse/* <spec>
+
+Portability:
+   This should work in any Common Lisp supporting Hemlock and CLX V11R3.
+
+Instructions:
+   Load the fasl file into your editor Lisp.  A value of T for the hemlock
+variable "Follow Mouse To Read-Only Buffers", which is the default, means
+follow mouse is on.  Anything else means hemlock will behave normally.
+
+Bugs:
+   A few more PROMPT-FOR-... functions need to be modified.  They are mentioned
+in the source code.
diff --git a/contrib/follow-mouse/follow-mouse.lisp b/contrib/follow-mouse/follow-mouse.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d45c3a505fdbc10823617a463889271d27f03b75
--- /dev/null
+++ b/contrib/follow-mouse/follow-mouse.lisp
@@ -0,0 +1,152 @@
+;;; -*- Mode: Lisp; Package: HEMLOCK-INTERNALS  -*-
+
+(in-package "HEMLOCK-INTERNALS")
+
+;;; todd kaufmann     24 mar 88
+
+;;; because we will have lots of windows, with users moving between them lots,
+;;; we would like the window the mouse is in to be the one input goes to.
+;;; 
+;;; also, this is more in line with the way most X windows work
+;;;   (unless you like to use focus)
+
+;;; Modified by Dave Touretzky 5/23/88 to fix incremental search problem,
+;;; to change windows upon leaving the echo area if the mouse moves
+;;; while we're prompting for input, and to select the correct window
+;;; when we split a window, based on where the mouse ends up.
+
+;;; Bugs:
+;;;  - a few more prompt-for-* functions need to be modified.  they're
+;;;    flagged below.
+
+(defhvar "Follow Mouse to Window"
+  "When T, the current window becomes the one the mouse enters; when NIL,
+  behaves the old way"
+  :value T)
+
+(defhvar "Follow Mouse To Read-only Buffers"
+  "Whether to follow the mouse to Read-only buffers or not"
+  :value T)
+
+(defvar *last-window-mouse-entered* nil)  ;set to the most recent LEGAL window entered
+
+(defun change-to-current-entered-window (window)
+  "Make the buffer the mouse has moved to be the current buffer."
+  (let ((buffer (window-buffer window)))
+    (when
+	(and *in-the-editor*
+	     (value ed::follow-mouse-to-window)
+	     ;; don't move cursor to menus
+	     (not (string= (buffer-major-mode buffer) "HMenu"))
+	     ;; don't move TO echo area
+	     (not (eq buffer *echo-area-buffer*))
+	     ;; can move to read-only buffers if user says it's okay
+	     (if (buffer-writable buffer) t
+		 (value ed::follow-mouse-to-read-only-buffers))
+	     ;; if we get here, this is a valid window to move to:  remember it
+	     (setf *last-window-mouse-entered* window)
+	     ;; but don't move OUT of the echo area if it's currently prompting.
+	     (not (eq (current-window) *echo-area-window*))
+	     ;; and don't move out of current window during an incremental search
+	     (not *during-incremental-search*)
+	     ;; Make sure it's not a random typeout buffer.
+	     (member window *window-list*)
+	     )
+      (setf (current-window) window
+	    (current-buffer) buffer
+	    *last-window-mouse-entered* nil))))
+
+
+(add-hook ed::enter-window-hook 'change-to-current-entered-window)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; If the user is being prompted in the echo area and moves the
+;;; mouse, we can't switch windows.  So remember where the mouse
+;;; has gone to, and switch when he leaves the echo area buffer.
+
+(defun change-windows-if-mouse-moved ()
+  (when (and *last-window-mouse-entered*
+	     (not (eq (current-window) *last-window-mouse-entered*)))
+    (change-to-current-entered-window *last-window-mouse-entered*)))
+
+
+;from echo.lisp
+
+(defun parse-for-something ()
+  (display-prompt-nicely)
+  (let ((start-window (current-window)))
+    (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
+    (setf (current-window) *echo-area-window*)
+    (unwind-protect
+	(use-buffer *echo-area-buffer*
+		    (recursive-edit nil))
+      (setf (current-window) start-window)
+      (change-windows-if-mouse-moved))))  ; <--- here's the change
+
+;---> Note:  must make the same change to the following:
+;	prompt-for-y-or-n
+;	prompt-for-character*
+;	prompt-for-key
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Fix for the problem of switching buffers in the middle of an
+;;; incremental search.
+;;;
+;;; Modify %i-search from searchcoms.lisp to bind a global variable
+;;; hi::*during-incremental-search* to T.  Check for this in body of
+;;; change-to-current-entered-window above.
+
+(defvar *during-incremental-search* nil)
+
+(in-package "HEMLOCK")
+
+(defun %i-search (string point trailer direction failure)
+  (unwind-protect			           ;<---- here's the change
+   (do* ((hi::*during-incremental-search* t)       ;<---- here's the change
+	 (curr-point (copy-mark point :temporary))
+	 (curr-trailer (copy-mark trailer :temporary))
+	 (next-char (get-key-event *editor-input* t)
+		    (get-key-event *editor-input* t)))
+	(nil)
+     (case (%i-search-char-eval next-char string point trailer direction failure)
+       (:cancel
+	(%i-search-echo-refresh string direction failure)
+	(unless (zerop (length string))
+	  (i-search-pattern string direction)))
+       (:return-cancel
+	(unless (zerop (length string)) (return :cancel))
+	(beep))
+       (:control-g
+	(when failure (return :control-g))
+	(%i-search-echo-refresh string direction nil)
+	(unless (zerop (length string))
+	  (i-search-pattern string direction))))
+     (move-mark point curr-point)
+     (move-mark trailer curr-trailer))
+   (hi::change-windows-if-mouse-moved)))	   ;<---- here's the change
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Fix Split Window to not change the current window.
+;;; That way, if the mouse is still in the current window,
+;;; everything's fine.  If the mouse ended up in the new
+;;; window, a mouse-entered-window event will handle the
+;;; change to the new window.
+
+; From filecoms.lisp:
+
+(defcommand "Split Window" (p)
+  "Make a new window by splitting the current window.
+   The new window is made the current window and displays starting at
+   the same place as the current window."
+  "Create a new window which displays starting at the same place
+   as the current window."
+  (declare (ignore p))
+  (let ((new (make-window (window-display-start (current-window)))))
+    (unless new (editor-error "Could not make a new window."))
+;    (setf (current-window) new)     <--- commented out this line
+ ))
diff --git a/contrib/games/feebs/brains.lisp b/contrib/games/feebs/brains.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a5c953bc5d08161dd7210fb1d81224cff5ffa123
--- /dev/null
+++ b/contrib/games/feebs/brains.lisp
@@ -0,0 +1,58 @@
+;;; -*- Mode: Lisp; Package: Sample-Brains; Log: feebs.log -*-
+;;;
+;;; Some Feeb brains.
+;;; Written by Skef Wholey and Scott Fahlman.
+;;;
+;;; The file Feebs.Lisp contains some feebs that are built-in for noise
+;;; purposes while running: RANDOM-BRAIN, WANDERING-BRAIN, and
+;;; CONSERVATIVE-BRAIN.  This file contains some other simply examples of
+;;; feebs.
+;;;
+
+(in-package "SAMPLE-BRAINS" :use '("LISP" "FEEBS"))
+
+
+;;; Experimental brain.  Like the built-in conservative brain, but without the
+;;; range limitation.
+;;;
+(defun cautious-brain (status proximity vision vision-left vision-right)
+  (declare (ignore vision-left vision-right))
+  (let ((stuff (my-square proximity)))
+    (cond ((and (consp stuff) (member :mushroom stuff :test #'eq))
+	   :eat-mushroom)
+	  ((and (consp stuff) (member :carcass stuff :test #'eq))
+	   :eat-carcass)
+	  ((and (ready-to-fire status)
+		(> (energy-reserve status) 30)
+		(dotimes (index (line-of-sight status))
+		  (let ((stuff (aref vision index)))
+		    (if (listp stuff)
+			(if (dolist (thing stuff)
+			      (if (feeb-image-p thing)
+				  (return t)))
+			    (return t))
+			(if (feeb-image-p stuff)
+			    (return t))))))
+	   :flame)
+	  ((and (not (eq (left-square proximity) :rock))
+		(> 0.2 (random 1.0)))
+	   :turn-left)
+	  ((and (not (eq (right-square proximity) :rock))
+		(> 0.2 (random 1.0)))
+	   :turn-right)
+	  ((not (ready-to-fire status))
+	   :wait)
+	  ((> (line-of-sight status) 0)
+	   :move-forward)
+	  ((not (eq (left-square proximity) :rock))
+	   :turn-left)
+	  ((not (eq (right-square proximity) :rock))
+	   :turn-right)
+	  (t
+	   :turn-around))))
+
+(define-feeb "Cau1" 'cautious-brain)
+(define-feeb "Cau2" 'cautious-brain)
+(define-feeb "Cau3" 'cautious-brain)
+
+
diff --git a/contrib/games/feebs/feebs.catalog b/contrib/games/feebs/feebs.catalog
new file mode 100644
index 0000000000000000000000000000000000000000..3ae7ae87d00bb7f433f0065cf880ebc657a63da0
--- /dev/null
+++ b/contrib/games/feebs/feebs.catalog
@@ -0,0 +1,37 @@
+[Name]		FEEBS
+
+[Description]	"Planet of the Feebs is a simulation game that is
+		intended as a training aid for beginning programmers in
+		Common Lisp.  It is loosely based on the "Maze War" game,
+		written by Jim Guyton, Bruce Malasky, and assorted others
+		at Xerox PARC.  In "Planet of the Feebs", however, the
+		players do not control their creatures by hand.  Instead,
+		they supply programs which control the creatures as they
+		move around the maze trying to zap one another.  The game
+		presents an open-ended challenge, and advanced players may
+		find themselves reaching deep into the AI bag of tricks as
+		they try to build ever more clever and adaptable creatures.
+
+[Author]	Skef Wholey, Scott Fahlman, Dan Kuokka, Jim Healy
+
+[Maintainer]	Members of the CMU Common Lisp Group.
+[Address]	Carnegie-Mellon University
+		Computer Science Department
+		Pittsburgh, PA 15213
+
+[Net Address]   Slisp@C.CS.CMU.EDU  (at CMU send mail to Gripe)
+
+[Copywrite Status] Public domain.
+
+[Files]		feebs.lisp, feebs.fasl, feebs.catalog, feebs.mss,
+		feebs.log, brains.lisp, brains.fasl, mazes.lisp
+
+[How to Get]	source /../spice/usr/slisp/library/rt/feebs/get-feebs.cmd
+
+[Portability]	Dependent on Version 10 of the X Window Manager.
+
+[Instructions]	Load feebs.fasl and brains.fasl.
+		call FEEBS:FEEBS.
+
+[Wish List]	Add egocentric display for one selected feeb.
+
diff --git a/contrib/games/feebs/feebs.lisp b/contrib/games/feebs/feebs.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b48340a562d7daf9302953afafc9f1b50618387a
--- /dev/null
+++ b/contrib/games/feebs/feebs.lisp
@@ -0,0 +1,1779 @@
+;;; -*- Mode: Lisp; Package: Feebs; Log: feebs.log -*-
+;;;
+;;; Planet of the Feebs.
+;;; A somewhat educational simulation game.
+;;;
+;;; Written by Skef Wholey.
+;;; Modified by Scott Fahlman.
+;;; Modified by Dan Kuokka.
+;;; Modified by Jim Healy.
+
+
+(in-package "FEEBS" :use "LISP")
+
+;;; Export everything we want the players to get their hands on.
+
+(export '(*single-step* *delay*
+          *number-of-feebs* *game-length*
+	  *points-for-killing* *points-for-dying* *maze-i-size*
+	  *maze-j-size* *flame-energy* *mushroom-energy*
+	  *carcass-energy* *maximum-energy* *minimum-starting-energy*
+	  *maximum-starting-energy* *number-of-mushrooms*
+	  *number-of-mushroom-sites* *carcass-guaranteed-lifetime*
+	  *carcass-rot-probability* *fireball-dissipation-probability*
+	  *fireball-reflection-probability* *flame-recovery-probability*
+	  *slow-feeb-noop-switch* *slow-feeb-noop-factor*
+	  name facing i-position j-position peeking line-of-sight
+	  energy-reserve score kills ready-to-fire aborted last-move
+	  feeb-image-p feeb-image-name feeb-image-facing
+	  fireball-image-p fireball-image-direction
+	  my-square left-square right-square rear-square
+	  list-parameter-settings
+	  define-feeb feebs load-feebs north south east west))
+
+;;; Macro for computing whether a random event has occurred, given the
+;;; chance of occurrence as a ratio.
+
+(defmacro chance (ratio)
+  `(< (random (denominator ,ratio)) (numerator ,ratio)))
+
+;;; Directions
+
+(defconstant north 0)
+(defconstant east 1)
+(defconstant south 2)
+(defconstant west 3)
+
+;;; These control the user interface.
+
+(defvar *single-step* nil
+  "If non-null, wait for a mouse click at the end of each round.")
+
+(defvar *delay* nil
+  "If non-null, sleep this many seconds after each round.")
+
+(defvar *continue* t
+  "If null, quit the game immediately.")
+
+(defvar *feep-dead-feebs* nil
+  "If non-null, feep every-time a feep dies or is killed.")
+
+
+;;; Parameters that affect strategy of the game.
+
+(defvar *feeb-parameters* nil)
+
+(defmacro def-feeb-parm (name value doc)
+  `(progn
+    (defvar ,name ,value ,doc)
+    (pushnew ',name *feeb-parameters*)))
+
+(defun list-parameter-settings ()
+  (let ((settings nil))
+    (dolist (parm *feeb-parameters*)
+      (push (cons parm (symbol-value parm)) settings))
+    settings))
+
+
+;;; General game parameters:
+
+(def-feeb-parm *number-of-feebs* 10
+  "Number of feebs that will play in the game.")
+
+(def-feeb-parm *game-length* 1000
+  "Number of cycles in the simulation.")
+
+(def-feeb-parm *slow-feeb-noop-switch* t
+  "If non-null, each feeb has a chance of having its orders aborted in
+  proportion to the time it takes to produce them.")
+
+(def-feeb-parm *slow-feeb-noop-factor* .25
+  "If *slow-feeb-noop-switch* is non-null, a feeb's orders will be aborted
+  with probability equal to the product of this factor times the time
+  taken by this feeb divided by the total time taken by all feebs this turn.")
+
+(def-feeb-parm *feep-dead-feebs-volume* 1
+  "An integer between -7 and 7 which determines the volume of the feep
+   emitted when a feeb dies.  The softest volume is 0 and the loudest
+   is 7.  Negative volumes are usually not heard.")
+
+;;; Scoring:
+
+(def-feeb-parm *points-for-killing* 1
+  "Added to one's score for killing an opponent.")
+
+(def-feeb-parm *points-for-dying* -2
+  "Added to one's score for being killed or starving.")
+
+
+;;; Characteristics of the maze:
+
+(def-feeb-parm *maze-i-size* 32
+  "Number of rows in the maze.")
+
+(def-feeb-parm *maze-j-size* 32
+  "Number of columns in the maze.")
+
+(def-feeb-parm *number-of-mushrooms* 10
+  "Average number of mushrooms in the maze at any given time.")
+
+(def-feeb-parm *number-of-mushroom-sites* 0
+  "Number of places at which mushrooms might grow.")
+
+
+;;; Energies:
+
+(def-feeb-parm *flame-energy* 10
+  "Energy used when a feeb flames.")
+
+(def-feeb-parm *mushroom-energy* 50
+  "Energy gained when a mushroom is eaten.")
+
+(def-feeb-parm *carcass-energy* 30
+  "Energy gained by feeding on a carcass.")
+
+(def-feeb-parm *maximum-energy* 200
+  "The most energy a feeb can accumulate.")
+
+(def-feeb-parm *minimum-starting-energy* 50
+  "Smallest amount of energy a feeb will start with.")
+
+(def-feeb-parm *maximum-starting-energy* 100
+  "Greatest amount of energy a feeb will start with.")
+
+
+;;; Carcasses:
+
+(def-feeb-parm *carcass-guaranteed-lifetime* 3
+  "Minimum number of turns a carcass will hang around.")
+
+(def-feeb-parm *carcass-rot-probability* 1/3
+  "Chance of a carcass rotting away each turn after its guaranteed lifetime.")
+
+
+;;; Fireballs:
+
+(def-feeb-parm *fireball-dissipation-probability* 1/4
+  "Chance that a fireball will dissipate each turn after it is fired.")
+
+(def-feeb-parm *fireball-reflection-probability* 1/2
+  "Chance that a fireball will reflect when it hits a wall.")
+
+(def-feeb-parm *flame-recovery-probability* 1/2
+  "Chance a feeb will regain its ability to flame each turn after flaming once.")
+
+
+;;; Structures:
+
+;;; The Feeb structure contains all of the info relevant to a particular feeb.
+;;; The info available to the brain function is in the Status sub-structure.
+
+(defstruct (feeb
+	    (:print-function print-feeb)
+	    (:constructor make-feeb (id brain)))
+  id
+  brain
+  image
+  status
+  proximity
+  time
+  last-score
+  last-kills
+  (dead-p nil)
+  (turns-dead 0)
+  (turns-since-flamed 0)
+  (vision (make-array (max *maze-j-size* *maze-j-size*)))
+  (vision-left (make-array (max *maze-j-size* *maze-j-size*)))
+  (vision-right (make-array (max *maze-j-size* *maze-j-size*))))
+
+(defstruct (status
+	    (:conc-name nil)
+	    (:constructor make-status (name facing i-position j-position)))
+  name
+  facing
+  i-position
+  j-position
+  peeking
+  line-of-sight
+  (energy-reserve (+ *minimum-starting-energy*
+		     (random (- *maximum-starting-energy*
+				*minimum-starting-energy*))))
+  (score 0)
+  (kills 0)
+  (ready-to-fire t)
+  (aborted nil)
+  (last-move :dead))
+
+
+(defun print-feeb (structure stream depth)
+  (declare (ignore depth))
+  (format stream "#<Feeb ~S>"
+	  (name (feeb-status structure))))
+
+
+(defstruct (proximity
+	    (:conc-name nil))
+  my-square
+  rear-square
+  left-square
+  right-square)
+
+
+;;; These image structures are used to represent feebs and fireballs in
+;;; the sensory displays of other feebs.
+
+(defstruct (feeb-image
+	    (:print-function print-feeb-image)
+	    (:constructor make-feeb-image (name facing feeb)))
+  name
+  facing
+  feeb)
+
+(defun print-feeb-image (structure stream depth)
+  (declare (ignore depth))
+  (format stream "#<Feeb-Image of ~S facing ~S>"
+	  (feeb-image-name structure)
+	  (feeb-image-facing structure)))
+
+
+(defstruct (fireball-image
+	    (:print-function print-fireball-image)
+	    (:constructor make-fireball-image (direction owner i j di dj)))
+  direction
+  owner
+  i
+  j
+  di
+  dj
+  (new t))
+
+(defun print-fireball-image (structure stream depth)
+  (declare (ignore depth))
+  (format stream "#<Fireball moving ~S>"
+	  (fireball-image-direction structure)))
+
+(defstruct (position
+	    (:constructor make-position (i j))
+	    (:print-function print-position))
+  i
+  j)
+
+(defun print-position (structure stream depth)
+  (declare (ignore depth))
+  (format stream "#<Position (~A, ~A)>"
+	  (position-i structure)
+	  (position-j structure)))
+
+
+;;; Setting up the maze.
+
+;;; The default maze.
+;;; X represents a wall,
+;;; * represents a mushroom patch, and
+;;; e is a feeb entry point.
+
+(defparameter default-layout
+  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "Xe   *        XXXXXXX XXXXXXXXXX"
+    "XXXXX XXXXXXX XXXXXXX    * XXXXX"
+    "XXXXX XXXXXXX XXXXXXX XXX XXXXXX"
+    "XXXXX XXX XXX  XXXXXXeXXX XXXXXX"
+    "XXXXX XXX XXXX XXXXXXXXXX XXXXXX"
+    "XXXXX XXX XXXX XX XXXXXXX XXXXXX"
+    "XXXXX    *  XX XX XXXXXXX XXXXXX"
+    "XXXXX XXXX XXX XX*    *   XXXXXX"
+    "XX   *XXXX XXX XX XXXX XXXXXXXXX"
+    "XX XX XXXXeXXX XX XXXX XXXXXXXXX"
+    "XX XX XXXX XXX   * *  *        X"
+    "XX XX XXXX XXXXXXXX XXXXXXXXXXeX"
+    "XXeXX XXXX XXXXXXXX XXXXXXXXXX X"
+    "XX XX     *   *     XXXXXXXX   X"
+    "XX XXXXXXXXXXX XXXX XXXXXXXX XXX"
+    "XX eXXXXXXXXXX  XXXe  XXXXXX XXX"
+    "XX XXXXXXXXXXXXe XXXXXXXXXXX XXX"
+    "XX*  XXX XXXXXXX  XXXXXXXXXX XXX"
+    "XX X  XX XXXXXXXX eXXXXXXXXX XXX"
+    "XX XX  X XXXXXXXXX  XXXXXXXX XXX"
+    "X  XXX  *    XXXXXX*        *  X"
+    "X XXXXXX XXX XXXXXX XXXXXXXXXX X"
+    "X XXXXXX XXX XXXXXX X        X X"
+    "X XXXXXX XXX XXXXXX X XXXXXX X X"
+    "X    *     *     XX X X  *eX X X"
+    "XXXXX XXXX XXXXXXXX X XXX XX X X"
+    "XXXXX XXXX XXXXX   *X XXX XX X X"
+    "XXXXX XXXX XXXXX XX X    e   X X"
+    "XXXXX XXXX     e XX XXX*XXXXXX X"
+    "XXXXX XXXXXXXXXXXXX            X"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
+
+(defvar maze (make-array (list *maze-i-size* *maze-j-size*)
+			 :initial-element ()))
+
+(defvar *mushroom-sites*)
+(defvar *entry-points*)
+(defvar *number-of-entry-points*)
+
+(defun init-maze (maze-strings)
+  (setq *mushroom-sites* nil)
+  (setq *entry-points* nil)
+  (do ((rows maze-strings (cdr rows))
+       (i 0 (1+ i)))
+      ((null rows))
+    (let ((str (car rows)))
+      (dotimes (j (length str))
+	(setf (aref maze i j) nil)
+	(case (schar str j)
+	  (#\X
+	   (setf (aref maze i j) :rock))
+	  (#\*
+	   (push (make-position i j) *mushroom-sites*))
+	  (#\e
+	   (push (make-position i j) *entry-points*))
+	  (#\space
+	   )
+	  (t
+	   (error "Bad thing in maze spec: ~C." (schar str j)))))))
+  (setq *number-of-mushroom-sites* (length *mushroom-sites*))
+  (setq *number-of-entry-points* (length *entry-points*)))
+
+(defun create-mushrooms ()
+  (dotimes (i *number-of-mushrooms*)
+    (do ((site (nth (random *number-of-mushroom-sites*) *mushroom-sites*)
+	       (nth (random *number-of-mushroom-sites*) *mushroom-sites*)))
+	((null (aref maze (position-i site) (position-j site)))
+	 (setf (aref maze (position-i site) (position-j site)) :mushroom)))))
+
+
+;;; Setting up the feebs.
+
+(defvar *feebs* nil
+  "A list of all the feebs in the current game.")
+
+(defvar *next-feeb-id* 0
+  "A counter used to assign a unique numerical code to each feeb.")
+
+(defun create-feeb (name brain)
+  (let* ((feeb (make-feeb *next-feeb-id* brain))
+	 (facing (random 4))
+	 (position (pick-random-entry-point)))
+    (setf (feeb-image feeb)
+	  (make-feeb-image name facing feeb))
+    (setf (feeb-status feeb)
+	  (make-status name facing (position-i position)
+		       (position-j position)))
+    (setf (feeb-proximity feeb) (make-proximity))
+    (push feeb *feebs*)
+    (incf *next-feeb-id*)
+    (setf (aref maze (position-i position) (position-j position))
+	  (feeb-image feeb))
+    feeb))
+
+;;; Start at some randomly chosen entry point.  If this one is occupied,
+;;; scan successive entry points until a winner is found.  Circle back
+;;; to start of list if necessary.
+
+(defun pick-random-entry-point ()
+  (do ((points (nthcdr (random *number-of-entry-points*) *entry-points*)
+	       (cdr points)))
+      (nil)
+    (when (null points)
+	  (setq points *entry-points*))
+    (when (null (aref maze (position-i (car points))
+		           (position-j (car points))))
+	  (return (car points)))))
+
+
+;;; Define-Feeb builds a list of feebs to create.  Create-Feebs actually
+;;; builds the feebs on this list.
+
+(defvar *feebs-to-be* nil)
+
+(defun define-feeb (name brain)
+  (push (cons name brain) *feebs-to-be*))
+
+(defun create-feebs ()
+  (when (> (length *feebs-to-be*) *number-of-entry-points*)
+	(error "More feebs than entry points."))
+  (setq *feebs* nil)
+  (setq *next-feeb-id* 0)
+  (dolist (feeb-spec (reverse *feebs-to-be*))
+    (create-feeb (car feeb-spec) (cdr feeb-spec))))
+
+
+;;; Vision calculation.
+
+;;; Some macros for directional arithmetic.
+
+(defmacro left-of (facing)
+  `(mod (+ ,facing 3) 4))
+
+(defmacro right-of (facing)
+  `(mod (+ ,facing 1) 4))
+
+(defmacro behind (facing)
+  `(mod (+ ,facing 2) 4))
+
+;;; These guys tell us offsets given an orientation.
+
+(defconstant facing-vector-1 '#(-1 0 1 0))
+(defconstant facing-vector-2 '#(0 1 0 -1))
+
+(defmacro forward-di (facing)
+  `(svref facing-vector-1 ,facing))
+
+(defmacro forward-dj (facing)
+  `(svref facing-vector-2 ,facing))
+
+(defmacro left-di (facing)
+  `(forward-di (left-of ,facing)))
+
+(defmacro left-dj (facing)
+  `(forward-dj (left-of ,facing)))
+
+(defmacro right-di (facing)
+  `(forward-di (right-of ,facing)))
+
+(defmacro right-dj (facing)
+  `(forward-dj (right-of ,facing)))
+
+(defmacro behind-di (facing)
+  `(forward-di (behind ,facing)))
+
+(defmacro behind-dj (facing)
+  `(forward-dj (behind ,facing)))
+
+(defun compute-vision (feeb)
+  (let* ((status (feeb-status feeb))
+	 (proximity (feeb-proximity feeb))
+	 (vision (feeb-vision feeb))
+	 (vision-left (feeb-vision-left feeb))
+	 (vision-right (feeb-vision-right feeb))
+	 (facing (facing status))
+	 vision-di
+	 vision-dj
+	 (i (i-position status))
+	 (j (j-position status)))
+    ;; First fill in proximity info.
+    (setf (my-square proximity)
+	  (aref maze i j))
+    (setf (left-square proximity)
+	  (aref maze (+ i (left-di facing)) (+ j (left-dj facing))))
+    (setf (right-square proximity)
+	  (aref maze (+ i (right-di facing)) (+ j (right-dj facing))))
+    (setf (rear-square proximity)
+	  (aref maze (+ i (behind-di facing)) (+ j (behind-dj facing))))
+    ;; The vision vector starts in the square the feeb is facing.
+    (setq i (+ i (forward-di facing)))
+    (setq j (+ j (forward-dj facing)))
+    ;; Figure out which direction to scan in.
+    (case (peeking status)
+      (nil)
+      (:left (setq facing (left-of facing)))
+      (:right (setq facing (right-of facing))))
+    (setq vision-di (forward-di facing))
+    (setq vision-dj (forward-dj facing))
+    (do* ((i i (+ i vision-di))
+	  (j j (+ j vision-dj))
+	  (left-wall-i (+ i (left-di facing)) (+ left-wall-i vision-di))
+	  (left-wall-j (+ j (left-dj facing)) (+ left-wall-j vision-dj))
+	  (right-wall-i (+ i (right-di facing)) (+ right-wall-i vision-di))
+	  (right-wall-j (+ j (right-dj facing)) (+ right-wall-j vision-dj))
+	  (index 0 (1+ index)))
+	 ((eq (aref maze i j) :rock)
+	  (setf (line-of-sight status) index))
+      (setf (aref vision index) (aref maze i j))
+      (setf (aref vision-left index)
+	    (side-imagify (aref maze left-wall-i left-wall-j)
+			  (right-of facing)))
+      (setf (aref vision-right index)
+	    (side-imagify (aref maze right-wall-i right-wall-j)
+			  (left-of facing))))))
+
+;;; Compute the info to be put into the vision-left and vision-right vectors.
+;;; A peeking feeb must be facing in the specified direction in order to count.
+
+(defun side-imagify (stuff facing)
+  (cond ((eq stuff :rock) :rock)
+	((and (feeb-image-p stuff)
+	      (= facing (feeb-image-facing stuff))
+	      (peeking (feeb-status (feeb-image-feeb stuff))))
+	 :peeking)
+	((listp stuff)
+	 (do ((stuff stuff (cdr stuff)))
+	     ((null stuff) nil)
+	   (when (and (feeb-image-p (car stuff))
+		      (= facing (feeb-image-facing (car stuff)))
+		      (peeking (feeb-status (feeb-image-feeb (car stuff)))))
+		 (return :peeking))))
+	(t nil)))
+
+
+;;; Movement.
+
+;;; Each turn, the following stuff has to happen:
+;;;	1. Bump the turn counter; end the game if we should.
+;;;	2. Maybe grow some mushrooms.
+;;;	3. Maybe disappear some carcasses.
+;;;	4. Move fireballs around.
+;;;	5. See if any feebs have starved.
+;;;	6. See if any feebs can flame again.
+;;;	7. Compute vision and stuff for feebs.
+;;;	8. Collect the feebs' moves.
+;;;	9. Do the feeb's moves.
+
+(defvar *current-turn* 0)
+
+(defvar *mushrooms-alive*)
+(defvar *dead-feebs*)
+(defvar *fireballs-flying*)
+
+(defun init-play ()
+  (setq *mushrooms-alive* *number-of-mushrooms*)
+  (setq *dead-feebs* nil)
+  (setq *fireballs-flying* nil))
+
+(defun play ()
+  (dotimes (*current-turn* *game-length*)
+    (play-one-turn)
+    (when (plusp (x:xpending)) (system:server))
+    (redisplay)
+    (display-status)
+    (cond ((not *continue*) (return-from play))
+	  (*single-step* (get-mouse-buttonpress))
+	  (*delay* (sleep-with-server *delay*)))))
+
+(defun play-one-turn ()
+  ;; Grow some mushrooms:
+  (dotimes (i (- *number-of-mushrooms* *mushrooms-alive*))
+    (let* ((site (nth (random *number-of-mushroom-sites*) *mushroom-sites*))
+	   (i (position-i site))
+	   (j (position-j site))
+	   (stuff (aref maze (position-i site) (position-j site))))
+      (cond ((null stuff)
+	     (place-object :mushroom i j))
+	    ((atom stuff)
+	     (unless (eq stuff :mushroom)
+	       (place-object :mushroom i j)))
+	    (t
+	     (unless (member :mushroom stuff)
+	       (place-object :mushroom i j))))))
+  ;; Rot some carcasses:
+  (dolist (feeb *dead-feebs*)
+    (incf (feeb-turns-dead feeb))
+    (when (> (feeb-turns-dead feeb) *carcass-guaranteed-lifetime*)
+      (when (chance *carcass-rot-probability*)
+	(delete-object :carcass
+		       (i-position (feeb-status feeb))
+		       (j-position (feeb-status feeb)))
+	(setq *dead-feebs* (delete feeb *dead-feebs*))
+	(reincarnate-feeb feeb))))
+  ;; Move some fireballs:
+  (dolist (fireball *fireballs-flying*)
+    (move-one-fireball fireball))
+  ;; Starve some feebs:
+  (dolist (feeb *feebs*)
+    (unless (feeb-dead-p feeb)
+      (when (<= (decf (energy-reserve (feeb-status feeb))) 0)
+	(kill-feeb feeb))))
+  ;; Let some feebs regain the power to flame:
+  (dolist (feeb *feebs*)
+    (unless (feeb-dead-p feeb)
+      (unless (ready-to-fire (feeb-status feeb))
+	(incf (feeb-turns-since-flamed feeb))
+	(when (and (> (feeb-turns-since-flamed feeb) 1)
+		   (chance *flame-recovery-probability*))
+	  (setf (ready-to-fire (feeb-status feeb)) t)))))
+  ;; Compute vision for all the feebs.
+  (dolist (feeb *feebs*)
+    (unless (feeb-dead-p feeb)
+      (compute-vision feeb)))
+  ;; Collect all the feebs' moves, keeping track of the time each one takes.
+  (let ((total-time 1))
+    (dolist (feeb *feebs*)
+      (unless (feeb-dead-p feeb)
+	(let ((time (get-internal-real-time)))
+	  (setf (last-move (feeb-status feeb))
+		(funcall (feeb-brain feeb)
+			 (feeb-status feeb)
+			 (feeb-proximity feeb)
+			 (feeb-vision feeb)
+			 (feeb-vision-left feeb)
+			 (feeb-vision-right feeb)))
+	  (setq time (- (get-internal-real-time) time))
+	  (incf total-time time)
+	  (setf (feeb-time feeb) time))))
+    ;; Do all the feebs' moves, or perhaps abort the move according
+    ;; to the time taken by the feeb.
+    (setq total-time (float total-time))
+    (dolist (feeb *feebs*)
+      (unless (feeb-dead-p feeb)
+	(cond ((and *slow-feeb-noop-switch*
+		    (< (random 1.0)
+		       (* *slow-feeb-noop-factor*
+			  (/ (float (feeb-time feeb)) total-time))))
+	       (setf (aborted (feeb-status feeb)) t))
+	      (t (setf (aborted (feeb-status feeb)) nil)
+		 (do-move feeb (last-move (feeb-status feeb)))))
+	;; Make the image consistent with the feeb.
+	(setf (feeb-image-facing (feeb-image feeb))
+	      (facing (feeb-status feeb)))))))
+
+(defun move-one-fireball (fireball)
+  (let ((i (fireball-image-i fireball))
+	(j (fireball-image-j fireball)))
+    ;; Remove fireball from current square, unless it is new.
+    (if (fireball-image-new fireball)
+	(setf (fireball-image-new fireball) nil)
+	(delete-object fireball i j))
+    ;; The fireball might dissipate.
+    (when (chance *fireball-dissipation-probability*)
+	  (setq *fireballs-flying* (delete fireball *fireballs-flying*))
+	  (return-from move-one-fireball nil))
+    ;; Now move it to new coordinates.
+    (incf i (fireball-image-di fireball))
+    (incf j (fireball-image-dj fireball))
+    ;; If it hits rock, either reflect or dissipate.
+    (when (eq (aref maze i j) :rock)
+      (cond ((chance *fireball-reflection-probability*)
+	     (setf (fireball-image-di fireball)
+		   (- (fireball-image-di fireball)))
+	     (setf (fireball-image-dj fireball)
+		   (- (fireball-image-dj fireball)))
+	     (setf (fireball-image-direction fireball)
+		   (behind (fireball-image-direction fireball)))
+	     (setq i (fireball-image-i fireball))
+	     (setq j (fireball-image-j fireball)))
+	    (t (setq *fireballs-flying*
+		     (delete fireball *fireballs-flying*))
+	       (return-from move-one-fireball nil))))
+    ;; Now put the fireball into the new square.
+    (setf (fireball-image-i fireball) i)
+    (setf (fireball-image-j fireball) j)
+    (place-object fireball i j)
+    ;; And destroy whatever is there.
+    (let ((stuff (aref maze i j)))
+      ;; If there is other stuff in the square, the contents will be a list.
+      (when (listp stuff)
+	    (dolist (thing stuff)
+	      (cond ((fireball-image-p thing) nil)
+		    ((eq thing :mushroom)
+		     (delete-object :mushroom i j))
+		    ((feeb-image-p thing)
+		     (setq thing (feeb-image-feeb thing))
+		     (score-kill fireball thing))))))))
+
+;;; The fireball kills the feeb.  Update score for killer and victims.
+;;; No credit for the kill if you shoot yourself.
+
+(defun score-kill (fireball feeb)
+  (unless (eq (fireball-image-owner fireball) feeb)
+	  (incf (score (feeb-status (fireball-image-owner fireball)))
+		*points-for-killing*)
+	  (incf (kills (feeb-status (fireball-image-owner fireball)))))
+  (kill-feeb feeb))
+
+
+;;; Doing feeb moves.
+
+(defun do-move (feeb move)
+  (let ((status (feeb-status feeb)))
+    ;; Redisplay the feeb's old square, whatever the action is.
+    (queue-redisplay (i-position status) (j-position status))
+    ;; If feeb was peeking last move, redisplay the square it is facing
+    ;; to get rid of the periscope.
+    (when (peeking status)
+      (queue-redisplay (+ (i-position status) (forward-di (facing status)))
+		       (+ (j-position status) (forward-dj (facing status)))))
+    ;; Peeking gets undone every move.
+    (setf (peeking status) nil)
+    (case move
+      (:turn-left
+       (setf (facing status) (left-of (facing status))))      
+      (:turn-right
+       (setf (facing status) (right-of (facing status))))
+      (:turn-around
+       (setf (facing status) (behind (facing status))))
+      (:move-forward
+       (let* ((facing (facing status))
+	      (old-i (i-position status))
+	      (old-j (j-position status))
+	      (new-i (+ (forward-di facing) old-i))
+	      (new-j (+ (forward-dj facing) old-j))
+	      (stuff (aref maze new-i new-j)))
+	 (when (eq stuff :rock) (return-from do-move nil))
+	 (delete-object (feeb-image feeb) old-i old-j)
+	 (setf (i-position status) new-i)
+	 (setf (j-position status) new-j)
+	 (place-object (feeb-image feeb) new-i new-j)
+	 ;; Look for a fireball in the destination square.
+	 (when (fireball-image-p stuff)
+	   (score-kill stuff feeb)
+	   (return-from do-move nil))
+	 (when (consp stuff)
+	   (dolist (thing stuff)
+	     (when (fireball-image-p thing)
+	       (score-kill thing feeb)
+	       (return-from do-move nil))))))
+      (:flame
+       (when (ready-to-fire status)
+	 (let* ((facing (facing status))
+		(i (i-position status))
+		(j (j-position status))
+		(fireball (make-fireball-image
+			   facing feeb i j
+			   (forward-di facing) (forward-dj facing))))
+	   ;; Queue the fireball, marked as new, but don't put it on map yet.
+	   (push fireball *fireballs-flying*)
+	   (decf (energy-reserve status) *flame-energy*)
+	   (setf (ready-to-fire status) nil)
+	   (setf (feeb-turns-since-flamed feeb) 0))))
+      (:eat-mushroom
+       (let* ((i (i-position status))
+	      (j (j-position status))
+	      (stuff (aref maze i j)))
+	 (when (and (listp stuff)
+		    (member :mushroom stuff))
+	   (delete-object :mushroom i j)
+	   (setf (energy-reserve status)
+		 (min (+ (energy-reserve status) *mushroom-energy*)
+		      *maximum-energy*)))))
+      (:eat-carcass
+       (let* ((i (i-position status))
+	      (j (j-position status))
+	      (stuff (aref maze i j)))
+	 (when (and (listp stuff)
+		    (member :carcass stuff))
+	   (setf (energy-reserve status)
+		 (min (+ (energy-reserve status) *carcass-energy*)
+		      *maximum-energy*)))))
+      (:peek-left
+       (unless (eq (aref maze (+ (i-position status)
+				 (forward-di (facing status)))
+			      (+ (j-position status)
+				 (forward-dj (facing status))))
+		   :rock)
+	       (setf (peeking status) :left)))
+      (:peek-right
+       (unless (eq (aref maze (+ (i-position status)
+				 (forward-di (facing status)))
+			      (+ (j-position status)
+				 (forward-dj (facing status))))
+		   :rock)
+	       (setf (peeking status) :right)))
+      (:wait
+       ))))
+
+;;; Movement/Redisplay interface.
+
+(defun delete-object (thing i j)
+  (when (eq thing :mushroom)
+    (decf *mushrooms-alive*))
+  (let ((stuff (aref maze i j)))
+    (cond ((atom stuff)
+	   (setf (aref maze i j) nil))
+	  ((null (cddr stuff))
+	   (setf (aref maze i j)
+		 (if (eq (car stuff) thing)
+		     (cadr stuff)
+		     (car stuff))))
+	  (t
+	   (setf (aref maze i j) (delete thing stuff)))))
+  (queue-redisplay i j))
+
+(defun place-object (thing i j)
+  (when (eq thing :mushroom)
+    (incf *mushrooms-alive*))
+  (let ((stuff (aref maze i j)))
+    (cond ((null stuff)
+	   (setf (aref maze i j) thing))
+	  ((consp stuff)
+	   (setf (aref maze i j) (cons thing stuff)))
+	  (t
+	   (setf (aref maze i j) (list thing stuff)))))
+  (queue-redisplay i j))
+
+(defun reincarnate-feeb (feeb)
+  (let ((position (nth (random (length *entry-points*)) *entry-points*))
+	(facing (random 4))
+	(status (feeb-status feeb)))
+    (place-object (feeb-image feeb)
+		  (position-i position) (position-j position))
+    (setf (i-position status) (position-i position))
+    (setf (j-position status) (position-j position))
+    (setf (facing status) facing)
+    (setf (feeb-dead-p feeb) nil)
+    (setf (ready-to-fire status) t)
+    (setf (energy-reserve status)
+	  (+ *minimum-starting-energy*
+	     (random (- *maximum-starting-energy*
+			*minimum-starting-energy*))))
+    (setf (last-move status) :dead)))
+
+(defun kill-feeb (feeb)
+  (push feeb *dead-feebs*)
+  (setf (feeb-dead-p feeb) t)
+  (setf (feeb-turns-dead feeb) 0)
+  (setf (energy-reserve (feeb-status feeb)) 0)
+  (let* ((status (feeb-status feeb))
+	 (i (i-position status))
+	 (j (j-position status)))
+    (incf (score status) *points-for-dying*)
+    ;; Clean up the periscope when a peeking feeb dies.
+    (when (peeking status)
+      (queue-redisplay (+ i (forward-di (facing status)))
+		       (+ j (forward-dj (facing status)))))
+    (delete-object (feeb-image feeb) i j)
+    (place-object :carcass i j)
+    (when *feep-dead-feebs*
+      (feep *feep-dead-feebs-volume*))))
+
+;;; Display routines for Feebs under X (Version 10).  All display
+;;; primitives used in this program are defined here.  This was
+;;; written for a monochrome display but could easily be adapted
+;;; for a color display.
+
+(defvar *birds-eye-window*)
+(defvar *status-window*)
+(defvar *banner-window*)
+
+(defvar *status-font-id*)
+(defvar *banner-font-id*)
+
+(defparameter bordercolor nil)
+(defparameter background nil)
+(defparameter borderwidth 1)
+
+(defparameter birds-eye-width 704)
+(defparameter birds-eye-height 704)
+(defparameter birds-eye-x 36)
+(defparameter birds-eye-y 60)
+
+(defparameter status-window-width 248)
+(defparameter status-window-height 704)
+(defparameter status-window-x 740)
+(defparameter status-window-y 60)
+
+(defparameter banner-window-width 952)
+(defparameter banner-window-height 27)
+(defparameter banner-window-x 36)
+(defparameter banner-window-y 32)
+
+(defparameter feebs-font "8x13")
+(defparameter *char-width* 8)
+(defparameter *char-height* 13)
+
+(defparameter banner-font "micr25")
+(defparameter feebs-banner
+  "Planet of the Feebs: A Somewhat Educational Simulation Game")
+
+(defconstant redisplay-scale 22)
+(defconstant pixel-character #\X)
+
+(defun init-graphics ()
+  (x:open-console)
+  (setf bordercolor (x:blackpixmap))
+  (setf background (x:whitepixmap))
+  (setq *status-font-id* (x:xgetfont feebs-font))
+  (setq *banner-font-id* (x:xgetfont banner-font)))
+
+(defun tini-graphics ()
+  (x:xfreefont *status-font-id*)
+  (x:xfreefont *banner-font-id*))
+
+(defmacro create-window (x y width height)
+  (declare (fixnum x y width height))
+  `(x:xcreatewindow (x:rootwindow) ,x ,y ,width ,height borderwidth
+		  bordercolor background))
+
+(defmacro prepare-for-xevents (window)
+  `(progn (x:xselectinput ,window important-xevents)
+     (system:add-xwindow-object ,window ,window *feebs-windows*)))
+
+(defmacro display-window (window)
+  `(x:xmapwindow ,window))
+
+(defmacro delete-window (window)
+  `(x:xdestroywindow ,window))
+
+;;; Window event control section.  Lots of hair necessary to deal
+;;; with funny stuff of X windows.  Ignore it if you want to, but
+;;; it won't go away.
+
+(defconstant important-xevents
+  (logior x:exposeregion x:exposewindow x:buttonpressed x:keypressed))
+
+(defvar *buttonpressed-flag* nil)
+(defconstant blow-away-feebs-character #\q)
+(defconstant single-step-feebs-character #\s)
+(defconstant auto-mode-feebs-character #\a)
+
+;;; Create an object set of windows to receive certain events from X.
+
+(defvar *feebs-windows* (system:make-object-set "Feebs Windows"))
+
+;;; Sleep-with-server sleeps the appropriate amount of time but
+;;; still processes xevents with the system server.
+
+(defun sleep-with-server (time)
+  (let ((end (+ (get-internal-real-time)
+		(truncate (* time internal-time-units-per-second)))))
+    (loop
+      (let ((left (- end (get-internal-real-time))))
+	(unless (plusp left) (return nil))
+	(system:server (* left (truncate 1000 internal-time-units-per-second)))))))
+
+;;; Redraws a specific window if an exposure event (either exposewindow
+;;; or exposeregion) occurs.
+
+(defun redraw-all-exposed-regions (object width height x y subwindow)
+  (declare (ignore width height x y subwindow))
+  (cond ((eq object *birds-eye-window*)
+	 (redisplay-all))
+	((eq object *status-window*)
+	 (display-all-status))
+	((eq object *banner-window*)
+	 (redisplay-banner))))
+
+(defun redraw-all-exposed-windows (object subwindow)
+  (declare (ignore object subwindow))
+  (cond ((eq object *birds-eye-window*)
+	 (redisplay-all))
+	((eq object *status-window*)
+	 (display-all-status))
+	((eq object *banner-window*)
+	 (redisplay-banner))))
+
+;;; Sets the buttonpressed flag to true when a mouse button is pressed.
+
+(defun set-buttonpressed-flag (object mod-bits scan-code x y
+				      subwindow time abs-x abs-y)
+  (declare (ignore object mod-bits scan-code x y subwindow time abs-x abs-y))
+  (setq *buttonpressed-flag* t))
+
+;;; Check which key was pressed and do the appropriate thing.
+
+(defun check-keypressed (object mod-bits scan-code x y
+				subwindow time abs-x abs-y)
+  (declare (ignore object x y subwindow time abs-x abs-y))
+  (cond ((eq (hemlock-internals::translate-character scan-code mod-bits)
+	     blow-away-feebs-character)
+	 (format t "Feebs was interrupted at turn ~D.~%" *current-turn*)
+	 (setq *continue* nil))
+	((eq (hemlock-internals::translate-character scan-code mod-bits)
+	     single-step-feebs-character)
+	 (setq *single-step* t))
+	((eq (hemlock-internals::translate-character scan-code mod-bits)
+	     auto-mode-feebs-character)
+	 (setq *single-step* nil))))
+
+;;; Stops and waits until any one of the mouse buttons is pressed.
+
+(defun get-mouse-buttonpress ()
+  (loop
+    (when *buttonpressed-flag*
+      (setq *buttonpressed-flag* nil)
+      (return))
+    (system:server)))
+
+;;; Tell the X server which functions will handle which events when
+;;; they occur.
+
+(x:serve-exposeregion  *feebs-windows* #'redraw-all-exposed-regions)
+(x:serve-exposewindow  *feebs-windows* #'redraw-all-exposed-windows)
+(x:serve-buttonpressed *feebs-windows* #'set-buttonpressed-flag)
+(x:serve-keypressed    *feebs-windows* #'check-keypressed)
+
+;;; Rings the keyboard bell.
+
+(defun feep (feep-volume)
+  (x:xfeep feep-volume))
+
+;;; The following section of code is used to manipulate an array
+;;; of 16-bit unsigned integers (a "bit-array").  This array
+;;; can be encoded with a graphic pattern from strings with
+;;; "X"'s in them and then passed to X window manager routines to 
+;;; create a bitmap for display.
+
+;;; Computes the number of 16-bit unsigned integers needed for
+;;; the bit-array.
+
+(defmacro bit-array-size (width height)
+  (declare (fixnum width height))
+  `(* (truncate (+ ,width 15) 16) ,height))
+
+;;; Computes how many bits each line of the bit-array has.
+
+(defmacro bit-array-line-len (width)
+  (declare (fixnum width))
+  `(truncate (+ ,width 15) 16))
+
+;;; Allows referencing of individual bits in the bit-array.
+
+(defun bit-array-ref (array x y width)
+  (declare (fixnum x y width))
+  (multiple-value-bind (words bits) (truncate x 16)
+    (ldb (byte 1 bits)
+	 (aref array
+	       (+ (* y (bit-array-line-len width))
+		  words))))))
+
+;;; Defines bit-array-ref as a setfable form to allow setting
+;;; of the individual bits in the bit-array.
+
+(defsetf bit-array-ref (array x y width) (new)
+  (declare (fixnum x y width))
+  (let ((words (gensym))
+	(bits (gensym)))
+    `(multiple-value-bind (,words ,bits) (truncate ,x 16)
+       (setf (ldb (byte 1 ,bits) 
+		  (aref ,array
+			(+ (* ,y (bit-array-line-len ,width))
+			   ,words)))
+	     ,new))))
+
+;;; Creates an array of 16-bit unsigned integers with the bits
+;;; in this array set to 1 or 0 according to where there is an
+;;; "X" in the strings.  This bit-array can then be passed to
+;;; the X routines to create a bitmap.
+
+(defun make-bit-array-from-strings (strings width height)
+  (declare (list strings) (integer width height))
+  (let ((bit-array (make-array (bit-array-size width height)
+				 :element-type '(unsigned-byte 16)
+				 :initial-element 0)))
+    (do ((strings strings (cdr strings))
+	 (row 0 (1+ row)))
+	((eq row height))
+      (let ((string (car strings)))
+	(declare (simple-string string))
+	(dotimes (column width)
+	  (if (char= (schar string column) pixel-character)
+	      (setf (bit-array-ref bit-array column row width) 1)))))
+    bit-array))
+
+(defmacro make-bitmap (bit-array width height)
+  (declare (fixnum width height))
+  `(x:xstorebitmap ,width ,height ,bit-array))
+
+(defmacro delete-bitmap (bitmap)
+  `(x:xfreebitmap ,bitmap))
+
+;;; Rotates the image in the bit-array to face in the
+;;; specified direction relative to the current.
+
+(defun rotate-bit-array (bit-array width height direction)
+  (declare (fixnum width height))
+  (if (eq width height)
+      (let ((rotated-bit-array (make-array (bit-array-size width height)
+				    :element-type '(unsigned-byte 16)
+				    :initial-element 0)))
+	(cond ((eq direction east)
+	       (dotimes (j height)
+		 (dotimes (i width)
+		   (if (eq (bit-array-ref bit-array i j width) 1)
+		       (setf (bit-array-ref rotated-bit-array 
+					    (- width j) i width) 1)))))
+	      ((eq direction south)
+	       (dotimes (j height)
+		 (dotimes (i width)
+		   (if (eq (bit-array-ref bit-array i j width) 1)
+		       (setf (bit-array-ref rotated-bit-array
+					    (- width i) (- height j)
+					    width) 1)))))
+	      ((eq direction west)
+	       (dotimes (j height)
+		 (dotimes (i width)
+		   (if (eq (bit-array-ref bit-array i j width) 1)
+		       (setf (bit-array-ref rotated-bit-array
+					    j (- height i) width) 1))))))
+	rotated-bit-array)))
+
+;;; Completely shades in a rectangular region of the screen at
+;;; x and y coordinates and specified width and height.  (or
+;;; shades the region white if :undraw is t.)
+
+(defmacro draw-rectangle (window x y width height &key (undraw nil))
+  (declare (fixnum x y width height))
+  `(x:xpixset ,window ,x ,y ,width ,height (if ,undraw x:whitepixel x:blackpixel)))
+
+;;; Draws an X bitmap to the screen at x and y coordinates with
+;;; the specified width and height.
+
+(defmacro draw-bitmap (window x y width height bitmap)
+  (declare (fixnum x y width height))
+  `(x:xpixfill ,window ,x ,y ,width ,height x:blackpixel ,bitmap
+	     x:gxclear x:allplanes))
+
+;;; Prints a string of characters in the specified location.
+
+(defmacro draw-string (window x y string)
+  (declare (fixnum x y) (simple-string string))
+  `(x:xtext ,window ,x ,y ,string (length ,string)
+	  *status-font-id* x:blackpixel x:whitepixel))
+
+;;; Prints a feeb-id in inverse video in the specified location.
+
+(defmacro draw-feeb-id (window x y string)
+  (declare (fixnum x y) (simple-string string))
+  `(x:xtext ,window ,x ,y ,string (length ,string)
+	  *status-font-id* x:whitepixel x:blackpixel))
+
+
+;;; Redisplay functions.  Control the movement of the feebs in the
+;;; maze window.
+
+(defun init-banner ()
+  (setq *banner-window*
+	(create-window banner-window-x banner-window-y
+		       banner-window-width banner-window-height))
+  (x:xsync 1)
+  (prepare-for-xevents *banner-window*)
+  (display-window *banner-window*)
+  (redisplay-banner))
+
+(defun tini-banner ()
+  (x:xflush)
+  (delete-window *banner-window*))
+
+(defun init-redisplay ()
+  (setq *birds-eye-window* 
+	(create-window birds-eye-x birds-eye-y birds-eye-width birds-eye-height))
+  (init-bitmaps)
+  (x:xsync 1)
+  (prepare-for-xevents *birds-eye-window*)
+  (display-window *birds-eye-window*)
+  (redisplay-all))
+
+(defun tini-redisplay ()
+  (x:xflush)
+  (delete-window *birds-eye-window*)
+  (tini-bitmaps))
+
+(defun redisplay-banner ()
+  (x:xtextpad *banner-window* 40 3 feebs-banner 59 *banner-font-id*
+	      0 8 x:blackpixel x:whitepixel x:gxcopy x:allplanes))
+
+(defvar *redisplay-map* (make-array (list *maze-i-size* *maze-j-size*)
+				    :element-type 'bit))
+
+(defvar *redisplay-hints* (make-array *maze-i-size*))
+
+(defun queue-redisplay (i j)
+  (setf (aref *redisplay-map* i j) 1)
+  (setf (aref *redisplay-hints* i) t))
+
+(defun redisplay ()
+  (dotimes (i *maze-i-size*)
+    (when (aref *redisplay-hints* i)
+      (setf (aref *redisplay-hints* i) nil)
+      (dotimes (j *maze-j-size*)
+	(when (/= (aref *redisplay-map* i j) 0)
+	  (setf (aref *redisplay-map* i j) 0)
+	  (redisplay-square i j)))))
+  (dolist (feeb *feebs*)
+    (draw-periscope feeb)))
+
+(defun redisplay-all ()
+  (dotimes (i *maze-i-size*)
+    (setf (aref *redisplay-hints* i) nil)
+    (dotimes (j *maze-j-size*)
+      (setf (aref *redisplay-map* i j) 0)
+      (redisplay-square i j)))
+  (dolist (feeb *feebs*)
+    (unless (feeb-dead-p feeb)
+      (draw-periscope feeb))))
+
+(defun redisplay-square (i j)
+  (let ((stuff (aref maze i j))
+	(display-x (* j redisplay-scale))
+	(display-y (* i redisplay-scale)))
+    (if (eq stuff :rock)
+      (draw-rectangle *birds-eye-window* display-x display-y
+		      redisplay-scale redisplay-scale)
+      (draw-rectangle *birds-eye-window* display-x display-y
+		      redisplay-scale redisplay-scale :undraw t))
+    (if (consp stuff)
+	(dolist (substuff stuff)
+	  (display-one-item substuff display-x display-y))
+	(display-one-item stuff display-x display-y))))
+
+(defun display-one-item (stuff display-x display-y)
+  (cond ((null stuff)
+	 )
+	((eq stuff :rock)
+	 )
+	((eq stuff :mushroom)
+	 (draw-mushroom display-x display-y))
+	((eq stuff :carcass)
+	 (draw-carcass display-x display-y))
+	((feeb-image-p stuff)
+	 (setq stuff (feeb-image-feeb stuff))
+	 (draw-feeb display-x display-y stuff))
+	((fireball-image-p stuff)
+	 (draw-fireball display-x display-y
+			(fireball-image-direction stuff)))
+	(t
+	 (error "Some strange thing in the maze: ~S." stuff))))
+
+
+;;; String-maps for images.  These will be transformed into bitmaps
+;;; that can be displayed in a small area.  The scale of the string-
+;;; maps is given by the variable redisplay-scale.
+
+(defvar *mushroom-bitmap*)
+(defvar *carcass-bitmap*)
+(defvar *fireball-bitmaps* (make-array 4))
+
+(defun init-bitmaps ()
+  (setq *mushroom-bitmap*
+	(make-bitmap
+	 (make-bit-array-from-strings
+	  '("                      "
+	    "                      "
+	    "                      "
+	    "                      "
+	    "        XXXXXXX       "
+	    "     XXXX X X XXX     "
+	    "    XX X X X X X X    "
+	    "   XX X X X X X X X   "
+	    "  XX X X X X X X X X  "
+	    " XX XXX X XXX XXX X X "
+	    "         X X          "
+	    "         X X          "
+	    "         X  X         "
+	    "          X X         "
+	    "          X X         "
+	    "          X  X        "
+	    "           X X        "
+	    "          X   X       "
+	    "    XXXXXX     XXXX   "
+	    "                      "
+	    "                      "
+	    "                      ")
+	  redisplay-scale redisplay-scale)
+	 redisplay-scale redisplay-scale))
+  (setq *carcass-bitmap* 
+	(make-bitmap
+	 (make-bit-array-from-strings
+	  '("                      "
+	    "                      "
+	    "  XXXXX         XXXXX "
+	    "  XXXXX         XXXXX "
+	    "    XXX         XXX   "
+	    "    XXX         XXX   "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXX   XXXXXX   XXXX "
+	    " XXX X X XXXX X X XXX "
+	    " XXX  X  XXXX  X  XXX "
+	    " XXX X X XXXX X X XXX "
+	    " XXXX   XXXXXX   XXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    " XXXXXXXXXXXXXXXXXXXX "
+	    "                      "
+	    "                      ")
+	  redisplay-scale redisplay-scale)
+	 redisplay-scale redisplay-scale))
+  (let ((bit-array (make-bit-array-from-strings
+		      '("                      "
+			"           X          "
+			"         X  X  X      "
+			"      X X  X XX X     "
+			"       X       X      "
+			"     X    X X    X    "
+			"     X   XXXX  X      "
+			"     X   XXXX  X      "
+			"       X  XX   X X    "
+			"      X X       X     "
+			"     X  X     X       "
+			"       X X  X  X      "
+			"       X    X         "
+			"       X  X  X        "
+			"        X X  X        "
+			"        X   X         "
+			"         X            "
+			"         X X          "
+			"            X         "
+			"          X           "
+			"          X           "
+			"                      ")
+		      redisplay-scale redisplay-scale)))
+    (setf (svref *fireball-bitmaps* 0)
+	  (make-bitmap bit-array redisplay-scale redisplay-scale))
+    (setf (svref *fireball-bitmaps* 1)
+	  (make-bitmap (rotate-bit-array bit-array redisplay-scale
+					   redisplay-scale east)
+			redisplay-scale redisplay-scale))
+    (setf (svref *fireball-bitmaps* 2)
+	  (make-bitmap (rotate-bit-array bit-array redisplay-scale
+					   redisplay-scale south)
+			redisplay-scale redisplay-scale))
+    (setf (svref *fireball-bitmaps* 3)
+	  (make-bitmap (rotate-bit-array bit-array redisplay-scale
+					   redisplay-scale west)
+			redisplay-scale redisplay-scale))))
+
+(defun tini-bitmaps ()
+  (delete-bitmap *mushroom-bitmap*)
+  (delete-bitmap *carcass-bitmap*)
+  (dotimes (i 4)
+    (delete-bitmap (svref *fireball-bitmaps* i))))
+
+(defun draw-mushroom (x y)
+  (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale
+	       *mushroom-bitmap*))
+
+(defun draw-carcass (x y)
+  (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale
+	       *carcass-bitmap*))
+
+(defun draw-feeb (x y feeb)
+  (let ((id (make-string 1 :initial-element (digit-char (feeb-id feeb)))))
+    (draw-rectangle *birds-eye-window* (+ x 1) (+ y 1) 20 20)
+    (case (facing (feeb-status feeb))
+      (0
+       ;; Draw the feeb-id on the feeb's chest.
+       (draw-feeb-id *birds-eye-window* (+ x 7) (+ y 8) id)
+       ;; Draw the feeb's eye-outline.
+       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 3) 5 5 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 3) 5 5 :undraw t)
+       ;; Put pupils in the feeb's eyes.
+       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 4) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 4) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 5) 1 1 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 5) 1 1 :undraw t))
+      (1
+       ;; Draw the feeb-id on the feeb's chest.
+       (draw-feeb-id *birds-eye-window* (+ x 3) (+ y 5) id)
+       ;; Draw the feeb's eye-outline.
+       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 4) 5 5 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 14) 5 5 :undraw t)
+       ;; Put pupils in the feeb's eyes.
+       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 5) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 15) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 6) 1 1 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 16) 1 1 :undraw t))
+      (2
+       ;; Draw the feeb-id on the feeb's chest.
+       (draw-feeb-id *birds-eye-window* (+ x 7) (+ y 1) id)
+       ;; Draw the feeb's eye-outline.
+       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 14) 5 5 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 14) 5 5 :undraw t)
+       ;; Put pupils in the feeb's eyes.
+       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 15) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 15) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 16) 1 1 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 16) 1 1 :undraw t))
+      (3
+       ;; Draw the feeb-id on the feeb's chest.
+       (draw-feeb-id *birds-eye-window* (+ x 11) (+ y 5) id)
+       ;; Draw the feeb's eye-outline.
+       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 14) 5 5 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 4) 5 5 :undraw t)
+       ;; Put pupils in the feeb's eyes.
+       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 15) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 5) 3 3)
+       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 16) 1 1 :undraw t)
+       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 6) 1 1 :undraw t)))))
+
+;;; Must draw a peeking feeb's periscope in a separate operation, so that it
+;;; doesn't get clobbered by other drawing in the square being peeked at.
+
+(defun draw-periscope (feeb)
+  (when (and (not (feeb-dead-p feeb))
+	     (peeking (feeb-status feeb)))
+    (let* ((status (feeb-status feeb))
+	   (peeking (peeking status))
+	   (x (* redisplay-scale (j-position status)))
+	   (y (* redisplay-scale (i-position status))))
+      (case (facing status)
+	(0
+	 (draw-rectangle *birds-eye-window* (+ x 11) (- y 5) 2 7)
+	 (if (eq peeking :left)
+	     (draw-rectangle *birds-eye-window* (+ x 9) (- y 5) 2 2)
+	     (draw-rectangle *birds-eye-window* (+ x 13) (- y 5) 2 2)))
+	(1
+	 (draw-rectangle *birds-eye-window* (+ x 22) (+ y 11) 7 2)
+	 (if (eq peeking :left)
+	     (draw-rectangle *birds-eye-window* (+ x 27) (+ y 9) 2 2)
+	     (draw-rectangle *birds-eye-window* (+ x 27) (+ y 13) 2 2)))
+	(2
+	 (draw-rectangle *birds-eye-window* (+ x 11) (+ y 22) 2 7)
+	 (if (eq peeking :left)
+	     (draw-rectangle *birds-eye-window* (+ x 13) (+ y 27) 2 2)
+	     (draw-rectangle *birds-eye-window* (+ x 9) (+ y 27) 2 2)))
+	(3
+	 (draw-rectangle *birds-eye-window* (- x 5) (+ y 11) 7 2)
+	 (if (eq peeking :left)
+	     (draw-rectangle *birds-eye-window* (- x 5) (+ y 13) 2 2)
+	     (draw-rectangle *birds-eye-window* (- x 5) (+ y 9) 2 2)))))))
+
+(defun draw-fireball (x y facing)
+  (declare (fixnum x y facing))
+  (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale
+	       (svref *fireball-bitmaps* facing)))
+
+
+;;; Status display.
+
+(defconstant turn-column 6)
+(defconstant id-column 0)
+(defconstant name-column 3)
+(defconstant score-column 8)
+(defconstant kill-column 13)
+(defconstant energy-column 18)
+(defconstant last-move-column 23)
+
+(defun init-status-display ()
+  (setq *status-window* (create-window status-window-x status-window-y
+				       status-window-width status-window-height))
+  (x:xsync 1)
+  (prepare-for-xevents *status-window*)
+  (display-window *status-window*)
+  (display-all-status))
+
+(defun tini-status-display ()
+  (x:xflush)
+  (delete-window *status-window*))
+
+;;; Energy values change every turn, and always are in the range
+;;; from 0 to 200, so just pre-compute all the strings for efficiency.
+
+(defvar *small-number-strings*
+  '#("  0" "  1" "  2" "  3" "  4" "  5" "  6" "  7" "  8" "  9"
+     " 10" " 11" " 12" " 13" " 14" " 15" " 16" " 17" " 18" " 19"
+     " 20" " 21" " 22" " 23" " 24" " 25" " 26" " 27" " 28" " 29"
+     " 30" " 31" " 32" " 33" " 34" " 35" " 36" " 37" " 38" " 39"
+     " 40" " 41" " 42" " 43" " 44" " 45" " 46" " 47" " 48" " 49"
+     " 50" " 51" " 52" " 53" " 54" " 55" " 56" " 57" " 58" " 59"
+     " 60" " 61" " 62" " 63" " 64" " 65" " 66" " 67" " 68" " 69"
+     " 70" " 71" " 72" " 73" " 74" " 75" " 76" " 77" " 78" " 79"
+     " 80" " 81" " 82" " 83" " 84" " 85" " 86" " 87" " 88" " 89"
+     " 90" " 91" " 92" " 93" " 94" " 95" " 96" " 97" " 98" " 99"
+     "100" "101" "102" "103" "104" "105" "106" "107" "108" "109"
+     "110" "111" "112" "113" "114" "115" "116" "117" "118" "119"
+     "120" "121" "122" "123" "124" "125" "126" "127" "128" "129"
+     "130" "131" "132" "133" "134" "135" "136" "137" "138" "139"
+     "140" "141" "142" "143" "144" "145" "146" "147" "148" "149"
+     "150" "151" "152" "153" "154" "155" "156" "157" "158" "159"
+     "160" "161" "162" "163" "164" "165" "166" "167" "168" "169"
+     "170" "171" "172" "173" "174" "175" "176" "177" "178" "179"
+     "180" "181" "182" "183" "184" "185" "186" "187" "188" "189"
+     "190" "191" "192" "193" "194" "195" "196" "197" "198" "199"
+     "200"))
+
+(defmacro energy-to-string (energy)
+  `(svref *small-number-strings* (max ,energy 0)))
+
+;;; This refreshes or initializes all parts of the display.
+
+(defun display-all-status ()
+  (display-string "*STATUS*" 1 8 8)
+  (display-string "Turn: " 3 0 6)
+  (display-number *current-turn* 3 8 6)
+  ;; 00000000001111111111222222222233333333334444444444
+  ;; 01234567890123456789012345678901234567890123456789
+  (display-string 
+    "ID Name Sco. Kill Eng. LM" 4 0 25)
+  (display-string
+    "-------------------------" 5 0 25)
+  (dolist (feeb *feebs*)
+    (let ((status (feeb-status feeb))
+	  (line (+ (feeb-id feeb) 6)))
+      (display-number (feeb-id feeb) line 0 3)
+      (display-string (name status) line 3 4)
+      (setf (feeb-last-score feeb) (score status))
+      (display-number (score status) line 8 4)
+      (setf (feeb-last-kills feeb) (kills status))
+      (display-number (kills status) line 13 4)
+      (display-string (energy-to-string (energy-reserve status)) line 18 4)
+      (display-string (cond ((feeb-dead-p feeb) "De")
+			    ((aborted status) "Ab")
+			    (t (case (last-move status)
+				 (:turn-left "TL")
+				 (:turn-right "TR")
+				 (:turn-around "TA")
+				 (:move-forward "MF")
+				 (:eat-mushroom "EM")
+				 (:eat-carcass "EC")
+				 (:peek-left "PL")
+				 (:peek-right "PR")
+				 (:wait "WA")
+				 (T "NM"))))
+		      line 23 2)))
+  (display-string
+   "Click any mouse button to" 22 0 25)
+  (display-string
+   "zap windows at the end." 23 3 23)
+  (display-string
+   "Press the \"q\" key to quit" 25 0 25)
+  (display-string
+   "at any time." 26 3 12)
+  (display-string
+   "Press the \"s\" key to jump" 28 0 25)
+  (display-string
+   "into single-step mode." 29 3 22)
+  (display-string
+   "Click any mouse button to" 31 0 25)
+  (display-string
+   "single-step." 32 3 12)
+  (display-string
+   "Press the \"a\" key to jump" 34 0 25)
+  (display-string
+   "back to automatic mode." 35 3 13))
+
+(defun display-status ()
+  (display-number *current-turn* 3 8 6)
+  (dolist (feeb *feebs*)
+    (let ((status (feeb-status feeb))
+	  (line (+ (feeb-id feeb) 6))
+	  temp)
+      (unless (= (feeb-last-score feeb)
+		 (setq temp (score status)))
+	(setf (feeb-last-score feeb) temp)
+	(display-number temp line 8 4))
+      (unless (= (feeb-last-kills feeb)
+		 (setq temp (kills status)))
+	(setf (feeb-last-kills feeb) temp)
+	(display-number temp line 13 4))
+      (display-string (energy-to-string (energy-reserve status)) line 18 4)
+      (display-string (cond ((feeb-dead-p feeb) "De")
+			    ((aborted status) "Ab")
+			    (t (case (last-move status)
+				 (:turn-left "TL")
+				 (:turn-right "TR")
+				 (:turn-around "TA")
+				 (:move-forward "MF")
+				 (:eat-mushroom "EM")
+				 (:eat-carcass "EC")
+				 (:peek-left "PL")
+				 (:peek-right "PR")
+				 (:wait "WA")
+				 (T "NM"))))
+		      line 23 2))))
+
+(defun display-string (string line column field-width)
+  (draw-rectangle *status-window* 
+		  (* (+ column 2) *char-width*) (* line *char-height*) 
+		  (* field-width *char-width*) *char-height* :undraw t)
+  (draw-string *status-window* (* (+ column 2) *char-width*)
+	       (* line *char-height*)
+	       string))
+
+;;; Print a number plus optionally a leading minus sign.  Buffers the
+;;; characters in a pre-existing string, so does no consing.  The number
+;;; is printed right-justified within a field of the specified length,
+;;; starting at the specified line and column.
+
+(defvar *number-string-length* 5)
+(defvar *number-string-buffer* (make-array *number-string-length*
+					   :element-type 'string-char))
+
+(defun display-number (n line column field )
+  (let ((charpos *number-string-length*)
+	(quotient (abs n))
+	(remainder 0))
+    (cond ((zerop n)
+	   ;; Special-case zero so it doesn't print as nothing at all.
+	   (decf charpos)
+	   (setf (schar *number-string-buffer* charpos) #\0))
+	  (t
+	   ;; Stuff digits into the string from right to left.
+	   (do ()
+	       ((zerop quotient))
+	     (multiple-value-setq (quotient remainder)
+	       (truncate quotient 10))
+	     (decf charpos)
+	     (setf (schar *number-string-buffer* charpos)
+		   (digit-char remainder)))
+	   ;; And output the minus sign if needed.
+	   (when (minusp n)
+		 (decf charpos)
+		 (setf (schar *number-string-buffer* charpos) #\-))))
+    (do ()
+        ((<= charpos 0))
+      (decf charpos)
+      (setf (schar *number-string-buffer* charpos) #\space))
+    ;; Now print it.
+    (draw-rectangle *status-window*
+		    (* column *char-width*) (* line *char-height*)
+		    (* field *char-width*) *char-height* :undraw t)
+    (draw-string *status-window* 
+		  (* (+ column field (- *number-string-length*)) *char-width*)
+		  (* line *char-height*)
+		  *number-string-buffer*)))
+
+;;; It.
+
+(defun feebs (&key (layout default-layout)	
+		   single-step
+		   delay
+		   files
+		   feep-dead-feebs)
+  "This starts the simulation.  Takes some options as keyword arguments.
+  :Single-step, if non-null, says to wait for any mouse click after each round.
+  :Delay, if non-null, is a number of seconds to wait after each round.
+  :Layout is the layout of the maze to use, if you don't want the default.
+  :Files is a list of files containing feeb definitions."
+  (let ((*single-step* single-step)
+	(*delay* delay)
+	(*feep-dead-feebs* feep-dead-feebs)
+	(*continue* t))
+    (when files (apply #'load-feebs files))
+    (let ((n (- *number-of-feebs* (length *feebs-to-be*))))
+      (cond ((minusp n)
+	     (error "Too many pre-defined feebs: ~S.~%"
+		    (length *feebs-to-be*)))
+	    ((zerop n))
+	    (t (format t "Making ~S dumb auto-feebs.~%" n)
+	       (make-auto-feebs n))))
+    (init-maze layout)
+    (create-mushrooms)
+    (create-feebs)
+    (init-play)
+    (unwind-protect
+	(progn
+	  (init-graphics)
+	  (init-banner)
+	  (init-redisplay)
+	  (init-status-display)
+	  (play))
+      (when (and (not *single-step*) *continue*)
+	(display-string "THE END." 19 8 8)
+	(get-mouse-buttonpress))
+      (x:xsync 1)
+      (tini-redisplay)
+      (tini-status-display)
+      (tini-banner)
+      (x:xflush)
+      (tini-graphics))
+    (write-line "Final scores:")
+    (dolist (feeb (reverse *feebs*))
+      (format t "(~A) ~20A  ~5D~%"
+	      (feeb-id feeb)
+	      (feeb-image-name (feeb-image feeb))
+	      (score (feeb-status feeb))))))
+
+
+;;; Feeb creation.
+
+(defun reset-feebs ()
+  (setq *feebs-to-be* nil))
+
+(defun load-feebs (&rest files)
+  (reset-feebs)
+  (dolist (file files)
+    (load file)))
+
+(defun make-auto-feebs (n)
+  (let* ((nrandoms (floor n 3))
+	 (nwanders (floor n 3))
+	 (nconserve (- n nrandoms nwanders)))
+    (dotimes (i nrandoms)
+      (push (cons (concatenate 'string "Rnd" (princ-to-string (1+ i)))
+		  'random-brain)
+	    *feebs-to-be*))
+    (dotimes (i nwanders)
+      (push (cons (concatenate 'string "Wnd" (princ-to-string (1+ i)))
+		  'wandering-brain)
+	    *feebs-to-be*))
+    (dotimes (i nconserve)
+      (push (cons (concatenate 'string "Cns" (princ-to-string (1+ i)))
+		  'conservative-brain)
+	    *feebs-to-be*))))
+
+
+;;; Here are some simple auto-feeb brains to use until we get better ones.
+
+;;; About the stupidest brain possible.  Something for everyone to feel
+;;; superior to.
+
+(defun random-brain (status proximity vision vision-left vision-right)
+  (declare (ignore status proximity vision vision-left vision-right))
+  (svref '#(:turn-left :turn-right :turn-around :move-forward
+	    :flame :eat-mushroom :eat-carcass :peek-left :peek-right
+	    :wait)
+	 (random 10)))
+
+
+;;; This one wanders around, feeds when it can, and shoots at any visible
+;;; opponent.
+
+(defun wandering-brain (status proximity vision vision-left vision-right)
+  (declare (ignore vision-left vision-right))
+  (let ((stuff (my-square proximity)))
+    (cond ((and (consp stuff) (member :mushroom stuff :test #'eq))
+	   :eat-mushroom)
+	  ((and (consp stuff) (member :carcass stuff :test #'eq))
+	   :eat-carcass)
+	  ((and (ready-to-fire status)
+		(dotimes (index (line-of-sight status))
+		  (let ((stuff (aref vision index)))
+		    (if (listp stuff)
+			(if (dolist (thing stuff)
+			      (if (feeb-image-p thing)
+				  (return t)))
+			    (return t))
+			(if (feeb-image-p stuff)
+			    (return t))))))
+	   :flame)
+	  ((and (not (eq (left-square proximity) :rock))
+		(> 0.2 (random 1.0)))
+	   :turn-left)
+	  ((and (not (eq (right-square proximity) :rock))
+		(> 0.2 (random 1.0)))
+	   :turn-right)
+	  ((not (ready-to-fire status))
+	   :wait)
+	  ((> (line-of-sight status) 0)
+	   :move-forward)
+	  ((not (eq (left-square proximity) :rock))
+	   :turn-left)
+	  ((not (eq (right-square proximity) :rock))
+	   :turn-right)
+	  (t
+	   :turn-around))))
+
+;;; This one is similar to the wandering brain, but doesn't shoot if
+;;; energy reserves are too low or the opponent is too far away.
+
+(defun conservative-brain (status proximity vision vision-left vision-right)
+  (declare (ignore vision-left vision-right))
+  (let ((stuff (my-square proximity)))
+    (cond ((and (consp stuff) (member :mushroom stuff :test #'eq))
+	   :eat-mushroom)
+	  ((and (consp stuff) (member :carcass stuff :test #'eq))
+	   :eat-carcass)
+	  ((and (ready-to-fire status)
+		(> (energy-reserve status) 30)
+		(dotimes (index (min (line-of-sight status) 5))
+		  (let ((stuff (aref vision index)))
+		    (if (listp stuff)
+			(if (dolist (thing stuff)
+			      (if (feeb-image-p thing)
+				  (return t)))
+			    (return t))
+			(if (feeb-image-p stuff)
+			    (return t))))))
+	   :flame)
+	  ((and (not (eq (left-square proximity) :rock))
+		(> 0.2 (random 1.0)))
+	   :turn-left)
+	  ((and (not (eq (right-square proximity) :rock))
+		(> 0.2 (random 1.0)))
+	   :turn-right)
+	  ((not (ready-to-fire status))
+	   :wait)
+	  ((> (line-of-sight status) 0)
+	   :move-forward)
+	  ((not (eq (left-square proximity) :rock))
+	   :turn-left)
+	  ((not (eq (right-square proximity) :rock))
+	   :turn-right)
+	  (t
+	   :turn-around))))
diff --git a/contrib/games/feebs/feebs.log b/contrib/games/feebs/feebs.log
new file mode 100644
index 0000000000000000000000000000000000000000..bcd02a8ee47465688d68713b38e26041559733a0
--- /dev/null
+++ b/contrib/games/feebs/feebs.log
@@ -0,0 +1,90 @@
+/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 16:33:43, Edit by Chiles.
+  Made FEEBS bind, instead of set, *single-step*,*delay*,
+  *feep-dead-feebs*, and *continue*.  These values were being retained
+  between runs.
+
+/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 15:35:47, Edit by Chiles.
+  Fixed X interaction by calling X:OPEN-CONSOLE in INIT-GRAPHICS.  Also,
+  set bordercolor and background parameters in INIT-GRAPHICS.  Made
+  KILL-FEEB look at the value of *feep-dead-feebs*.
+
+/usr2/lisp/library/rt/feebs/brains.lisp, 11-Oct-87 12:01:50, Edit by Chiles.
+  Written by Skef and Scott.  This is just a file of sample feebs that are
+  pretty dumb.
+
+/usr2/lisp/library/rt/feebs/mazes.lisp, 11-Oct-87 11:57:15, Edit by Chiles.
+  Created by Jim Healy, July 1987.  This file contains some sample mazes
+  with various curious properties.
+
+/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:53:54, Edit by Chiles.
+  No time stamp for this either, but it is close to the previous line's.
+
+  ;;; Modifications by Jim Healy:
+  ;;;
+  ;;; Ported the graphics to the IBM RT PC using the X window manager.
+  ;;; Added functions to create and store bitmaps for X.
+  ;;; Added event-handling routines to catch incoming events from the
+  ;;;   X server and redisplay the windows if exposed.
+  ;;; Changed :single-step option to work by clicking a mouse button.
+  ;;; Added keypress features to quit the game prematurely (q), jump
+  ;;;   into single-step mode (s), and go back to automatic mode (a).
+  ;;; Added the neat "Planet of the Feebs" banner at the top.
+  ;;; Added feature to zap windows at end of game by clicking a mouse
+  ;;;   button.
+  ;;; Fixed the disembodied periscopes bug.
+
+/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:52:55, Edit by Chiles.
+  No time stamp on this entry.
+
+  ;;; Modifications by Dan Kuokka:
+  ;;;
+  ;;; Built the interface to a generalized set of graphics primitives.
+  ;;; Wrote rotate-bitmap.
+
+/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:51:54, Edit by Chiles.
+  No time stamp on this entry either.
+
+  ;;; The following by Scott Fahlman, for initial public release:
+  ;;;
+  ;;; Installed CHANCE macro to speed up random events. 
+  ;;; Modified points for being killed from -5 to -2. 
+  ;;; When you zap yourself, you get no points for the kill.
+  ;;; Eliminated random length of game.  Now *GAME-LENGTH* = 1000.
+  ;;; Modified default maze slightly so that no two entry points are
+  ;;;   line of sight, regardless of how the feebs are facing.
+  ;;; Changed directions from keywords to constants, with integer values:
+  ;;;   north = 1, east = 2, etc.
+  ;;; Randomize initial entry points for feebs.
+  ;;; Display more interesting stuff in text area: score, energy, last move.
+  ;;; Keep energy in range 0 to 200 always, fix bug that caused any eating
+  ;;;   to push energy to maximum.
+  ;;; Display kills in status area, along with score.
+  ;;; ABORTED status field was not being maintained.
+  ;;; Install a smoother function for aborting moves of slow feebs.
+  ;;; Add single-step and slow motion.
+  ;;; Put in proximity sense, start vision array in space in front of the
+  ;;;   the feeb's current location, going forward, left, or right from there.
+  ;;; Store the appropriate image list in each maze cell, eliminating the
+  ;;;   IMAGIFY operations.  Add a pointer from the feeb-image back to the
+  ;;;   full feeb-structure.
+  ;;; Allow *maze-i-size* and *maze-j-size* to be different.
+  ;;; Fixed a couple of bugs in fireball motion.
+  ;;; Feebs running into fireballs get zapped.
+  ;;; Make sure image is updated between action and redisplay.
+  ;;; Queue redisplay for a feeb's old square on every move.
+  ;;; Improve mushroom image to not hit edges of square.
+  ;;; Improve fireball display to show direction of travel.
+  ;;; On reflection, update fireball DIRECTION as well as DI, DJ.
+  ;;; Display current turn.  Improve kludgy number printing.
+  ;;; Display periscope-like appendage when feeb is peeking.
+  ;;; Do not execute peek command if the feeb is facing a rock wall.
+  ;;; When a feeb was peeking last move, queue the forward square for
+  ;;;   redisplay to get rid of the periscope.
+  ;;; Set up auto-feeb creation and add some stupid auto-feebs.
+  ;;; Remove the terse printing function for the status structure to make
+  ;;;   it somewhat easier to debug things.
+  ;;; Fixed a bug in the DI and DJ macros.
+
+/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:50:10, Edit by Chiles.
+  Created by Skef Wholey -- No time stamp.
+
diff --git a/contrib/games/feebs/feebs.mss b/contrib/games/feebs/feebs.mss
new file mode 100644
index 0000000000000000000000000000000000000000..450d2e97cf996830a9e8b77dbb4149af219720ea
--- /dev/null
+++ b/contrib/games/feebs/feebs.mss
@@ -0,0 +1,556 @@
+@make [article]
+@device [dover]
+
+@begin [titlepage]
+@begin [titlebox]
+@majorheading [Planet of the Feebs]
+@heading [A Somewhat Educational Simulation Game]
+
+Scott E. Fahlman
+Computer Science Department
+Carnegie-Mellon University
+
+Version: @value [filedate]
+@end [titlebox]
+
+@copyrightnotice [Scott E. Fahlman]
+@end[titlepage]
+@newpage
+@section [Introduction]
+
+@i[Planet of the Feebs] is a simulation game that is intended as a
+training aid for beginning programmers in Common Lisp.  It is loosely
+based on the "Maze War" game, written by Jim Guyton, Bruce Malasky, and
+assorted others at Xerox PARC.  In @i[Planet of the Feebs], however, the
+players do not control their creatures by hand.  Instead, they supply
+programs which control the creatures as they move around the maze trying
+to zap one another.  The game presents an open-ended challenge, and
+advanced players may find themselves reaching deep into the AI bag of
+tricks as they try to build ever more clever and adaptable creatures.
+
+The current version of the program runs in CMU Common Lisp on the IBM RT
+PC under the Mach operating system.  It uses the X window manager.  It
+was designed by Scott Fahlman and programmed by Fahlman, Skef Wholey,
+and Dan Kuokka.  Other members of the Spice Lisp group at CMU have
+contributed ideas and have helped to tune and polish the system.
+
+The Feebs environment is easily reconfigurable by changing certain
+global parameters.  Normally, the parameters to be used in a given
+contest are announced to the players before they begin writing their
+programs, since very different strategies may be appropriate with
+different parameters.  In this document, we will indicate the names of
+those parameters in boldface, followed by the usual value of this
+parameter in parentheses.  To see how any given feebs world is
+configured, execute the function (list-parameter-settings), which will
+create and return an A-list of all the interesting parameters:
+
+@begin [example]
+((*number-of-feebs* . 10)
+ (*carcass-rot-probability* . 1/3) ...)
+@end [example]
+
+@section [Life Among The Feebs]
+
+Deep below the surface of a medium-sized planet, in a long-forgotten
+maze of tunnels, live a race of strange creatures, the feebs.  The
+origin of the name "feebs" is lost in the mists of antiquity.  Some say
+that the name is short for "feeble minded", which most of the creatures
+certainly are; some say that the name is a contraction of the term
+"flaming bogons", a phrase whose origins are also, unfortunately, lost
+in antiquity; most likely, the name comes from the feebing noise that
+the creatures occasionally make as they wander the maze.
+
+Locked in their isolated world, the feebs compete fiercely for the
+two types of available food: large mushrooms that sometimes appear at
+certain places in the labyrinth, and each other.  Life is tough in the
+labyrinth; it's every feeb for itself.  The goal is survival, and any
+competitors must be ruthlessly eliminated.
+
+Physically very similar to one another, the feebs must try to survive by
+superior intelligence.  Each feeb has an electrical organ which can use
+to "flame" at its competitors, emitting a lethal "fireball" -- actually
+an unstable ball of high-energy plasma, similar to ball lightning.  The
+fireball travels erratically down the tunnel in the direction the
+creature is facing.  The flame is the feeb's only weapon.  The only
+defense is to stay out of the line of fire or to outrun the oncoming
+fireball, but a feeb who hides in a secluded corner of the maze will
+eventually starve.  Unfortunately, the mushrooms tend to grow at tunnel
+junctions and in dead-end corridors, places where feeding creatures run
+a considerable risk of ambush or entrapment.
+
+The walls of the maze emit a soft glow due to a coating of
+phosphorescent (but inedible) fungi.  Even in this dim light, the feebs
+can see well.  The feebs can peek around corners without exposing
+themselves to hostile fire, but a peeking feeb can be seen by opponents
+in the tunnel he is peeking into.
+
+The simple feeb world does not allow for much variety of action.  Feebs
+can turn by 90 or 180 degrees, move one step forward, flame, feed, peek
+around corners, or stay put.  Feebs cannot back up or move sideways;
+they must turn in the direction they want to go.  Some feebs are
+moderately intelligent, but none of them has much coordination.
+Consequently, a feeb can only perform one of these basic actions at
+once.  (Very early in feeb evolution they learned not to chew gum.)  All
+of the feebs suffer from the same limitations, so cleverness -- and
+sometimes a bit of luck -- are all-important.
+
+@section [The Game]
+
+@subsection [Overview]
+
+@i[Planet of the Feebs] is played by up to @b[*number-of-feebs*] (10)
+human players at once.  Each player controls one of the feebs in the
+maze.  This control is not exerted directly, but rather by supplying a
+program, called the @i[behavior function], that controls the creature's
+actions.  All of the programmed feebs are turned loose in the maze at
+once, and the competition for survival begins.  The game runs for a
+number of turns specified by @b[*game-length*] (1000).  Zapping an
+opponent gives a feeb @b[*points-for-killing*] (+1) point, while being
+zapped or dying of hunger gives it a penalty of @b[*points-for-dying*]
+(-2) points.  Feebs that manage to shoot themselves do not get credit
+for the kill.  A dead feeb is reincarnated as soon as his carcass has
+rotted, which takes a few turns.  These newly reincarnated creatures
+re-enter the maze at some randomly-chosen entry point.
+
+Being highly evolved creatures, the feebs think using Common Lisp.  (At
+one time there were feebs who thought using Pascal, but all of these
+have attained a provably correct extinction.)  Each feeb's behavior, at
+each turn of the game, is supplied by a Common Lisp function (which may
+be a lexical closure).  This function receives as its arguments the
+feeb's sensory inputs (including some internal sensations such as the
+degree of hunger) and it returns one of the simple actions of which the
+feeb is capable.
+
+The game proceeds as a series of synchronous turns.  At the start of
+each turn various natural phenomena occur: mushrooms grow, flame-balls
+move (destroying things as they go), and feebs occasionally die of
+starvation.  Next, the behavior function for each feeb receives its
+sensory inputs and computes its desired action.  Occasionally an action
+is turned to a no-op because the feeb has responded too slowly (see
+below).  Finally, all remaining actions are executed at once.
+
+The maze is laid out as a array of size @b[*maze-i-size*] by
+@b[*maze-j-size*] (32 x 32).  Some locations or "squares" contain rock,
+others empty space.  All tunnels are one unit wide.  There are T, L and
++ junctions, as well as dead ends, but no large rooms.  There are no
+disconnected parts of the maze: it is possible to reach any tunnel
+square from any other tunnel square.  The feebs may or may not know the
+specific layout of the maze in advance (see the section on Contest
+Rules), but a feeb in a strange maze may build up some sort of map as he
+wanders around.  Feebs do have a mysterious navigational sense that
+tells them their own I and J coordinates at any given time, as well as
+the direction in which they are facing.
+
+A feeb always faces North, South, East, or West, and never anything in
+between.  Any number of feebs may occupy a given square at once.  A feeb
+has a short-range sense of "proximity" that tells it what is in its own
+square and certain adjacent squares.  However, a feeb cannot flame into
+its own square or engage in hand-to-hand combat (feebs have no hands,
+and their rubbery beaks are only strong enough to attack mushrooms and
+flame-broiled opponents).  It is rather awkward for two feebs in the
+same square to disengage without becoming targets for one another, but
+it is also dangerous to remain together, since a successful shot into
+this square by another feeb will kill all the occupants.  Mushrooms and
+carcasses do not impede the movement of live feebs.
+
+A maze normally contains @b[*number-of-feebs*] (10) feebs, usually
+representing that many different players.  If fewer than the specified
+number of players are participating, the remaining niches are filled by
+the addition of "autofeebs" supplied by the system.  These creatures
+come in several types, but all have rather simple behavior patterns.
+Some are almost suicidally aggressive, for example, while others run
+from trouble whenever possible.
+
+The maze designer pre-designates a set of entry points.  These may be
+close to one another, but no entry point will be visible from any other.
+There must be at least as many of these entry points as there are feebs
+in the maze.  At the start of the game, each feeb is assigned a
+different entry point, randomly chosen from this predefined set, facing
+in a randomly chosen direction.  A feeb being reincarnated will appear
+at one of the original entry points, chosen at random.  This might
+result in two feebs suddenly facing one another, but the new feeb is in
+considerably greater danger than the existing ones, since it may well
+materialize facing a wall or dead end -- yet another reason not to get
+yourself killed in the first place.
+
+@subsection [Food]
+
+Feebs have to eat.  At each turn, the behavior function receives an
+indication of the creature's current energy reserves, measured in Zots.
+This energy reserve is decreased by one Zot after each turn, regardless
+of what the creature did during that turn.  Flaming uses up an
+additional @b[*flame-energy*] (10) Zots.  The energy is decremented when
+the action is executed; if the remaining energy at the start of a turn
+is zero or negative, the creature starves to death immediately, leaving
+a carcass.
+
+A feeb feeds by executing the :EAT-MUSHROOM or :EAT-CARCASS command
+while in a square occupied by the specified type of food.  A feeding
+feeb can do nothing else in that turn, and hence is rather vulnerable.
+Feeding on a mushroom increments the feeb's energy reserve by
+@b[*mushroom-energy*] (50) Zots, but destroys the mushroom.  Feeding on
+a carcass increments the energy reserve by @b[*carcass-energy*] (30)
+Zots per turn, and may go on for several turns before the carcass rots.
+Feebs have a maximum capacity of @b[*maximum-energy*] (200) Zots --
+gorging beyond that point does not increase the creature's reserves,
+though it may be useful as a way of keeping food away from opponents.
+Feebs start the game moderately hungry, with a reserve randomly chosen
+between @b[*minimum-starting-energy*] (50) and
+@b[*maximum-starting-energy*] (100) Zots.
+
+The maze designer pre-designates certain squares as mushroom-growing
+locations.  Typically, there will be @b[*number-of-mushrooms*] (10)
+mushrooms in the maze at any given time and
+@b[*number-of-mushroom-sites*] (30) places where they may appear.  The
+initial locations of the mushrooms are chosen at random from this set of
+locations.  Once a mushroom appears, it will remain in that square until
+it is eaten or destroyed by a fireball.  Whenever a mushroom is
+destroyed, a new one appears at some vacant mushroom-growing location,
+chosen at random.  There can never be more than one mushroom in a square
+at any given time.  Since an eaten mushroom reappears somewhere else and
+an uneaten mushroom will stay around forever, as the game progresses the
+mushrooms will tend to be found in parts of the maze that are seldom
+visited or at exposed locations where feeding is too risky.
+
+Whenever a feeb dies, either from incineration or starvation, a carcass
+is left behind in the square where the death occurred.  Unlike
+mushrooms, which disappear when eaten, a carcass may be fed upon
+repeatedly, by any number of feebs, until it rots away.  A feeb killed
+during Turn T will not begin to rot until turn T+N, where N is the value
+of @b[*carcass-guaranteed-lifetime*] (3).  At the end of that turn, and
+at the end of each turn thereafter, it has a
+@b[*carcass-rot-probability*] (1/3) chance of rotting away (disappearing
+completely).  The feeb that died is not reincarnated until after the
+carcass has rotted away.  At that point, the feeb appears in one of the
+starting squares, pointing in some random direction, and with energy
+reserves computed as at the start of the game.
+
+@subsection [Flaming]
+
+When a feeb flames, the fireball travels down the tunnel in the direction
+the feeb is facing, moving at one square per turn.  More precisely, if a
+feeb gives the :FLAME command during turn T, the fireball appears in the
+adjacent square at the start of turn T+1, destroying the contents.  (The
+intended victim may, however, have moved away during turn T.)  The fireball
+enters the next square at the start of turn T+2, and so on.
+
+As the fireball tries to enter each new square, including the first one, it
+has a certain probability of dissipating: this is controlled by
+@b[*fireball-dissipation-probability*] (1/4).  When a fireball enters a
+square containing a mushroom, that mushroom is destroyed.  When a fireball
+enters a square containing a live feeb, that feeb is killed, leaving a
+carcass.  Existing carcasses are already burned, so they are not affected
+by subsequent fireballs.  A feeb will also be killed if it moves into a
+square currently occupied by a fireball.
+
+The fireball proceeds in this manner, killing everything in its path,
+until it either dissipates or encounters the wall at the end of the
+straight-line corridor.  When the fireball hits the wall, it often
+dissipates, but it may be reflected back in the direction it came from
+with probability @b[*fireball-reflection-probability*] (1/2).  More
+precisely, if the fireball is in square S, the last space of a corridor,
+at time T, and would move into a solid-rock square at T+1, and it
+happens to be successfully reflected, its direction is reversed and it
+appears to be entering square S from the solid rock square at the start
+of time T+1.  In addition to the possibility that it will not be
+reflected, the fireball must face the usual dissipation probability on
+this turn as well.  A reflected fireball then proceeds to travel back in
+the direction it came from until it dissipates or is reflected again.
+Fireballs pass through one another with no interference.
+
+The relatively slow motion of the fireballs has some interesting
+consequences.  If a feeb sees a fireball coming, it may well be able to
+outrun it or to duck into a side corridor, though time wasted in turning
+may be fatal.  It is safe to dash past the mouth of a tunnel in which
+another feeb is lurking unless the second feeb happens to flame in
+anticipation of the move.  However, it is unwise to stop or turn while
+in such an intersection.  Because of the rule that a feeb moving into a
+square occupied by a fireball is killed, a feeb cannot avoid a fireball
+by rushing toward it, attempting to swap places.  However, a feeb can
+safely move into the square of an enemy feeb that is firing on the
+current turn.  It is very unhealthy for a feeb to move forward in the
+turn immediately following one in which it fires.
+
+After flaming, the feeb must wait an unpredictable amount of time before
+it can flame again.  On the turn after it fires, a feeb definitely will
+be unable to fire.  On every every turn thereafter, the flamer will have
+a probability of @b[*flame-recovery-probability*] (1/2) of recovering
+and being able to flame again.  A feeb can sense whether it is ready to
+fire or not, but cannot tell whether an opponent is able to fire.  Thus,
+a certain amount of bluffing is possible.
+
+@subsection [Timing]
+
+It is dangerous for a feeb to spend too much time thinking about what to do
+next.  The time taken by each of the behavior functions is recorded.  The
+action ordered by the feeb has a chance of being aborted (turned into a
+no-op) with a probability that is proportional to the time the feeb took to
+generate the order.  This can be particularly awkward in the middle of a
+shootout or when running from a fireball.
+
+More precisely, if @b[*slow-feeb-noop-switch*] (T) is non-nil, then the
+probability of aborting a feeb's move is the product of the time the feeb
+took and @b[*slow-feeb-noop-factor*] (.25), divided by the total time taken
+by all feebs on this turn.  If @b[*slow-feeb-noop-switch*] is NIL, this
+feature is disabled and no moves are aborted; this mode is recommended when
+some of the feebs are being controlled by hand.
+
+@subsection [Actions]
+
+Behavior functions are only called when the creature is alive.
+A behavior function indicates its selected action by returning one of
+the following keyword symbols:
+
+@Begin[Description]
+:TURN-LEFT @\Turn left by 90 degrees, staying in the current square.
+
+:TURN-RIGHT @\Turn right by 90 degrees, staying in the current square.
+
+:TURN-AROUND @\Turn around 180 degrees, staying in the current square.
+
+:MOVE-FORWARD @\Move forward one square.
+
+:FLAME @\Shoot a flame in the direction the creature is facing.
+
+:EAT-MUSHROOM @\Feed on a mushroom if one is available in the current
+square.  Otherwise, do nothing.
+
+:EAT-CARCASS @\Feed on a carcass if at least one is available in the
+current square.  Otherwise, do nothing.
+
+:PEEK-LEFT @\The creature does not actually move, but the visual input
+received next turn will be what the creature would see if it were to move
+forward one square and turn left.  If the creature wishes to continue
+peeking left, this command must be repeated each turn.
+
+:PEEK-RIGHT @\Analogous to PEEK-LEFT.
+
+:WAIT @\Stay put and do nothing.
+@End[Description]
+
+Any output that is not one of the symbols listed above is interpreted as
+a :WAIT.
+
+@subsection [Sensory Inputs]
+
+The behavior function always receives five arguments, representing its
+various sensory inputs.  The programmer can call these whatever he
+likes, but I will call them STATUS, PROXIMITY, VISION, VISION-LEFT, and
+VISION-RIGHT.  Each of these is a data structure that the program can
+access, but not modify, using a variety of accessing functions.  The
+system will destructively modify these structures from one turn to the
+next.
+
+The information in the STATUS structure can be accessed as follows:
+
+@Begin[Description]
+
+(name status) @\A string.  Whatever name the user supplied for this
+creature at the start of the game.
+
+(facing status) @\The direction the feeb is facing, encoded as a small
+integer: 0 = north, 1 = east, 2 = south, 3 = west.  Note: for
+convenience, NORTH, EAST, SOUTH, and WEST are defined as constants with
+the integer values specified above.
+
+(i-position status) @\An integer from zero (inclusive) to @b[*maze-i-size*]
+(exclusive) indicating the creature's current I position.
+
+(j-position status) @\Analogous to i-position.
+
+(peeking status) @\One of :LEFT, :RIGHT, or NIL.  Indicates whether the
+visual information coming in this turn is the result of a peek command
+in the previous turn.
+
+(line-of-sight status) @\An integer indicating the number of squares
+that can be seen in the direction the feeb is facing or peeking.  Thus,
+the number of valid entries in the VISION vector.
+
+(energy-reserve status) @\An integer indicating how many energy units
+the creature has, equivalent to the number of turns it can live (without
+flaming) before it starves to death.
+
+(score status) @\The creature's current score.
+
+(kills status) @\The total number of rivals killed by this feeb (not
+counting suicides).
+
+(ready-to-fire status) @\T if the creature is able to fire this turn,
+NIL if not.
+
+(aborted status) @\T if the creature's last move was aborted because it
+took too long.
+
+(last-move status) @\The last move issued by the creature.  Any of the
+action symbols listed above, or :DEAD if the creature has just been
+reincarnated.
+@End[Description]
+
+The PROXIMITY input is also a read-only structure, with slots describing
+the contents of the creature's current square and the adjacent ones to
+its rear, left, and right.  The slots are accessed as follows:
+
+@Begin[Description]
+(my-square proximity) @\Returns the contents of the current square.  A
+feeb does not see himself in this square, even though he is there.
+
+(rear-square proximity) @\Returns the contents of the square behind the
+creature.
+
+(left-square proximity) @\Returns the contents of the square to the
+creature's left.
+
+(right-square proximity) @\Returns the contents of the square to the
+creature's right.
+@End[Description]
+
+The values returned by these functions can be any of the following:
+
+@Begin[Description]
+NIL @\The square is empty space.
+
+:ROCK @\A solid rock wall in this direction.
+
+:MUSHROOM @\The square contains a mushroom.
+
+:CARCASS @\The square contains a carcass.
+
+A structure of type FEEB-IMAGE @\This represents a feeb.  One can call
+(feeb-image-name x) on this image to get the feeb's name and
+(feeb-image-facing x) to get the direction it is facing, expressed as an
+integer from 0 to 3.
+
+A structure of type FIREBALL-IMAGE @\This represents a fireball.  One
+can call (fireball-image-direction x) on this image to get the direction
+the fireball is moving, expressed as an integer from 0 to 3.
+
+A list @\This is used when more than one item is in the square at once.
+The list can contain any number of image structures, plus perhaps a
+:MUSHROOM and/or :CARCASS symbol.
+@End[Description]
+
+The VISION argument receives a simple vector whose length is the maximum of
+*maze-i-size* and *maze-j-size*.  Thus, it can hold any possible linear
+line of sight that can occur in the maze.  However, only some of the
+entries are really valid, as indicated by the value returned by the
+(line-of-sight status) call; entries beyond the valid range may contain
+garbage or hallucinations.
+
+Each item in the VISION vector describes what is in a given cell, using
+the same notation as for the PROXIMITY argument.  (svref vision 0)
+should return information about the square into which the feeb is
+facing, the same information that would be returned by (front-square
+proximity).  If the feeb is looking straight ahead, (svref vision 1)
+would return the contents of the next square in that direction, and so
+on, until we reach (svref vision (line-of-sight status)), which contains
+garbage.  If the feeb is peeking left or right, (svref vision 0)
+still accesses the square physically in front of the feeb, but higher
+indices access a line of squares to the left or right of that square.
+
+The VISION-LEFT and VISION-RIGHT arguments are simple vectors whose
+entries correspond to the entries in VISION.  Instead of indicating what
+is in each square along the line of sight, however, they tell the
+creature what is to the left or right of that square, along the
+direction in which you are looking (or peeking).  Each entry will have
+one of three values: NIL (an opening on that side), :ROCK (a solid rock
+wall on that side), or :PEEKING (an opening from which some creature is
+peeking into your corridor).  There is no way to tell whether the peeker
+is peeking in your feeb's direction or the other way or whether there are
+more than one of them.
+
+@section [Contest Rules]
+
+The rules for a feeb contest, including the settings of all the control
+parameters, are announced in advance so that the programmers know what
+kind of strategy to program into their behavior functions.  Knowledge
+about the maze itself may or may not be available, depending on how
+difficult the contest organizers want to make the game.  There are four
+levels of complexity:
+
+@begin [description]
+Level 0:@\The players are told in advance what the maze will look like,
+with or without information about the location of mushroom spaces and
+starting spaces.  This information can be used in writing the behavior
+functions.
+
+Level 1:@\No information is available about the maze in advance, but
+once the game begins a feeb can examine a map of the entire maze and
+plan a global strategy.  The map is an array of dimensions *maze-i-size*
+by *maze-j-size*, capable of holding any Lisp object in each element.
+Initially, each array cell will be either :ROCK or NIL (open space).  To
+obtain a map, call (GET-MAZE-MAP).  Each call produces a distinct map
+array, so it is possible to write into the map array, perhaps to take
+notes.
+
+Level 2:@\No map is available.  If a feeb wants information about the
+shape of the maze, it must explore the maze for itself.  Calls to
+(GET-MAZE-MAP) return NIL.
+
+Level 3:@\No map is available, and the feeb's location sense is
+disabled.  The I-POSITION and J-POSITION cells of the status object will
+always read 0.  This makes it much harder to create a map, since
+sections of map developed during different incarnations must be fitted
+together.
+@end [description]
+
+Each player will supply a feeb-creation function with some unique name.
+This function, which should be compiled, is loaded and then called with
+no arguments.  It returns two values: a behavior function for one feeb
+and a string that will be used as that feeb's name.  To avoid name
+conflicts, each player should choose a different package.  A complete
+feeb definition file might look like this:
+
+@begin [example]
+;;; -*- Package: Darth-Feeb -*-
+
+(in-package "DARTH-FEEB" :use '("LISP" "FEEBS"))
+
+;;; This feeb probably won't do too well against any other feebs.
+
+(defun darth-feeb-creator ()
+  (values
+    #'(lambda (status vision vision-left vision-right)
+        (declare (ignore status vision vision-left vision-right))
+        (svref '#(:turn-left :move-forward :flame) (random 3)))
+    "Darth Feeb"))
+
+@end [example]
+
+In a new Lisp, load "feebs.fasl" and any files containing feeb creation
+functions.  Then call (feebs:create-feeb <foo>) for each of the feeb
+creation functions.  Finally type (feebs:feebs) to start the show.
+Auto-feebs will be created as needed.  At the end, the final scores of
+all the feebs will be printed.
+
+Team play is possible, with a sort of telepathic communication between
+feebs on the same team.  This is accomplished by calling each
+feeb-creation function more than once.  All feebs "hatched" from the
+same creation function are team-mates, and their scores can be added
+together at the end of the game.  The creation function should return a
+different name for each team member; it can return the same behavior
+function for all team members, or a different function for each.  It is
+possible for these behavior functions to communicate via shared lexical
+variables.
+
+@section [Ideas for Future Extensions]
+
+It would be possible to create a large set of attributes and abilities
+that feebs might possess, and to make some of the existing ones
+optional.  Each of these abilities could be assigned a certain value,
+and players could select which combination of abilities their feebs will
+have from this menu.  There could be a fixed limit on the total value of
+features chosen, or a feeb too heavily loaded with features might just
+become slower or less energy-efficient than the others.
+
+Among the features that might be on the menu would be the ability to
+move backwards or sideways, the ability to peek, some ability to kill
+opponents in one's own square, extended range for the omni-directional
+proximity sense, a limited range for the visual sense, some ability to
+survive a fireball hit, a sense of smell that indicates the distance to
+the nearest food, the ability to see through a fireball (taken for
+granted now), the ability to obtain a complete or partial map,
+cold-bloodedness (a stationary feeb uses much less energy), and so on.
+
+We might also create a much more diverse and interesting set of
+non-player flora and fauna, and perhaps a more interesting landscape.
+
diff --git a/contrib/games/feebs/mazes.lisp b/contrib/games/feebs/mazes.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0b7cc587a81bac3f968dadbfc9dd6698cba8069b
--- /dev/null
+++ b/contrib/games/feebs/mazes.lisp
@@ -0,0 +1,238 @@
+;;; -*- Mode: Lisp; Package: Feebs; Log: feebs.log -*-
+;;;
+;;; Mazes for Planet of the Feebs.
+;;; A somewhat educational simulation game.
+;;;
+;;; Created by Jim Healy, July 1987.
+;;;
+;;; **************************************************
+;;; Maze guidelines:
+;;;    Maze should be *maze-i-size* by *maze-j-size*
+;;;       (currently 32 x 32).
+;;;    X represents a wall.
+;;;    * represents a mushroom patch.
+;;;    e is a feeb entry point.
+;;; **************************************************
+
+;;; Maze1 has a good number of dead ends and little nooks.
+
+(defparameter maze1
+  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXX     *eXXXX      *e      ** X"
+    "XXX XXXXX XXXX XXXXXXXXXXXX XX X"
+    "XXX   XXX      XXXXXX       X  X"
+    "XXXXX XXXXXXX XXXXXXX XXXXXXX XX"
+    "X *       XXX XX *    XeXX    XX"
+    "X XXXXXXX XXX XXXXXXX X XXX XXXX"
+    "X  XXXXXX XXX XX      X      *XX"
+    "X XXXXXXX XXX XXXXXXX XXXXXXXXXX"
+    "X XXXXXXX XXX*     e  XXXXXX XXX"
+    "X         XXXXX XXXXXXXXX  * XXX"
+    "X XXXXX XXXXXX     XXXXXX XX  XX"
+    "X eXXXX XXXXXX XXX  XXXXX XX XXX"
+    "X XXXXX*       XXXXe XXXX XX  XX"
+    "X XXXXX XXXXXX XXXXX  XXX XXX XX"
+    "X eXXXX    e   XXXXXX *XX XX  XX"
+    "X XXXXX XXXXXX XXXXXXX  X XXeXXX"
+    "X   XXX        XXXXXXXX   XX  XX"
+    "X XXXXX XXXXXX XXXXXXXXXX XXXXXX"
+    "X XXXXX      * XXXXX          XX"
+    "X*  XXX XXXXXX XXXXX XXXXXX X XX"
+    "X XXXXX e      XXXXX X  e   X XX"
+    "X XX XX XXXXXX XXXXX X XXXXXX XX"
+    "X         *XXX XXXXX       *  XX"
+    "X XX XX XXXXXX XXXXXXXXXX XXXXXX"
+    "X XXXXX XXXXXX   *   *        XX"
+    "X   XXX XXXXXXXXXXXXXXXXXXXXX XX"
+    "X XXXX    X    X   eX    X    XX"
+    "X  XXX XX X XX X XX X XX X XX XX"
+    "X XXXX XX X XX X XX X XX*X XX XX"
+    "X e *  XX   XX * XX   XX   XXeXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
+
+;;; Maze2 doesn't have any really long corridors.
+
+(defparameter maze2
+  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "X  eXXXXX * X   XXXXXX X e XXXXX"
+    "X XXXX    X X XXXX   X   X XXXXX"
+    "X  XX  XXXX   XXXX X*  X X XXXXX"
+    "XX XX XXX   XXXX   XX XX X     X"
+    "XX e  XXX XXXXXXX XX  XXXXXXXX*X"
+    "XXXX XXX    XXXXX X e XXX   XX X"
+    "XXXX XXX XXXXXXXX   XXXX  X    X"
+    "XX * XX   XXe  XXXXXXXXXX XX XXX"
+    "XX XXXX X XX X   XXX XXXXX   XXX"
+    "XX        XX XXX X   XX    XXXXX"
+    "XXXXX XXX   *XXX   X    XXXXXXXX"
+    "XX*   XXXXXX  XXXX XXXX XXXXXXXX"
+    "XXXXX XX XXXX XXXXXXXXX XXXXXXXX"
+    "XXXXX  e XXXX   *XXXXXX   eXXXXX"
+    "XXXXXXXX XXXXXXX XXXXXXXXX XXXXX"
+    "XXXXXX     XXXXX  eXXXXX   XXXXX"
+    "XXXXXX XXX XXXXXXX XXXXX XXXXXXX"
+    "XX     XXX X   XXX XX    X    XX"
+    "XX XXX   XXXXX XX   XX XXX XX XX"
+    "XX XXXXX  *X   XX X XX XXXXXX*XX"
+    "X    XXXXX   XXXX X      XX   XX"
+    "X XX XXXXXXX   XXXXX*X X Xe XXXX"
+    "X    XXXX  e X XXXXX*XX  XX XXXX"
+    "X XX XXXXXX XX   XXX*XXX     XXX"
+    "XXXX  eXXX  XXXX XX  XXXXX X   X"
+    "XXXXXX XXXXXXXXX XX XXXX   XXX X"
+    "XXX *  X X    XX    XXXX XXX X X"
+    "XX  XXXX X XX XXXX XXX   X  e  X"
+    "XX XX  *   X *   X XXXX XX XXX*X"
+    "XX    XXX XXX XX  eXXX     XXX*X"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
+
+;;; Maze3 has the minimum number of mushroom sites, most
+;;; of which are between a rock and a hard place.  Those
+;;; poor feebs!
+
+(defparameter maze3
+  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "X    e  XXXXXX XXXXXXX*XXXXXXXXX"
+    "X X XXX XXXXX e   XXXX XXX e   X"
+    "X   XXX XXXXXX XX XX   XXX XXX X"
+    "XXX XXX XXXXXX XX XX X X   e   X"
+    "Xe  XXX*XXXX*  XX XXeX X XXXXX X"
+    "X X XXX XXXXXX XX XX X   XXXXX X"
+    "X   XXX XXXXXX XX*   XXXXXXXXX X"
+    "X XXXXX XX e   XX XXXXXXXX XXX X"
+    "X X XXX XXX XXXXX XXXXXX   XXX X"
+    "Xe  XXX      XXXX XXXX   X X   X"
+    "XXX XXXX XXXXXXXX  X   XXX   XXX"
+    "XXX  eXX XXXXXXXXX   XXXXX XXXXX"
+    "XXXXX XXXXXXXXXXXX XXXXXX    XXX"
+    "XXXXX     *    XX eXX XXX XX XXX"
+    "XX*XXXX XXXXXX XX XXX XXX XX XXX"
+    "XX X    XXXXX  X  XXX    eXX XXX"
+    "X    XXXXXXXX XX XXXX XXX XX XXX"
+    "X XXXXeXXXXXX    XXXX XXX XX XXX"
+    "X      XX*XXXXX XXXXXXXXX    XXX"
+    "XXXXXX    XXX   XXXX  XXXXXX XXX"
+    "XXXXXXXXX XXX XXXXXX XXXXXX  XXX"
+    "XXX       XX  e          eX XXXX"
+    "XX  XXXXX    XXXX XXXX XXXX XXXX"
+    "XX XXXXX  XX XXXX XXXX XXXX   XX"
+    "XX eXXXX XX  XXXX XXXX XXXXXX XX"
+    "XXX XX   XXX     *        XXX XX"
+    "XX  XX XXXX* XXXX XXXX XXXXXX XX"
+    "XXX  X XXXXX XXXX XXXX X      XX"
+    "XXXX    e    XXXX XXXX X XX X  X"
+    "XXXXXXXXXXXX     *e       X e XX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
+
+
+;;; Maze4 is symmetric about the vertical axis.  (Wow...)
+
+(defparameter maze4
+  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "X*        eXXXXXXXXXXe        *X"
+    "X XXXXXXXX            XXXXXXXX X"
+    "X XX   XXXXXXX XX XXXXXXX   XX X"
+    "X    XeXXXXXXX XX XXXXXXXeX    X"
+    "XX X XXXXXXX  eXXe  XXXXXXX X XX"
+    "XX X XXXXXXX XXXXXX XXXXXXX X XX"
+    "XX * XXXXXXX XXXXXX XXXXXXX * XX"
+    "XX X XXXe              eXXX X XX"
+    "XX X XXX XXXXXXXXXXXXXX XXX X XX"
+    "XX e XXX    XXXXXXXX    XXX e XX"
+    "XX X XXXXXX XXXXXXXX XXXXXX X XX"
+    "XX X XXXX   XXXXXXXX   XXXX X XX"
+    "XX   XXXX XXXe   eXXXX XXXX   XX"
+    "XXX XXXXX XXX XXX XXXX XXXXX XXX"
+    "XXX XXXXX XXX      XXX XXXXX XXX"
+    "X*  XXXXX     XXXX     XXXXX  *X"
+    "X XXXXX XX XX  **  XX XX XXXXX X"
+    "X XXXXX XX XX XXXX XX XX XXXXX X"
+    "X XXX e XX XX XXXX XX XX e XXX X"
+    "X XXXXX XX    XXXX    XX XXXXX X"
+    "X XXXXX XXXXX XXXX XXXXX XXXXX X"
+    "X     X XXXXX XXXX XXXXX X     X"
+    "XXXXX  *                *  XXXXX"
+    "XXXXX XXXXXXXX XX XXXXXXXX XXXXX"
+    "XXXXX XXXXXXXX XX XXXXXXXX XXXXX"
+    "XXXXX    XXXXX XX XXXXX    XXXXX"
+    "XXXX  XX  XXXXeXXeXXXX  XX  XXXX"
+    "XXX  XXXX  XXX XX XXX  XXXX  XXX"
+    "XXX XXXXXX XXX XX XXX XXXXXX XXX"
+    "XX*       e    XX    e       *XX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
+
+;;; Maze5 has a lot of long corridors good for feeb showdowns.
+;;; Furthermore, all the feeb entry-points are in the corridors.
+;;; You can run but you can't hide!
+
+(defparameter maze5
+  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "X              e           e   X"
+    "X XXXXXXX*XXXXXXXXXXXX XXXXXXX X"
+    "X               e              X"
+    "X X XXXXX XXXXXXXXXXXX XXXXX X X"
+    "X              *               X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX XXXXXXXXXXXX XXeXX X X"
+    "X X XX XX    *         XX XX X X"
+    "XeX XX XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX          e   XX XXeX X"
+    "X X XXeXX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX XXXXXXXXXXXX XX XX XeX"
+    "X*X XX XX              XX XX X X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X XeXX XX XXXXXXXXXXXX*XX XX X X"
+    "X X XX XX  *           XX XX*X X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX  e           XX XX*X X"
+    "X X XX*XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX              XX XXeX X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X X XX XX XXXXXXXXXXXX XX XX X X"
+    "X             e                X"
+    "X*X XXXXX XXXXXXXXXXXX XXXXX X*X"
+    "X             e       *        X"
+    "X XXXXXXX XXXXXXXXXXXX XXXXXXX X"
+    "X     e        *               X"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
+
+;;; Don't try to run this next one!  Just use it to create
+;;; new mazes.
+
+(defparameter maze-template
+  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
+    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
+
diff --git a/contrib/hist/hist.catalog b/contrib/hist/hist.catalog
new file mode 100644
index 0000000000000000000000000000000000000000..e6858e5e332903b8ed1bba1d78ba5aae8119fa39
--- /dev/null
+++ b/contrib/hist/hist.catalog
@@ -0,0 +1,53 @@
+Package Name:
+   HIST
+
+Description:
+   Simple histogram facility using Format strings for output.
+
+Author:
+   Scott E. Fahlman
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   Scott.Fahlman@CS.CMU.EDU
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   hist.lisp, hist.fasl, hist.catalog
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>.
+   cp /afs/cs.cmu.edu/project/slisp/library/hist/* <spec>
+
+Portability:
+   Should run in any legal Common Lisp.
+
+Instructions:
+   Hist is a macro of form (HIST (min max [bucket-size]) . body)
+
+Creates a histogram with buckets of the specified size (defaults to 1),
+spanning the range from Low (inclusive) to High (exclusive), with two
+additional buckets to catch values below and above this range.  The body is
+executed as a progn, and every call to Hist-Record within the body provides a
+value for the histogram to count.  When Body exits, the histogram is printed
+out and Hist returns Nil.
+
+A simple example:
+   (hist (0 10) (dotimes (i 1000) (random 10)))
+This example may make the RANDOM distribution look more normal:
+   (hist (0 10 2) (dotimes (i 1000) (random 10)))
+This example will show you overflow buckets:
+   (hist (2 12) (dotimes (i 1000) (random 15)))
+
+Wish List:
+   Some sort of automatic scaling for the number and size of buckets would be
+nice, if the user chooses not to supply these.  This would probably require
+running the body twice, once to determine the spread of values, and again to
+actually produce the histogram.
diff --git a/contrib/hist/hist.lisp b/contrib/hist/hist.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..40f212416371cae068f458448a8f71ac5c84cbdb
--- /dev/null
+++ b/contrib/hist/hist.lisp
@@ -0,0 +1,89 @@
+;;; -*- Mode: Lisp; Package: Hist; Log: Hist.Log -*-
+;;;
+;;; This code has been placed in the public domain by the author.
+;;; It is distributed without warranty of any kind.
+;;;
+;;; Description: Simple Histogram facility.  Just prints out the result
+;;;   using Format.  No fancy graphics.
+;;;
+;;; Author: Scott E. Fahlman
+;;;
+;;; Current maintainer:	Scott E. Fahlman
+;;;
+;;; Address: Carnegie-Mellon University
+;;;          Computer Science Department
+;;;	     Pittsburgh, PA 15213
+;;;
+;;; Net address: Scott.Fahlman@cmu-cs-a
+;;;
+;;; Copyright status: Public domain.
+;;;
+;;; Compatibility: Should run in any legal Common Lisp implementation.
+;;;
+;;; Dependencies: Depends only on standard Common Lisp facilities.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package "HIST")
+(export '(hist hist-record))
+
+;;; Uses a bunch of specials for communication.
+
+(proclaim '(special *hist-lower-limit*
+		    *hist-upper-limit*
+		    *hist-bucket-size*
+		    *hist-nbuckets*
+		    *hist-array*))
+
+(defconstant hist-limit 60
+  "The maximum number of #'s that are to be printed.")
+
+(defmacro hist ((low high &optional (bucket-size 1))
+		&body body)
+  "Format is (HIST (low high [bucket-size]) . body).
+  Creates a histogram with buckets of the specified size (defaults to 1),
+  spanning the range from Low (inclusive) to High (exclusive), with two
+  additional buckets to catch values below and above this range.
+  The body is executed as a progn, and every call to Hist-Record within
+  the body provides a value for the histogram to count.
+  When Body exits, the histogram is printed out and Hist returns Nil."
+  `(let* ((*hist-lower-limit* ,low)
+	  (*hist-upper-limit* ,high)
+	  (*hist-bucket-size* ,bucket-size)
+	  (*hist-nbuckets*
+	   (+ 2 (ceiling (- *hist-upper-limit* *hist-lower-limit*)
+			 *hist-bucket-size*)))
+	  (*hist-array* (make-array *hist-nbuckets* :initial-element 0)))
+     (progn ,@body)
+     (let ((biggest 0) (scale 1))
+       (dotimes (b (- *hist-nbuckets* 2))
+	 (when (> (svref *hist-array* b) biggest)
+	   (setq biggest (svref *hist-array* b))))
+       (when (> biggest hist-limit)
+	 (setq scale (ceiling biggest hist-limit))
+	 (format t "~&Each \"#\" equals ~S units.  The \".\" indicates a fraction."
+		 scale))
+       (format t "~&< ~S: ~12,8T~S~%"
+	       *hist-lower-limit*
+	       (svref *hist-array* (1- *hist-nbuckets*)))
+       (do ((b 0 (1+ b))
+	    (bval *hist-lower-limit* (+ bval *hist-bucket-size*))
+	    (bcount 0))
+	   ((= b (- *hist-nbuckets* 2)))
+	 (setq bcount (svref *hist-array* b))
+	 (multiple-value-bind (q r) (truncate bcount scale)
+	   (format t "~S: ~12,8T~S~20,8T~V,1,0,'#@A~%"
+		   bval bcount (1+ q) (if (zerop r) #\  #\.))))
+       (format t "> ~S: ~12,8T~S~%"
+	       *hist-upper-limit*
+	       (svref *hist-array* (- *hist-nbuckets* 2))))
+     nil))
+
+(defun hist-record (value)
+  "This function should only be called within the body of a HIST form.
+  Increments the proper histogram counter to record this value."
+  (cond ((< value *hist-lower-limit*)
+	 (incf (svref *hist-array* (1- *hist-nbuckets*))))
+	((>= value *hist-upper-limit*)
+	 (incf (svref *hist-array* (- *hist-nbuckets* 2))))
+	(t (incf (svref *hist-array* (floor (- value *hist-lower-limit*)
+					    *hist-bucket-size*))))))
diff --git a/contrib/library-maintenance/catalog-cat.lisp b/contrib/library-maintenance/catalog-cat.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..4d2493896adae6dc08f02c1300adf74b9f3257f5
--- /dev/null
+++ b/contrib/library-maintenance/catalog-cat.lisp
@@ -0,0 +1,64 @@
+;;; -*- Mode: Lisp; Package: library -*-
+;;; 
+;;; This contains somewhat specific code for gathering all the pertinent
+;;; .catalog files from the CMU Common Lisp Library subdirectories to
+;;; construct one catalog.txt file from them.
+;;; 
+;;; This code uses at least one implementation internal function, hacks
+;;; pathnames as strings, accepts CMU Common Lisp logical names, tries
+;;; to determine what a directory name looks like, uses CMU Common Lisp
+;;; extensions, and generally tries not to be portable in any way.
+;;; 
+;;; Written by Bill Chiles
+;;;
+
+(in-package "LIBRARY" :nicknames '("LIB"))
+
+(export 'build-catalog)
+
+
+(defun build-catalog (dir)
+  "Gather all the .catalog files from the subdirectories of dir, bashing them
+   into a file named \"new-catalog.txt\" in dir.  The argument must be a
+   logical name or end with a slash (/)"
+  (with-open-file (stream (merge-pathnames dir "new-catalog.txt")
+			  :direction :output :if-exists :new-version)
+    (let* ((files (catalog-files dir))
+	   (last (car (last files))))
+      (dolist (f files)
+	(with-open-file (catalog f)
+	  (do ((line (read-line catalog nil :eof)
+		     (read-line catalog nil :eof)))
+	      ((eq line :eof))
+	    (write-line line stream))
+	  (unless (equal f last)
+	    (format stream "~%~|~%")))))))
+
+
+;;; CATALOG-FILES does a DIRECTORY (CMU Common Lisp) of dir returning a
+;;; list of file names containing the string ".catalog".  The directory
+;;; listing may include subdirectories, but these subdirs contain only
+;;; files (one of which is a catalog file).  The subdirectory catalog
+;;; files are included in the result list in order of the subdirectory's
+;;; appearance.
+;;; 
+(defun catalog-files (dir)
+  (let ((listing (directory dir))
+	result)
+    (dolist (f listing (nreverse result))
+      (let ((name (namestring f)))
+	(declare (simple-string name))
+	(if (directoryp f)
+	    (dolist (f (directory name))
+	      (let ((name (namestring f)))
+		(declare (simple-string name))
+		(when (search ".catalog" name :test #'char=)
+		  (push name result)
+		  (return))))
+	    (if (search ".catalog" name :test #'char=)
+		(push name result)))))))
+
+(defun directoryp (p)
+  (let ((p (pathname p)))
+    (string= (the simple-string (directory-namestring p))
+	     (the simple-string (namestring p)))))
diff --git a/contrib/library-maintenance/compile-lib.lisp b/contrib/library-maintenance/compile-lib.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8525db0fdab037d62a4ed9f1994348451be8fee6
--- /dev/null
+++ b/contrib/library-maintenance/compile-lib.lisp
@@ -0,0 +1,21 @@
+;;; -*- Mode: Lisp; Package: library -*-
+;;;
+;;; This file contains stupid code to simply compile all the library entries.
+;;;
+;;; Written by Blaine Burks.
+;;;
+
+(in-package "LIBRARY" :nicknames '("LIB"))
+
+(export '(compile-entries))
+
+(defun compile-entries ()
+  (let ((lib-directory (directory ed::*lisp-library-directory*)))
+    (dolist (lib-spec lib-directory)
+      (let* ((path-parts (pathname-directory lib-spec))
+	     (last (svref path-parts (1- (length path-parts))))
+	     (raw-pathname (merge-pathnames last lib-spec)))
+	(when (and (ed::directoryp lib-spec)
+		   (probe-file (merge-pathnames ".catalog" raw-pathname)))
+	  (compile-file (merge-pathnames raw-pathname ".lisp") :error-file nil)
+	  (write-string last))))))
diff --git a/contrib/library-maintenance/old-catalog-format.txt b/contrib/library-maintenance/old-catalog-format.txt
new file mode 100644
index 0000000000000000000000000000000000000000..d6ea1d00eec4d0a342b3c12e7ce2c1f6b0b23982
--- /dev/null
+++ b/contrib/library-maintenance/old-catalog-format.txt
@@ -0,0 +1,72 @@
+
+CATALOG ENTRY FORMAT FOR CATALOG.TXT.
+
+Each entry is on a separate page, separated by the page mark Control-L.
+
+Each entry consists of fields.  Each new field begins with a field name in
+square brackets, then an arbitrary amount of text.  This rather rigid
+format is designed to make it easy to build various sorts of software to
+automatically manipulate catalogs.  The field names are sensitive to
+spelling, but insensitive to case and extra whitespace.
+
+Fields currently recognized are as follows:
+
+[Name] or [Module Name]: The name of the program or set of programs.  If no
+Package Name is supplied, then this is assumed to name of the package in
+which the code lives.
+
+[Package Name]: If the programs are loaded into a package of their own, the
+name of this package.  If no Name or Module Name is supplied, the package
+name will be used as the name for everything.
+
+[Description]: A brief description of what the program does.
+
+[Author]: Name of the author, or "anonymous".
+
+[Maintainer]: Name of current maintainer, if different from the author.  If
+a program is not being maintained by anyone, the Maintainer is "none".
+
+[Address], [Address of Author], [Address of Maintainer]: Physical mailing
+address of author or maintainer.  If the field is just "address", it is
+assumed to be the maintainer if one is specified, and the author otherwise.
+
+[Net Address], [Net Address of Author], [Net Address of Maintainer]: A
+network address that can be reached from the arpanet.
+
+[Copyright Status]: "Public domain" or some sort of copyright notice.
+
+[Files]: A list of the files comprising this facility.  If a system whose
+name is "Foo" is distributed as files "foo.slisp", "foo.sfasl", and
+(optionally) "foo.doc" or "foo.press" for documentation.  In order to
+minimize maintenance headaches and encourage people to build on the work of
+others, we want all programs in the library to include complete sources.
+
+[How to Get]: This can either be a shell command using such programs as lcp
+or cp.  There will usually be a .cmd file that will copy all the sources,
+binaries, catalog, and log files to the user's current directory.  This
+.cmd file will try to preserve write date (such as using -p with cp).
+
+[Portability]: If the program will run in any legal Common Lisp, say so.
+If there are known dependencies on CMU Common Lisp specific or
+Mach/RT specific features, describe them here.
+
+[Dependencies]: If the program requires other library packages not built
+into the standard CMU Common Lisp core image, list those other packages
+here.
+
+[Instructions]: Place here any instructions for use that are too lengthy to
+be mere documentation strings, but that are not lengthy enough to deserve a
+separate document.
+
+[Recent Changes]: What is different between this version and the one that
+preceded it, if any.  (May go back several versions at the author's
+discretion.)
+
+[Bugs]: Describe here any known bugs or treacherous features.
+
+[Future Plans]: Describe here any improvements planned by the author.
+
+[Wish List]: Describe here any desirable features that the author does not
+plan to work on in the near future.
+
+[Notes]: Anything else that users or potential users ought to know about.
diff --git a/contrib/ops/ops-backup.lisp b/contrib/ops/ops-backup.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a940546f2c8eef3ea307c3aeeafebf77b79cf2e9
--- /dev/null
+++ b/contrib/ops/ops-backup.lisp
@@ -0,0 +1,196 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; Definitions and functions for backing up.
+
+(in-package "OPS")
+
+
+;;; Internal Global Variables
+
+(defvar *refracts*)
+(defvar *record*)
+(defvar *record-array*)
+(defvar *recording*)
+(defvar *max-record-index*)
+(defvar *record-index*)
+
+
+
+(defun backup-init ()
+  (setq *recording* nil)
+  (setq *refracts* nil)
+  (setq *record-array* (make-array 256 :initial-element ()))  ;jgk
+  (initialize-record))
+
+
+(defun back (k)
+  (prog (r)
+    loop   (and (< k 1.) (return nil))
+    (setq r (getvector *record-array* *record-index*))	; (('))
+    (and (null r) (return '|nothing more stored|))
+    (putvector *record-array* *record-index* nil)
+    (record-index-plus -1.)
+    (undo-record r)
+    (setq k (1- k))
+    (go loop)))
+
+
+; *max-record-index* holds the maximum legal index for record-array
+; so it and the following must be changed at the same time
+
+(defun begin-record (p data)
+  (setq *recording* t)
+  (setq *record* (list '=>refract p data))) 
+
+(defun end-record nil
+  (cond (*recording*
+	 (setq *record*
+	       (cons *cycle-count* (cons *p-name* *record*)))
+	 (record-index-plus 1.)
+	 (putvector *record-array* *record-index* *record*)
+	 (setq *record* nil)
+	 (setq *recording* nil)))) 
+
+(defun record-change (direct time elm)
+  (cond (*recording*
+	 (setq *record*
+	       (cons direct (cons time (cons elm *record*))))))) 
+
+; to maintain refraction information, need keep only one piece of information:
+; need to record all unsuccessful attempts to delete things from the conflict
+; set.  unsuccessful deletes are caused by attempting to delete refracted
+; instantiations.  when backing up, have to avoid putting things back into the
+; conflict set if they were not deleted when running forward
+
+(defun record-refract (rule data)
+  (and *recording*
+       (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
+
+(defun refracted (rule data)
+  (prog (z)
+    (and (null *refracts*) (return nil))
+    (setq z (cons rule data))
+    (return (member z *refracts* :test #'equal))))
+
+
+(defun record-index-plus (k)
+  (setq *record-index* (+ k *record-index*))	;"plus" changed to "+" by gdw
+  (cond ((< *record-index* 0.)
+	 (setq *record-index* *max-record-index*))
+	((> *record-index* *max-record-index*)
+	 (setq *record-index* 0.)))) 
+
+; the following routine initializes the record.  putting nil in the
+; first slot indicates that that the record does not go back further
+; than that.  (when the system backs up, it writes nil over the used
+; records so that it will recognize which records it has used.  thus
+; the system is set up anyway never to back over a nil.)
+
+(defun initialize-record nil
+  (setq *record-index* 0.)
+  (setq *recording* nil)
+  (setq *max-record-index* 31.)
+  (putvector *record-array* 0. nil)) 
+
+
+;; replaced per jcp
+;;; Commented out
+#|
+(defun undo-record (r)
+  (prog (save act a b rate)
+    ;###	(comment *recording* must be off during back up)
+    (setq save *recording*)
+    (setq *refracts* nil)
+    (setq *recording* nil)
+    (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
+    (setq r (cddr r))
+    top  (and (atom r) (go fin))
+    (setq act (car r))
+    (setq a (cadr r))
+    (setq b (caddr r))
+    (setq r (cdddr r))
+    (and *wtrace* (back-print (list '|undo:| act a)))
+    (cond ((eq act '<=wm) (add-to-wm b a))
+	  ((eq act '=>wm) (remove-from-wm b))
+	  ((eq act '<=refract)
+	   (setq *refracts* (cons (cons a b) *refracts*)))
+	  ((and (eq act '=>refract) (still-present b))
+	   (setq *refracts* (delete (cons a b) *refracts*))
+	   (setq rate (rating-part (get a 'topnode)))
+	   (removecs a b)
+	   (insertcs a b rate))
+	  (t (%warn '|back: cannot undo action| (list act a))))
+    (go top)
+    fin  (setq *recording* save)
+    (setq *refracts* nil)
+    (return nil)))
+;;; End commented out
+|#
+
+
+(defun undo-record (r)
+  (prog (save act a b rate)
+    ;###	(comment *recording* must be off during back up)
+    (setq save *recording*)
+    (setq *refracts* nil)
+    (setq *recording* nil)
+    (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
+    (setq r (cddr r))
+    top  (and (atom r) (go fin))
+    (setq act (car r))
+    (setq a (cadr r))
+    (setq b (caddr r))
+    (setq r (cdddr r))
+    (and *wtrace* (back-print (list '|undo:| act a)))
+    (cond ((eq act '<=wm) (add-to-wm b a))
+	  ((eq act '=>wm) (remove-from-wm b))
+	  ((eq act '<=refract)
+	   (setq *refracts* (cons (cons a b) *refracts*)))
+	  ((and (eq act '=>refract) (still-present b))
+	   (setq *refracts* (spdelete (cons a b) *refracts*))
+	   (setq rate (rating-part (get a 'topnode)))
+	   (removecs a b)
+	   (insertcs a b rate))
+	  (t (%warn '|back: cannot undo action| (list act a))))
+    (go top)
+    fin  (setq *recording* save)
+    (setq *refracts* nil)
+    (return nil))) 
+
+
+
+; still-present makes sure that the user has not deleted something
+; from wm which occurs in the instantiation about to be restored; it
+; makes the check by determining whether each wme still has a time tag.
+
+(defun still-present (data)
+  (prog nil
+    loop
+    (cond ((atom data) (return t))
+	  ((creation-time (car data))
+	   (setq data (cdr data))
+	   (go loop))
+	  (t (return nil))))) 
+
+
+(defun back-print (x) 
+  (prog (port)
+    (setq port (trace-file))
+    (terpri port)
+    (print x port)))
diff --git a/contrib/ops/ops-compile.lisp b/contrib/ops/ops-compile.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a94da3bde80f3bb17395e85fd43256a4db9d5b53
--- /dev/null
+++ b/contrib/ops/ops-compile.lisp
@@ -0,0 +1,805 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; This file contains functions compile productions.
+
+(in-package "OPS")
+(shadow '(remove write))    ; Should get this by requiring ops-rhs
+(export '--> )
+
+
+;;; External global variables
+
+(defvar *real-cnt*)
+(defvar *virtual-cnt*)
+(defvar *last-node*)
+(defvar *first-node*)
+(defvar *pcount*)
+
+
+;;; Internal global variables
+
+(defvar *matrix*)
+(defvar *curcond*)
+(defvar *feature-count*)
+(defvar *ce-count*)
+(defvar *vars*)
+(defvar *ce-vars*)
+(defvar *rhs-bound-vars*)
+(defvar *rhs-bound-ce-vars*)
+(defvar *last-branch*)
+(defvar *subnum*)
+(defvar *cur-vars*)
+(defvar *action-type*)
+
+
+
+(defun compile-init ()
+  (setq *real-cnt* (setq *virtual-cnt* 0.))
+  (setq *pcount* 0.)
+  (make-bottom-node))
+
+
+;;; LHS Compiler
+
+(defun ops-p (z) 
+  (finish-literalize)
+  (princ '*) 
+  ;(drain) commented out temporarily
+  (force-output)			;@@@ clisp drain?
+  (compile-production (car z) (cdr z))) 
+
+
+(defun compile-production (name matrix) ;jgk inverted args to catch and quoted tag
+  (setq *p-name* name)
+  (catch '!error! (cmp-p name matrix))
+  (setq *p-name* nil))
+#|
+(defun compile-production (name matrix) ;jgk inverted args to catch 
+  (prog (erm)				;and quoted tag
+    (setq *p-name* name)
+    (setq erm (catch '!error! (cmp-p name matrix)))
+    (setq *p-name* nil)))
+|#
+
+(defun peek-lex nil (car *matrix*)) 
+
+(defun lex nil
+  (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) 
+
+(defun end-of-p nil (atom *matrix*)) 
+
+(defun rest-of-p nil *matrix*) 
+
+(defun prepare-lex (prod) (setq *matrix* prod)) 
+
+
+(defun peek-sublex nil (car *curcond*)) 
+
+(defun sublex nil
+  (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) 
+
+(defun end-of-ce nil (atom *curcond*)) 
+
+(defun rest-of-ce nil *curcond*) 
+
+(defun prepare-sublex (ce) (setq *curcond* ce)) 
+
+(defun make-bottom-node nil (setq *first-node* (list '&bus nil))) 
+
+(defun cmp-p (name matrix)
+  (prog (m bakptrs)
+    (cond ((or (null name) (consp  name))	;dtpr\consp gdw
+	   (%error '|illegal production name| name))
+	  ((equal (get name 'production) matrix)
+	   (return nil)))
+    (prepare-lex matrix)
+    (excise-p name)
+    (setq bakptrs nil)
+    (setq *pcount* (1+ *pcount*))		;"plus" changed to "+" by gdw
+    (setq *feature-count* 0.)
+    (setq *ce-count* 0)
+    (setq *vars* nil)
+    (setq *ce-vars* nil)
+    (setq *rhs-bound-vars* nil)
+    (setq *rhs-bound-ce-vars* nil)
+    (setq *last-branch* nil)
+    (setq m (rest-of-p))
+    l1   (and (end-of-p) (%error '|no '-->' in production| m))
+    (cmp-prin)
+    (setq bakptrs (cons *last-branch* bakptrs))
+    (or (eq '--> (peek-lex)) (go l1))
+    (lex)
+    (check-rhs (rest-of-p))
+    (link-new-node (list '&p
+			 *feature-count*
+			 name
+			 (encode-dope)
+			 (encode-ce-dope)
+			 (cons 'progn (rest-of-p))))
+    (putprop name (cdr (nreverse bakptrs)) 'backpointers)
+    (putprop name matrix 'production)
+    (putprop name *last-node* 'topnode))) 
+
+(defun rating-part (pnode) (cadr pnode)) 
+
+(defun var-part (pnode) (car (cdddr pnode))) 
+
+(defun ce-var-part (pnode) (cadr (cdddr pnode))) 
+
+(defun rhs-part (pnode) (caddr (cdddr pnode))) 
+
+(defun cmp-prin nil
+  (prog nil
+    (setq *last-node* *first-node*)
+    (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
+	  ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
+	  (t (cmp-posce) (cmp-and))))) 
+
+(defun cmp-negce nil (lex) (cmp-ce)) 
+
+(defun cmp-posce nil
+  (setq *ce-count* (1+ *ce-count*))		;"plus" changed to "+" by gdw
+  (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))	;"plus" changed to "+" by gdw
+	(t (cmp-ce)))) 
+
+(defun cmp-ce+cevar nil
+  (prog (z)
+    (lex)
+    (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
+	  (t (cmp-ce) (cmp-cevar)))
+    (setq z (lex))
+    (or (eq z '\}) (%error '|missing '}'| z)))) 
+
+(defun new-subnum (k)
+  (or (numberp k) (%error '|tab must be a number| k))
+  (setq *subnum* (fix k))) 
+
+(defun incr-subnum nil (setq *subnum* (1+ *subnum*))) 
+
+(defun cmp-ce nil
+  (prog (z)
+    (new-subnum 0.)
+    (setq *cur-vars* nil)
+    (setq z (lex))
+    (and (atom z)
+	 (%error '|atomic conditions are not allowed| z))
+    (prepare-sublex z)
+    la   (and (end-of-ce) (return nil))
+    (incr-subnum)
+    (cmp-element)
+    (go la))) 
+
+(defun cmp-element nil
+  (and (eq (peek-sublex) '^) (cmp-tab))
+  (cond ((eq (peek-sublex) '\{) (cmp-product))
+	(t (cmp-atomic-or-any))))
+
+(defun cmp-atomic-or-any nil
+  (cond ((eq (peek-sublex) '<<) (cmp-any))
+	(t (cmp-atomic))))
+
+(defun cmp-any nil
+  (prog (a z)
+    (sublex)
+    (setq z nil)
+    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
+    (setq a (sublex))
+    (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
+    (link-new-node (list '&any nil (current-field) z)))) 
+
+
+(defun cmp-tab nil
+  (prog (r)
+    (sublex)
+    (setq r (sublex))
+    (setq r ($litbind r))
+    (new-subnum r))) 
+
+(defun get-bind (x)
+  (prog (r)
+    (cond ((and (symbolp x) (setq r (literal-binding-of x)))
+	   (return r))
+	  (t (return nil))))) 
+
+(defun cmp-atomic nil
+  (prog (test x)
+    (setq x (peek-sublex))
+    (cond ((eq x '= ) (setq test 'eq) (sublex))
+	  ((eq x '<>) (setq test 'ne) (sublex))
+	  ((eq x '<) (setq test 'lt) (sublex))
+	  ((eq x '<=) (setq test 'le) (sublex))
+	  ((eq x '>) (setq test 'gt) (sublex))
+	  ((eq x '>=) (setq test 'ge) (sublex))
+	  ((eq x '<=>) (setq test 'xx) (sublex))
+	  (t (setq test 'eq)))
+    (cmp-symbol test))) 
+
+(defun cmp-product nil
+  (prog (save)
+    (setq save (rest-of-ce))
+    (sublex)
+    la   (cond ((end-of-ce)
+		(cond ((member '\} save :test #'equal) 
+		       (%error '|wrong contex for '}'| save))
+		      (t (%error '|missing '}'| save))))
+	       ((eq (peek-sublex) '\}) (sublex) (return nil)))
+    (cmp-atomic-or-any)
+    (go la))) 
+
+(defun cmp-symbol (test)
+  (prog (flag)
+    (setq flag t)
+    (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
+    (cond ((and flag (variablep (peek-sublex)))
+	   (cmp-var test))
+	  ((numberp (peek-sublex)) (cmp-number test))
+	  ((symbolp (peek-sublex)) (cmp-constant test))
+	  (t (%error '|unrecognized symbol| (sublex)))))) 
+
+(defun cmp-constant (test)   ;jgk inserted concatenate form
+  (or (member test '(eq ne xx))
+      (%error '|non-numeric constant after numeric predicate| (sublex)))
+  (link-new-node (list (intern (concatenate 'string
+					    "T"
+					    (symbol-name  test)
+					    "A"))
+		       nil
+		       (current-field)
+		       (sublex)))) 
+
+(defun cmp-number (test)   ;jgk inserted concatenate form
+  (link-new-node (list (intern (concatenate 'string
+					    "T"
+					    (symbol-name  test)
+;@@@ error? reported by laird fix\	    "A"))
+		       "N"))
+  nil
+  (current-field)
+  (sublex)))) 
+
+(defun current-field nil (field-name *subnum*)) 
+
+(defun field-name (num)
+  (if (< 0 num 127)
+      (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11*
+		    *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
+		    *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
+		    *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
+		    *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
+		    *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
+		    *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
+		    *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
+		    *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
+		    *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
+		    *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
+		    *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
+		    *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
+		    *c125* *c126* *c127*)
+	     num)
+      (%error '|condition is too long| (rest-of-ce))))
+
+;;; Compiling variables
+;
+;
+;
+; *cur-vars* are the variables in the condition element currently 
+; being compiled.  *vars* are the variables in the earlier condition
+; elements.  *ce-vars* are the condition element variables.  note
+; that the interpreter will not confuse condition element and regular
+; variables even if they have the same name.
+;
+; *cur-vars* is a list of triples: (name predicate subelement-number)
+; eg:		( (<x> eq 3)
+;		  (<y> ne 1)
+;		  . . . )
+;
+; *vars* is a list of triples: (name ce-number subelement-number)
+; eg:		( (<x> 3 3)
+;		  (<y> 1 1)
+;		  . . . )
+;
+; *ce-vars* is a list of pairs: (name ce-number)
+; eg:		( (ce1 1)
+;		  (<c3> 3)
+;		  . . . )
+
+(defmacro var-dope (var) `(assq ,var *vars*))
+
+(defmacro ce-var-dope (var) `(assq ,var *ce-vars*))
+
+(defun cmp-var (test)
+  (prog (old name)
+    (setq name (sublex))
+    (setq old (assq name *cur-vars*))
+    (cond ((and old (eq (cadr old) 'eq))
+	   (cmp-old-eq-var test old))
+	  ((and old (eq test 'eq)) (cmp-new-eq-var name old))
+	  (t (cmp-new-var name test))))) 
+
+(defun cmp-new-var (name test)
+  (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) 
+
+(defun cmp-old-eq-var (test old)  ; jgk inserted concatenate form
+  (link-new-node (list (intern (concatenate 'string
+					    "T"
+					    (symbol-name  test)
+					    "S"))
+		       nil
+		       (current-field)
+		       (field-name (caddr old))))) 
+
+
+
+(defun cmp-new-eq-var (name old)  ;jgk inserted concatenate form
+  (prog (pred next)
+    (setq *cur-vars* (delq old *cur-vars*))
+    (setq next (assq name *cur-vars*))
+    (cond (next (cmp-new-eq-var name next))
+	  (t (cmp-new-var name 'eq)))
+    (setq pred (cadr old))
+    (link-new-node (list (intern (concatenate 'string
+					      "T"
+					      (symbol-name  pred)
+					      "S"))
+			 nil
+			 (field-name (caddr old))
+			 (current-field))))) 
+
+(defun cmp-cevar nil
+  (prog (name old)
+    (setq name (lex))
+    (setq old (assq name *ce-vars*))
+    (and old
+	 (%error '|condition element variable used twice| name))
+    (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) 
+
+(defun cmp-not nil (cmp-beta '&not)) 
+
+(defun cmp-nobeta nil (cmp-beta nil)) 
+
+(defun cmp-and nil (cmp-beta '&and)) 
+
+(defun cmp-beta (kind)
+  (prog (tlist vdope vname #|vpred vpos|# old)
+    (setq tlist nil)
+    la   (and (atom *cur-vars*) (go lb))
+    (setq vdope (car *cur-vars*))
+    (setq *cur-vars* (cdr *cur-vars*))
+    (setq vname (car vdope))
+    ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
+    ;;  (setq vpos (caddr vdope))
+    (setq old (assq vname *vars*))
+    (cond (old (setq tlist (add-test tlist vdope old)))
+	  ((not (eq kind '&not)) (promote-var vdope)))
+    (go la)
+    lb   (and kind (build-beta kind tlist))
+    (or (eq kind '&not) (fudge))
+    (setq *last-branch* *last-node*))) 
+
+(defun add-test (list new old) ; jgk inserted concatenate form
+  (prog (ttype lloc rloc)
+    (setq *feature-count* (1+ *feature-count*))
+    (setq ttype (intern (concatenate 'string "T"
+				     (symbol-name (cadr new))
+				     "B")))
+    (setq rloc (encode-singleton (caddr new)))
+    (setq lloc (encode-pair (cadr old) (caddr old)))
+    (return (cons ttype (cons lloc (cons rloc list)))))) 
+
+; the following two functions encode indices so that gelm can
+; decode them as fast as possible
+
+(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) 
+;"plus" changed to "+" by gdw
+
+(defun encode-singleton (a) (1- a)) 
+
+(defun promote-var (dope)
+  (prog (vname vpred vpos new)
+    (setq vname (car dope))
+    (setq vpred (cadr dope))
+    (setq vpos (caddr dope))
+    (or (eq 'eq vpred)
+	(%error '|illegal predicate for first occurrence|
+		(list vname vpred)))
+    (setq new (list vname 0. vpos))
+    (setq *vars* (cons new *vars*)))) 
+
+(defun fudge nil
+  (mapc (function fudge*) *vars*)
+  (mapc (function fudge*) *ce-vars*)) 
+
+(defun fudge* (z)
+  (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) 
+
+(defun build-beta (type tests)
+  (prog (rpred lpred lnode lef)
+    (link-new-node (list '&mem nil nil (protomem)))
+    (setq rpred *last-node*)
+    (cond ((eq type '&and)
+	   (setq lnode (list '&mem nil nil (protomem))))
+	  (t (setq lnode (list '&two nil nil))))
+    (setq lpred (link-to-branch lnode))
+    (cond ((eq type '&and) (setq lef lpred))
+	  (t (setq lef (protomem))))
+    (link-new-beta-node (list type nil lef rpred tests)))) 
+
+(defun protomem nil (list nil)) 
+
+(defun memory-part (mem-node) (car (cadddr mem-node))) 
+
+(defun encode-dope nil
+  (prog (r all z k)
+    (setq r nil)
+    (setq all *vars*)
+    la   (and (atom all) (return r))
+    (setq z (car all))
+    (setq all (cdr all))
+    (setq k (encode-pair (cadr z) (caddr z)))
+    (setq r (cons (car z) (cons k r)))
+    (go la))) 
+
+(defun encode-ce-dope nil
+  (prog (r all z k)
+    (setq r nil)
+    (setq all *ce-vars*)
+    la   (and (atom all) (return r))
+    (setq z (car all))
+    (setq all (cdr all))
+    (setq k (cadr z))
+    (setq r (cons (car z) (cons k r)))
+    (go la))) 
+
+
+
+;;; Linking the nodes
+
+(defun link-new-node (r)
+  (cond ((not (member (car r) '(&p &mem &two &and &not) :test #'equal))
+	 (setq *feature-count* (1+ *feature-count*))))
+  (setq *virtual-cnt* (1+ *virtual-cnt*))
+  (setq *last-node* (link-left *last-node* r))) 
+
+(defun link-to-branch (r)
+  (setq *virtual-cnt* (1+ *virtual-cnt*))
+  (setq *last-branch* (link-left *last-branch* r))) 
+
+(defun link-new-beta-node (r)
+  (setq *virtual-cnt* (1+ *virtual-cnt*))
+  (setq *last-node* (link-both *last-branch* *last-node* r))
+  (setq *last-branch* *last-node*)) 
+
+(defun link-left (pred succ)
+  (prog (a r)
+    (setq a (left-outs pred))
+    (setq r (find-equiv-node succ a))
+    (and r (return r))
+    (setq *real-cnt* (1+ *real-cnt*))
+    (attach-left pred succ)
+    (return succ))) 
+
+(defun link-both (left right succ)
+  (prog (a r)
+    (setq a (interq (left-outs left) (right-outs right)))
+    (setq r (find-equiv-beta-node succ a))
+    (and r (return r))
+    (setq *real-cnt* (1+ *real-cnt*))
+    (attach-left left succ)
+    (attach-right right succ)
+    (return succ))) 
+
+(defun attach-right (old new)
+  (rplaca (cddr old) (cons new (caddr old)))) 
+
+(defun attach-left (old new)
+  (rplaca (cdr old) (cons new (cadr old)))) 
+
+(defun right-outs (node) (caddr node)) 
+
+(defun left-outs (node) (cadr node)) 
+
+(defun find-equiv-node (node list)
+  (prog (a)
+    (setq a list)
+    l1   (cond ((atom a) (return nil))
+	       ((equiv node (car a)) (return (car a))))
+    (setq a (cdr a))
+    (go l1))) 
+
+(defun find-equiv-beta-node (node list)
+  (prog (a)
+    (setq a list)
+    l1   (cond ((atom a) (return nil))
+	       ((beta-equiv node (car a)) (return (car a))))
+    (setq a (cdr a))
+    (go l1))) 
+
+; do not look at the predecessor fields of beta nodes; they have to be
+; identical because of the way the candidate nodes were found
+
+(defun equiv (a b)
+  (and (eq (car a) (car b))
+       (or (eq (car a) '&mem)
+	   (eq (car a) '&two)
+	   (equal (caddr a) (caddr b)))
+       (equal (cdddr a) (cdddr b)))) 
+
+(defun beta-equiv (a b)
+  (and (eq (car a) (car b))
+       (equal (cddddr a) (cddddr b))
+       (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
+
+; the equivalence tests are set up to consider the contents of
+; node memories, so they are ready for the build action
+
+
+
+;;; Check the RHSs of productions 
+
+
+(defun check-rhs (rhs) (mapc (function check-action) rhs))
+
+(defun check-action (x)
+  (prog (a)
+    (cond ((atom x)
+	   (%warn '|atomic action| x)
+	   (return nil)))
+    (setq a (setq *action-type* (car x)))
+    (case a
+      (bind (check-bind x))
+      (cbind (check-cbind x))
+      (make (check-make x))
+      (modify (check-modify x))
+      (remove (check-remove x))
+      (write (check-write x))	
+      (call (check-call x))		
+      (halt (check-halt x))
+      (openfile (check-openfile x))
+      (closefile (check-closefile x))
+      (default (check-default x))
+      (build (check-build x))
+      (t (%warn '|undefined rhs action| a)))))
+
+
+;(defun chg-to-write (x)
+;	(setq x (cons 'write (cdr x))))
+
+(defun check-build (z)
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (check-build-collect (cdr z)))
+
+(defun check-build-collect (args)
+  (prog (r)
+    top	(and (null args) (return nil))
+    (setq r (car args))
+    (setq args (cdr args))
+    (cond ((consp  r) (check-build-collect r))	;dtpr\consp gdw
+	  ((eq r '\\)
+	   (and (null args) (%warn '|nothing to evaluate| r))
+	   (check-rhs-value (car args))
+	   (setq args (cdr args))))
+    (go top)))
+
+(defun check-remove (z) 				;@@@ kluge by gdw
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (mapc (function check-rhs-ce-var) (cdr z))) 
+
+;(defun check-remove (z) 					;original
+   ; (and (null (cdr z)) (%warn '|needs arguments| z))
+   ;(mapc (function check-rhs-ce-var) (cdr z))) 
+
+(defun check-make (z)
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (check-change& (cdr z))) 
+
+(defun check-openfile (z)
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (check-change& (cdr z))) 
+
+(defun check-closefile (z)
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (check-change& (cdr z))) 
+
+(defun check-default (z)
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (check-change& (cdr z))) 
+
+(defun check-modify (z)
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (check-rhs-ce-var (cadr z))
+  (and (null (cddr z)) (%warn '|no changes to make| z))
+  (check-change& (cddr z))) 
+
+(defun check-write (z)				;note this works w/write
+  (and (null (cdr z)) (%warn '|needs arguments| z))
+  (check-change& (cdr z))) 
+
+(defun check-call (z)
+  (prog (f)
+    (and (null (cdr z)) (%warn '|needs arguments| z))
+    (setq f (cadr z))
+    (and (variablep f)
+	 (%warn '|function name must be a constant| z))
+    (or (symbolp f)
+	(%warn '|function name must be a symbolic atom| f))
+    (or (externalp f)
+	(%warn '|function name not declared external| f))
+    (check-change& (cddr z)))) 
+
+(defun check-halt (z)
+  (or (null (cdr z)) (%warn '|does not take arguments| z))) 
+
+(defun check-cbind (z)
+  (prog (v)
+    (or (= (length z) 2.) (%warn '|takes only one argument| z))
+    (setq v (cadr z))
+    (or (variablep v) (%warn '|takes variable as argument| z))
+    (note-ce-variable v))) 
+
+(defun check-bind (z)
+  (prog (v)
+    (or (> (length z) 1.) (%warn '|needs arguments| z))
+    (setq v (cadr z))
+    (or (variablep v) (%warn '|takes variable as argument| z))
+    (note-variable v)
+    (check-change& (cddr z)))) 
+
+
+(defun check-change& (z)
+  (prog (r tab-flag)
+    (setq tab-flag nil)
+    la   (and (atom z) (return nil))
+    (setq r (car z))
+    (setq z (cdr z))
+    (cond ((eq r '^)
+	   (and tab-flag
+		(%warn '|no value before this tab| (car z)))
+	   (setq tab-flag t)
+	   (check-tab-index (car z))
+	   (setq z (cdr z)))
+	  ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
+	  (t (setq tab-flag nil) (check-rhs-value r)))
+    (go la))) 
+
+(defun check-rhs-ce-var (v)
+  (cond ((and (not (numberp v)) (not (ce-bound? v)))
+	 (%warn '|unbound element variable| v))
+	((and (numberp v) (or (< v 1.) (> v *ce-count*)))
+	 (%warn '|numeric element designator out of bounds| v)))) 
+
+(defun check-rhs-value (x)
+  (cond ((consp  x) (check-rhs-function x))	;dtpr\consp gdw
+	(t (check-rhs-atomic x)))) 
+
+(defun check-rhs-atomic (x)
+  (and (variablep x) 
+       (not (bound? x)) 
+       (%warn '|unbound variable| x)))
+
+(defun check-rhs-function (x)
+  (prog (a)
+    (setq a (car x))
+    (cond ((eq a 'compute) (check-compute x))
+	  ((eq a 'arith) (check-compute x))
+	  ((eq a 'substr) (check-substr x))
+	  ((eq a 'accept) (check-accept x))
+	  ((eq a 'acceptline) (check-acceptline x))
+	  ((eq a 'crlf) (check-crlf x))
+	  ((eq a 'genatom) (check-genatom x))
+	  ((eq a 'litval) (check-litval x))
+	  ((eq a 'tabto) (check-tabto x))
+	  ((eq a 'rjust) (check-rjust x))
+	  ((not (externalp a))
+	   (%warn '"rhs function not declared external" a)))))
+
+(defun externalp (x)
+  ;  (cond ((symbolp x) (get x 'external-routine)) 	;) @@@
+  ;ok, I'm eliminating this temporarily @@@@
+  (cond ((symbolp x) t)
+	(t (%warn '|not a legal function name| x) nil)))
+
+
+(defun check-litval (x) 
+  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
+  (check-rhs-atomic (cadr x)))
+
+(defun check-accept (x)
+  (cond ((= (length x) 1) nil)
+	((= (length x) 2) (check-rhs-atomic (cadr x)))
+	(t (%warn '|too many arguments| x))))
+
+(defun check-acceptline (x)
+  (mapc (function check-rhs-atomic) (cdr x)))
+
+(defun check-crlf (x) 
+  (check-0-args x)) 
+
+(defun check-genatom (x) (check-0-args x)) 
+
+(defun check-tabto (x)
+  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
+  (check-print-control (cadr x)))
+
+(defun check-rjust (x)
+  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
+  (check-print-control (cadr x)))
+
+(defun check-0-args (x)
+  (or (= (length x) 1.) (%warn '|should not have arguments| x))) 
+
+(defun check-substr (x)
+  (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
+  (check-rhs-ce-var (cadr x))
+  (check-substr-index (caddr x))
+  (check-last-substr-index (cadddr x))) 
+
+(defun check-compute (x) (check-arithmetic (cdr x))) 
+
+(defun check-arithmetic (l)
+  (cond ((atom l)
+	 (%warn '|syntax error in arithmetic expression| l))
+	((atom (cdr l)) (check-term (car l)))
+	((not (member (cadr l) '(+ - * // \\)))	;"plus" changed to "+" by gdw
+	 (%warn '|unknown operator| l))
+	(t (check-term (car l)) (check-arithmetic (cddr l))))) 
+
+(defun check-term (x)
+  (cond ((consp  x) (check-arithmetic x))	;dtpr\consp gdw
+	(t (check-rhs-atomic x)))) 
+
+(defun check-last-substr-index (x)
+  (or (eq x 'inf) (check-substr-index x))) 
+
+(defun check-substr-index (x)
+  (prog (v)
+    (cond ((bound? x) (return x)))
+    (setq v ($litbind x))
+    (cond ((not (numberp v))
+	   (%warn '|unbound symbol used as index in substr| x))
+	  ((or (< v 1.) (> v 127.))
+	   (%warn '|index out of bounds in tab| x))))) 
+
+(defun check-print-control (x)
+  (prog ()
+    (cond ((bound? x) (return x)))
+    (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
+	   (%warn '|illegal value for printer control| x))))) 
+
+(defun check-tab-index (x)
+  (prog (v)
+    (cond ((bound? x) (return x)))
+    (setq v ($litbind x))
+    (cond ((not (numberp v))
+	   (%warn '|unbound symbol occurs after ^| x))
+	  ((or (< v 1.) (> v 127.))
+	   (%warn '|index out of bounds after ^| x))))) 
+
+(defun note-variable (var)
+  (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
+
+(defun bound? (var)
+  (or (member var *rhs-bound-vars*)
+      (var-dope var)))
+
+(defun note-ce-variable (ce-var)
+  (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
+
+(defun ce-bound? (ce-var)
+  (or (member ce-var *rhs-bound-ce-vars*)
+      (ce-var-dope ce-var)))
diff --git a/contrib/ops/ops-io.lisp b/contrib/ops/ops-io.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..216c3c416a6ee22009ea3b4bf71540f4d0f19636
--- /dev/null
+++ b/contrib/ops/ops-io.lisp
@@ -0,0 +1,541 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; This file contains all the functions pertaining to I/O.
+
+(in-package "OPS")
+(shadow '(write))    ; Should get this by requiring ops-rhs
+
+
+;;; Internal global variables.
+
+(defvar *write-file*)
+(defvar *trace-file*)
+(defvar *accept-file*)
+(defvar *ppline*)
+(defvar *filters*)
+
+
+
+;;; Initialization
+
+(defun io-init ()
+  (setq *write-file* nil)
+  (setq *trace-file* nil)
+  (setq *accept-file* nil))
+
+
+
+;;; User I/O commands
+;;; Dario Giuse - rewrote the (write) function to follow OPS-5 specifications.
+;;; Michael Huhns fixed a few bugs in this rewrttien functions some years later.
+
+
+(defmacro append-string (x)
+  `(setq wrstring (concatenate 'simple-string wrstring ,x)))
+
+
+(defun ops-write (z)
+  (prog (port max k x)
+    (cond ((not *in-rhs*)
+	   (%warn '|cannot be called at top level| 'write)
+	   (return nil)))
+    ($reset)
+    (eval-args z)
+    (setq max ($parametercount))
+    (cond ((< max 1)
+	   (%warn '|write: nothing to print| z)
+	   (return nil)))
+    (setq x ($parameter 1))
+    (cond ((and (symbolp x) ($ofile x)) 
+	   (setq port ($ofile x))
+	   (setq k 2))
+	  (t
+	   (setq port (default-write-file))
+	   (setq k 1)))
+    ;; Analyze and output all the parameters (write) was passed.
+    (do* ((wrstring "")
+	  (x ($parameter k) ($parameter k))
+	  (field-width))
+	 ((> k max)
+	  (format port wrstring)
+	  (force-output))     ; Dario Giuse - added to force output
+      (incf k)
+      (case x
+	(|=== C R L F ===|
+	 (format port "~A~%" wrstring)     ; Flush the previous line
+	 (setq wrstring ""))
+	(|=== R J U S T ===|
+	 (setq field-width ($parameter k))           ; Number following (tabto)
+	 (incf k)
+	 (setq x (format nil "~A" ($parameter k)))   ; Next field to print
+	 (when (<= (length x) field-width)
+	   ;; Right-justify field
+	   (append-string (format nil "~V@A" field-width x))
+	   (incf k)))   ; Skip next field, since we printed it already
+	(|=== T A B T O ===|
+	 (setq x ($parameter k))         ; Position to tab to
+	 (incf k)
+	 (when (< x (length wrstring))
+	   ;; Flush line, start a new one
+	   (format port "~A~%" wrstring)
+	   (setq wrstring ""))
+	 (append-string (format nil "~V,1@T" (- x (length wrstring) 1))))
+	(t
+	 (append-string (format nil "~A " x)))))))
+
+
+(defun ops-openfile (z)
+  (prog (file mode id)
+    ($reset)
+    (eval-args z)
+    (cond ((not (equal ($parametercount) 3.))
+	   (%warn '|openfile: wrong number of arguments| z)
+	   (return nil)))
+    (setq id ($parameter 1))
+    (setq file ($parameter 2))
+    (setq mode ($parameter 3))
+    (cond ((not (symbolp id))
+	   (%warn '|openfile: file id must be a symbolic atom| id)
+	   (return nil))
+	  ((null id)
+	   (%warn '|openfile: 'nil' is reserved for the terminal| nil)
+	   (return nil))
+	  ((or ($ifile id)($ofile id))
+	   (%warn '|openfile: name already in use| id)
+	   (return nil)))
+;@@@	(cond ((eq mode 'in) (putprop id (infile file) 'inputfile))
+;@@@	      ((eq mode 'out) (putprop id (outfile file) 'outputfile))
+; dec 7 83 gdw added setq : is putprop needed ? )
+    (cond ((eq mode 'in) (putprop id (setq id (infile file)) 'inputfile))
+	  ((eq mode 'out) (putprop id (setq id (outfile file)) 'outputfile))
+	  (t (%warn '|openfile: illegal mode| mode)
+	     (return nil)))
+    (return nil)))
+
+
+(defun infile (f_name)
+  (open f_name :direction :input))
+
+(defun outfile (f_name)
+  (open f_name :direction :output :if-exists :new-version))
+
+(defun ops-closefile (z)
+  ($reset)
+  (eval-args z)
+  (mapc (function closefile2) (use-result-array)))
+
+(defun closefile2 (file)
+  (prog (port)
+    (cond ((not (symbolp file))
+	   (%warn '|closefile: illegal file identifier| file))
+	  ((setq port ($ifile file))
+	   (close port)
+	   (remprop file 'inputfile))
+	  ((setq port ($ofile file))
+	   (close port)
+	   (remprop file 'outputfile)))
+    (return nil)))
+
+
+(defun ops-default (z)
+  (prog (file use)
+    ($reset)
+    (eval-args z)
+    (cond ((not (equal ($parametercount) 2.))
+	   (%warn '|default: wrong number of arguments| z)
+	   (return nil)))
+    (setq file ($parameter 1))
+    (setq use ($parameter 2))
+    (cond ((not (symbolp file))
+	   (%warn '|default: illegal file identifier| file)
+	   (return nil))
+	  ((not (member use '(write accept trace) :test #'equal))
+	   (%warn '|default: illegal use for a file| use)
+	   (return nil))
+	  ((and (member use '(write trace) :test #'equal)
+		(not (null file))
+		(not ($ofile file)))
+	   (%warn '|default: file has not been opened for output| file)
+	   (return nil))
+	  ((and (equal use 'accept) 
+		(not (null file))
+		(not ($ifile file)))
+	   (%warn '|default: file has not been opened for input| file)
+	   (return nil))
+	  ((equal use 'write) (setq *write-file* file))
+	  ((equal use 'accept) (setq *accept-file* file))
+	  ((equal use 'trace) (setq *trace-file* file)))
+    (return nil)))
+
+
+(defun ops-accept (z)
+  (prog (port arg)
+    (cond ((> (length z) 1.)
+	   (%warn '|accept: wrong number of arguments| z)
+	   (return nil)))
+    (setq port *standard-input*)
+    (cond (*accept-file*
+	   (setq port ($ifile *accept-file*))
+	   (cond ((null port) 
+		  (%warn '|accept: file has been closed| *accept-file*)
+		  (return nil)))))
+    (cond ((= (length z) 1)
+	   (setq arg ($varbind (car z)))
+	   (cond ((not (symbolp arg))
+		  (%warn '|accept: illegal file name| arg)
+		  (return nil)))
+	   (setq port ($ifile arg))
+	   (cond ((null port) 
+		  (%warn '|accept: file not open for input| arg)
+		  (return nil)))))
+    (cond ((equal (peek-char t port nil "eof" ) "eof" )
+	   ($value 'end-of-file)
+	   (return nil)))
+    (flat-value (read port)))) 
+
+
+
+;;; Dario Giuse - completely changed the algorithm. It now uses one read-line
+;;; and the read-from-string.
+;;;
+(defun ops-acceptline (z)
+  (let ((port *standard-input*)
+	(def z))
+    (cond (*accept-file*
+	   (setq port ($ifile *accept-file*))
+	   (cond ((null port) 
+		  (%warn '|acceptline: file has been closed| 
+			 *accept-file*)
+		  (return-from ops-acceptline nil)))))
+    (cond ((> (length def) 0)
+	   (let ((arg ($varbind (car def))))
+	     (cond ((and (symbolp arg) ($ifile arg))
+		    (setq port ($ifile arg))
+		    (setq def (cdr def)))))))
+    (let ((line (read-line port nil 'eof)))
+      (declare (simple-string line))
+      ;; Strip meaningless characters from start and end of string.
+      (setq line (string-trim '(#\( #\) #\, #\tab #\space) line))
+      (when (equal line "")
+	(mapc (function $change) def)
+	(return-from ops-acceptline nil))
+      (setq line (concatenate 'simple-string "(" line ")"))
+      ;; Read all items from the line
+      (flat-value (read-from-string line)))))
+
+
+
+
+(defun ops-rjust (z)
+  (prog (val)
+    (cond ((not (= (length z) 1.))
+	   (%warn '|rjust: wrong number of arguments| z)
+	   (return nil)))
+    (setq val ($varbind (car z)))
+    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
+	   (%warn '|rjust: illegal value for field width| val)
+	   (return nil)))
+    ($value '|=== R J U S T ===|)
+    ($value val)))
+
+
+(defun ops-crlf (z)
+  (cond  (z (%warn '|crlf: does not take arguments| z))
+	 (t ($value '|=== C R L F ===|))))
+
+
+(defun ops-tabto (z)
+  (prog (val)
+    (cond ((not (= (length z) 1.))
+	   (%warn '|tabto: wrong number of arguments| z)
+	   (return nil)))
+    (setq val ($varbind (car z)))
+    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
+	   (%warn '|tabto: illegal column number| z)
+	   (return nil)))
+    ($value '|=== T A B T O ===|)
+    ($value val)))
+
+
+
+(defun do-rjust (width value port)
+  (prog (size)
+    (cond ((eq value '|=== T A B T O ===|)
+	   (%warn '|rjust cannot precede this function| 'tabto)
+	   (return nil))
+	  ((eq value '|=== C R L F ===|)
+	   (%warn '|rjust cannot precede this function| 'crlf)
+	   (return nil))
+	  ((eq value '|=== R J U S T ===|)
+	   (%warn '|rjust cannot precede this function| 'rjust)
+	   (return nil)))
+    ;original->        (setq size (flatc value (1+ width)))
+    (setq size (min value (1+ width)))  ;### KLUGE
+    (cond ((> size width)
+	   (princ '| | port)
+	   (princ value port)
+	   (return nil)))
+    ;###        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
+    ;^^^KLUGE @@@do
+    (princ value port)))
+
+(defun do-tabto (col port)
+  (prog (pos)
+    ;### KLUGE: FLUSHES STREAM & SETS POS TO 0
+    ;OIRGINAL->	(setq pos (1+ (nwritn port)))	;hmm-takes 1 arg @@@ port
+    (finish-output port);kluge
+    (setq pos 0);kluge
+    (cond ((> pos col)
+	   (terpri port)
+	   (setq pos 1)))
+    ;###(do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
+    ;^^^KLUGE @@@do
+    (return nil)))
+
+
+(defun flat-value (x)
+  (cond ((atom x) ($value x))
+	(t (mapc (function flat-value) x)))) 
+
+
+
+;;; Printing WM
+
+(defun ops-ppwm (avlist)
+  (prog (next a)
+    (setq *filters* nil)
+    (setq next 1.)
+    loop   (and (atom avlist) (go print))
+    (setq a (car avlist))
+    (setq avlist (cdr avlist))
+    ;this must be expecting (ppwm class ^ attr ^ attr2 ...) not ^attr
+    (cond ((eq a '^)
+	   (setq next (car avlist))
+	   (setq avlist (cdr avlist))
+	   (setq next ($litbind next))
+	   (and (floatp next) (setq next (fix next)))
+	   (cond ((or (not (numberp next))
+		      (> next *size-result-array*)
+		      (> 1. next))
+		  (%warn '|illegal index after ^| next)
+		  (return nil))))
+	  ((variablep a)
+	   (%warn '|ppwm does not take variables| a)
+	   (return nil))
+	  (t (setq *filters* (cons next (cons a *filters*)))
+	     (setq next (1+ next))))
+    (go loop)
+    print (mapwm (function ppwm2))
+    (terpri)
+    (return nil))) 
+
+
+(defun default-write-file ()
+  (prog (port)
+    (setq port *standard-output*)
+    (cond (*write-file*
+	   (setq port ($ofile *write-file*))
+	   (cond ((null port) 
+		  (%warn '|write: file has been closed| *write-file*)
+		  (setq port *standard-output*)))))
+    (return port)))
+
+
+(defun trace-file ()
+  (prog (port)
+    (setq port *standard-output*)
+    (cond (*trace-file*
+	   (setq port ($ofile *trace-file*))
+	   (cond ((null port)
+		  (%warn '|trace: file has been closed| *trace-file*)
+		  (setq port *standard-output*)))))
+    (return port)))
+
+
+(defun ppwm2 (elm-tag)
+  (cond ((filter (car elm-tag))
+	 (terpri) (ppelm (car elm-tag) (default-write-file))))) 
+
+(defun filter (elm)
+  (prog (fl indx val)
+    (setq fl *filters*)
+    top  (and (atom fl) (return t))
+    (setq indx (car fl))
+    (setq val (cadr fl))
+    (setq fl (cddr fl))
+    (and (ident (nth (1- indx) elm) val) (go top))
+    (return nil))) 
+
+(defun ident (x y)
+  (cond ((eq x y) t)
+	((not (numberp x)) nil)
+	((not (numberp y)) nil)
+	((=alg x y) t)
+	(t nil))) 
+
+; the new ppelm is designed especially to handle literalize format
+; however, it will do as well as the old ppelm on other formats
+
+(defun ppelm (elm port)
+  (prog (ppdat sep val att mode lastpos)
+    (princ (creation-time elm) port)
+    (princ '|:  | port)
+    (setq mode 'vector)
+    (setq ppdat (get (car elm) 'ppdat))
+    (and ppdat (setq mode 'a-v))
+    (setq sep "(")				; ")" 
+    (setq lastpos 0)
+    (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
+	((atom vlist) nil)					; terminate
+      (setq val (car vlist))				; tagbody begin
+      (setq att (assoc curpos ppdat))	;should ret (curpos attr-name) 
+      (cond (att (setq att (cdr att)))	; att = (attr-name) ??
+	    (t (setq att curpos)))
+      (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
+      (cond ((or (not (null val)) (eq mode 'vector))
+	     (princ sep port)
+	     (ppval val att lastpos port)
+	     (setq sep '|    |)
+	     (setq lastpos curpos))))
+    (princ '|)| port)))
+
+(defun ppval (val att lastpos port)
+  ;  (break "in ppval")		
+  (cond ((not (equal att (1+ lastpos)))		; ok, if we got an att 
+	 (princ '^ port)
+	 (princ att port)
+	 (princ '| | port)))
+  (princ val port))
+
+
+
+;;; Printing production memory
+
+(defun ops-pm (z) (mapc (function pprule) z) (terpri) nil)
+
+(defun pprule (name)
+  (prog (matrix next lab)
+    (and (not (symbolp name)) (return nil))
+    (setq matrix (get name 'production))
+    (and (null matrix) (return nil))
+    (terpri)
+    (princ '|(p |)      ;)
+    (princ name)
+    top	(and (atom matrix) (go fin))
+    (setq next (car matrix))
+    (setq matrix (cdr matrix))
+    (setq lab nil)
+    (terpri)
+    (cond ((eq next '-)
+	   (princ '|  - |)
+	   (setq next (car matrix))
+	   (setq matrix (cdr matrix)))
+	  ((eq next '-->)
+	   (princ '|  |))
+	  ((and (eq next '{) (atom (car matrix)))
+	   (princ '|   {|)
+	   (setq lab (car matrix))
+	   (setq next (cadr matrix))
+	   (setq matrix (cdddr matrix)))
+	  ((eq next '{)
+	   (princ '|   {|)
+	   (setq lab (cadr matrix))
+	   (setq next (car matrix))
+	   (setq matrix (cdddr matrix)))
+	  (t (princ '|    |)))
+    (ppline next)
+    (cond (lab (princ '| |) (princ lab) (princ '})))
+    (go top)
+    fin	(princ '|)|)))
+
+(defun ppline (line)
+  (prog ()
+    (cond ((atom line) (princ line))
+	  (t
+	   (princ '|(|)      ;)
+	   (setq *ppline* line)
+	   (ppline2)
+	   ;(
+	   (princ '|)|)))
+    (return nil)))
+
+(defun ppline2 ()
+  (prog (needspace)
+    (setq needspace nil)
+    top  (and (atom *ppline*) (return nil))
+    (and needspace (princ '| |))
+    (cond ((eq (car *ppline*) '^) (ppattval))
+	  (t (pponlyval)))
+    (setq needspace t)
+    (go top)))
+
+(defun ppattval ()
+  (prog (att val)
+    (setq att (cadr *ppline*))
+    (setq *ppline* (cddr *ppline*))
+    (setq val (getval))
+    ;###	(cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)))
+    ;@@@ nwritn no arg
+    ;						;"plus" changed to "+" by gdw
+    ;	       (terpri)
+    ;	       (princ '|        |)
+    (princ '^)
+    (princ att)
+    (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
+
+(defun pponlyval ()
+  (prog (val needspace)
+    (setq val (getval))
+    (setq needspace nil)
+    ;###	(cond ((> (+ (nwritn) (flatc val)) 76.)))
+    ;"plus" changed to "+" by gdw
+    ;	       (setq needspace nil)		;^nwritn no arg @@@
+    ;	       (terpri)
+    ;	       (princ '|        |)
+    top	(and (atom val) (return nil))
+    (and needspace (princ '| |))
+    (setq needspace t)
+    (princ (car val))
+    (setq val (cdr val))
+    (go top)))
+
+(defun getval ()
+  (prog (res v1)
+    (setq v1 (car *ppline*))
+    (setq *ppline* (cdr *ppline*))
+    (cond ((member v1 '(= <> < <= => > <=>))
+	   (setq res (cons v1 (getval))))
+	  ((eq v1 '{)
+	   (setq res (cons v1 (getupto '}))))
+	  ((eq v1 '<<)
+	   (setq res (cons v1 (getupto '>>))))
+	  ((eq v1 '//)
+	   (setq res (list v1 (car *ppline*)))
+	   (setq *ppline* (cdr *ppline*)))
+	  (t (setq res (list v1))))
+    (return res)))
+
+(defun getupto (end)
+  (prog (v)
+    (and (atom *ppline*) (return nil))
+    (setq v (car *ppline*))
+    (setq *ppline* (cdr *ppline*))
+    (cond ((eq v end) (return (list v)))
+	  (t (return (cons v (getupto end))))))) 
+
diff --git a/contrib/ops/ops-main.lisp b/contrib/ops/ops-main.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7397abff24d89aa8a0ab57c84c01316a48192cb2
--- /dev/null
+++ b/contrib/ops/ops-main.lisp
@@ -0,0 +1,726 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; This file contains the top-level functions, function to literalize
+;;;; and access attributes, and functions to manage the conflict set.
+
+
+(in-package "OPS")
+
+(export '(literalize p vector-attribute strategy watch))
+
+
+;;; Global variables also used by other modules.
+
+(defvar *halt-flag*)
+(defvar *cycle-count*)
+(defvar *p-name*)
+(defvar *ptrace*)
+(defvar *wtrace*)
+
+
+;;; Global variables used in this module only.
+
+(defvar *limit-token*)
+(defvar *total-wm*)
+(defvar *max-token*)
+(defvar *total-token*)
+(defvar *brkpts*)
+(defvar *phase*)
+(defvar *break-flag*)
+(defvar *remaining-cycles*)
+(defvar *conflict-set*)
+(defvar *max-cs*)
+(defvar *total-cs*)
+(defvar *limit-cs*)
+(defvar *strategy*)
+(defvar *class-list*)
+(defvar *buckets*)
+
+
+
+(defun main-init ()
+  (setq *cycle-count* 0.)
+  (setq *p-name* nil)
+  (setq *ptrace* t)
+  (setq *wtrace* nil)
+  (setq *limit-token* 1000000.)
+  (setq *limit-cs* 1000000.)
+  (setq *total-wm* 0.)
+  (setq *total-token* (setq *max-token* 0.))
+  (setq *max-cs* (setq *total-cs* 0.))
+  (setq *conflict-set* nil)
+  (setq *strategy* 'lex)
+  (setq *buckets* 127.)		; regular OPS5 allows 64 named slots
+  (setq *class-list* nil)
+  (setq *brkpts* nil)
+  (setq *remaining-cycles* 1000000))
+
+
+
+;;;; Top level commands.
+
+
+(defmacro run (&body z)
+  `(ops-run ',z))
+
+(defmacro ppwm (&body avlist)
+  `(ops-ppwm ',avlist))
+
+(defmacro wm (&body a) 
+  `(ops-wm ',a))
+
+(defmacro pm (&body z)
+  `(ops-pm ',z))
+
+(defmacro cs (&body z)
+  `(ops-cs ',z))
+
+(defmacro matches (&body rule-list)
+  `(ops-matches ',rule-list))
+
+(defmacro strategy (&body z)
+  `(ops-strategy ',z))
+
+(defmacro watch (&body z)
+  `(ops-watch ',z))
+
+(defmacro pbreak (&body z)
+  `(ops-pbreak ',z))
+
+(defmacro excise (&body z)
+  `(ops-excise ',z))
+
+(defmacro p (&body z) 
+  `(ops-p ',z))
+
+(defmacro external (&body z) 
+  `(ops-external ',z))
+
+(defmacro literal (&body z)
+  `(ops-literal ',z))
+
+(defmacro literalize (&body z)
+  `(ops-literalize ',z))
+
+(defmacro vector-attribute (&body l)
+  `(ops-vector-attribute ',l))
+
+(defun top-level-remove (z)
+  (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
+	(t (process-changes nil (get-wm z))))) 
+
+
+
+;;; Functions for run command
+
+(defun ops-run (z)
+  (cond ((atom z) (setq *remaining-cycles* 1000000.) (do-continue nil))
+	((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.))
+	 (setq *remaining-cycles* (car z))
+	 (do-continue nil))
+	(t 'what?))) 
+
+
+(defun do-continue (wmi)
+  (cond (*critical*
+	 (terpri)
+	 (princ '|warning: network may be inconsistent|)))
+  (process-changes wmi nil)
+  (print-times (main))) 
+
+
+(defun process-changes (adds dels)
+  (prog (x)
+    process-deletes (and (atom dels) (go process-adds))
+    (setq x (car dels))
+    (setq dels (cdr dels))
+    (remove-from-wm x)
+    (go process-deletes)
+    process-adds (and (atom adds) (return nil))
+    (setq x (car adds))
+    (setq adds (cdr adds))
+    (add-to-wm x nil)
+    (go process-adds))) 
+
+
+(defun main nil
+  (prog (instance r)
+    (setq *halt-flag* nil)
+    (setq *break-flag* nil)
+    (setq instance nil)
+    dil  (setq *phase* 'conflict-resolution)
+    (cond (*halt-flag*
+	   (setq r '|end -- explicit halt|)
+	   (go finis))
+	  ((zerop *remaining-cycles*)
+	   (setq r '***break***)
+	   (setq *break-flag* t)
+	   (go finis))
+	  (*break-flag* (setq r '***break***) (go finis)))
+    (setq *remaining-cycles* (1- *remaining-cycles*))
+    (setq instance (conflict-resolution))
+    (cond ((not instance)
+	   (setq r '|end -- no production true|)
+	   (go finis)))
+    (setq *phase* (car instance))
+    (accum-stats)
+    (eval-rhs (car instance) (cdr instance))
+    (check-limits)
+    (and (broken (car instance)) (setq *break-flag* t))
+    (go dil)
+    finis (setq *p-name* nil)
+    (return r))) 
+
+
+(defun broken (rule) (member rule *brkpts*))
+
+
+(defun accum-stats nil
+  (setq *cycle-count* (1+ *cycle-count*))
+  (setq *total-token* (+ *total-token* *current-token*))
+  ;"plus" changed to "+" by gdw
+  (cond ((> *current-token* *max-token*)
+	 (setq *max-token* *current-token*)))
+  (setq *total-wm* (+ *total-wm* *current-wm*))	;"plus" changed to "+" by gdw
+  (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) 
+
+
+(defun check-limits nil
+  (cond ((> (length *conflict-set*) *limit-cs*)
+	 (format t "~%~%conflict set size exceeded the limit of ~D after ~D~%"
+		 *limit-cs* *p-name*)
+	 (setq *halt-flag* t)))
+  (cond ((> *current-token* *limit-token*)
+	 (format t "~%~%token memory size exceeded the limit of ~D after ~D~%"
+		 *limit-token* *p-name*)
+	 (setq *halt-flag* t))))
+
+
+(defun print-times (mess)
+  (prog (cc)
+    (cond (*break-flag* (terpri) (return mess)))
+    (setq cc (+ (float *cycle-count*) 1.0e-20))
+    (terpri)
+    (princ mess)
+    (terpri)
+    (format t "~3D productions (~D // ~D nodes)~%"
+	    *pcount* *real-cnt* *virtual-cnt*)
+    (format t "~3D firings (~D rhs actions)~%"
+	    *cycle-count* *action-count*)
+    (format t "~3D mean working memory size (~D maximum)~%"
+	    (round (float *total-wm*) cc) *max-wm*)
+    (format t "~3D mean conflict set size (~D maximum)~%"
+	    (round (float *total-cs*) cc) *max-cs*)
+    (format t "~3D mean token memory size (~D maximum)~%"
+	    (round (float *total-token*) cc)
+	    *max-token*)))
+
+
+;;; Functions for strategy command
+
+(defun ops-strategy (z)
+  (cond ((atom z) *strategy*)
+	((equal z '(lex)) (setq *strategy* 'lex))
+	((equal z '(mea)) (setq *strategy* 'mea))
+	(t 'what?))) 
+
+
+;;; Functions for watch command
+
+(defun ops-watch (z)
+  (cond ((equal z '(0.))
+	 (setq *wtrace* nil)
+	 (setq *ptrace* nil)
+	 0.)
+	((equal z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
+	((equal z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
+	((equal z '(3.))
+	 (setq *wtrace* t)
+	 (setq *ptrace* t)
+	 '(2. -- conflict set trace not supported))
+	((and (atom z) (null *ptrace*)) 0.)
+	((and (atom z) (null *wtrace*)) 1.)
+	((atom z) 2.)
+	(t 'what?))) 
+
+
+;;; Functions for excise command
+
+(defun ops-excise (z) (mapc (function excise-p) z))
+
+(defun excise-p (name)
+  (cond ((and (symbolp name) (get name 'topnode))
+	 (format t "~S is excised~%" name)
+	 (setq *pcount* (1- *pcount*))
+	 (remove-from-conflict-set name)
+	 (kill-node (get name 'topnode))
+	 (remprop name 'production)
+	 (remprop name 'backpointers)
+	 (remprop name 'topnode)))) 
+
+(defun kill-node (node)
+  (prog nil
+    top  (and (atom node) (return nil))
+    (rplaca node '&old)
+    (setq node (cdr node))
+    (go top))) 
+
+
+;;; Functions for external command
+
+(defun ops-external (z) (catch '!error! (external2 z))) ;jgk inverted args
+;& quoted tag
+(defun external2 (z) (mapc (function external3) z))
+
+(defun external3 (x) 
+  (cond ((symbolp x) (putprop x t 'external-routine))
+	(t (%error '|not a legal function name| x))))
+
+;;; Functions for pbreak command
+
+(defun ops-pbreak (z)
+  (cond ((atom z) (terpri) *brkpts*)
+	(t (mapc (function pbreak2) z) nil)))
+
+(defun pbreak2 (rule)
+  (cond ((not (symbolp rule)) (%warn '|illegal name| rule))
+	((not (get rule 'topnode)) (%warn '|not a production| rule))
+	((member rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
+	(t (setq *brkpts* (cons rule *brkpts*)))))
+
+(defun rematm (atm list)
+  (cond ((atom list) list)
+	((eq atm (car list)) (rematm atm (cdr list)))
+	(t (cons (car list) (rematm atm (cdr list))))))
+
+
+;;; Functions for matches command
+
+(defun ops-matches (rule-list)
+  (mapc (function matches2) rule-list)
+  (terpri)) 
+
+
+(defun matches2 (p)
+  (cond ((atom p)
+	 (terpri)
+	 (terpri)
+	 (princ p)
+	 (matches3 (get p 'backpointers) 2. (ncons 1.))))) 
+
+
+(defun matches3 (nodes ce part)
+  (cond ((not (null nodes))
+	 (terpri)
+	 (princ '| ** matches for |)
+	 (princ part)
+	 (princ '| ** |)
+	 (mapc (function write-elms) (find-left-mem (car nodes)))
+	 (terpri)
+	 (princ '| ** matches for |)
+	 (princ (ncons ce))
+	 (princ '| ** |)
+	 (mapc (function write-elms) (find-right-mem (car nodes)))
+	 (matches3 (cdr nodes) (1+ ce) (cons ce part))))) 
+
+
+(defun write-elms (wme-or-count)
+  (cond ((consp  wme-or-count)	;dtpr\consp gdw
+	 (terpri)
+	 (mapc (function write-elms2) wme-or-count)))) 
+
+
+(defun write-elms2 (x)
+  (princ '|  |)
+  (princ (creation-time x)))
+
+
+(defun find-left-mem (node)
+  (cond ((eq (car node) '&and) (memory-part (caddr node)))
+	(t (car (caddr node))))) 
+
+
+(defun find-right-mem (node) (memory-part (cadddr node))) 
+
+
+;;; Function for cs command.
+
+(defun ops-cs (z)
+  (cond ((atom z) (conflict-set))
+	(t 'what?))) 
+
+
+
+;;;; Functions for literalize and related operations.
+
+(defun ops-literal (z)
+  (prog (atm val old)
+    top  (and (atom z) (return 'bound))
+    (or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
+    (setq atm (car z))
+    (setq val (caddr z))
+    (setq z (cdddr z))
+    (cond ((not (numberp val))
+	   (%warn '|can bind only to numbers| val))
+	  ((or (not (symbolp atm)) (variablep atm))
+	   (%warn '|can bind only constant atoms| atm))
+	  ((and (setq old (literal-binding-of atm)) (not (equal old val)))
+	   (%warn '|attempt to rebind attribute| atm))
+	  (t (putprop atm val 'ops-bind)))
+    (go top))) 
+
+
+(defun ops-literalize (l)
+  (prog (class-name atts)
+    (setq class-name (car l))
+    (cond ((have-compiled-production)
+	   (%warn '|literalize called after p| class-name)
+	   (return nil))
+	  ((get class-name 'att-list)
+	   (%warn '|attempt to redefine class| class-name)
+	   (return nil)))
+    (setq *class-list* (cons class-name *class-list*))
+    (setq atts (remove-duplicates (cdr l)))		; ??? should this
+    ; warn of dup atts?
+    (test-attribute-names atts)
+    (mark-conflicts atts atts)
+    (putprop class-name atts 'att-list))) 
+
+(defun ops-vector-attribute (l)
+  (cond ((have-compiled-production)
+	 (%warn '|vector-attribute called after p| l))
+	(t 
+	 (test-attribute-names l)
+	 (mapc (function vector-attribute2) l)))) 
+
+(defun vector-attribute2 (att) (putprop att t 'vector-attribute))
+
+(defun is-vector-attribute (att) (get att 'vector-attribute))
+
+(defun test-attribute-names (l)
+  (mapc (function test-attribute-names2) l)) 
+
+(defun test-attribute-names2 (atm)
+  (cond ((or (not (symbolp atm)) (variablep atm))
+	 (%warn '|can bind only constant atoms| atm)))) 
+
+(defun finish-literalize nil
+  (cond ((not (null *class-list*))
+	 (mapc (function note-user-assigns) *class-list*)
+	 (mapc (function assign-scalars) *class-list*)
+	 (mapc (function assign-vectors) *class-list*)
+	 (mapc (function put-ppdat) *class-list*)
+	 (mapc (function erase-literal-info) *class-list*)
+	 (setq *class-list* nil)
+	 (setq *buckets* nil)))) 
+
+(defun have-compiled-production nil (not (zerop *pcount*))) 
+	   
+(defun put-ppdat (class)
+  (prog (al att ppdat)
+    (setq ppdat nil)
+    (setq al (get class 'att-list))
+    top  (cond ((not (atom al))
+		(setq att (car al))
+		(setq al (cdr al))
+		(setq ppdat
+		      (cons (cons (literal-binding-of att) att)
+			    ppdat))
+		(go top)))
+    (putprop class ppdat 'ppdat))) 
+
+; note-user-assigns and note-user-vector-assigns are needed only when
+; literal and literalize are both used in a program.  They make sure that
+; the assignments that are made explicitly with literal do not cause problems
+; for the literalized classes.
+
+(defun note-user-assigns (class)
+  (mapc (function note-user-assigns2) (get class 'att-list)))
+
+(defun note-user-assigns2 (att)
+  (prog (num conf buck clash)
+    (setq num (literal-binding-of att))
+    (and (null num) (return nil))
+    (setq conf (get att 'conflicts))
+    (setq buck (store-binding att num))
+    (setq clash (find-common-atom buck conf))
+    (and clash
+	 (%warn '|attributes in a class assigned the same number|
+		(cons att clash)))
+    (return nil)))
+
+(defun note-user-vector-assigns (att given needed)
+  (and (> needed given)
+       (%warn '|vector attribute assigned too small a value in literal| att)))
+
+(defun assign-scalars (class)
+  (mapc (function assign-scalars2) (get class 'att-list))) 
+
+(defun assign-scalars2 (att)
+  (prog (tlist num bucket conf)
+    (and (literal-binding-of att) (return nil))
+    (and (is-vector-attribute att) (return nil))
+    (setq tlist (buckets))
+    (setq conf (get att 'conflicts))
+    top  (cond ((atom tlist)
+		(%warn '|could not generate a binding| att)
+		(store-binding att -1.)
+		(return nil)))
+    (setq num (caar tlist))
+    (setq bucket (cdar tlist))
+    (setq tlist (cdr tlist))
+    (cond ((disjoint bucket conf) (store-binding att num))
+	  (t (go top))))) 
+
+(defun assign-vectors (class)
+  (mapc (function assign-vectors2) (get class 'att-list))) 
+
+(defun assign-vectors2 (att)
+  (prog (big conf new old need)
+    (and (not (is-vector-attribute att)) (return nil))
+    (setq big 1.)
+    (setq conf (get att 'conflicts))
+    top  (cond ((not (atom conf))
+		(setq new (car conf))
+		(setq conf (cdr conf))
+		(cond ((is-vector-attribute new)
+		       (%warn '|class has two vector attributes|
+			      (list att new)))
+		      (t (setq big (max (literal-binding-of new) big))))
+		(go top)))
+    (setq need (1+ big))			;"plus" changed to "+" by gdw
+    (setq old (literal-binding-of att))
+    (cond (old (note-user-vector-assigns att old need))
+	  (t (store-binding att need)))
+    (return nil)))
+
+(defun disjoint (la lb) (not (find-common-atom la lb))) 
+
+(defun find-common-atom (la lb)
+  (prog nil
+    top  (cond ((null la) (return nil))
+	       ((member (car la) lb) (return (car la)))
+	       (t (setq la (cdr la)) (go top))))) 
+
+(defun mark-conflicts (rem all)
+  (cond ((not (null rem))
+	 (mark-conflicts2 (car rem) all)
+	 (mark-conflicts (cdr rem) all)))) 
+
+(defun mark-conflicts2 (atm lst)
+  (prog (l)
+    (setq l lst)
+    top  (and (atom l) (return nil))
+    (conflict atm (car l))
+    (setq l (cdr l))
+    (go top))) 
+
+(defun conflict (a b)
+  (prog (old)
+    (setq old (get a 'conflicts))
+    (and (not (eq a b))
+	 (not (member b old))
+	 (putprop a (cons b old) 'conflicts)))) 
+
+;@@@ use intrinsic 
+;(defun remove-duplicates  (lst)
+   ;  (cond ((atom lst) nil)
+	    ;        ((member (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
+	    ;        (t (cons (car lst) (remove-duplicates (cdr lst)))))) 
+
+(defun literal-binding-of (name) (get name 'ops-bind)) 
+
+(defun store-binding (name lit)
+  (putprop name lit 'ops-bind)
+  (add-bucket name lit)) 
+
+(defun add-bucket (name num)
+  (prog (buc)
+    (setq buc (assoc num (buckets)))
+    (and (not (member name buc))
+	 (rplacd buc (cons name (cdr buc))))
+    (return buc))) 
+
+(defun buckets nil
+  (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
+  *buckets*) 
+
+(defun make-nums (k)
+  (prog (nums)
+    (setq nums nil)
+    l    (and (< k 2.) (return nums))
+    (setq nums (cons (ncons k) nums))
+    (setq k (1- k))
+    (go l))) 
+
+(defun erase-literal-info (class)
+  (mapc (function erase-literal-info2) (get class 'att-list))
+  (remprop class 'att-list)) 
+
+(defun erase-literal-info2 (att) (remprop att 'conflicts)) 
+
+
+
+
+;;;; Functions for conflict set management and resolution.
+
+
+;;; Each conflict set element is a list of the following form:
+;;; ((p-name . data-part) (sorted wm-recency) special-case-number)
+
+(defun conflict-resolution nil
+  (prog (best len)
+    (setq len (length *conflict-set*))
+    (cond ((> len *max-cs*) (setq *max-cs* len)))
+    (setq *total-cs* (+ *total-cs* len))	;"plus" changed to "+" by gdw
+    (cond (*conflict-set*
+	   (setq best (best-of *conflict-set*))
+	   (setq *conflict-set* (delq best *conflict-set*))
+	   (return (pname-instantiation best)))
+	  (t (return nil))))) 
+
+(defun removecs (name data)
+  (prog (cr-data inst cs)
+    (setq cr-data (cons name data))
+    (setq cs *conflict-set*)
+    loop	(cond ((null cs) 
+		       (record-refract name data)
+		       (return nil)))
+    (setq inst (car cs))
+    (setq cs (cdr cs))
+    (and (not (top-levels-eq (car inst) cr-data)) (go loop))
+    (setq *conflict-set* (delq inst *conflict-set*))))
+
+(defun insertcs (name data rating)
+  (prog (instan)
+    (and (refracted name data) (return nil))
+    (setq instan (list (cons name data) (order-tags data) rating))
+    (and (atom *conflict-set*) (setq *conflict-set* nil))
+    (return (setq *conflict-set* (cons instan *conflict-set*))))) 
+
+
+(defun remove-from-conflict-set (name)
+  (prog (cs entry)
+    l1   (setq cs *conflict-set*)
+    l2   (cond ((atom cs) (return nil)))
+    (setq entry (car cs))
+    (setq cs (cdr cs))
+    (cond ((eq name (caar entry))
+	   (setq *conflict-set* (delq entry *conflict-set*))
+	   (go l1))
+	  (t (go l2))))) 
+
+(defun order-tags (dat)
+  (prog (tags)
+    (setq tags nil)
+    l1p  (and (atom dat) (go l2p))
+    (setq tags (cons (creation-time (car dat)) tags))
+    (setq dat (cdr dat))
+    (go l1p)
+    l2p  (cond ((eq *strategy* 'mea)
+		(return (cons (car tags) (dsort (cdr tags)))))
+	       (t (return (dsort tags)))))) 
+
+; destructively sort x into descending order
+
+(defun dsort (x)
+  (prog (sorted cur next cval nval)
+    (and (atom (cdr x)) (return x))
+    loop (setq sorted t)
+    (setq cur x)
+    (setq next (cdr x))
+    chek (setq cval (car cur))
+    (setq nval (car next))
+    (cond ((> nval cval)
+	   (setq sorted nil)
+	   (rplaca cur nval)
+	   (rplaca next cval)))
+    (setq cur next)
+    (setq next (cdr cur))
+    (cond ((not (null next)) (go chek))
+	  (sorted (return x))
+	  (t (go loop))))) 
+
+(defun best-of (set) (best-of* (car set) (cdr set))) 
+
+(defun best-of* (best rem)
+  (cond ((not rem) best)
+	((conflict-set-compare best (car rem))
+	 (best-of* best (cdr rem)))
+	(t (best-of* (car rem) (cdr rem))))) 
+
+(defun pname-instantiation (conflict-elem) (car conflict-elem)) 
+
+(defun order-part (conflict-elem) (cdr conflict-elem)) 
+
+(defun instantiation (conflict-elem)
+  (cdr (pname-instantiation conflict-elem))) 
+
+
+(defun conflict-set-compare (x y)
+  (prog (x-order y-order xl yl xv yv)
+    (setq x-order (order-part x))
+    (setq y-order (order-part y))
+    (setq xl (car x-order))
+    (setq yl (car y-order))
+    data (cond ((and (null xl) (null yl)) (go ps))
+	       ((null yl) (return t))
+	       ((null xl) (return nil)))
+    (setq xv (car xl))
+    (setq yv (car yl))
+    (cond ((> xv yv) (return t))
+	  ((> yv xv) (return nil)))
+    (setq xl (cdr xl))
+    (setq yl (cdr yl))
+    (go data)
+    ps   (setq xl (cdr x-order))
+    (setq yl (cdr y-order))
+    psl  (cond ((null xl) (return t)))
+    (setq xv (car xl))
+    (setq yv (car yl))
+    (cond ((> xv yv) (return t))
+	  ((> yv xv) (return nil)))
+    (setq xl (cdr xl))
+    (setq yl (cdr yl))
+    (go psl))) 
+
+
+(defun conflict-set nil
+  (prog (cnts cs p z best)
+    (setq cnts nil)
+    (setq cs *conflict-set*)
+    l1p  (and (atom cs) (go l2p))
+    (setq p (caaar cs))
+    (setq cs (cdr cs))
+    (setq z (assq p cnts))
+    (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
+	  (t (rplacd z (1+ (cdr z)))))
+    (go l1p)
+    l2p  (cond ((atom cnts)
+		(setq best (best-of *conflict-set*))
+		(terpri)
+		(return (list (caar best) 'dominates))))
+    (terpri)
+    (princ (caar cnts))
+    (cond ((> (cdar cnts) 1.)
+	   (princ '|	(|)
+		  (princ (cdar cnts))
+		  (princ '| occurrences)|)))
+    (setq cnts (cdr cnts))
+    (go l2p))) 
diff --git a/contrib/ops/ops-match.lisp b/contrib/ops/ops-match.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1ae230697a2429d5de22f4b3d88c5d54d7e99ba6
--- /dev/null
+++ b/contrib/ops/ops-match.lisp
@@ -0,0 +1,749 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; This file contains the functions that match working memory
+;;;; elements against productions LHS.
+
+(in-package "OPS")
+
+
+
+;;; External global variables
+
+(defvar *current-token*)
+
+
+;;; Internal global variables
+
+(defvar *alpha-data-part*)
+(defvar *alpha-flag-part*)
+(defvar *flag-part*)
+(defvar *data-part*)
+(defvar *sendtocall*)
+(defvar *side*)
+(proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
+	   *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
+	   *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
+	   *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
+	   *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
+	   *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
+	   *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69*
+	   *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79*
+	   *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89*
+	   *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99*
+	   *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* *c109*
+	   *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* *c118* *c119*
+	   *c120* *c121* *c122* *c123* *c124* *c125* *c126* *c127*))
+
+
+
+;;; Network interpreter
+
+
+(defun match-init ()
+  (setq *current-token* 0.))
+
+
+(defun match (flag wme)
+  (sendto flag (list wme) 'left (list *first-node*)))
+
+; note that eval-nodelist is not set up to handle building
+; productions.  would have to add something like ops4's build-flag
+
+(defun eval-nodelist (nl)
+  (prog nil
+    top  (and (not nl) (return nil))
+    (setq *sendtocall* nil)
+    (setq *last-node* (car nl))
+    (apply (caar nl) (cdar nl))
+    (setq nl (cdr nl))
+    (go top))) 
+
+(defun sendto (flag data side nl)
+  (prog nil
+    top  (and (not nl) (return nil))
+    (setq *side* side)
+    (setq *flag-part* flag)
+    (setq *data-part* data)
+    (setq *sendtocall* t)
+    (setq *last-node* (car nl))
+    (apply (caar nl) (cdar nl))
+    (setq nl (cdr nl))
+    (go top))) 
+
+; &bus sets up the registers for the one-input nodes.  note that this
+(defun &bus (outs)
+  (prog (dp)
+    (setq *alpha-flag-part* *flag-part*)
+    (setq *alpha-data-part* *data-part*)
+    (setq dp (car *data-part*))
+    (setq *c1* (car dp))
+    (setq dp (cdr dp))
+    (setq *c2* (car dp))
+    (setq dp (cdr dp))
+    (setq *c3* (car dp))
+    (setq dp (cdr dp))
+    (setq *c4* (car dp))
+    (setq dp (cdr dp))
+    (setq *c5* (car dp))
+    (setq dp (cdr dp))
+    (setq *c6* (car dp))
+    (setq dp (cdr dp))
+    (setq *c7* (car dp))
+    (setq dp (cdr dp))
+    (setq *c8* (car dp))
+    (setq dp (cdr dp))
+    (setq *c9* (car dp))
+    (setq dp (cdr dp))
+    (setq *c10* (car dp))
+    (setq dp (cdr dp))
+    (setq *c11* (car dp))
+    (setq dp (cdr dp))
+    (setq *c12* (car dp))
+    (setq dp (cdr dp))
+    (setq *c13* (car dp))
+    (setq dp (cdr dp))
+    (setq *c14* (car dp))
+    (setq dp (cdr dp))
+    (setq *c15* (car dp))
+    (setq dp (cdr dp))
+    (setq *c16* (car dp))
+    (setq dp (cdr dp))
+    (setq *c17* (car dp))
+    (setq dp (cdr dp))
+    (setq *c18* (car dp))
+    (setq dp (cdr dp))
+    (setq *c19* (car dp))
+    (setq dp (cdr dp))
+    (setq *c20* (car dp))
+    (setq dp (cdr dp))
+    (setq *c21* (car dp))
+    (setq dp (cdr dp))
+    (setq *c22* (car dp))
+    (setq dp (cdr dp))
+    (setq *c23* (car dp))
+    (setq dp (cdr dp))
+    (setq *c24* (car dp))
+    (setq dp (cdr dp))
+    (setq *c25* (car dp))
+    (setq dp (cdr dp))
+    (setq *c26* (car dp))
+    (setq dp (cdr dp))
+    (setq *c27* (car dp))
+    (setq dp (cdr dp))
+    (setq *c28* (car dp))
+    (setq dp (cdr dp))
+    (setq *c29* (car dp))
+    (setq dp (cdr dp))
+    (setq *c30* (car dp))
+    (setq dp (cdr dp))
+    (setq *c31* (car dp))
+    (setq dp (cdr dp))
+    (setq *c32* (car dp))
+    (setq dp (cdr dp))
+    (setq *c33* (car dp))
+    (setq dp (cdr dp))
+    (setq *c34* (car dp))
+    (setq dp (cdr dp))
+    (setq *c35* (car dp))
+    (setq dp (cdr dp))
+    (setq *c36* (car dp))
+    (setq dp (cdr dp))
+    (setq *c37* (car dp))
+    (setq dp (cdr dp))
+    (setq *c38* (car dp))
+    (setq dp (cdr dp))
+    (setq *c39* (car dp))
+    (setq dp (cdr dp))
+    (setq *c40* (car dp))
+    (setq dp (cdr dp))
+    (setq *c41* (car dp))
+    (setq dp (cdr dp))
+    (setq *c42* (car dp))
+    (setq dp (cdr dp))
+    (setq *c43* (car dp))
+    (setq dp (cdr dp))
+    (setq *c44* (car dp))
+    (setq dp (cdr dp))
+    (setq *c45* (car dp))
+    (setq dp (cdr dp))
+    (setq *c46* (car dp))
+    (setq dp (cdr dp))
+    (setq *c47* (car dp))
+    (setq dp (cdr dp))
+    (setq *c48* (car dp))
+    (setq dp (cdr dp))
+    (setq *c49* (car dp))
+    (setq dp (cdr dp))
+    (setq *c50* (car dp))
+    (setq dp (cdr dp))
+    (setq *c51* (car dp))
+    (setq dp (cdr dp))
+    (setq *c52* (car dp))
+    (setq dp (cdr dp))
+    (setq *c53* (car dp))
+    (setq dp (cdr dp))
+    (setq *c54* (car dp))
+    (setq dp (cdr dp))
+    (setq *c55* (car dp))
+    (setq dp (cdr dp))
+    (setq *c56* (car dp))
+    (setq dp (cdr dp))
+    (setq *c57* (car dp))
+    (setq dp (cdr dp))
+    (setq *c58* (car dp))
+    (setq dp (cdr dp))
+    (setq *c59* (car dp))
+    (setq dp (cdr dp))
+    (setq *c60* (car dp))
+    (setq dp (cdr dp))
+    (setq *c61* (car dp))
+    (setq dp (cdr dp))
+    (setq *c62* (car dp))
+    (setq dp (cdr dp))
+    (setq *c63* (car dp))
+    (setq dp (cdr dp))
+    (setq *c64* (car dp))
+    ;-------- added for 127 atr
+    (setq dp (cdr dp))
+    (setq *c65* (car dp))
+    (setq dp (cdr dp))
+    (setq *c66* (car dp))
+    (setq dp (cdr dp))
+    (setq *c67* (car dp))
+    (setq dp (cdr dp))
+    (setq *c68* (car dp))
+    (setq dp (cdr dp))
+    (setq *c69*(car dp))
+    (setq dp (cdr dp))
+    (setq *c70* (car dp))
+    (setq dp (cdr dp))
+    (setq *c71* (car dp))
+    (setq dp (cdr dp))
+    (setq *c72* (car dp))
+    (setq dp (cdr dp))
+    (setq *c73* (car dp))
+    (setq dp (cdr dp))
+    (setq *c74* (car dp))
+    (setq dp (cdr dp))
+    (setq *c75* (car dp))
+    (setq dp (cdr dp))
+    (setq *c76* (car dp))
+    (setq dp (cdr dp))
+    (setq *c77* (car dp))
+    (setq dp (cdr dp))
+    (setq *c78* (car dp))
+    (setq dp (cdr dp))
+    (setq *c79*(car dp))
+    (setq dp (cdr dp))
+    (setq *c80* (car dp))
+    (setq dp (cdr dp))
+    (setq *c81* (car dp))
+    (setq dp (cdr dp))
+    (setq *c82* (car dp))
+    (setq dp (cdr dp))
+    (setq *c83* (car dp))
+    (setq dp (cdr dp))
+    (setq *c84* (car dp))
+    (setq dp (cdr dp))
+    (setq *c85* (car dp))
+    (setq dp (cdr dp))
+    (setq *c86* (car dp))
+    (setq dp (cdr dp))
+    (setq *c87* (car dp))
+    (setq dp (cdr dp))
+    (setq *c88* (car dp))
+    (setq dp (cdr dp))
+    (setq *c89*(car dp))
+    (setq dp (cdr dp))
+    (setq *c90* (car dp))
+    (setq dp (cdr dp))
+    (setq *c91* (car dp))
+    (setq dp (cdr dp))
+    (setq *c92* (car dp))
+    (setq dp (cdr dp))
+    (setq *c93* (car dp))
+    (setq dp (cdr dp))
+    (setq *c94* (car dp))
+    (setq dp (cdr dp))
+    (setq *c95* (car dp))
+    (setq dp (cdr dp))
+    (setq *c96* (car dp))
+    (setq dp (cdr dp))
+    (setq *c97* (car dp))
+    (setq dp (cdr dp))
+    (setq *c98* (car dp))
+    (setq dp (cdr dp))
+    (setq *c99*(car dp))
+    (setq dp (cdr dp))
+    (setq *c100* (car dp))
+    (setq dp (cdr dp))
+    (setq *c101* (car dp))
+    (setq dp (cdr dp))
+    (setq *c102* (car dp))
+    (setq dp (cdr dp))
+    (setq *c103* (car dp))
+    (setq dp (cdr dp))
+    (setq *c104* (car dp))
+    (setq dp (cdr dp))
+    (setq *c105* (car dp))
+    (setq dp (cdr dp))
+    (setq *c106* (car dp))
+    (setq dp (cdr dp))
+    (setq *c107* (car dp))
+    (setq dp (cdr dp))
+    (setq *c108* (car dp))
+    (setq dp (cdr dp))
+    (setq *c109*(car dp))
+    (setq dp (cdr dp))
+    (setq *c110* (car dp))
+    (setq dp (cdr dp))
+    (setq *c111* (car dp))
+    (setq dp (cdr dp))
+    (setq *c112* (car dp))
+    (setq dp (cdr dp))
+    (setq *c113* (car dp))
+    (setq dp (cdr dp))
+    (setq *c114* (car dp))
+    (setq dp (cdr dp))
+    (setq *c115* (car dp))
+    (setq dp (cdr dp))
+    (setq *c116* (car dp))
+    (setq dp (cdr dp))
+    (setq *c117* (car dp))
+    (setq dp (cdr dp))
+    (setq *c118* (car dp))
+    (setq dp (cdr dp))
+    (setq *c119*(car dp))
+    (setq dp (cdr dp))
+    (setq *c120* (car dp))
+    (setq dp (cdr dp))
+    (setq *c121* (car dp))
+    (setq dp (cdr dp))
+    (setq *c122* (car dp))
+    (setq dp (cdr dp))
+    (setq *c123* (car dp))
+    (setq dp (cdr dp))
+    (setq *c124* (car dp))
+    (setq dp (cdr dp))
+    (setq *c125* (car dp))
+    (setq dp (cdr dp))
+    (setq *c126* (car dp))
+    (setq dp (cdr dp))
+    (setq *c127* (car dp))
+    ;(setq dp (cdr dp))
+    ;(setq *c128* (car dp))
+    ;--------
+    (eval-nodelist outs))) 
+
+(defun &any (outs register const-list)
+  (prog (z c)
+    (setq z (fast-symeval register))
+    (cond ((numberp z) (go number)))
+    symbol (cond ((null const-list) (return nil))
+		 ((eq (car const-list) z) (go ok))
+		 (t (setq const-list (cdr const-list)) (go symbol)))
+    number (cond ((null const-list) (return nil))
+		 ((and (numberp (setq c (car const-list)))
+		       (=alg c z))
+		  (go ok))
+		 (t (setq const-list (cdr const-list)) (go number)))
+    ok   (eval-nodelist outs))) 
+
+(defun teqa (outs register constant)
+  (and (eq (fast-symeval register) constant) (eval-nodelist outs))) 
+
+(defun tnea (outs register constant)
+  (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs))) 
+
+(defun txxa (outs register constant)
+  (declare (ignore constant))
+  (and (symbolp (fast-symeval register)) (eval-nodelist outs))) 
+
+(defun teqn (outs register constant)
+  (prog (z)
+    (setq z (fast-symeval register))
+    (and (numberp z)
+	 (=alg z constant)
+	 (eval-nodelist outs)))) 
+
+(defun tnen (outs register constant)
+  (prog (z)
+    (setq z (fast-symeval register))
+    (and (or (not (numberp z))
+	     (not (=alg z constant)))
+	 (eval-nodelist outs)))) 
+
+(defun txxn (outs register constant)
+  (declare (ignore constant))
+  (prog (z)
+    (setq z (fast-symeval register))
+    (and (numberp z) (eval-nodelist outs)))) 
+
+(defun tltn (outs register constant)
+  (prog (z)
+    (setq z (fast-symeval register))
+    (and (numberp z)
+	 (> constant z)
+	 (eval-nodelist outs)))) 
+
+(defun tgtn (outs register constant)
+  (prog (z)
+    (setq z (fast-symeval register))
+    (and (numberp z)
+	 (> z constant)
+	 (eval-nodelist outs)))) 
+
+(defun tgen (outs register constant)
+  (prog (z)
+    (setq z (fast-symeval register))
+    (and (numberp z)
+	 (not (> constant z))
+	 (eval-nodelist outs)))) 
+
+(defun tlen (outs register constant)
+  (prog (z)
+    (setq z (fast-symeval register))
+    (and (numberp z)
+	 (not (> z constant))
+	 (eval-nodelist outs)))) 
+
+(defun teqs (outs vara varb)
+  (prog (a b)
+    (setq a (fast-symeval vara))
+    (setq b (fast-symeval varb))
+    (cond ((eq a b) (eval-nodelist outs))
+	  ((and (numberp a)
+		(numberp b)
+		(=alg a b))
+	   (eval-nodelist outs))))) 
+
+(defun tnes (outs vara varb)
+  (prog (a b)
+    (setq a (fast-symeval vara))
+    (setq b (fast-symeval varb))
+    (cond ((eq a b) (return nil))
+	  ((and (numberp a)
+		(numberp b)
+		(=alg a b))
+	   (return nil))
+	  (t (eval-nodelist outs))))) 
+
+(defun txxs (outs vara varb)
+  (prog (a b)
+    (setq a (fast-symeval vara))
+    (setq b (fast-symeval varb))
+    (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
+	  ((and (not (numberp a)) (not (numberp b)))
+	   (eval-nodelist outs))))) 
+
+(defun tlts (outs vara varb)
+  (prog (a b)
+    (setq a (fast-symeval vara))
+    (setq b (fast-symeval varb))
+    (and (numberp a)
+	 (numberp b)
+	 (> b a)
+	 (eval-nodelist outs)))) 
+
+(defun tgts (outs vara varb)
+  (prog (a b)
+    (setq a (fast-symeval vara))
+    (setq b (fast-symeval varb))
+    (and (numberp a)
+	 (numberp b)
+	 (> a b)
+	 (eval-nodelist outs)))) 
+
+(defun tges (outs vara varb)
+  (prog (a b)
+    (setq a (fast-symeval vara))
+    (setq b (fast-symeval varb))
+    (and (numberp a)
+	 (numberp b)
+	 (not (> b a))
+	 (eval-nodelist outs)))) 
+
+(defun tles (outs vara varb)
+  (prog (a b)
+    (setq a (fast-symeval vara))
+    (setq b (fast-symeval varb))
+    (and (numberp a)
+	 (numberp b)
+	 (not (> a b))
+	 (eval-nodelist outs)))) 
+
+(defun &two (left-outs right-outs)
+  (prog (fp dp)
+    (cond (*sendtocall*
+	   (setq fp *flag-part*)
+	   (setq dp *data-part*))
+	  (t
+	   (setq fp *alpha-flag-part*)
+	   (setq dp *alpha-data-part*)))
+    (sendto fp dp 'left left-outs)
+    (sendto fp dp 'right right-outs))) 
+
+(defun &mem (left-outs right-outs memory-list)
+  (prog (fp dp)
+    (cond (*sendtocall*
+	   (setq fp *flag-part*)
+	   (setq dp *data-part*))
+	  (t
+	   (setq fp *alpha-flag-part*)
+	   (setq dp *alpha-data-part*)))
+    (sendto fp dp 'left left-outs)
+    (add-token memory-list fp dp nil)
+    (sendto fp dp 'right right-outs))) 
+
+(defun &and (outs lpred rpred tests)
+  (prog (mem)
+    (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
+	  (t (setq mem (memory-part rpred))))
+    (cond ((not mem) (return nil))
+	  ((eq *side* 'right) (and-right outs mem tests))
+	  (t (and-left outs mem tests))))) 
+
+(defun and-left (outs mem tests)
+  (prog (fp dp memdp tlist tst lind rind res)
+    (setq fp *flag-part*)
+    (setq dp *data-part*)
+    fail (and (null mem) (return nil))
+    (setq memdp (car mem))
+    (setq mem (cdr mem))
+    (setq tlist tests)
+    tloop (and (null tlist) (go succ))
+    (setq tst (car tlist))
+    (setq tlist (cdr tlist))
+    (setq lind (car tlist))
+    (setq tlist (cdr tlist))
+    (setq rind (car tlist))
+    (setq tlist (cdr tlist))
+    ;###        (comment the next line differs in and-left & -right)
+    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
+    (cond (res (go tloop))
+	  (t (go fail)))
+    succ 
+    ;###	(comment the next line differs in and-left & -right)
+    (sendto fp (cons (car memdp) dp) 'left outs)
+    (go fail))) 
+
+(defun and-right (outs mem tests)
+  (prog (fp dp memdp tlist tst lind rind res)
+    (setq fp *flag-part*)
+    (setq dp *data-part*)
+    fail (and (null mem) (return nil))
+    (setq memdp (car mem))
+    (setq mem (cdr mem))
+    (setq tlist tests)
+    tloop (and (null tlist) (go succ))
+    (setq tst (car tlist))
+    (setq tlist (cdr tlist))
+    (setq lind (car tlist))
+    (setq tlist (cdr tlist))
+    (setq rind (car tlist))
+    (setq tlist (cdr tlist))
+    ;###        (comment the next line differs in and-left & -right)
+    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
+    (cond (res (go tloop))
+	  (t (go fail)))
+    succ 
+    ;###        (comment the next line differs in and-left & -right)
+    (sendto fp (cons (car dp) memdp) 'right outs)
+    (go fail))) 
+
+
+(defun teqb (new eqvar)
+  (cond ((eq new eqvar) t)
+	((not (numberp new)) nil)
+	((not (numberp eqvar)) nil)
+	((=alg new eqvar) t)
+	(t nil))) 
+
+(defun tneb (new eqvar)
+  (cond ((eq new eqvar) nil)
+	((not (numberp new)) t)
+	((not (numberp eqvar)) t)
+	((=alg new eqvar) nil)
+	(t t))) 
+
+(defun tltb (new eqvar)
+  (cond ((not (numberp new)) nil)
+	((not (numberp eqvar)) nil)
+	((> eqvar new) t)
+	(t nil))) 
+
+(defun tgtb (new eqvar)
+  (cond ((not (numberp new)) nil)
+	((not (numberp eqvar)) nil)
+	((> new eqvar) t)
+	(t nil))) 
+
+(defun tgeb (new eqvar)
+  (cond ((not (numberp new)) nil)
+	((not (numberp eqvar)) nil)
+	((not (> eqvar new)) t)
+	(t nil))) 
+
+(defun tleb (new eqvar)
+  (cond ((not (numberp new)) nil)
+	((not (numberp eqvar)) nil)
+	((not (> new eqvar)) t)
+	(t nil))) 
+
+(defun txxb (new eqvar)
+  (cond ((numberp new)
+	 (cond ((numberp eqvar) t)
+	       (t nil)))
+	(t
+	 (cond ((numberp eqvar) nil)
+	       (t t))))) 
+
+
+(defun &p (rating name var-dope ce-var-dope rhs)
+  (declare (ignore var-dope ce-var-dope rhs))
+  (prog (fp dp)
+    (cond (*sendtocall*
+	   (setq fp *flag-part*)
+	   (setq dp *data-part*))
+	  (t
+	   (setq fp *alpha-flag-part*)
+	   (setq dp *alpha-data-part*)))
+    (and (member fp '(nil old)) (removecs name dp))
+    (and fp (insertcs name dp rating)))) 
+
+(defun &old (a b c d e)
+  (declare (ignore a b c d e))
+  nil) 
+
+(defun &not (outs lmem rpred tests)
+  (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
+	((eq *side* 'right) (not-right outs (car lmem) tests))
+	(t (not-left outs (memory-part rpred) tests lmem)))) 
+
+(defun not-left (outs mem tests own-mem)
+  (prog (fp dp memdp tlist tst lind rind res c)
+    (setq fp *flag-part*)
+    (setq dp *data-part*)
+    (setq c 0.)
+    fail (and (null mem) (go fin))
+    (setq memdp (car mem))
+    (setq mem (cdr mem))
+    (setq tlist tests)
+    tloop (and (null tlist) (setq c (1+ c)) (go fail))
+    (setq tst (car tlist))
+    (setq tlist (cdr tlist))
+    (setq lind (car tlist))
+    (setq tlist (cdr tlist))
+    (setq rind (car tlist))
+    (setq tlist (cdr tlist))
+    ;###        (comment the next line differs in not-left & -right)
+    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
+    (cond (res (go tloop))
+	  (t (go fail)))
+    fin  (add-token own-mem fp dp c)
+    (and (== c 0.) (sendto fp dp 'left outs)))) 
+
+(defun not-right (outs mem tests)
+  (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
+    (setq fp *flag-part*)
+    (setq dp *data-part*)
+    (cond ((not fp) (setq inc -1.) (setq newfp 'new))
+	  ((eq fp 'new) (setq inc 1.) (setq newfp nil))
+	  (t (return nil)))
+    fail (and (null mem) (return nil))
+    (setq memdp (car mem))
+    (setq newc (cadr mem))
+    (setq tlist tests)
+    tloop (and (null tlist) (go succ))
+    (setq tst (car tlist))
+    (setq tlist (cdr tlist))
+    (setq lind (car tlist))
+    (setq tlist (cdr tlist))
+    (setq rind (car tlist))
+    (setq tlist (cdr tlist))
+    ;###        (comment the next line differs in not-left & -right)
+    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
+    (cond (res (go tloop))
+	  (t (setq mem (cddr mem)) (go fail)))
+    succ (setq newc (+ inc newc))		;"plus" changed to "+" by gdw
+    (rplaca (cdr mem) newc)
+    (cond ((or (and (== inc -1.) (== newc 0.))
+	       (and (== inc 1.) (== newc 1.)))
+	   (sendto newfp memdp 'right outs)))
+    (setq mem (cddr mem))
+    (go fail))) 
+
+
+;;; Node memories
+
+
+(defun add-token (memlis flag data-part num)
+  (prog (was-present)
+    (cond ((eq flag 'new)
+	   (setq was-present nil)
+	   (real-add-token memlis data-part num))
+	  ((not flag) 
+	   (setq was-present (remove-old memlis data-part num)))
+	  ((eq flag 'old) (setq was-present t)))
+    (return was-present))) 
+
+(defun real-add-token (lis data-part num)
+  (setq *current-token* (1+ *current-token*))
+  (cond (num (rplaca lis (cons num (car lis)))))
+  (rplaca lis (cons data-part (car lis)))) 
+
+(defun remove-old (lis data num)
+  (cond (num (remove-old-num lis data))
+	(t (remove-old-no-num lis data)))) 
+
+(defun remove-old-num (lis data)
+  (prog (m next last)
+    (setq m (car lis))
+    (cond ((atom m) (return nil))
+	  ((top-levels-eq data (car m))
+	   (setq *current-token* (1- *current-token*))
+	   (rplaca lis (cddr m))
+	   (return (car m))))
+    (setq next m)
+    loop (setq last next)
+    (setq next (cddr next))
+    (cond ((atom next) (return nil))
+	  ((top-levels-eq data (car next))
+	   (rplacd (cdr last) (cddr next))
+	   (setq *current-token* (1- *current-token*))
+	   (return (car next)))
+	  (t (go loop))))) 
+
+(defun remove-old-no-num (lis data)
+  (prog (m next last)
+    (setq m (car lis))
+    (cond ((atom m) (return nil))
+	  ((top-levels-eq data (car m))
+	   (setq *current-token* (1- *current-token*))
+	   (rplaca lis (cdr m))
+	   (return (car m))))
+    (setq next m)
+    loop (setq last next)
+    (setq next (cdr next))
+    (cond ((atom next) (return nil))
+	  ((top-levels-eq data (car next))
+	   (rplacd last (cdr next))
+	   (setq *current-token* (1- *current-token*))
+	   (return (car next)))
+	  (t (go loop))))) 
diff --git a/contrib/ops/ops-rhs.lisp b/contrib/ops/ops-rhs.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7b8de9bd75d23bc8e1009ee60734ec0922f0fcf9
--- /dev/null
+++ b/contrib/ops/ops-rhs.lisp
@@ -0,0 +1,646 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; This file contains all the functions necessary for RHS actions
+;;;; including $actions.
+
+(in-package "OPS")
+(shadow '(remove write))
+(export '(remove write make modify crlf))
+
+
+(proclaim '(special *ptrace* *cycle-count* *halt-flag* *wtrace*))
+
+
+;;; External global variables
+
+(defvar *size-result-array*)
+(defvar *in-rhs*)
+(defvar *current-wm*)
+(defvar *max-wm*)
+(defvar *action-count*)
+(defvar *critical*)
+
+
+;;; Internal global variables
+
+(defvar *wmpart-list*)
+(defvar *wm-filter*)
+(defvar *wm*)
+(defvar *old-wm*)
+(defvar *result-array*)
+(defvar *variable-memory*)
+(defvar *last*)
+(defvar *max-index*)
+(defvar *next-index*)
+(defvar *data-matched*)
+(defvar *ce-variable-memory*)
+(defvar *rest*)
+(defvar *build-trace*)
+
+
+;;;; Functions for RHS evaluation
+
+(defun rhs-init ()
+  ; if the size of result-array changes, change the line in i-g-v which
+  ; sets the value of *size-result-array*
+  (setq *size-result-array* 255.)                             ;255 /256 set by gdw
+  (setq *result-array* (make-array 256 :initial-element nil))  ;jgk
+  (setq *in-rhs* nil)
+  (setq *build-trace* nil)
+  (setq *max-wm* (setq *current-wm* 0.))
+  (setq *action-count* 0.)
+  (setq *critical* nil)
+  (setq *wmpart-list* nil))
+
+
+(defun eval-rhs (pname data)
+  (prog (node port)
+    (cond (*ptrace*
+	   (setq port (trace-file))
+	   (terpri port)
+	   (princ *cycle-count* port)
+	   (princ '|. | port)
+	   (princ pname port)
+	   (time-tag-print data port)))
+    (setq *data-matched* data)
+    (setq *p-name* pname)
+    (setq *last* nil)
+    (setq node (get pname 'topnode))
+    (init-var-mem (var-part node))
+    (init-ce-var-mem (ce-var-part node))
+    (begin-record pname data)
+    (setq *in-rhs* t)
+    (eval (rhs-part node))
+    (setq *in-rhs* nil)
+    (end-record))) 
+
+
+(defun eval-args (z)
+  (prog (r)
+    (rhs-tab 1.)
+    la   (and (atom z) (return nil))
+    (setq r (car z))
+    (setq z (cdr z))
+    (cond ((EQ R '^)
+	   (RHS-tab (car z))
+	   (setq r (cadr z))
+	   (setq z (cddr z))))
+    (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
+	  (t ($change r)))
+    (go la))) 
+
+
+
+;;;; RHS actions
+;;;; Some of these can be called at the top level.
+
+(defmacro make (&body z)
+  `(ops-make ',z))
+
+(defmacro remove (&body z)
+  `(ops-remove ',z))
+
+(defmacro modify (&body z)
+  `(ops-modify ',z))
+
+(defmacro openfile (&body z)
+  `(ops-openfile ',z))
+
+(defmacro closefile (&body z)
+  `(ops-closefile ',z))
+
+(defmacro default (&body z)
+  `(ops-default ',z))
+
+(defmacro write (&body z)
+  `(ops-write ',z))
+
+(defmacro crlf (&body z)
+  `(ops-crlf ',z))
+
+(defmacro tabto (&body z)
+  `(ops-tabto ',z))
+
+(defmacro rjust (&body z)
+  `(ops-rjust ',z))
+
+(defmacro call (&body z)
+  `(ops-call ',z))
+
+(defmacro bind (&body z)
+  `(ops-bind ',z))
+
+(defmacro cbind (&body z)
+  `(ops-cbind ',z))
+
+(defmacro build (&body z)
+  `(ops-build ',z))
+
+(defmacro substr (&body l)
+  `(ops-substr ',l))
+
+(defmacro compute (&body z)
+  `(ops-compute ',z))
+
+(defmacro litval (&body z)
+  `(ops-litval ',z))
+
+(defmacro accept (&body z)
+  `(ops-accept ',z))
+
+(defmacro acceptline (&body z)
+  `(ops-acceptline ',z))
+
+(defmacro arith (&body z)
+  `(ops-arith ',z))
+
+
+(defun ops-make (z)
+  (prog nil
+    ($reset)
+    (eval-args z)
+    ($assert))) 
+
+(defun ops-remove (z)
+  (prog (old)
+    (and (not *in-rhs*)(return (top-level-remove z)))
+    top  (and (atom z) (return nil))
+    (setq old (get-ce-var-bind (car z)))
+    (cond ((null old)
+	   (%warn '|remove: argument not an element variable| (car z))
+	   (return nil)))
+    (remove-from-wm old)
+    (setq z (cdr z))
+    (go top))) 
+
+(defun ops-modify (z)
+  (prog (old)
+    (cond ((not *in-rhs*)
+	   (%warn '|cannot be called at top level| 'modify)
+	   (return nil)))
+    (setq old (get-ce-var-bind (car z)))
+    (cond ((null old)
+	   (%warn '|modify: first argument must be an element variable|
+		  (car z))
+	   (return nil)))
+    (remove-from-wm old)
+    (setq z (cdr z))
+    ($reset)
+    copy (and (atom old) (go fin))
+    ($change (car old))
+    (setq old (cdr old))
+    (go copy)
+    fin  (eval-args z)
+    ($assert))) 
+
+(defun ops-bind (z)
+  (prog (val)
+    (cond ((not *in-rhs*)
+	   (%warn '|cannot be called at top level| 'bind)
+	   (return nil)))
+    (cond ((< (length z) 1.)
+	   (%warn '|bind: wrong number of arguments to| z)
+	   (return nil))
+	  ((not (symbolp (car z)))
+	   (%warn '|bind: illegal argument| (car z))
+	   (return nil))
+	  ((= (length z) 1.) (setq val (gensym)))
+	  (t ($reset)
+	     (eval-args (cdr z))
+	     (setq val ($parameter 1.))))
+    (make-var-bind (car z) val))) 
+
+(defun ops-cbind (z)
+  (cond ((not *in-rhs*)
+	 (%warn '|cannot be called at top level| 'cbind))
+	((not (= (length z) 1.))
+	 (%warn '|cbind: wrong number of arguments| z))
+	((not (symbolp (car z)))
+	 (%warn '|cbind: illegal argument| (car z)))
+	((null *last*)
+	 (%warn '|cbind: nothing added yet| (car z)))
+	(t (make-ce-var-bind (car z) *last*)))) 
+
+
+(defun ops-call (z)
+  (prog (f)
+    (setq f (car z))
+    ($reset)
+    (eval-args (cdr z))
+    (funcall f))) 
+
+
+(defun halt nil 
+  (cond ((not *in-rhs*)
+	 (%warn '|cannot be called at top level| 'halt))
+	(t (setq *halt-flag* t)))) 
+
+(defun ops-build (z)
+  (prog (r)
+    (cond ((not *in-rhs*)
+	   (%warn '|cannot be called at top level| 'build)
+	   (return nil)))
+    ($reset)
+    (build-collect z)
+    (setq r (unflat (use-result-array)))
+    (and *build-trace* (funcall *build-trace* r))
+    (compile-production (car r) (cdr r)))) 
+
+(defun ops-compute (z) ($value (ari z))) 
+
+; arith is the obsolete form of compute
+(defun ops-arith (z) ($value (ari z))) 
+
+(defun ari (x)
+  (cond ((atom x)
+	 (%warn '|bad syntax in arithmetic expression | x)
+	 0.)
+	((atom (cdr x)) (ari-unit (car x)))
+	((eq (cadr x) '+)
+	 (+ (ari-unit (car x)) (ari (cddr x))))
+	;"plus" changed to "+" by gdw
+	((eq (cadr x) '-)
+	 (- (ari-unit (car x)) (ari (cddr x))))
+	((eq (cadr x) '*)
+	 (* (ari-unit (car x)) (ari (cddr x))))
+	((eq (cadr x) '//)
+	 (floor (ari-unit (car x)) (ari (cddr x))))   ;@@@ quotient? /
+	;@@@ kluge only works for integers
+	;@@@ changed to floor by jcp (from round)
+	((eq (cadr x) '\\)
+	 (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
+	(t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
+
+(defun ari-unit (a)
+  (prog (r)
+    (cond ((consp  a) (setq r (ari a)))	;dtpr\consp gdw
+	  (t (setq r ($varbind a))))
+    (cond ((not (numberp r))
+	   (%warn '|bad value in arithmetic expression| a)
+	   (return 0.))
+	  (t (return r))))) 
+
+(defun ops-substr (l)
+  (prog (k elm start end)
+    (cond ((not (= (length l) 3.))
+	   (%warn '|substr: wrong number of arguments| l)
+	   (return nil)))
+    (setq elm (get-ce-var-bind (car l)))
+    (cond ((null elm)
+	   (%warn '|first argument to substr must be a ce var|
+		  l)
+	   (return nil)))
+    (setq start ($varbind (cadr l)))
+    (setq start ($litbind start))
+    (cond ((not (numberp start))
+	   (%warn '|second argument to substr must be a number|
+		  l)
+	   (return nil)))
+;###	(comment |if a variable is bound to INF, the following|
+;	 |will get the binding and treat it as INF is|
+;	 |always treated.  that may not be good|)
+    (setq end ($varbind (caddr l)))
+    (cond ((eq end 'inf) (setq end (length elm))))
+    (setq end ($litbind end))
+    (cond ((not (numberp end))
+	   (%warn '|third argument to substr must be a number|
+		  l)
+	   (return nil)))
+;###	(comment |this loop does not check for the end of elm|
+;         |instead it relies on cdr of nil being nil|
+;         |this may not work in all versions of lisp|)
+    (setq k 1.)
+    la   (cond ((> k end) (return nil))
+	       ((not (< k start)) ($value (car elm))))
+    (setq elm (cdr elm))
+    (setq k (1+ k))
+    (go la))) 
+
+(defun genatom nil ($value (gensym))) 
+
+(defun ops-litval (z)
+  (prog (r)
+    (cond ((not (= (length z) 1.))
+	   (%warn '|litval: wrong number of arguments| z)
+	   ($value 0) 
+	   (return nil))
+	  ((numberp (car z)) ($value (car z)) (return nil)))
+    (setq r ($litbind ($varbind (car z))))
+    (cond ((numberp r) ($value r) (return nil)))
+    (%warn '|litval: argument has no literal binding| (car z))
+    ($value 0)))
+
+
+
+; rhs-tab implements the tab ('^') function in the rhs.  it has
+; four responsibilities:
+;	- to move the array pointers
+;	- to watch for tabbing off the left end of the array
+;	  (ie, to watch for pointers less than 1)
+;	- to watch for tabbing off the right end of the array
+;	- to write nil in all the slots that are skipped
+; the last is necessary if the result array is not to be cleared
+; after each use; if rhs-tab did not do this, $reset
+; would be much slower.
+
+(defun rhs-tab (z) ($tab ($varbind z)))
+
+
+(defun time-tag-print (data port)
+  (cond ((not (null data))
+	 (time-tag-print (cdr data) port)
+	 (princ '| | port)
+	 (princ (creation-time (car data)) port))))
+
+(defun init-var-mem (vlist)
+  (prog (v ind r)
+    (setq *variable-memory* nil)
+    top  (and (atom vlist) (return nil))
+    (setq v (car vlist))
+    (setq ind (cadr vlist))
+    (setq vlist (cddr vlist))
+    (setq r (gelm *data-matched* ind))
+    (setq *variable-memory* (cons (cons v r) *variable-memory*))
+    (go top))) 
+
+(defun init-ce-var-mem (vlist)
+  (prog (v ind r)
+    (setq *ce-variable-memory* nil)
+    top  (and (atom vlist) (return nil))
+    (setq v (car vlist))
+    (setq ind (cadr vlist))
+    (setq vlist (cddr vlist))
+    (setq r (ce-gelm *data-matched* ind))
+    (setq *ce-variable-memory*
+	  (cons (cons v r) *ce-variable-memory*))
+    (go top))) 
+
+(defun make-ce-var-bind (var elem)
+  (setq *ce-variable-memory*
+	(cons (cons var elem) *ce-variable-memory*))) 
+
+(defun make-var-bind (var elem)
+  (setq *variable-memory* (cons (cons var elem) *variable-memory*))) 
+
+(defun get-ce-var-bind (x)
+  (prog (r)
+    (cond ((numberp x) (return (get-num-ce x))))
+    (setq r (assq x *ce-variable-memory*))
+    (cond (r (return (cdr r)))
+	  (t (return nil))))) 
+
+(defun get-num-ce (x)
+  (prog (r l d)
+    (setq r *data-matched*)
+    (setq l (length r))
+    (setq d (- l x))
+    (and (> 0. d) (return nil))
+    la   (cond ((null r) (return nil))
+	       ((> 1. d) (return (car r))))
+    (setq d (1- d))
+    (setq r (cdr r))
+    (go la))) 
+
+
+(defun build-collect (z)
+  (prog (r)
+    la   (and (atom z) (return nil))
+    (setq r (car z))
+    (setq z (cdr z))
+    (cond ((consp  r)	;dtpr\consp gdw
+	   ($value '\()
+		   (build-collect r)
+		   ($value '\)))
+	  ((eq r '\\) ($change (car z)) (setq z (cdr z)))
+	  (t ($value r)))
+    (go la))) 
+
+(defun unflat (x) (setq *rest* x) (unflat*)) 
+
+(defun unflat* nil
+  (prog (c)
+    (cond ((atom *rest*) (return nil)))
+    (setq c (car *rest*))
+    (setq *rest* (cdr *rest*))
+    (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
+	   ((eq c '\)) (return nil))
+	  (t (return (cons c (unflat*))))))) 
+
+
+
+;;;; $Functions.
+;;;; These functions provide an interface to the result array.
+;;;; The result array is used to organize attribute values into their
+;;;; correct slot.
+
+(defun $litbind (x)
+  (prog (r)
+    (cond ((and (symbolp x) (setq r (literal-binding-of x)))
+	   (return r))
+	  (t (return x))))) 
+
+(defun $varbind (x)
+  (prog (r)
+    (and (not *in-rhs*) (return x))
+    (setq r (assq x *variable-memory*))
+    (cond (r (return (cdr r)))
+	  (t (return x))))) 
+
+(defun $change (x)
+  (prog nil
+    (cond ((consp  x) (eval-function x))	;dtpr\consp gdw
+	  (t ($value ($varbind x)))))) 
+
+(defun $reset nil
+  (setq *max-index* 0.)
+  (setq *next-index* 1.)) 
+
+(defun $tab (z)
+  (prog (edge next)
+    (setq next ($litbind z))
+    (and (floatp next) (setq next (fix next)))
+    (cond ((or (not (numberp next)) 
+	       (> next *size-result-array*)
+	       (> 1. next))				; ( '| |)
+	   (%warn '|illegal index after ^| next)
+	   (return *next-index*)))
+    (setq edge (- next 1.))
+    (cond ((> *max-index* edge) (go ok)))
+    clear (cond ((== *max-index* edge) (go ok)))
+    (putvector *result-array* edge nil)
+    (setq edge (1- edge))
+    (go clear)
+    ok   (setq *next-index* next)
+    (return next))) 
+
+(defun $value (v)
+  (cond ((> *next-index* *size-result-array*)
+	 (%warn '|index too large| *next-index*))
+	(t
+	 (and (> *next-index* *max-index*)
+	      (setq *max-index* *next-index*))
+	 (putvector *result-array* *next-index* v)
+	 (setq *next-index* (1+ *next-index*))))) 
+
+(defun $assert nil
+  (setq *last* (use-result-array))
+  (add-to-wm *last* nil))
+
+(defun $parametercount nil *max-index*)
+
+(defun $parameter (k)
+  (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
+	 (%warn '|illegal parameter number | k)
+	 nil)
+	((> k *max-index*) nil)
+	(t (getvector *result-array* k))))
+
+(defun $ifile (x) 
+  (cond ((symbolp x) (get x 'inputfile))
+	(t nil)))
+
+(defun $ofile (x) 
+  (cond ((symbolp x) (get x 'outputfile))
+	(t nil)))
+
+
+;;; Use-result-array returns the contents of the result array as a list.
+
+(defun use-result-array nil
+  (prog (k r)
+    (setq k *max-index*)
+    (setq r nil)
+    top  (and (== k 0.) (return r))
+    (setq r (cons (getvector *result-array* k) r))
+    (setq k (1- k))
+    (go top))) 
+
+
+(defun eval-function (form)
+  (cond ((not *in-rhs*)
+	 (%warn '|functions cannot be used at top level| (car form)))
+	(t (eval form))))
+
+
+
+;;;; WM maintaining functions
+
+;;; The order of operations in the following two functions is critical.
+;;; add-to-wm order: (1) change wm (2) record change (3) match 
+;;; remove-from-wm order: (1) record change (2) match (3) change wm
+;;; (back will not restore state properly unless wm changes are recorded
+;;; before the cs changes that they cause)  (match will give errors if 
+;;; the thing matched is not in wm at the time)
+
+(defun add-to-wm (wme override)
+  (prog (fa z part timetag port)
+    (setq *critical* t)
+    (setq *current-wm* (1+ *current-wm*))
+    (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
+    (setq *action-count* (1+ *action-count*))
+    (setq fa (wm-hash wme))
+    (or (member fa *wmpart-list*)
+	(setq *wmpart-list* (cons fa *wmpart-list*)))
+    (setq part (get fa 'wmpart*))
+    (cond (override (setq timetag override))
+	  (t (setq timetag *action-count*)))
+    (setq z (cons wme timetag))
+    (putprop fa (cons z part) 'wmpart*)
+    (record-change '=>wm *action-count* wme)
+    (match 'new wme)
+    (setq *critical* nil)
+    (cond ((and *in-rhs* *wtrace*)
+	   (setq port (trace-file))
+	   (terpri port)
+	   (princ '|=>wm: | port)
+	   (ppelm wme port))))) 
+
+;;; remove-from-wm uses eq, not equal to determine if wme is present
+
+(defun remove-from-wm (wme)
+  (prog (fa z part timetag port)
+    (setq fa (wm-hash wme))
+    (setq part (get fa 'wmpart*))
+    (setq z (assq wme part))
+    (or z (return nil))
+    (setq timetag (cdr z))
+    (cond ((and *wtrace* *in-rhs*)
+	   (setq port (trace-file))
+	   (terpri port)
+	   (princ '|<=wm: | port)
+	   (ppelm wme port)))
+    (setq *action-count* (1+ *action-count*))
+    (setq *critical* t)
+    (setq *current-wm* (1- *current-wm*))
+    (record-change '<=wm timetag wme)
+    (match nil wme)
+    (putprop fa (delq z part) 'wmpart*)
+    (setq *critical* nil))) 
+
+;;; mapwm maps down the elements of wm, applying fn to each element
+;;; each element is of form (datum . creation-time)
+
+(defun mapwm (fn)
+  (prog (wmpl part)
+    (setq wmpl *wmpart-list*)
+    lab1 (cond ((atom wmpl) (return nil)))
+    (setq part (get (car wmpl) 'wmpart*))
+    (setq wmpl (cdr wmpl))
+    (mapc fn part)
+    (go lab1))) 
+
+(defun ops-wm (a) 
+  (mapc (function (lambda (z) (terpri) (ppelm z *standard-output*))) 
+	(get-wm a))
+  nil) 
+
+(defun creation-time (wme)
+  (cdr (assq wme (get (wm-hash wme) 'wmpart*)))) 
+
+
+(defun get-wm (z)
+  (setq *wm-filter* z)
+  (setq *wm* nil)
+  (mapwm (function get-wm2))
+  (prog2 nil *wm* (setq *wm* nil))) 
+
+(defun get-wm2 (elem) 
+  ; (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*) :test #'equal)))
+  (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*)) ;test #'equal)
+	(setq *wm* (cons (car elem) *wm*)))))
+
+(defun wm-hash (x)
+  (cond ((not x) '<default>)
+	((not (car x)) (wm-hash (cdr x)))
+	((symbolp (car x)) (car x))
+	(t (wm-hash (cdr x))))) 
+
+(defun refresh nil
+  (prog nil
+    (setq *old-wm* nil)
+    (mapwm (function refresh-collect))
+    (mapc (function refresh-del) *old-wm*)
+    (mapc (function refresh-add) *old-wm*)
+    (setq *old-wm* nil))) 
+
+(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) 
+
+(defun refresh-del (x) (remove-from-wm (car x))) 
+
+(defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
diff --git a/contrib/ops/ops-util.lisp b/contrib/ops/ops-util.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e0f940d37dfe0261a6f4bfb891bfb6a77dc9b383
--- /dev/null
+++ b/contrib/ops/ops-util.lisp
@@ -0,0 +1,239 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; This file contains utility definitions that are needed by other ops
+;;;; modules.  This must be loaded first so commonlisp systems that
+;;;; expand macros early have them available.
+
+(in-package "OPS")
+
+
+
+;;; Assq is included in some Common Lisp implementations (like Spice Lisp and
+;;; the Zetalisp CLCP) as an extension.  We'll use ASSOC if it's not there.
+;;; DK- turned assq into a function so it can be 'applied'
+
+(eval-when (compile load eval)
+  (unless (fboundp 'assq)
+    (defmacro assq (i l)
+      `(assoc ,i ,l))))
+
+;;; Ditto for DELQ.
+
+(eval-when (compile load eval)
+  (unless (fboundp 'delq)
+    (defmacro delq (i l)
+      `(delete ,i ,l :test #'eq))))
+
+;
+; Spdelete "special delete" is a function which deletes every occurence
+; of element from list. This function was defined because common lisp's
+; delete function only deletes top level elements from a list, not lists
+; from lists. 
+;
+(defun spdelete (element list)
+  
+  (cond ((null list) nil)
+	((equal element (car list)) (spdelete element (cdr list)))
+	(t (cons (car list) (spdelete element (cdr list))))))
+
+
+;;; Functions that were revised so that they would compile efficiently
+
+(eval-when (compile eval load)
+	   
+;* The function == is machine dependent!
+;* This function compares small integers for equality.  It uses EQ
+;* so that it will be fast, and it will consequently not work on all
+;* Lisps.  It works in Franz Lisp for integers in [-128, 127]
+;(system::macro == (z) `(eq ,(cadr z) ,(caddr z)))
+;;;
+;;; Dario Giuse - made a macro. This is going to be faster than anything else.
+;;;
+;;; Skef Wholey - The = function in Common Lisp will compile into good code
+;;; (in all implementations that I know of) when given the right declarations.
+;;; In this case, we know both numbers are fixnums, so we use that information.
+
+(defmacro == (x y)
+  `(= (the fixnum ,x) (the fixnum ,y)))
+
+;;; =ALG returns T if A and B are algebraically equal.
+;;; This corresponds to equalp - Dario Giuse
+;;; But equalp uses eql for comparison if the things are numbers - Skef Wholey
+;;;
+(defmacro =alg (a b)
+  `(eql ,a ,b))
+
+	   
+(defmacro fast-symeval (&body z)
+  `(symbol-value ,(car z)))
+
+; getvector and putvector are fast routines for using ONE-DIMENSIONAL
+; arrays.  these routines do no checking; they assume
+;	1. the array is a vector with 0 being the index of the first
+;	   element
+;	2. the vector holds arbitrary list values
+
+; Example call: (putvector array index value)
+;;; Dario Giuse - 6/20/84
+
+(defmacro putvector (array index value)
+  `(setf (aref ,array ,index) ,value))
+
+;;; Example call: (getvector name index)
+;;;
+(defmacro getvector (array index)
+  `(aref ,array ,index))
+
+
+;;; Dario Giuse  6/21/84
+(defmacro putprop (atom value property)
+  `(setf (get ,atom ,property) ,value))
+
+) ;eval-when
+
+
+(defun ce-gelm (x k)
+  (declare (optimize speed))
+  (prog nil
+    loop (and (== k 1.) (return (car x)))
+    (setq k (1- k))
+    (setq x (cdr x))
+    (go loop))) 
+
+; The loops in gelm were unwound so that fewer calls on DIFFERENCE
+; would be needed
+
+(defun gelm (x k)
+  ; (locally) 				;@@@ locally isn't implemented yet
+  (declare (optimize speed))
+  (prog (ce sub)
+    (setq ce (truncate  k 10000.))		;use multiple-value-setq???
+    (setq sub (- k (* ce 10000.)))		;@@@ ^
+    
+    celoop (and (eq ce 0.) (go ph2))
+    (setq x (cdr x))
+    (and (eq ce 1.) (go ph2))
+    (setq x (cdr x))
+    (and (eq ce 2.) (go ph2))
+    (setq x (cdr x))
+    (and (eq ce 3.) (go ph2))
+    (setq x (cdr x))
+    (and (eq ce 4.) (go ph2))
+    (setq ce (- ce 4.))
+    (go celoop)
+    ph2  (setq x (car x))
+    subloop (and (eq sub 0.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 1.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 2.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 3.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 4.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 5.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 6.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 7.) (go finis))
+    (setq x (cdr x))
+    (and (eq sub 8.) (go finis))
+    (setq sub (- sub 8.))
+    (go subloop)
+    finis (return (car x))) ) ;  )  	;end prog,< locally >, defun
+
+
+
+;;; intersect two lists using eq for the equality test
+(defun interq (x y)
+  (cond ((atom x) nil)
+	((member (car x) y) (cons (car x) (interq (cdr x) y)))
+	(t (interq (cdr x) y)))) 
+
+
+(proclaim '(special *p-name*))
+
+(defun %warn (what where)
+  (prog nil
+    (terpri)
+    (princ '?)
+    (and *p-name* (princ *p-name*))
+    (princ '|..|)
+    (princ where)
+    (princ '|..|)
+    (princ what)
+    (return where))) 
+
+(defun %error (what where)
+  (%warn what where)
+  (throw '!error! '!error!)) 	;jgk quoted arguments
+
+;@@@(defun round (x) (fix (+ 0.5 x))) 		;"plus" changed to "+" by gdw
+;@@@ removed; calls converted to native clisp (round)
+
+(defun top-levels-eq (la lb)
+  (prog nil
+    lx   (cond ((eq la lb) (return t))
+	       ((null la) (return nil))
+	       ((null lb) (return nil))
+	       ((not (eq (car la) (car lb))) (return nil)))
+    (setq la (cdr la))
+    (setq lb (cdr lb))
+    (go lx))) 
+
+
+;(defun dtpr  (x) (consp x))	;dtpr\consp gdw
+
+
+(defun fix (x)(floor x))
+
+
+(eval-when (compile load eval)
+(defmacro ncons (x) `(cons ,x nil))
+);eval-when
+
+
+;@@@ revision suggested by sf/inc. by gdw
+(defun variablep (x)
+  (and (symbolp x)
+       (char= (char (symbol-name x) 0) #\< )))
+
+
+
+;@@@   this is a mistake: it must either go before = is called for 
+;non-numeric args, or such calls replaced with eq, equal, etc.
+;(defun = 
+;(x y) (equal x y))
+
+
+
+#|
+Commented out - Dario Giuse.
+This is unnecessary in Spice Lisp
+
+; break mechanism:
+(proclaim '(special erm *break-character*))
+
+(defun setbreak nil (setq *break-flag* t))
+(setq *break-character* #\control-D)
+(bind-keyboard-function *break-character* #'setbreak)
+(princ "*** use control-d for ops break, or setq *break-character asciival***")
+
+|#
diff --git a/contrib/ops/ops.catalog b/contrib/ops/ops.catalog
new file mode 100644
index 0000000000000000000000000000000000000000..f28a5502404cd19b14c875fc00410e00a5d9544c
--- /dev/null
+++ b/contrib/ops/ops.catalog
@@ -0,0 +1,48 @@
+Name:
+   OPS
+
+Package Name:
+   OPS
+
+Description:
+   Interpreter for Ops5, a programming language for production systems.
+
+Author:
+   Charles L. Forgy.  Ported to Common lisp by George Wood and Jim Kowalski.
+CMU Common Lisp mods by Dario Guise, Skef Wholey, and Dan Kuokka.
+
+Maintainer:
+   CMU Common Lisp Group.
+
+Net Address:
+   slisp-group@b
+
+Copyright Status:
+   Public domain.
+
+Files:
+   ops.lisp, ops-backup.lisp, ops-compile.lisp, ops-io.lisp, ops-main.lisp,
+ops-match.lisp, ops-rhs.lisp, ops-util.lisp, ops.catalog, ops-demo-mab.lisp,
+ops-demo-ttt.lisp, and binaries.
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>.
+   cp /afs/cs.cmu.edu/project/slisp/library/ops/* <spec>
+
+Portability:
+   Should run in any legal Common Lisp implementation.
+
+Instructions:
+   From Lisp, load "ops" and then go into the OPS package with (in-package
+'ops).  Now you can load your OPS5 code or start typing in productions.
+
+There are two demos -- interactive tic-tac-toe and the monkey and banana
+problem.  To run the former just load it and call RUN.  For the latter, first
+enter "(make start 1)" and then call RUN.
+
+See the OPS5 User's Manual, July 1981, by Forgy, CMU CSD.
+
+Bugs:
+   This has been put in its own package, but only a few interfaces have been
+exported.  You must run in the ops package.
diff --git a/contrib/ops/ops.lisp b/contrib/ops/ops.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ccf1a3d070970b17d1fcd84f39ff04cd0c9649c4
--- /dev/null
+++ b/contrib/ops/ops.lisp
@@ -0,0 +1,52 @@
+;
+;************************************************************************
+;
+;	VPS2 -- Interpreter for OPS5
+;
+;
+;
+; This Common Lisp version of OPS5 is in the public domain.  It is based
+; in part on based on a Franz Lisp implementation done by Charles L. Forgy
+; at Carnegie-Mellon University, which was placed in the public domain by
+; the author in accordance with CMU policies.  This version has been
+; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
+; and Dan Kuokka.
+;
+; This code is made available is, and without warranty of any kind by the
+; authors or by Carnegie-Mellon University.
+;
+
+;;;; This file handles the loading of all files composing the OPS interpreter.
+;;;; It also performs the necessary initialization.
+
+
+(setf (search-list "ops:") '("/afs/cs/project/clisp/library/ops/"))
+
+(in-package "OPS")
+
+(defun ops-init ()
+  ; Allows ^ , { , and } operators to be right next to another symbol.
+  (set-macro-character #\{ #'(lambda (s c)
+			       (declare (ignore s c))
+			       '\{))
+  (set-macro-character #\} #'(lambda (s c)
+			       (declare (ignore s c))
+			       '\}))
+  (set-macro-character #\^ #'(lambda (s c)
+			       (declare (ignore s c))
+			       '\^))
+  (backup-init)
+  (compile-init)
+  (main-init)
+  (match-init)
+  (io-init)
+  (rhs-init))
+
+(load "ops:ops-util")
+(load "ops:ops-backup")
+(load "ops:ops-compile")
+(load "ops:ops-main")
+(load "ops:ops-match")
+(load "ops:ops-io")
+(load "ops:ops-rhs")
+(ops-init)
diff --git a/contrib/psgraph/psgraph.catalog b/contrib/psgraph/psgraph.catalog
new file mode 100644
index 0000000000000000000000000000000000000000..2703a4a8757bbb9b3dc3d91bfadab1e25c3e40d4
--- /dev/null
+++ b/contrib/psgraph/psgraph.catalog
@@ -0,0 +1,61 @@
+Name:
+   PSgrapher
+
+Description:
+   The PSgrapher is a set of Lisp routines that can be called to produce
+Postscript commands that display a directed acyclic graph.
+
+Author:
+   Joseph Bates.  Skef put the whole thing in the PSGRPAPH package and added
+functionality which allows the user to specify EQ, EQUAL, or EQUALP as the
+node equivalence function.  Bill made all exported symbols have stars on them.
+
+Address:
+   Carnegie-Mellon University
+   Computer Science Department
+   Pittsburgh, PA 15213
+
+Net Address:
+   Joseph.Bates@CS.CMU.EDU
+
+Copyright Status:
+   Public Domain.
+
+Files:
+   psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog
+
+How to Get:
+   The following unix command will copy the pertinent files into directory
+<spec>.
+   cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec>
+
+Portability:
+   Should run in any legal Common Lisp.  Requires Postscript for printing.
+
+Instructions:
+   See psgraph.doc.
+
+Bugs:
+   This code blindly outputs what the user gives it as node labels.  It should
+run through the output escaping any PS control characters.  For example, if
+node labels contain parentheses, your output PS file will not print.
+
+Examples:
+   Skef Wholey submitted this as a reasonable example:
+
+;;; I use this in my compiler so I can look at code trees without
+;;; crawling around them in the inspector.  The postsript previewer
+;;; groks the generated ps file, which is bitchin' marvy.
+
+   (defun code-graph-to-file (s file &optional shrink insert)
+     (let ((psgraph:*fontname* "Times-Roman")
+	   (psgraph:*fontsize* 8)
+	   (psgraph:*second-fontname* "Times-BoldItalic")
+	   (psgraph:*second-fontsize* 6)
+	   (psgraph:*boxgray* "0")
+	   (psgraph:*edgegray* "0")
+	   (psgraph:*extra-x-spacing* 30))
+       (with-open-file (*standard-output* file
+					  :direction :output
+					  :if-exists :supersede)
+	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
diff --git a/contrib/psgraph/psgraph.doc b/contrib/psgraph/psgraph.doc
new file mode 100644
index 0000000000000000000000000000000000000000..e7b17692d06d8a4714eb3ee0a3268ef9b1cff85d
--- /dev/null
+++ b/contrib/psgraph/psgraph.doc
@@ -0,0 +1,125 @@
+Here is a brief summary of how to use the PSgrapher.
+
+The PSgrapher is a set of Lisp routines that can be called to produce
+Postscript commands to display a directed acyclic graph.  It uses the same
+basic algorithm as the ISI Grapher.  It is slower than the ISI grapher, but
+produces much prettier output than using Xdump to copy an ISI Grapher screen
+image to a Postscript printer.  It also allows arbitrary information to be
+displayed with a node, and can print as many output pages as are necessary to
+accomodate large graphs (subject to Postscript printer limits, typically one or
+two thousand nodes).
+
+The PSgrapher is small enough and easy enough to use to be included in other
+systems without pain.  It is also free and not copyrighted.
+
+Copy the file /afs/cs/project/clisp/library/psgraph/psgraph.lisp to your
+directory.  It is written in Common Lisp, and has been tested on CMU Common
+Lisp on RTs and Lucid on SUNs.  All interfaces described below are exported
+from the "PSGRAPH" package.
+
+There are several useful global variables that can be modified and one function
+to be called.  The variables affect the style of the printed image, the
+function walks a graph and produces output.
+
+A graph is defined by a root node and a function for getting children of a
+node.  Nodes are named by Lisp objects, and these names are checked using a
+user-supplied test function (defaults to EQUAL) for purposes of walking the
+graph and topologically sorting it.  Typically one uses atoms to name nodes,
+for example in graphing an inheritence net one could use the class names as
+node names.
+
+To produce a graph call the function:
+    (psgraph:psgraph root-node-name
+		     child-function
+		     info-function
+		     &optional (shrink nil)
+		     &optional (insert nil)
+		     &optional (test #'equal))
+
+Root-node-name is a Lisp object naming the root of the graph (there must be
+exactly one root).
+
+Child-function takes a node name and returns a list of node names.
+
+Info-function takes a node name and returns a list of strings.  Each string
+shows up as one line in the printed form of the node, with the first string
+displayed in one font (determined by variables *fontname*, *fontsize*) and the
+others in another font (determined by variables *second-fontname*,
+*second-fontsize*).  Typically the first string is just the name of the node,
+eg, (string node-name).
+
+Shrink is a boolean.  It defaults to nil, and in this case the graph
+prints on as many pages as are needed to show the whole thing.  If shrink
+is t then the entire graph is squashed appropriately to fit on one page
+of output.
+
+Insert is a boolean.  It defaults to nil, and in this case the generated
+Postscript file contains commands to print the output.  If insert is t
+then the output file is always shrunk (shrink is t) and no commands are
+generated to print the page.  This means the resulting file can be included
+in Scribe files, for example, and Scribe can decide when to print the page.
+
+Test is a function that return whether two nodes are the same.
+
+After loading psgraph, one can play with the various global variables, all of
+which have string values (except for the two font size variables).  *fontname*,
+*fontsize*, *second-fontname*, *second-fontsize* are as described above.  They
+default to "Helvetica" in 10 point and "Helvetica-Oblique" in 8 point,
+respectively.  *boxgray* and *boxkind* determine how the boxes around nodes
+look.  *boxkind* is either "fill" or "stroke", for solid or outline boxes, and
+*boxgray* is "0" for solid black, "1" for solid white, or in between.  These
+default to ".2" and "stroke".
+
+Other variables:
+   *max-psnodes*
+   *extra-x-spacing*
+   *extra-y-spacing*
+   *edgewidth*
+   *edgegray*
+   *edgecap*
+   *textgray*
+   *pageheight*
+   *pagewidth*
+   *boxradius*
+   *boxedge*
+   *chunksize*
+
+
+Psgraph sends its output to *standard-output*, so typically it is called
+from within (with-open-file  ....).  For example, one might use it like this:
+
+   (load "psgraph.fasl")
+   (setf psgraph:*boxkind* "fill")
+   (setf psgraph:*boxgray* ".8")
+   (setf psgraph:*fontsize* 8)
+   (setf psgraph:*second-fontsize* 6)
+
+   (defun graph (&optional (shrink t))
+     (with-open-file (*standard-output* "g.ps"
+		      :direction :output
+		      :if-exists :supersede)
+	  (psgraph:psgraph 'A #'children #'info shrink nil #'eq)))
+
+   (defun children (x)
+      (cond ((eq x 'A) '(B C D))
+	    ((member x '(B C D)) '(E F G))
+	    ((member x '(E F G)) '(H))
+	    (t nil)))
+
+   (defun info (x)
+      (list (string x)))
+
+
+Another example:
+   (defun code-graph-to-file (s file &optional shrink insert)
+     (let ((psgraph:*fontname* "Times-Roman")
+	   (psgraph:*fontsize* 8)
+	   (psgraph:*second-fontname* "Times-BoldItalic")
+	   (psgraph:*second-fontsize* 6)
+	   (psgraph:*boxgray* "0")
+	   (psgraph:*edgegray* "0")
+	   (psgraph:*extra-x-spacing* 30))
+       (with-open-file (*standard-output* file
+					  :direction :output
+					  :if-exists :supersede)
+	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
diff --git a/contrib/psgraph/psgraph.lisp b/contrib/psgraph/psgraph.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..09e37bbcf1871f09e96468e385606260f77bc3e4
--- /dev/null
+++ b/contrib/psgraph/psgraph.lisp
@@ -0,0 +1,506 @@
+;;; -*- Mode: Lisp; Package: PSGRAPH; Log: psgraph.log -*-
+;;;
+;;; PostScript DAG Grapher  -- Joseph Bates, CMU CSD, March 1988
+;;;
+;;; See psgraph.log for other modifiers.
+;;;
+(in-package "PSGRAPH")
+
+(export '(*max-psnodes* *extra-x-spacing* *extra-y-spacing* *fontname*
+	  *fontsize* *second-fontname* *second-fontsize* *boxgray* *boxkind*
+	  *edgewidth* *edgegray* *edgecap* *textgray* *pageheight* *pagewidth*
+	  *boxradius* *boxedge* *chunksize*
+
+	  psgraph))
+
+
+(defstruct psnode
+  name
+  info
+  children
+  parents
+  appears-in-top-sort
+  children-appear-in-top-sort
+  yvalue
+  height
+)
+
+(defvar *max-psnodes* 5000)
+(defvar *extra-x-spacing* 20)
+(defvar *extra-y-spacing* 6)
+(defvar *fontname* "Helvetica")
+(defvar *fontsize* 10)
+(defvar *second-fontname* "Helvetica-Oblique")
+(defvar *second-fontsize* 8)
+(defvar *boxgray* ".2")      ;; 0 is black, 1 is white
+(defvar *boxkind* "stroke")  ;; stroke for outline, fill for solid
+(defvar *edgewidth* ".5")    ;; .5 is thin lines, 1 is fairly thick
+(defvar *edgegray* ".2")     ;; dark, but not solid black, lines
+(defvar *edgecap* "1")       ;; round the line caps
+(defvar *textgray* "0")      ;; solid black text
+(defvar *pageheight* 720)
+(defvar *pagewidth* (+ (* 7 72) 36))
+(defvar *boxradius* (floor *fontsize* 2))
+(defvar *boxedge* (floor *fontsize* 4))
+(defvar *chunksize* 400)
+
+(defvar num-psnodes)
+(defvar narray)
+(defvar psnode-index)
+(defvar child-function)
+(defvar info-function)
+(defvar top-sort)
+(defvar maximum-y)
+(defvar minimum-y)
+(defvar rows)
+(defvar y-offset)
+(defvar psnodes-at-y)
+(defvar ancestor-cache)
+
+(defun psgraph (root childf infof &optional (shrink nil) (insert nil) (test #'equal))
+  (unless (member test (list 'eq 'equal 'equalp #'eq #'equal #'equalp))
+    (error "Test must be a function suitable to hand to Make-Hash-Table."))
+  (when insert (setf shrink t))
+  (setq narray (make-array *max-psnodes*))
+  (setq num-psnodes 0)
+  (setq psnode-index (make-hash-table :test test
+				      :size 500
+				      :rehash-size 2.0))
+  (setq child-function childf)
+  (setq info-function infof)
+  (setq ancestor-cache (make-hash-table :test test
+					:size 1000
+					:rehash-size 2.0))
+
+  ;;; walk the graph computing node info
+  (walk-graph root)
+  (dotimes (index num-psnodes)
+    (setf (psnode-parents (aref narray index))
+	  (nreverse (psnode-parents (aref narray index))))
+    (setf (psnode-children (aref narray index))
+	  (nreverse (psnode-children (aref narray index)))))
+
+  ;;; topological sort the graph
+  (setq top-sort nil)
+  (top-sort-node 0)
+  (setq top-sort (nreverse top-sort))
+
+  ;;; declare this as a PostScript file
+  (format t "%!PS-Adobe-1.0~%")
+
+  ;;; this is required for the Apple LaserWriter (it likes to know the page
+  ;;; ordering so that it can print pages upside down).  It is best not to
+  ;;; confuse the LaserWriter when inserting things into a other documents.
+  (when (not insert)
+    (format t "%%Page: ? ?~%"))
+
+  ;;; define global functions
+  (dolist (line '(
+
+     "/max {2 copy lt {exch} if pop} def"
+
+     "/min {2 copy gt {exch} if pop} def"
+
+     "/inch {72 mul} def"
+
+     "/drawbox"
+     " {/height exch def"
+     "  /width exch def"
+     "  /y exch def"
+     "  /x exch def"
+     "  gsave newpath"
+     "  x y boxradius add moveto"
+     "  x y height add x width add y height add boxradius arcto pop pop pop pop"
+     "  x width add y height add x width add y boxradius arcto pop pop pop pop"
+     "  x width add y x y boxradius arcto pop pop pop pop"
+     "  x y x y height add boxradius arcto pop pop pop pop"
+     "  boxgray setgray boxkind grestore"
+     " } def"
+
+     "/printposter"
+     " {/rows exch def"
+     "  /columns exch def"
+     "  /bigpictureproc exch def"
+     "  newpath"
+     "    leftmargin botmargin moveto"
+     "    0 pageheight rlineto"
+     "    pagewidth 0 rlineto"
+     "    0 pageheight neg rlineto"
+     "  closepath clip"
+     "  leftmargin botmargin translate"
+     "  0 1 rows 1 sub"
+     "   {/rowcount exch def"
+     "    0 1 columns 1 sub"
+     "     {/colcount exch def"
+     "      gsave"
+     "       pagewidth colcount mul neg"
+     "       pageheight rowcount mul neg"
+     "       translate"
+     "       bigpictureproc"
+     "       gsave showpage grestore"
+     "      grestore"
+     "     } for"
+     "   } for"
+     " } def"
+
+   )) (format t "~A~%" line))
+
+  ;;; declare arrays
+  (format t "/xarray ~D array def~%" num-psnodes)
+  (format t "/widtharray ~D array def~%" num-psnodes)
+
+  ;;; define global settings
+  (format t "/leftmargin 36 def~%")
+  (format t "/botmargin 36 def~%")
+  (format t "/pagewidth ~D def~%" *pagewidth*)
+  (format t "/pageheight ~D def~%" *pageheight*)
+  (format t "/boxradius ~D def ~%" *boxradius*)
+  (format t "/boxedge ~D def ~%" *boxedge*)
+  (format t "/boxgray ~A def ~%" *boxgray*)
+  (format t "/boxkind {~A} def~%" *boxkind*)
+
+  ;;; compute width and height of each node
+  (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*)
+  (dotimes (index num-psnodes)
+    (format t "widtharray ~D (~A) stringwidth pop put~%"
+	    index
+	    (car (psnode-info (aref narray index)))))
+  (format t "/~A findfont ~D scalefont setfont~%"
+	  *second-fontname* *second-fontsize*)
+  (dotimes (index num-psnodes)
+    (format t "widtharray ~D get~%" index)
+    (dolist (info (cdr (psnode-info (aref narray index))))
+       (format t "(~A) stringwidth pop max~%" info))
+    (format t "~D add widtharray exch ~D exch put~%"
+ 	    (* 2 *boxedge*)
+	    index))
+  (dotimes (index num-psnodes)
+    (setf (psnode-height (aref narray index))
+	  (+ (* 2 *boxedge*)
+	     *extra-y-spacing*
+	     *fontsize*
+	     (* (- (length (psnode-info (aref narray index))) 1)
+		*second-fontsize*))))
+
+  ;;; compute x location of each node
+  (format t "xarray 0 0 put~%")
+  (dolist (index (cdr top-sort))
+    (let ((parents (psnode-parents (aref narray index))))
+      (format t "xarray ~D get widtharray ~D get add~%"
+	      (car parents) (car parents))
+      (dolist (parent (cdr parents))
+	  (format t "xarray ~D get widtharray ~D get add max~%"
+		  parent parent))
+      (format t "~D add xarray exch ~D exch put~%" *extra-x-spacing* index)))
+
+  ;;; compute maximum x used
+  (format t "/maximum-x 0~%")
+  (dotimes (index num-psnodes)
+     (format t "xarray ~D get widtharray ~D get add max~%"
+	     index index))
+  (format t "def~%")
+
+  ;;; compute y location of each node and maximum and minimum y used
+  (setq maximum-y 0)
+  (setq minimum-y 0)
+  (setq psnodes-at-y (make-hash-table :test test
+				      :size (* num-psnodes *fontsize*)
+				      :rehash-size 2.0))
+  (let ((currenty 0))
+    (dolist (index (reverse top-sort))
+       (let (desired-y)
+	 (cond ((null (psnode-children (aref narray index)))
+	          (setf desired-y currenty)
+		  (setf currenty (+ currenty (psnode-height
+					      (aref narray index)))))
+	       (t
+		 (let ((children (psnode-children (aref narray index)))
+		       (ysum 0))
+		   (dolist (child children)
+		      (setf ysum (+ ysum (psnode-yvalue (aref narray child)))))
+		   (setq desired-y (floor ysum (length children))))))
+
+	 ;;; We may not be able to put the node at the desired y.
+	 ;;; If there is another node that overlaps in the y direction
+	 ;;; and that node is neither a parent* nor child* (hence its x
+	 ;;; location may overlap this one) then we have to choose
+         ;;; another y value -- we choose the nearest (up or down)
+	 ;;; location so that there is no possible overlap in y or x.
+	 (let ((height (psnode-height (aref narray index)))
+	       (related (make-hash-table :test test
+					 :size (+ 50 num-psnodes)
+					 :rehash-size 2.0))
+	       collision
+	       upward-bot
+	       upward-top
+	       downward-bot
+	       downward-top)
+	   (setq upward-bot desired-y)
+	   (setq upward-top upward-bot)
+	   (setq downward-top (- (+ desired-y height) 1))
+	   (setq downward-bot downward-top)
+	   (loop
+	      ;;; check upward-top for collision
+	     (setq collision nil)
+	     (dolist (n (gethash upward-top psnodes-at-y))
+		(let ((r (gethash n related)))
+		  (when (null r)
+			(setf r (related-classes n index))
+			(setf (gethash n related) r))
+		  (when (eql r 'no)
+			(setq collision t)
+			(return))))
+				 
+	     ;;; if no collision and big enough space then we win
+	     (incf upward-top)
+	     (when (and (not collision) (= (- upward-top upward-bot) height))
+		   (setf desired-y upward-bot)
+		   (return))
+
+	     (when collision
+		   (setf upward-bot upward-top))
+
+	     ;;; check downward-bot for collision
+	     (setq collision nil)
+	     (dolist (n (gethash downward-bot psnodes-at-y))
+		(let ((r (gethash n related)))
+		  (when (null r)
+			(setf r (related-classes n index))
+			(setf (gethash n related) r))
+		  (when (eql r 'no)
+			(setq collision t)
+			(return))))
+
+	      ;;; if no collision and big enough space then we win
+	     (decf downward-bot)
+	     (when (and (not collision) (= (- downward-top downward-bot) height))
+		   (setf desired-y (+ 1 downward-bot))
+		   (return))
+	     
+	     (when collision
+		   (setf downward-top downward-bot))
+	   )
+	   ;;; add our name to psnodes-at-y table
+	   (dotimes (i height)
+	      (push index (gethash (+ i desired-y) psnodes-at-y)))
+
+	   (setf (psnode-yvalue (aref narray index)) desired-y)
+	 )
+
+	 (setf minimum-y (min minimum-y (psnode-yvalue (aref narray index))))
+	 (setf maximum-y
+	       (max maximum-y (+ (psnode-yvalue (aref narray index))
+				 (psnode-height (aref narray index))))))))
+		       
+  ;;; compute y-offset to center graph vertically
+  (setq rows (ceiling (- maximum-y minimum-y) *pageheight*))
+  (setq y-offset (- (floor (- (* rows *pageheight*) (- maximum-y minimum-y)) 2)
+		    minimum-y))
+  (when shrink (setq y-offset (- 0 minimum-y)))
+
+  ;;; create dictionary big enough to hold all the
+  ;;; procedures defined below and make it a current dictionary
+  (format t "~D dict begin~%"
+	  (+ (* 4 (+ num-psnodes (ceiling num-psnodes *chunksize*))) 50))
+
+  ;;; define procedures to display the background box for each node
+  (dotimes (index num-psnodes)
+     (format t "/box~D {~%" index)
+     (format t "xarray ~D get ~D widtharray ~D get ~D drawbox~%"
+	     index
+	     (+ y-offset 
+		(psnode-yvalue (aref narray index))
+                (floor *extra-y-spacing* 2))
+	     index
+	     (- (psnode-height (aref narray index)) *extra-y-spacing*))
+     (format t "} def~%"))
+
+  ;;; define procedures to display the text info for each node
+  (dotimes (index num-psnodes)
+     (let ((yvalue (+ y-offset
+		      (floor *extra-y-spacing* 2)
+		      (floor *fontsize* 5)
+                      *boxedge*
+		      (psnode-yvalue (aref narray index))
+		      (* *second-fontsize*
+			 (- (length (psnode-info (aref narray index))) 1)))))
+       (format t "/text~D {xarray ~D get boxedge add ~D moveto (~A) show} def~%"
+	       index
+	       index
+	       yvalue
+	       (car (psnode-info (aref narray index))))
+       (when (not (null (cdr (psnode-info (aref narray index)))))
+	   (format t "/secondtext~D {~%" index)
+	   (dolist (info (cdr (psnode-info (aref narray index))))
+	      (setq yvalue (- yvalue *second-fontsize*))
+	      (format t "xarray ~D get boxedge add ~D moveto (~A) show~%"
+		      index
+		      yvalue
+		      info))
+	   (format t "} def~%"))))
+
+  ;;; define procedures to display the edges leading into each node
+  (dotimes (index num-psnodes)
+     (format t "/edge~D {newpath~%" index)
+     (dolist (parent (psnode-parents (aref narray index)))
+        (format t "xarray ~D get widtharray ~D get add ~D moveto~%"
+		parent
+		parent
+		(+ (psnode-yvalue (aref narray parent))
+		   (floor (psnode-height (aref narray parent)) 2)
+		   y-offset))
+	(format t "xarray ~D get ~D lineto~%"
+		index
+		(+ (psnode-yvalue (aref narray index))
+		   (floor (psnode-height (aref narray index)) 2)
+		   y-offset)))
+     (format t "stroke } def~%"))
+
+  ;;; Define procedures to display chunks of boxes, text, and edges.
+  ;;; We limit each chunk to at most *chunksize* calls, to avoid overflowing
+  ;;; the Postscript operand stack.
+  (dotimes (index num-psnodes)
+     (when (eql (mod index *chunksize*) 0)
+	   (format t "/boxchunk~D {~%" (floor index *chunksize*)))
+     (format t "box~D~%" index)
+     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
+	       (eql index (- num-psnodes 1)))
+	   (format t "} def~%")))
+  (dotimes (index num-psnodes)
+     (when (eql (mod index *chunksize*) 0)
+	   (format t "/textchunk~D {~%" (floor index *chunksize*)))
+     (format t "text~D~%" index)
+     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
+	       (eql index (- num-psnodes 1)))
+	   (format t "} def~%")))
+  (dotimes (index num-psnodes)
+     (when (eql (mod index *chunksize*) 0)
+	   (format t "/secondtextchunk~D {~%" (floor index *chunksize*)))
+     (when (not (null (cdr (psnode-info (aref narray index)))))
+	   (format t "secondtext~D~%" index))
+     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
+	       (eql index (- num-psnodes 1)))
+	   (format t "} def~%")))
+  (dotimes (index num-psnodes)
+     (when (eql (mod index *chunksize*) 0)
+	   (format t "/edgechunk~D {~%" (floor index *chunksize*)))
+     (format t "edge~D~%" index)
+     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
+	       (eql index (- num-psnodes 1)))
+	   (format t "} def~%")))
+
+  ;;; Define procedure to display entire graph.
+  ;;; First do the boxes, then the edges, then the text.
+  (format t "/drawgraph { gsave~%")
+  (dotimes (i (ceiling num-psnodes *chunksize*))
+     (format t "boxchunk~D~%" i))
+  (format t "~A setlinewidth~%" *edgewidth*)
+  (format t "~A setlinecap~%" *edgecap*)
+  (format t "~A setgray~%" *edgegray*)
+  (dotimes (i (ceiling num-psnodes *chunksize*))
+     (format t "edgechunk~D~%" i))
+  (format t "~A setgray~%" *textgray*)
+  (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*)
+  (dotimes (i (ceiling num-psnodes *chunksize*))
+     (format t "textchunk~D~%" i))
+  (format t "/~A findfont ~D scalefont setfont~%" *second-fontname* *second-fontsize*)
+  (dotimes (i (ceiling num-psnodes *chunksize*))
+     (format t "secondtextchunk~D~%" i))
+  (format t "grestore } def~%")
+
+  ;;; show the virtual page in as many actual pages as needed
+  (cond (shrink
+          ;;; shrink the output to fit on one page
+	  (format t "leftmargin botmargin translate~%")
+	  (format t "pagewidth dup maximum-x max div pageheight dup ~D max ~
+	             div min dup scale~%"
+		  (- maximum-y minimum-y))
+	  (if insert
+	      (format t "drawgraph end~%")
+	      (format t "drawgraph showpage end~%")))
+	(t
+	  (format t "{drawgraph} maximum-x pagewidth div ceiling ~
+	             ~D printposter end~%"
+		  rows)))
+  
+)
+
+
+(defun walk-graph (root)
+  (when (eql num-psnodes *max-psnodes*)
+	(error "More than ~D nodes in graph.  Graphing aborted."))
+  (let ((root-index num-psnodes)
+	(child-names (apply child-function (list root))))
+    (incf num-psnodes)
+    (setf (gethash root psnode-index) root-index)
+    (setf (aref narray root-index) (make-psnode))
+    (setf (psnode-name (aref narray root-index)) root)
+    (setf (psnode-info (aref narray root-index))
+	  (apply info-function (list root)))
+    (setf (psnode-children (aref narray root-index)) nil)
+    (setf (psnode-parents (aref narray root-index)) nil)
+    (setf (psnode-appears-in-top-sort (aref narray root-index)) nil)
+    (setf (psnode-children-appear-in-top-sort (aref narray root-index)) nil)
+    (dolist (child child-names)
+	    (let ((child-index (gethash child psnode-index)))
+	      (cond (child-index
+		      (push child-index
+			    (psnode-children (aref narray root-index)))
+		      (push root-index
+			    (psnode-parents (aref narray child-index))))
+		    (t
+		      (let ((child-index (walk-graph child)))
+			(push child-index
+			      (psnode-children (aref narray root-index)))
+			(push root-index
+			      (psnode-parents (aref narray child-index))))))))
+    root-index)
+)
+	  
+(defun top-sort-node (index)
+  (when (not (psnode-appears-in-top-sort (aref narray index)))
+
+	;;; make sure the parents are processed
+	(dolist (parent (psnode-parents (aref narray index)))
+		(top-sort-parent parent))
+
+	;;; add this node to top-sort
+	(push index top-sort)
+	(setf (psnode-appears-in-top-sort (aref narray index)) t))
+
+  (when (not (psnode-children-appear-in-top-sort (aref narray index)))
+	(dolist (child (psnode-children (aref narray index)))
+		(top-sort-node child))
+	(setf (psnode-children-appear-in-top-sort (aref narray index)) t))
+)
+
+(defun top-sort-parent (index)
+  (when (not (psnode-appears-in-top-sort (aref narray index)))
+
+	;;; make sure the parents are processed
+	(dolist (parent (psnode-parents (aref narray index)))
+		(top-sort-parent parent))
+
+	;;; add this node to top-sort
+	(push index top-sort)
+	(setf (psnode-appears-in-top-sort (aref narray index)) t))
+)
+
+(defun related-classes (x y)
+  (cond ((ancestor x y) 'yes)
+	((ancestor y x) 'yes)
+	(t 'no))
+)
+
+(defun ancestor (x y)
+  (let ((cached-value (gethash (list x y) ancestor-cache)))
+    (cond (cached-value (car cached-value))
+	  (t
+	    (setq cached-value
+		  (cond ((equal x y) t)
+			(t
+			  (some #'(lambda (child) (ancestor child y))
+				(psnode-children (aref narray x))))))
+	    (setf (gethash (list x y) ancestor-cache) (list cached-value))
+	    cached-value)))
+)
diff --git a/contrib/psgraph/psgraph.log b/contrib/psgraph/psgraph.log
new file mode 100644
index 0000000000000000000000000000000000000000..2214c46483006730ea5c185b074b31324f2678ef
--- /dev/null
+++ b/contrib/psgraph/psgraph.log
@@ -0,0 +1,18 @@
+/usr1/chiles/work/psgraph.lisp, Jul-90 10:59:13, Edit by Mkant.
+  Fixed shrink mode so that it scales x and y axes uniformly (e.g., aspect
+  ratio = 1).
+
+/usr1/chiles/work/psgraph.lisp, 01-May-90 10:59:13, Edit by Chiles.
+  Made exported specials have stars.
+
+/usr1/chiles/work/psgraph.lisp, APR 90, Edit by Skef Wholey.
+  ;;;     -- Now lives in the PSGRAPH package (instead of USER, or *package*...)
+  ;;;        with user-tweakable stuff exported.
+  ;;;     -- Node equivalence function can now be specified as EQ, EQUAL,
+  ;;;        or EQUALP.
+
+/usr1/chiles/work/psgraph.lisp, DEC 88, Edit by Joseph Bates
+  Modified to include optional insert parameter to psgraph.
+
+/usr1/chiles/work/psgraph.lisp, MAR 88, Edit by Joseph Bates
+  File created.