home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1988 / 04 / amsterda / amsterda.lst < prev   
File List  |  1979-12-31  |  6KB  |  163 lines
  1.  
  2.  
  3.  
  4. Listing One.  A simple adventure game written in AAL
  5.  
  6. (loc the-first-room
  7. "You are in a small, gloomy room lit by an unseen source above you.
  8. The walls and floor are smooth, hard and dark, like obsidian.  Exits
  9. lead west and south."
  10.   (contains whistle)
  11.   (exits
  12.    (w the-second-room)
  13.    (s "You have wandered around and wound up back where you started")))
  14.  
  15.  
  16. (loc the-second-room
  17. "You are in a vast chamber of ice and rock.  Fiery torches in the walls 
  18. provide an eerie light.  There is a passageway south and another exit to
  19. the north."
  20.   (contains monster)
  21.   (exits
  22.    (s "The passageway is blocked by rubble.")
  23.    (n (((alive monster) -> "The monster won't let you pass.")
  24.        the-first-room))))
  25.  
  26. (command blow
  27.         (blow *obj)
  28.         (requires ((carrying player *obj) "You don't have ~a" *obj))
  29.         "You can't blow that!")
  30.  
  31. (command (throw hurl chuck)
  32.         (throw *instr at *obj)
  33.         (requires (carrying player *instr)
  34.                   (here *obj))
  35.         "Nothing happens."))
  36.  
  37. (obj monster fixed
  38.      (action throw *obj
  39.              ("The monster destroys the ~a" *instr) 
  40.              (destroy *instr)))
  41.  
  42. (obj whistle
  43.      (action blow *obj
  44.              "The whistle emits a piercing screech."
  45.              ((here monster) -> 
  46.               "The monster's eyes bug out--wider--wider--and then,~
  47.                 finally, close forever."
  48.               (dead monster))))
  49.  
  50. ----------------------------------------------------------------
  51. Listing Two. [omitted--approx. 2 pages]
  52.  
  53. ----------------------------------------------------------------
  54. Listing Three. Code for streams
  55.  
  56. (defvar *empty-stream* nil)
  57.  
  58. (defmacro delay (thing)
  59.   `#'(lambda () ,thing))
  60.  
  61. (defun force (thing)
  62.   (funcall thing))
  63.  
  64. (defmacro stream-cons (thing stream)
  65.   `(cons ,thing (delay ,stream)))
  66.  
  67. (defun stream-empty? (stream)
  68.   (eq stream *empty-stream*))
  69.  
  70. (defun stream-car (stream)
  71.   (car stream))
  72.  
  73. (defun stream-cdr (stream)
  74.   (force (cdr stream)))
  75.  
  76. (defmacro dostream ((var stream) &body body)
  77.   (let ((tempvar (gensym)))
  78.     `(do* ((,tempvar ,stream (stream-cdr ,tempvar))
  79.            (,var (stream-car ,tempvar) (stream-car ,tempvar)))
  80.           ((stream-empty? ,tempvar) *empty-stream*)
  81.        ,@body)))
  82.  
  83. (defmacro stream-append (stream1 stream2)
  84.   `(stream-append-func ,stream1 (delay ,stream2)))
  85.  
  86.  
  87. (defun stream-append-func (stream delayed-stream)
  88.   (if (stream-empty? stream)
  89.       (force delayed-stream)
  90.       (stream-cons (stream-car stream)
  91.                    (stream-append-func (stream-cdr stream) delayed-stream))))
  92.  
  93. (defun stream-mapcar (function stream)
  94.   (if (stream-empty? stream)
  95.       *empty-stream*
  96.       (stream-cons (funcall function (stream-car stream))
  97.                    (stream-mapcar function (stream-cdr stream)))))
  98.  
  99. (defun stream-mapcan (function stream)
  100.   (if (stream-empty? stream)
  101.       *empty-stream*
  102.       (stream-append (funcall function (stream-car stream))
  103.                      (stream-mapcan function (stream-cdr stream)))))
  104.  
  105. (defun stream->list (stream)
  106.   (if (stream-empty? stream)
  107.       nil
  108.       (cons (stream-car stream)
  109.             (stream->list (stream-cdr stream)))))
  110.  
  111. (defun list->stream (list)
  112.   (if (null list)
  113.       *empty-stream*
  114.       (stream-cons (car list)
  115.                    (list->stream (cdr list)))))
  116.  
  117. ----------------------------------------------------------------
  118. Listing Four.  Code for the every action
  119.  
  120. (defun do-every-action (rule bindings)
  121.   ;; Get a list of bindings for the single quantified variable, using the
  122.   ;; antecedents; then execute the consequents for each binding.
  123.   (let* ((quant-vars (rule-quant-vars rule)))
  124.     (if (not (= (length quant-vars) 1))
  125.         (error "Only one quantified variable allowed in rule ~a" rule)
  126.         (let* ((bindings-stream (deduce (rule-antecedents rule) bindings))
  127.                (bindings-list (stream->list bindings-stream))
  128.                (filtered-list (mapcar #'(lambda (b) (extract-bindings b 
  129.                                                         quant-vars))
  130.                                       bindings-list))
  131.                (undup-list (delete-duplicate-bindings filtered-list))
  132.                (new-bindings-list (mapcar #'(lambda (b) (append b bindings))
  133.                                           undup-list)))
  134.           (dolist (new-bindings new-bindings-list)
  135.             (do-rule-actions (rule-consequents rule) new-bindings))))))
  136.  
  137.  
  138. ----------------------------------------------------------------
  139. Listing Five.  The check-reqs function
  140.  
  141. (defun check-reqs (reqs bindings)
  142.   (if (null reqs)
  143.       t
  144.       (let* ((req (car reqs))
  145.              (binding-stream (deduce-pattern (requirement-pattern req) 
  146.                                               bindings))
  147.              (fstring nil))
  148.         (cond
  149.           ((stream-empty? binding-stream)
  150.            (return-from check-reqs (if (requirement-succeeded? req)
  151.                                        nil
  152.                                        (requirement-failure-string req))))
  153.           (t
  154.            (setf (requirement-succeeded? req) t)
  155.            (dostream (binds binding-stream)
  156.              (let ((result (check-reqs (cdr reqs) binds)))
  157.                (if (eq result t)
  158.                    (return-from check-reqs t)
  159.                    (if result
  160.                        (setq fstring result)))))
  161.            fstring)))))
  162.  
  163.