home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / xlisp / XLisp 1.4 / xlisp.examples < prev   
Encoding:
Text File  |  1985-02-07  |  9.6 KB  |  281 lines  |  [TEXT/MACA]
  1. /* Written  2:29 am  Jan 31, 1985 by winkler@harvard in uiucdcs:net.sources.mac */
  2. /* ---------- "xlisp 1.4 examples" ---------- */
  3. Here are example programs written for xlisp version 1.4.  The file init.lsp
  4. is automatically loaded at run time.
  5.  
  6. ::::::::::::::
  7. fact.lsp
  8. ::::::::::::::
  9. (defun factorial (n)
  10.        (cond ((= n 1) 1)
  11.          (t (* n (factorial (- n 1))))))
  12. ::::::::::::::
  13. init.lsp
  14. ::::::::::::::
  15. ; get some more memory
  16. (expand 1)
  17.  
  18. ; some fake definitions for Common Lisp pseudo compatiblity
  19. (setq symbol-function symbol-value)
  20. (setq fboundp boundp)
  21. (setq first car)
  22. (setq second cadr)
  23. (setq rest cdr)
  24.  
  25. ; some more cxr functions
  26. (defun caddr (x) (car (cddr x)))
  27. (defun cadddr (x) (cadr (cddr x)))
  28.  
  29. ; (when test code...) - execute code when test is true
  30. (defmacro when (test &rest code)
  31.           `(cond (,test ,@code)))
  32.  
  33. ; (unless test code...) - execute code unless test is true
  34. (defmacro unless (test &rest code)
  35.           `(cond ((not ,test) ,@code)))
  36.  
  37. ; (makunbound sym) - make a symbol be unbound
  38. (defun makunbound (sym) (setq sym '*unbound*) sym)
  39.  
  40. ; (objectp expr) - object predicate
  41. (defun objectp (x) (eq (type x) 'OBJ))
  42.  
  43. ; (filep expr) - file predicate
  44. (defun filep (x) (eq (type x) 'FPTR))
  45.  
  46. ; (unintern sym) - remove a symbol from the oblist
  47. (defun unintern (sym) (cond ((member sym *oblist*)
  48.                              (setq *oblist* (delete sym *oblist*))
  49.                              t)
  50.                             (t nil)))
  51.  
  52. ; (mapcan ...)
  53. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  54.  
  55. ; (mapcon ...)
  56. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  57.  
  58. ; (save fun) - save a function definition to a file
  59. (defun save (fun)
  60.        (let* ((fname (strcat (symbol-name fun) ".lsp"))
  61.               (fp (openo fname)))
  62.              (cond (fp (print (cons (if (eq (car (eval fun)) 'lambda)
  63.                                         'defun
  64.                                         'defmacro)
  65.                                     (cons fun (cdr (eval fun)))) fp)
  66.                        (close fp)
  67.                        fname)
  68.                    (t nil))))
  69.  
  70. ; (debug) - enable debug breaks
  71. (defun debug ()
  72.        (setq *breakenable* t))
  73.  
  74. ; (nodebug) - disable debug breaks
  75. (defun nodebug ()
  76.        (setq *breakenable* nil))
  77.  
  78. ; initialize to enable breaks but no trace back
  79. (setq *breakenable* t)
  80. (setq *tracenable* nil)
  81. ::::::::::::::
  82. object.lsp
  83. ::::::::::::::
  84. ; This is an example using the object-oriented programming support in
  85. ; XLISP.  The example involves defining a class of objects representing
  86. ; dictionaries.  Each instance of this class will be a dictionary in
  87. ; which names and values can be stored.  There will also be a facility
  88. ; for finding the values associated with names after they have been
  89. ; stored.
  90.  
  91. ; Create the 'Dictionary' class.
  92.  
  93. (setq Dictionary (Class 'new))
  94.  
  95. ; Establish the instance variables for the new class.
  96. ; The variable 'entries' will point to an association list representing the
  97. ; entries in the dictionary instance.
  98.  
  99. (Dictionary 'ivars '(entries))
  100.  
  101. ; Setup the method for the 'isnew' initialization message.
  102. ; This message will be send whenever a new instance of the 'Dictionary'
  103. ; class is created.  Its purpose is to allow the new instance to be
  104. ; initialized before any other messages are sent to it.  It sets the value
  105. ; of 'entries' to nil to indicate that the dictionary is empty.
  106.  
  107. (Dictionary 'answer 'isnew '()
  108.         '((setq entries nil)
  109.           self))
  110.  
  111. ; Define the message 'add' to make a new entry in the dictionary.  This
  112. ; message takes two arguments.  The argument 'name' specifies the name
  113. ; of the new entry; the argument 'value' specifies the value to be
  114. ; associated with that name.
  115.  
  116. (Dictionary 'answer 'add '(name value)
  117.         '((setq entries
  118.                 (cons (cons name value) entries))
  119.           value))
  120.  
  121. ; Create an instance of the 'Dictionary' class.  This instance is an empty
  122. ; dictionary to which words may be added.
  123.  
  124. (setq d (Dictionary 'new))
  125.  
  126. ; Add some entries to the new dictionary.
  127.  
  128. (d 'add 'mozart 'composer)
  129. (d 'add 'winston 'computer-scientist)
  130.  
  131. ; Define a message to find entries in a dictionary.  This message takes
  132. ; one argument 'name' which specifies the name of the entry for which to
  133. ; search.  It returns the value associated with the entry if one is
  134. ; present in the dictionary.  Otherwise, it returns nil.
  135.  
  136. (Dictionary 'answer 'find '(name &aux entry)
  137.         '((cond ((setq entry (assoc name entries))
  138.           (cdr entry))
  139.          (t
  140.           nil))))
  141.  
  142. ; Try to find some entries in the dictionary we created.
  143.  
  144. (d 'find 'mozart)
  145. (d 'find 'winston)
  146. (d 'find 'bozo)
  147.  
  148. ; The names 'mozart' and 'winston' are found in the dictionary so their
  149. ; values 'composer' and 'computer-scientist' are returned.  The name 'bozo'
  150. ; is not found so nil is returned in this case.
  151. ::::::::::::::
  152. prolog.lsp
  153. ::::::::::::::
  154.  
  155. ;; The following is a tiny Prolog interpreter in MacLisp
  156. ;; written by Ken Kahn and modified for XLISP by David Betz.
  157. ;; It was inspired by other tiny Lisp-based Prologs of
  158. ;; Par Emanuelson and Martin Nilsson.
  159. ;; There are no side-effects anywhere in the implementation.
  160. ;; Though it is VERY slow of course.
  161.  
  162. (defun prolog (database &aux goal)
  163.        (do () ((not (progn (princ "Query?") (setq goal (read)))))
  164.               (prove (list (rename-variables goal '(0)))
  165.                      '((bottom-of-environment))
  166.                      database
  167.                      1)))
  168.  
  169. ;; prove - proves the conjunction of the list-of-goals
  170. ;;         in the current environment
  171.  
  172. (defun prove (list-of-goals environment database level)
  173.       (cond ((null list-of-goals) ;; succeeded since there are no goals
  174.              (print-bindings environment environment)
  175.              (not (y-or-n-p "More?")))
  176.             (t (try-each database database
  177.                          (cdr list-of-goals) (car list-of-goals)
  178.                          environment level))))
  179.  
  180. (defun try-each (database-left database goals-left goal environment level 
  181.                  &aux assertion new-enviroment)
  182.        (cond ((null database-left) nil) ;; fail since nothing left in database
  183.              (t (setq assertion
  184.                       (rename-variables (car database-left)
  185.                                         (list level)))
  186.                 (setq new-environment
  187.                       (unify goal (car assertion) environment))
  188.                 (cond ((null new-environment) ;; failed to unify
  189.                        (try-each (cdr database-left) database
  190.                                  goals-left goal
  191.                                  environment level))
  192.                       ((prove (append (cdr assertion) goals-left)
  193.                               new-environment
  194.                               database
  195.                               (+ 1 level)))
  196.                       (t (try-each (cdr database-left) database
  197.                                    goals-left goal
  198.                                    environment level))))))
  199.  
  200. (defun unify (x y environment &aux new-environment)
  201.        (setq x (value x environment))
  202.        (setq y (value y environment))
  203.        (cond ((variable-p x) (cons (list x y) environment))
  204.              ((variable-p y) (cons (list y x) environment))
  205.              ((or (atom x) (atom y))
  206.                   (cond ((equal x y) environment)
  207.                         (t nil)))
  208.              (t (setq new-environment (unify (car x) (car y) environment))
  209.                 (cond (new-environment (unify (cdr x) (cdr y) new-environment))
  210.                   (t nil)))))
  211.  
  212. (defun value (x environment &aux binding)
  213.        (cond ((variable-p x)
  214.               (setq binding (assoc x environment))
  215.               (cond ((null binding) x)
  216.                     (t (value (cadr binding) environment))))
  217.              (t x)))
  218.  
  219. (defun variable-p (x)
  220.        (and x (listp x) (eq (car x) '?)))
  221.  
  222. (defun rename-variables (term list-of-level)
  223.        (cond ((variable-p term) (append term list-of-level))
  224.              ((atom term) term)
  225.              (t (cons (rename-variables (car term) list-of-level)
  226.                       (rename-variables (cdr term) list-of-level)))))
  227.  
  228. (defun print-bindings (environment-left environment)
  229.        (cond ((cdr environment-left)
  230.               (cond ((= 0 (nth 2 (caar environment-left)))
  231.                      (prin1 (cadr (caar environment-left)))
  232.                      (princ " = ")
  233.                      (print (value (caar environment-left) environment))))
  234.               (print-bindings (cdr environment-left) environment))))
  235.  
  236. ;; a sample database:
  237. (setq db '(((father madelyn ernest))
  238.            ((mother madelyn virginia))
  239.        ((father david arnold))
  240.        ((mother david pauline))
  241.        ((father rachel david))
  242.        ((mother rachel madelyn))
  243.            ((grandparent (? grandparent) (? grandchild))
  244.             (parent (? grandparent) (? parent))
  245.             (parent (? parent) (? grandchild)))
  246.            ((parent (? parent) (? child))
  247.             (mother (? parent) (? child)))
  248.            ((parent (? parent) (? child))
  249.             (father (? parent) (? child)))))
  250.  
  251. ;; the following are utilities
  252. (defun y-or-n-p (prompt)
  253.        (princ prompt)
  254.        (eq (read) 'y))
  255.  
  256. ;; start things going
  257. (prolog db)
  258. ::::::::::::::
  259. trace.lsp
  260. ::::::::::::::
  261. (setq *tracelist* nil)
  262.  
  263. (defun evalhookfcn (expr &aux val)
  264.        (if (and (consp expr) (member (car expr) *tracelist*))
  265.            (progn (princ ">>> ") (print expr)
  266.                   (setq val (evalhook expr evalhookfcn nil))
  267.                   (princ "<<< ") (print val))
  268.            (evalhook expr evalhookfcn nil)))
  269.  
  270. (defun trace (fun)
  271.        (if (not (member fun *tracelist*))
  272.        (progn (setq *tracelist* (cons fun *tracelist*))
  273.                   (setq *evalhook* evalhookfcn)))
  274.        *tracelist*)
  275.  
  276. (defun untrace (fun)
  277.        (if (null (setq *tracelist* (delete fun *tracelist*)))
  278.            (setq *evalhook* nil))
  279.        *tracelist*)
  280. /* End of text from uiucdcs:net.sources.mac */
  281.