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 '¬)) + +(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 '¬)) (promote-var vdope))) + (go la) + lb (and kind (build-beta kind tlist)) + (or (eq kind '¬) (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 ¬) :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 ¬ (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.