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)

=>

'(you   are   in   the   living-room   of   a   wizards   house.   there   is   a   wizard   snoring   loudly   on   the   couch.   there   is   a   door   going   west   from   here.   there   is   a   stairway   going   upstairs   from   here.   you   see   a   sandwich-wrapper   on   the   floor.   you   see   a   bucket   on   the   floor.)

'(you are now carrying the bucket)

'(you   are   in   a   beautiful   garden.   there   is   a   well   in   front   of   you.   there   is   a   door   going   east   from   here.   you   see   a   frog   on   the   floor.   you   see   a   chain   on   the   floor.)

'(you are now carrying the chain)

'(you   are   in   the   living-room   of   a   wizards   house.   there   is   a   wizard   snoring   loudly   on   the   couch.   there   is   a   door   going   west   from   here.   there   is   a   stairway   going   upstairs   from   here.   you   see   a   sandwich-wrapper   on   the   floor.)

'(you   are   in   the   attic   of   the   wizards   house.   there   is   a   giant   welding   torch   in   the   corner.   there   is   a   stairway   going   downstairs   from   here.)

'(the chain is now securely welded to the bucket.)

'(you   are   in   the   living-room   of   a   wizards   house.   there   is   a   wizard   snoring   loudly   on   the   couch.   there   is   a   door   going   west   from   here.   there   is   a   stairway   going   upstairs   from   here.   you   see   a   sandwich-wrapper   on   the   floor.)

'(you   are   in   a   beautiful   garden.   there   is   a   well   in   front   of   you.   there   is   a   door   going   east   from   here.   you   see   a   frog   on   the   floor.)

'(the bucket is now full of water)

'(you   are   in   the   living-room   of   a   wizards   house.   there   is   a   wizard   snoring   loudly   on   the   couch.   there   is   a   door   going   west   from   here.   there   is   a   stairway   going   upstairs   from   here.   you   see   a   sandwich-wrapper   on   the   floor.)

'(the   wizard   awakens   from   his   slumber   and   greets   you   warmly.   he   hands   you   the   magic   low-card   donut-   you   win!   the   end.)