[plt-scheme] Casting SPELs in Lisp^H^H^H^H Scheme

In case someone is interested in translating
http://www.lisperati.com/casting.html -- here's the code, translated
to PLT.

-------------------------------------------------------------------------------
#lang scheme

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

(define *map*
  '((living-room (you are in the living-room of a wizards house. there is a wizard snoring loudly on the couch.)
                 (west door garden)
                 (upstairs stairway attic))
    (garden (you are in a beautiful garden. there is a well in front of you.)
            (east door living-room))
    (attic (you are in the attic of the abandoned house. there is a giant welding torch in the corner.)
           (downstairs stairway living-room))))

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

(define *location* 'living-room)

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

(define (describe-path path)
  `(there is a ,(second path) going ,(first path) from here.))

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

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

(define (describe-floor loc objs obj-loc)
  (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* (third next)) (look)]
          [else '(you cant go that way.)])))

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

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

(defspel (push! x l) (set! l (cons x l)))

(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 *chain-welded* #f)

(define *bucket-filled* #f)

(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 [(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.)]))

-------------------------------------------------------------------------------

-- 
          ((lambda (x) (x x)) (lambda (x) (x x)))          Eli Barzilay:
                    http://barzilay.org/                   Maze is Life!