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