# This is a shell archive.  Remove anything before this line, then
# unpack it by saving it in a file and typing "sh file".  (Files
# unpacked will be owned by you and have default permissions.)
#
# This archive contains:
# fact.lsp init.lsp object.lsp prolog.lsp trace.lsp


echo x - fact.lsp
cat > "fact.lsp" << '//E*O*F fact.lsp//'
(defun factorial (n)
       (cond ((= n 1) 1)
	     (t (* n (factorial (- n 1))))))
//E*O*F fact.lsp//

echo x - init.lsp
cat > "init.lsp" << '//E*O*F init.lsp//'
; get some more memory
(expand 1)

; some fake definitions for Common Lisp pseudo compatiblity
(setq symbol-function symbol-value)
(setq fboundp boundp)
(setq first car)
(setq second cadr)
(setq rest cdr)

; some more cxr functions
(defun caddr (x) (car (cddr x)))
(defun cadddr (x) (cadr (cddr x)))

; (when test code...) - execute code when test is true
(defmacro when (test &rest code)
          `(cond (,test ,@code)))

; (unless test code...) - execute code unless test is true
(defmacro unless (test &rest code)
          `(cond ((not ,test) ,@code)))

; (makunbound sym) - make a symbol be unbound
(defun makunbound (sym) (setq sym '*unbound*) sym)

; (objectp expr) - object predicate
(defun objectp (x) (eq (type x) 'OBJ))

; (filep expr) - file predicate
(defun filep (x) (eq (type x) 'FPTR))

; (unintern sym) - remove a symbol from the oblist
(defun unintern (sym) (cond ((member sym *oblist*)
                             (setq *oblist* (delete sym *oblist*))
                             t)
                            (t nil)))

; (mapcan ...)
(defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))

; (mapcon ...)
(defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))

; (save fun) - save a function definition to a file
(defun save (fun)
       (let* ((fname (strcat (symbol-name fun) ".lsp"))
              (fp (openo fname)))
             (cond (fp (print (cons (if (eq (car (eval fun)) 'lambda)
                                        'defun
                                        'defmacro)
                                    (cons fun (cdr (eval fun)))) fp)
                       (close fp)
                       fname)
                   (t nil))))

; (debug) - enable debug breaks
(defun debug ()
       (setq *breakenable* t))

; (nodebug) - disable debug breaks
(defun nodebug ()
       (setq *breakenable* nil))

; initialize to enable breaks but no trace back
(setq *breakenable* t)
(setq *tracenable* nil)
//E*O*F init.lsp//

echo x - object.lsp
cat > "object.lsp" << '//E*O*F object.lsp//'
; This is an example using the object-oriented programming support in
; XLISP.  The example involves defining a class of objects representing
; dictionaries.  Each instance of this class will be a dictionary in
; which names and values can be stored.  There will also be a facility
; for finding the values associated with names after they have been
; stored.

; Create the 'Dictionary' class.

(setq Dictionary (Class 'new))

; Establish the instance variables for the new class.
; The variable 'entries' will point to an association list representing the
; entries in the dictionary instance.

(Dictionary 'ivars '(entries))

; Setup the method for the 'isnew' initialization message.
; This message will be send whenever a new instance of the 'Dictionary'
; class is created.  Its purpose is to allow the new instance to be
; initialized before any other messages are sent to it.  It sets the value
; of 'entries' to nil to indicate that the dictionary is empty.

(Dictionary 'answer 'isnew '()
	    '((setq entries nil)
	      self))

; Define the message 'add' to make a new entry in the dictionary.  This
; message takes two arguments.  The argument 'name' specifies the name
; of the new entry; the argument 'value' specifies the value to be
; associated with that name.

(Dictionary 'answer 'add '(name value)
	    '((setq entries
	            (cons (cons name value) entries))
	      value))

; Create an instance of the 'Dictionary' class.  This instance is an empty
; dictionary to which words may be added.

(setq d (Dictionary 'new))

; Add some entries to the new dictionary.

(d 'add 'mozart 'composer)
(d 'add 'winston 'computer-scientist)

; Define a message to find entries in a dictionary.  This message takes
; one argument 'name' which specifies the name of the entry for which to
; search.  It returns the value associated with the entry if one is
; present in the dictionary.  Otherwise, it returns nil.

(Dictionary 'answer 'find '(name &aux entry)
	    '((cond ((setq entry (assoc name entries))
	      (cdr entry))
	     (t
	      nil))))

; Try to find some entries in the dictionary we created.

(d 'find 'mozart)
(d 'find 'winston)
(d 'find 'bozo)

; The names 'mozart' and 'winston' are found in the dictionary so their
; values 'composer' and 'computer-scientist' are returned.  The name 'bozo'
; is not found so nil is returned in this case.
//E*O*F object.lsp//

echo x - prolog.lsp
cat > "prolog.lsp" << '//E*O*F prolog.lsp//'

;; The following is a tiny Prolog interpreter in MacLisp
;; written by Ken Kahn and modified for XLISP by David Betz.
;; It was inspired by other tiny Lisp-based Prologs of
;; Par Emanuelson and Martin Nilsson.
;; There are no side-effects anywhere in the implementation.
;; Though it is VERY slow of course.

(defun prolog (database &aux goal)
       (do () ((not (progn (princ "Query?") (setq goal (read)))))
              (prove (list (rename-variables goal '(0)))
                     '((bottom-of-environment))
                     database
                     1)))

;; prove - proves the conjunction of the list-of-goals
;;         in the current environment

(defun prove (list-of-goals environment database level)
      (cond ((null list-of-goals) ;; succeeded since there are no goals
             (print-bindings environment environment)
             (not (y-or-n-p "More?")))
            (t (try-each database database
                         (cdr list-of-goals) (car list-of-goals)
                         environment level))))

(defun try-each (database-left database goals-left goal environment level 
                 &aux assertion new-enviroment)
       (cond ((null database-left) nil) ;; fail since nothing left in database
             (t (setq assertion
                      (rename-variables (car database-left)
                                        (list level)))
                (setq new-environment
                      (unify goal (car assertion) environment))
                (cond ((null new-environment) ;; failed to unify
                       (try-each (cdr database-left) database
                                 goals-left goal
                                 environment level))
                      ((prove (append (cdr assertion) goals-left)
                              new-environment
                              database
                              (+ 1 level)))
                      (t (try-each (cdr database-left) database
                                   goals-left goal
                                   environment level))))))

(defun unify (x y environment &aux new-environment)
       (setq x (value x environment))
       (setq y (value y environment))
       (cond ((variable-p x) (cons (list x y) environment))
             ((variable-p y) (cons (list y x) environment))
             ((or (atom x) (atom y))
                  (cond ((equal x y) environment)
    	                (t nil)))
             (t (setq new-environment (unify (car x) (car y) environment))
                (cond (new-environment (unify (cdr x) (cdr y) new-environment))
    		      (t nil)))))

(defun value (x environment &aux binding)
       (cond ((variable-p x)
              (setq binding (assoc x environment))
              (cond ((null binding) x)
                    (t (value (cadr binding) environment))))
             (t x)))

(defun variable-p (x)
       (and x (listp x) (eq (car x) '?)))

(defun rename-variables (term list-of-level)
       (cond ((variable-p term) (append term list-of-level))
             ((atom term) term)
             (t (cons (rename-variables (car term) list-of-level)
                      (rename-variables (cdr term) list-of-level)))))

(defun print-bindings (environment-left environment)
       (cond ((cdr environment-left)
              (cond ((= 0 (nth 2 (caar environment-left)))
                     (prin1 (cadr (caar environment-left)))
                     (princ " = ")
                     (print (value (caar environment-left) environment))))
              (print-bindings (cdr environment-left) environment))))

;; a sample database:
(setq db '(((father madelyn ernest))
           ((mother madelyn virginia))
	   ((father david arnold))
	   ((mother david pauline))
	   ((father rachel david))
	   ((mother rachel madelyn))
           ((grandparent (? grandparent) (? grandchild))
            (parent (? grandparent) (? parent))
            (parent (? parent) (? grandchild)))
           ((parent (? parent) (? child))
            (mother (? parent) (? child)))
           ((parent (? parent) (? child))
            (father (? parent) (? child)))))

;; the following are utilities
(defun y-or-n-p (prompt)
       (princ prompt)
       (eq (read) 'y))

;; start things going
(prolog db)
//E*O*F prolog.lsp//

echo x - trace.lsp
cat > "trace.lsp" << '//E*O*F trace.lsp//'
(setq *tracelist* nil)

(defun evalhookfcn (expr &aux val)
       (if (and (consp expr) (member (car expr) *tracelist*))
           (progn (princ ">>> ") (print expr)
                  (setq val (evalhook expr evalhookfcn nil))
                  (princ "<<< ") (print val))
           (evalhook expr evalhookfcn nil)))

(defun trace (fun)
       (if (not (member fun *tracelist*))
	   (progn (setq *tracelist* (cons fun *tracelist*))
                  (setq *evalhook* evalhookfcn)))
       *tracelist*)

(defun untrace (fun)
       (if (null (setq *tracelist* (delete fun *tracelist*)))
           (setq *evalhook* nil))
       *tracelist*)
//E*O*F trace.lsp//

echo Possible errors detected by \'wc\' [hopefully none]:
temp=/tmp/shar$$
trap "rm -f $temp; exit" 0 1 2 3 15
cat > $temp <<\!!!
      3     15     84 fact.lsp
     66    261   1959 init.lsp
     67    387   2374 object.lsp
    104    425   4289 prolog.lsp
     19     69    642 trace.lsp
    259   1157   9348 total
!!!
wc fact.lsp init.lsp object.lsp prolog.lsp trace.lsp | sed 's=[^ ]*/==' | diff -b $temp -
exit 0