0. #lang racket
1. ; Casting SPELs from http://www.lisperati.com/casting.html
2.  
3. ; globals
4. ;  immutable
5. (define *objects* '(sandwich-wrapper bucket frog chain))
6. (define *world* '((living-room (you are in the living-room of a wizards house. there is a wizard snoring loudly on the couch.)
7.                              (west door garden)
8.                              (upstairs stairway attic))
9.                 (garden (you are in a beautiful garden. there is a well in front of you.)
10.                         (east door living-room))
11.                 (attic (you are in the attic of the wizards house. there is a giant welding torch in the corner.)
12.                        (downstairs stairway living-room))))
13. ;  mutable
14. (define *object-locations* '((sandwich-wrapper living-room)
15.                              (bucket living-room)
16.                              (chain garden)
17.                              (frog garden)))
18. (define *location* 'living-room)
19. (define *chain-welded* #f)
20. (define *bucket-filled* #f)
21.  
22. ; functions / procedures - pure
23. (define (member? xs y)
24.   (cond [(empty? xs) #f]
25.         [(eq? (car xs) y)]
26.         [else (member? (cdr xs) y)]))
27. (define (describe-location location world)
28.   (second (assoc location world)))
29. (define (describe-path path)
30.   `(there is a ,(second path) going ,(first path) from here.))
31. (define (describe-paths location world)
32.   (apply append (map describe-path (cddr (assoc location world)))))
33. (define (is-at object location object-locations)
34.   (eq? (second (assoc object object-locations)) location))
35. (define (describe-floor location objects object-locations)
36.   (apply append (map (lambda (x)
37.                        `(you see a ,x on the floor.))
38.                      (filter (lambda (x)
39.                                (is-at x location object-locations))
40.                              objects))))
41. ; functions - impure
42. (define (look)
43.   (append (describe-location *location* *world*)
44.           (describe-paths *location* *world*)
45.           (describe-floor *location* *objects* *object-locations*)))
46. (define (walk-direction direction)
47.   (let ([next (assoc direction (cddr (assoc *location* *world*)))])
48.     (cond [(not next) '(you cant go that way)]
49.           [else (begin (set! *location* (third next)) (look))])))
50. (define (pickup-object object)
51.   (cond [(is-at object *location* *object-locations*) (begin (set! *object-locations* (cons `(,object body) *object-locations*))
52.                                                              `(you are now carrying the ,object))]
53.         [else '(you cannot get that.)]))
54. (define (inventory)
55.   (let ([known-locations (map (lambda (x) (cadr x)) *object-locations*)])
56.   (cond [(member? known-locations 'body) (filter (lambda (x)
57.                                                      (is-at x 'body *object-locations*))
58.                                                    *objects*)]
59.         [else '(nothing)])))
60. (define (have object)
61.   (member? (inventory) object))
62.  
63. ; SPELs
64. ;(define-syntax (walk stx)
65. ;  (let ([direction (cadr (syntax->datum stx))])
66. ;    (datum->syntax stx `(walk-direction ',direction))))
67. ;(define-syntax (pickup stx)
68. ;  (datum->syntax stx `(pickup-object ',(cadr (syntax->datum stx)))))
69. ;(define-syntax (carrying? stx)
70. ;  (datum->syntax stx `(have ',(cadr (syntax->datum stx)))))
71. (define-syntax-rule (walk direction)
72.   (walk-direction 'direction))
73. (define-syntax-rule (pickup object)
74.   (pickup-object 'object))
75. (define-syntax-rule (carrying? object)
76.   (have 'object))
77. (define-syntax-rule (game-action command subj obj place rest ...)
78.   (define-syntax-rule (command subject object)
79.     (cond [(and (eq?  *location* 'place)
80.                 (eq?  'subject 'subj)
81.                 (eq?  'object 'obj)
82.                 (have 'subj)) rest ...]
83.           [else '(i cant command like that)])))
84. (game-action weld chain bucket attic
85.              (cond [(have 'bucket) (begin (set! *chain-welded* #t)
86.                                           '(the chain is now securely welded to the bucket.))]
87.                    [else '(you do not have a bucket.)]))
88. (game-action dunk bucket well garden
89.              (cond [*chain-welded* (begin (set! *bucket-filled* #t)
90.                                           '(the bucket is now full of water))]
91.                    [else '(the water is too deep to reach.)]))
92. (game-action splash bucket wizard living-room
93.              (cond [(not *bucket-filled*) '(the bucket has nothing in it.)]
94.                    [(have 'frog) '(the wizard awakens and sees that you stole his frog.
95.                                        he is so upset he banishes you to the netherworlds-
96.                                        you lose! the end.)]
97.                    [else '(the wizard awakens from his slumber and greets you warmly.
98.                                he hands you the magic low-card donut- you win! the end.)]))
99. ;(look)
100. ;(pickup bucket)
101. ;(walk west)
102. ;(pickup chain)
103. ;(walk east)
104. ;(walk upstairs)
105. ;(weld chain bucket)
106. ;(walk downstairs)
107. ;(walk west)
108. ;(dunk bucket well)
109. ;(walk east)
110. ;(splash bucket wizard)

=>