Casting SPELs in LISP, Scheme version.

casting-spels.scm

;; Casting SPELs in LISP, scheme version

(define *objects* '(whiskey-bottle bucket frog chain))

(define *map* '((living-room (Your in the living room. Its dusty and dirty.)
                             (west door garden)
                             (upstairs stairway attic))
                (garden (Your in the garden. There stands a well.)
                        (east door living-room))
                (attic (Your in the attic. There is a welding torch in the corner.)
                          (downstairs stairway living-room))))

(define *object-locations* '((whiskey-bottle living-room)
                             (bucket living-room)
                             (frog garden)
                             (chain garden)))

(define *location* 'living-room)

(define *chain-welded* #f)

(define *bucket-filled* #f)

(define (describe-location location map)
  (cadr (assoc location map)))

(define (describe-path path)
  `(There is a ,(cadr path) going ,(car path) from here.))

(define (describe-paths location the-map)
  (apply append (map describe-path (cddr (assoc location the-map)))))

(define (is-at? obj loc obj-loc)
  (eq? (cadr (assoc obj obj-loc)) loc))

(define (describe-floor loc objs obj-loc)
  (apply append (map (lambda (x)
                       `(you see a ,x on the floor.))
                     (filter (lambda (x)
                               (is-at? x loc obj-loc))
                             objs))))

(define (look)
  (append (describe-location *location* *map*)
          (describe-paths *location* *map*)
          (describe-floor *location* *objects* *object-locations*)))

(define (walk-direction direction)
  (let ((next (assoc direction (cddr (assoc *location* *map*)))))
    (cond (next (set! *location* (caddr next)) (look))
          (else '(you cant go that way.)))))

(define-syntax-rule (defspel rest ...)
  (define-syntax-rule rest ...))

(defspel (walk direction)
  (walk-direction 'direction))

(define-syntax-rule (push! object location)
  (set! location (cons object location)))

(define-syntax-rule (pop! location)
  (let ((result (car location)))
    (set! location (cdr location))
    result))

(define (pickup-object object)
  (cond ((is-at? object *location* *object-locations*)
         (push! (list object 'body) *object-locations*)
         `(You are now carrying the ,object))
        (else '(You cannot get that.))))

(defspel (pickup object)
  (pickup-object 'object))

(define (inventory)
  (filter (lambda (x)
            (is-at? x 'body *object-locations*))
          *objects*))

(define (have? object)
  (member object (inventory)))

(define (weld subject object)
  (cond ((and (eq? *location* 'attic)
              (eq? subject 'chain)
              (eq? object 'bucket)
              (have? 'chain)
              (have? 'bucket)
              (not *chain-welded*))
         (set! *chain-welded* #t)
         '(The chain is now securely welded to the bucket.))
        (else '(You cannot weld like that.))))

(define (dunk subject object)
  (cond ((and (eq? *location* 'garden)
              (eq? subject 'bucket)
              (eq? object 'well)
              (have? 'bucket)
              *chain-welded*)
         (set! *bucket-filled* #t)
         '(The bucket is now full of water))
        (else '(You cannot dunk like that.))))

(defspel (game-action command subj obj place rest ...)
  (defspel (command subject object)
    (cond ((and (eq? *location* 'place)
                (eq? 'subject 'subj)
                (eq? 'object 'obj)
                (have? 'subj))
           rest ...)
          (else '(I cant command like that.)))))

(game-action weld chain bucket attic
             (cond ((and (have 'bucket) (set! *chain-welded* #t))
                    '(The chain is now securely welded to the bucket.))
                   (else '(You do not have a bucket.))))

(game-action dunk bucket well garden
             (cond (*chain-welded* (set! *bucket-filled* #t)
                                   '(the bucket is now full of water))
                   (else '(The water level is too low to reach.))))

(game-action splash bucket wizard living-room
             (cond ((not *bucket-filled*) '(the bucket has nothing in it.))
                   ((have 'frog) '(The wizard awakens and sees that you stole his frog.
                                       he is so upset he banishes you to the
                                       netherworlds- you lose! the end.))
                   (else '(The wizard awakens from his slumber and greets you warmly.
                             he hands you the magic low-carb donut- you win! the end.))))