Simtel MSDOS 1992 June/SIMTEL_0692.cdr/msdos/ddjmag/ddj8804.arc/AMSTERDA.ARC/AMSTERDA.LST

File List | 1980-01-01 | 6KB | 163 lines

Listing One.  A simple adventure game written in AAL

(loc the-first-room
"You are in a small, gloomy room lit by an unseen source above you.
The walls and floor are smooth, hard and dark, like obsidian.  Exits
lead west and south."
  (contains whistle)
  (exits
   (w the-second-room)
   (s "You have wandered around and wound up back where you started")))


(loc the-second-room
"You are in a vast chamber of ice and rock.  Fiery torches in the walls
provide an eerie light.  There is a passageway south and another exit to
the north."
  (contains monster)
  (exits
   (s "The passageway is blocked by rubble.")
   (n (((alive monster) -> "The monster won't let you pass.")
       the-first-room))))

(command blow
        (blow *obj)
        (requires ((carrying player *obj) "You don't have ~a" *obj))
        "You can't blow that!")

(command (throw hurl chuck)
        (throw *instr at *obj)
        (requires (carrying player *instr)
                  (here *obj))
        "Nothing happens."))

(obj monster fixed
     (action throw *obj
             ("The monster destroys the ~a" *instr)
             (destroy *instr)))

(obj whistle
     (action blow *obj
             "The whistle emits a piercing screech."
             ((here monster) ->
              "The monster's eyes bug out--wider--wider--and then,~
                finally, close forever."
              (dead monster))))

----------------------------------------------------------------
Listing Two. [omitted--approx. 2 pages]

----------------------------------------------------------------
Listing Three. Code for streams

(defvar *empty-stream* nil)

(defmacro delay (thing)
  `#'(lambda () ,thing))

(defun force (thing)
  (funcall thing))

(defmacro stream-cons (thing stream)
  `(cons ,thing (delay ,stream)))

(defun stream-empty? (stream)
  (eq stream *empty-stream*))

(defun stream-car (stream)
  (car stream))

(defun stream-cdr (stream)
  (force (cdr stream)))

(defmacro dostream ((var stream) &body body)
  (let ((tempvar (gensym)))
    `(do* ((,tempvar ,stream (stream-cdr ,tempvar))
           (,var (stream-car ,tempvar) (stream-car ,tempvar)))
          ((stream-empty? ,tempvar) *empty-stream*)
       ,@body)))

(defmacro stream-append (stream1 stream2)
  `(stream-append-func ,stream1 (delay ,stream2)))


(defun stream-append-func (stream delayed-stream)
  (if (stream-empty? stream)
      (force delayed-stream)
      (stream-cons (stream-car stream)
                   (stream-append-func (stream-cdr stream) delayed-stream))))

(defun stream-mapcar (function stream)
  (if (stream-empty? stream)
      *empty-stream*
      (stream-cons (funcall function (stream-car stream))
                   (stream-mapcar function (stream-cdr stream)))))

(defun stream-mapcan (function stream)
  (if (stream-empty? stream)
      *empty-stream*
      (stream-append (funcall function (stream-car stream))
                     (stream-mapcan function (stream-cdr stream)))))

(defun stream->list (stream)
  (if (stream-empty? stream)
      nil
      (cons (stream-car stream)
            (stream->list (stream-cdr stream)))))

(defun list->stream (list)
  (if (null list)
      *empty-stream*
      (stream-cons (car list)
                   (list->stream (cdr list)))))

----------------------------------------------------------------
Listing Four.  Code for the every action

(defun do-every-action (rule bindings)
  ;; Get a list of bindings for the single quantified variable, using the
  ;; antecedents; then execute the consequents for each binding.
  (let* ((quant-vars (rule-quant-vars rule)))
    (if (not (= (length quant-vars) 1))
        (error "Only one quantified variable allowed in rule ~a" rule)
        (let* ((bindings-stream (deduce (rule-antecedents rule) bindings))
               (bindings-list (stream->list bindings-stream))
               (filtered-list (mapcar #'(lambda (b) (extract-bindings b
                                                        quant-vars))
                                      bindings-list))
               (undup-list (delete-duplicate-bindings filtered-list))
               (new-bindings-list (mapcar #'(lambda (b) (append b bindings))
                                          undup-list)))
          (dolist (new-bindings new-bindings-list)
            (do-rule-actions (rule-consequents rule) new-bindings))))))


----------------------------------------------------------------
Listing Five.  The check-reqs function

(defun check-reqs (reqs bindings)
  (if (null reqs)
      t
      (let* ((req (car reqs))
             (binding-stream (deduce-pattern (requirement-pattern req)
                                              bindings))
             (fstring nil))
        (cond
          ((stream-empty? binding-stream)
           (return-from check-reqs (if (requirement-succeeded? req)
                                       nil
                                       (requirement-failure-string req))))
          (t
           (setf (requirement-succeeded? req) t)
           (dostream (binds binding-stream)
             (let ((result (check-reqs (cdr reqs) binds)))
               (if (eq result t)
                   (return-from check-reqs t)
                   (if result
                       (setq fstring result)))))
           fstring)))))