PasteRack.org
Paste # 62482
2020-05-20 23:20:38

Fork as a new paste.

Paste viewed 185 times.


Embed:

Casting SPELs in Racket

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

=>