xlisp v1.4 (2 of 5)
Chuck Wegrzyn
wegrzyn at encore.UUCP
Wed Mar 13 23:51:25 AEST 1985
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# fact.lsp
# init.lsp
# object.lsp
# prolog.lsp
# trace.lsp
# This archive created: Wed Mar 13 08:44:34 1985
echo shar: extracting fact.lsp '(84 characters)'
sed 's/^XX//' << \SHAR_EOF > fact.lsp
XX(defun factorial (n)
XX (cond ((= n 1) 1)
XX (t (* n (factorial (- n 1))))))
SHAR_EOF
if test 84 -ne "`wc -c fact.lsp`"
then
echo shar: error transmitting fact.lsp '(should have been 84 characters)'
fi
echo shar: extracting init.lsp '(1959 characters)'
sed 's/^XX//' << \SHAR_EOF > init.lsp
XX; get some more memory
XX(expand 1)
XX
XX; some fake definitions for Common Lisp pseudo compatiblity
XX(setq symbol-function symbol-value)
XX(setq fboundp boundp)
XX(setq first car)
XX(setq second cadr)
XX(setq rest cdr)
XX
XX; some more cxr functions
XX(defun caddr (x) (car (cddr x)))
XX(defun cadddr (x) (cadr (cddr x)))
XX
XX; (when test code...) - execute code when test is true
XX(defmacro when (test &rest code)
XX `(cond (,test , at code)))
XX
XX; (unless test code...) - execute code unless test is true
XX(defmacro unless (test &rest code)
XX `(cond ((not ,test) , at code)))
XX
XX; (makunbound sym) - make a symbol be unbound
XX(defun makunbound (sym) (setq sym '*unbound*) sym)
XX
XX; (objectp expr) - object predicate
XX(defun objectp (x) (eq (type x) 'OBJ))
XX
XX; (filep expr) - file predicate
XX(defun filep (x) (eq (type x) 'FPTR))
XX
XX; (unintern sym) - remove a symbol from the oblist
XX(defun unintern (sym) (cond ((member sym *oblist*)
XX (setq *oblist* (delete sym *oblist*))
XX t)
XX (t nil)))
XX
XX; (mapcan ...)
XX(defmacro mapcan (&rest args) `(apply #'nconc (mapcar , at args)))
XX
XX; (mapcon ...)
XX(defmacro mapcon (&rest args) `(apply #'nconc (maplist , at args)))
XX
XX; (save fun) - save a function definition to a file
XX(defun save (fun)
XX (let* ((fname (strcat (symbol-name fun) ".lsp"))
XX (fp (openo fname)))
XX (cond (fp (print (cons (if (eq (car (eval fun)) 'lambda)
XX 'defun
XX 'defmacro)
XX (cons fun (cdr (eval fun)))) fp)
XX (close fp)
XX fname)
XX (t nil))))
XX
XX; (debug) - enable debug breaks
XX(defun debug ()
XX (setq *breakenable* t))
XX
XX; (nodebug) - disable debug breaks
XX(defun nodebug ()
XX (setq *breakenable* nil))
XX
XX; initialize to enable breaks but no trace back
XX(setq *breakenable* t)
XX(setq *tracenable* nil)
SHAR_EOF
if test 1959 -ne "`wc -c init.lsp`"
then
echo shar: error transmitting init.lsp '(should have been 1959 characters)'
fi
echo shar: extracting object.lsp '(2374 characters)'
sed 's/^XX//' << \SHAR_EOF > object.lsp
XX; This is an example using the object-oriented programming support in
XX; XLISP. The example involves defining a class of objects representing
XX; dictionaries. Each instance of this class will be a dictionary in
XX; which names and values can be stored. There will also be a facility
XX; for finding the values associated with names after they have been
XX; stored.
XX
XX; Create the 'Dictionary' class.
XX
XX(setq Dictionary (Class 'new))
XX
XX; Establish the instance variables for the new class.
XX; The variable 'entries' will point to an association list representing the
XX; entries in the dictionary instance.
XX
XX(Dictionary 'ivars '(entries))
XX
XX; Setup the method for the 'isnew' initialization message.
XX; This message will be send whenever a new instance of the 'Dictionary'
XX; class is created. Its purpose is to allow the new instance to be
XX; initialized before any other messages are sent to it. It sets the value
XX; of 'entries' to nil to indicate that the dictionary is empty.
XX
XX(Dictionary 'answer 'isnew '()
XX '((setq entries nil)
XX self))
XX
XX; Define the message 'add' to make a new entry in the dictionary. This
XX; message takes two arguments. The argument 'name' specifies the name
XX; of the new entry; the argument 'value' specifies the value to be
XX; associated with that name.
XX
XX(Dictionary 'answer 'add '(name value)
XX '((setq entries
XX (cons (cons name value) entries))
XX value))
XX
XX; Create an instance of the 'Dictionary' class. This instance is an empty
XX; dictionary to which words may be added.
XX
XX(setq d (Dictionary 'new))
XX
XX; Add some entries to the new dictionary.
XX
XX(d 'add 'mozart 'composer)
XX(d 'add 'winston 'computer-scientist)
XX
XX; Define a message to find entries in a dictionary. This message takes
XX; one argument 'name' which specifies the name of the entry for which to
XX; search. It returns the value associated with the entry if one is
XX; present in the dictionary. Otherwise, it returns nil.
XX
XX(Dictionary 'answer 'find '(name &aux entry)
XX '((cond ((setq entry (assoc name entries))
XX (cdr entry))
XX (t
XX nil))))
XX
XX; Try to find some entries in the dictionary we created.
XX
XX(d 'find 'mozart)
XX(d 'find 'winston)
XX(d 'find 'bozo)
XX
XX; The names 'mozart' and 'winston' are found in the dictionary so their
XX; values 'composer' and 'computer-scientist' are returned. The name 'bozo'
XX; is not found so nil is returned in this case.
SHAR_EOF
if test 2374 -ne "`wc -c object.lsp`"
then
echo shar: error transmitting object.lsp '(should have been 2374 characters)'
fi
echo shar: extracting prolog.lsp '(4289 characters)'
sed 's/^XX//' << \SHAR_EOF > prolog.lsp
XX
XX;; The following is a tiny Prolog interpreter in MacLisp
XX;; written by Ken Kahn and modified for XLISP by David Betz.
XX;; It was inspired by other tiny Lisp-based Prologs of
XX;; Par Emanuelson and Martin Nilsson.
XX;; There are no side-effects anywhere in the implementation.
XX;; Though it is VERY slow of course.
XX
XX(defun prolog (database &aux goal)
XX (do () ((not (progn (princ "Query?") (setq goal (read)))))
XX (prove (list (rename-variables goal '(0)))
XX '((bottom-of-environment))
XX database
XX 1)))
XX
XX;; prove - proves the conjunction of the list-of-goals
XX;; in the current environment
XX
XX(defun prove (list-of-goals environment database level)
XX (cond ((null list-of-goals) ;; succeeded since there are no goals
XX (print-bindings environment environment)
XX (not (y-or-n-p "More?")))
XX (t (try-each database database
XX (cdr list-of-goals) (car list-of-goals)
XX environment level))))
XX
XX(defun try-each (database-left database goals-left goal environment level
XX &aux assertion new-enviroment)
XX (cond ((null database-left) nil) ;; fail since nothing left in database
XX (t (setq assertion
XX (rename-variables (car database-left)
XX (list level)))
XX (setq new-environment
XX (unify goal (car assertion) environment))
XX (cond ((null new-environment) ;; failed to unify
XX (try-each (cdr database-left) database
XX goals-left goal
XX environment level))
XX ((prove (append (cdr assertion) goals-left)
XX new-environment
XX database
XX (+ 1 level)))
XX (t (try-each (cdr database-left) database
XX goals-left goal
XX environment level))))))
XX
XX(defun unify (x y environment &aux new-environment)
XX (setq x (value x environment))
XX (setq y (value y environment))
XX (cond ((variable-p x) (cons (list x y) environment))
XX ((variable-p y) (cons (list y x) environment))
XX ((or (atom x) (atom y))
XX (cond ((equal x y) environment)
XX (t nil)))
XX (t (setq new-environment (unify (car x) (car y) environment))
XX (cond (new-environment (unify (cdr x) (cdr y) new-environment))
XX (t nil)))))
XX
XX(defun value (x environment &aux binding)
XX (cond ((variable-p x)
XX (setq binding (assoc x environment))
XX (cond ((null binding) x)
XX (t (value (cadr binding) environment))))
XX (t x)))
XX
XX(defun variable-p (x)
XX (and x (listp x) (eq (car x) '?)))
XX
XX(defun rename-variables (term list-of-level)
XX (cond ((variable-p term) (append term list-of-level))
XX ((atom term) term)
XX (t (cons (rename-variables (car term) list-of-level)
XX (rename-variables (cdr term) list-of-level)))))
XX
XX(defun print-bindings (environment-left environment)
XX (cond ((cdr environment-left)
XX (cond ((= 0 (nth 2 (caar environment-left)))
XX (prin1 (cadr (caar environment-left)))
XX (princ " = ")
XX (print (value (caar environment-left) environment))))
XX (print-bindings (cdr environment-left) environment))))
XX
XX;; a sample database:
XX(setq db '(((father madelyn ernest))
XX ((mother madelyn virginia))
XX ((father david arnold))
XX ((mother david pauline))
XX ((father rachel david))
XX ((mother rachel madelyn))
XX ((grandparent (? grandparent) (? grandchild))
XX (parent (? grandparent) (? parent))
XX (parent (? parent) (? grandchild)))
XX ((parent (? parent) (? child))
XX (mother (? parent) (? child)))
XX ((parent (? parent) (? child))
XX (father (? parent) (? child)))))
XX
XX;; the following are utilities
XX(defun y-or-n-p (prompt)
XX (princ prompt)
XX (eq (read) 'y))
XX
XX;; start things going
XX(prolog db)
SHAR_EOF
if test 4289 -ne "`wc -c prolog.lsp`"
then
echo shar: error transmitting prolog.lsp '(should have been 4289 characters)'
fi
echo shar: extracting trace.lsp '(642 characters)'
sed 's/^XX//' << \SHAR_EOF > trace.lsp
XX(setq *tracelist* nil)
XX
XX(defun evalhookfcn (expr &aux val)
XX (if (and (consp expr) (member (car expr) *tracelist*))
XX (progn (princ ">>> ") (print expr)
XX (setq val (evalhook expr evalhookfcn nil))
XX (princ "<<< ") (print val))
XX (evalhook expr evalhookfcn nil)))
XX
XX(defun trace (fun)
XX (if (not (member fun *tracelist*))
XX (progn (setq *tracelist* (cons fun *tracelist*))
XX (setq *evalhook* evalhookfcn)))
XX *tracelist*)
XX
XX(defun untrace (fun)
XX (if (null (setq *tracelist* (delete fun *tracelist*)))
XX (setq *evalhook* nil))
XX *tracelist*)
SHAR_EOF
if test 642 -ne "`wc -c trace.lsp`"
then
echo shar: error transmitting trace.lsp '(should have been 642 characters)'
fi
# End of shell archive
exit 0
More information about the Comp.sources.unix
mailing list