fork download 
  1. #lang racket
  2.  
  3. (define *nodes* '((living-room (you are in the living-room.
  4.                                    a wizard is snoring loudly on the couch.))
  5.                   (garden (you are in a beautiful garden.
  6.                               there is a well in front of you.))
  7.                   (attic (you are in the attic.
  8.                              there is a giant welding torch in the corner.))))
  9.  
  10. (define (describe-location location nodes)
  11.   (cadr (assq location nodes)))
  12.  
  13. (define *edges* '((living-room (garden west door)  
  14.                               (attic upstairs ladder))
  15.                   (garden (living-room east door))
  16.                   (attic (living-room downstairs ladder))))
  17.  
  18. (define (describe-path edge)
  19.   `(there is a ,(caddr edge) going ,(cadr edge) from here.))
  20.  
  21. (define (describe-paths location edges)
  22.   (apply append (map describe-path (cdr (assq location edges)))))
  23.  
  24. (define *objects* '(whiskey bucket frog chain))
  25.  
  26. (define *object-locations* '((whiskey living-room)
  27.                              (bucket living-room)
  28.                              (chain garden)
  29.                              (frog garden)))
  30.  
  31. (define (objects-at loc objs obj-loc)
  32.   (letrec ((is-at? (lambda (obj)
  33.                      (eq? (cadr (assoc obj obj-loc)) loc))))
  34.     (filter is-at? objs)))
  35.  
  36. (define (describe-objects loc objs obj-loc)
  37.   (letrec ((describe-obj (lambda (obj)
  38.                            `(you see a ,obj on the floor.))))
  39.     (apply append (map describe-obj (objects-at loc objs obj-loc)))))
  40.  
  41. (define *location* 'living-room)
  42.  
  43. (define (look)
  44.   (append (describe-location *location* *nodes*)
  45.          (describe-paths *location* *edges*)
  46.          (describe-objects *location* *objects* *object-locations*)))
  47.  
  48. (define (walk direction)
  49.   (letrec ((correct-way? (lambda (edge)
  50.                            (eq? (cadr edge) direction))))
  51.     (let ((next (findf correct-way? (cdr (assq *location* *edges*)))))
  52.       (if next 
  53.          (begin (set! *location* (car next)) 
  54.                (look))
  55.          '(you cannot go that way.)))))
  56.  
  57. (define-syntax push
  58.   (syntax-rules ()
  59.     ((_ item place) (set! place (cons item place)))))
  60.  
  61. (define (pickup object)
  62.   (cond ((memq object (objects-at *location* *objects* *object-locations*))
  63.          (push (list object 'body) *object-locations*)
  64.          `(you are now carrying the ,object))
  65.        (else '(you cannot get that.))))
  66.  
  67. (define (inventory)
  68.   (cons 'items- (objects-at 'body *objects* *object-locations*)))
  69.  
  70. (define (have object) 
  71.   (memq object (cdr (inventory))))
  72.  
  73. (define (game-repl)
  74.   (let ((cmd (game-read)))
  75.     (unless (eq? (car cmd) 'quit)
  76.       (game-print (game-eval cmd))
  77.       (game-repl))))
  78.  
  79. (define (game-read)
  80.   (let ((cmd (read (open-input-string (string-append "(" (read-line) ")")))))
  81.     (let ((quote-it (lambda (x)
  82.                    `(quote ,x))))
  83.       (cons (car cmd) (map quote-it (cdr cmd))))))
  84.  
  85. (define *allowed-commands* '(look walk pickup inventory))
  86.  
  87. (define (game-eval sexp)
  88.   (if (memq (car sexp) *allowed-commands*)
  89.      (eval sexp)
  90.      '(i do not know that command.)))
  91.  
  92. (define (tweak-text lst caps lit)
  93.     (let loop ((lst lst) (caps caps) (lit lit) (acc '()))
  94.       (if (null? lst)
  95.          (reverse acc)
  96.          (let ((item (car lst))
  97.                (rst (cdr lst)))
  98.       (cond ((char=? item #\space) (loop rst caps lit (cons item acc)))
  99.            ((memv item '(#\! #\? #\.)) (loop rst #t lit (cons item acc)))
  100.            ((char=? item #\") (loop rst caps (not lit) acc))
  101.            (lit (loop rst #f lit (cons item acc)))
  102.            (caps (loop rst #f lit (cons (char-upcase item) acc)))
  103.            (else (loop rst #f #f (cons (char-downcase item) acc))))))))
  104.  
  105. (define (game-print lst)
  106.   (display (list->string (tweak-text (string->list (string-trim (format "~a" lst) #px"\\(+|\\)+|\\ +" #:left? #t #:right? #t)) #t #f)))
  107.   (newline))
Success #stdin #stdout 0.7s 112192KB
comments (?)
stdin 
Standard input is empty
stdout 
Standard output is empty
https://ideone.com/qbJB5A
language:
Racket (racket 7.0)
created:
2 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!