work it

beautiful-racket/br/demo/txtadv/0-longhand/README.txt

@@ -0,0 +1,9 @@
+The "txtadv+world.rkt" is the initial implementation of the
+text-adventure game in Racket. The file name foreshadows a split of
+the program into two modules later.
+
+The "Model" section of the code is described in the article. The "The
+world" section is the verbose world description that we will improve
+in the next step. Sections from "Game state" on implement the game
+engine, and those parts will remain essentially unchanged as we
+improve the language for describing worlds.

beautiful-racket/br/demo/txtadv/0-longhand/txtadv+world.rkt

@@ -0,0 +1,409 @@
+#lang racket
+
+;; ============================================================
+;; Model:
+
+;; Elements of the world:
+(struct verb (aliases       ; list of symbols
+              desc          ; string
+              transitive?)) ; boolean
+(struct thing (name         ; symbol
+               [state #:mutable] ; any value
+               actions))    ; list of verb--thunk pairs
+(struct place (desc         ; string
+               [things #:mutable] ; list of things
+               actions))    ; list of verb--thunk pairs
+
+;; Tables mapping names<->things for save and load
+(define names (make-hash))
+(define elements (make-hash))
+
+(define (record-element! name val)
+  (hash-set! names name val)
+  (hash-set! elements val name))
+
+(define (name->element name) (hash-ref names name #f))
+(define (element->name obj) (hash-ref elements obj #f))
+
+;; ============================================================
+;; The world:
+
+;; Verbs ----------------------------------------
+;; Declare all the verbs that can be used in the game.
+;; Each verb has a canonical name, a set of aliases, 
+;; a printed form, and a boolean indincating whether it
+;; is transitive.
+
+(define north (verb (list 'north 'n) "go north" #f))
+(record-element! 'north north)
+
+(define south (verb (list 'south 's) "go south" #f))
+(record-element! 'south south)
+
+(define east (verb (list 'east 'e) "go east" #f))
+(record-element! 'east east)
+
+(define west (verb (list 'west 'w) "go west" #f))
+(record-element! 'west west)
+
+(define up (verb (list 'up) "go up" #f))
+(record-element! 'up up)
+
+(define down (verb (list 'down) "go down" #f))
+(record-element! 'down down)
+
+(define in (verb (list 'in 'enter) "enter" #f))
+(record-element! 'in in)
+
+(define out (verb (list 'out 'leave) "leave" #f))
+(record-element! 'out out)
+
+(define get (verb (list 'get 'grab 'take) "take" #t))
+(record-element! 'get get)
+
+(define put (verb (list 'put 'drop 'leave) "drop" #t))
+(record-element! 'put put)
+
+(define open (verb (list 'open 'unlock) "open" #t))
+(record-element! 'open open)
+
+(define close (verb (list 'close 'lock) "close" #t))
+(record-element! 'close close)
+
+(define knock (verb (list 'knock) (symbol->string 'knock) #t))
+(record-element! 'knock knock)
+
+(define quit (verb (list 'quit 'exit) "quit" #f))
+(record-element! 'quit quit)
+
+(define look (verb (list 'look 'show) "look" #f))
+(record-element! 'look look)
+
+(define inventory (verb (list 'inventory) "check inventory" #f))
+(record-element! 'inventory inventory)
+
+(define help (verb (list 'help) (symbol->string 'help) #f))
+(record-element! 'help help)
+
+(define save (verb (list 'save) (symbol->string 'save) #f))
+(record-element! 'save save)
+
+(define load (verb (list 'load) (symbol->string 'load) #f))
+(record-element! 'load load)
+
+(define all-verbs
+  (list north south east west up down in out
+        get put open close knock quit
+        look inventory help save load))
+
+;; Global actions ----------------------------------------
+;; Handle verbs that work anywhere.
+
+(define everywhere-actions
+  (list
+   (cons quit (lambda () (begin (printf "Bye!\n") (exit))))
+   (cons look (lambda () (show-current-place)))
+   (cons inventory (lambda () (show-inventory)))
+   (cons save (lambda () (save-game)))
+   (cons load (lambda () (load-game)))
+   (cons help (lambda () (show-help)))))
+
+;; Things ----------------------------------------
+;; Each thing handles a set of transitive verbs.
+
+(define cactus
+  (thing 'cactus 
+         #f 
+         (list (cons get (lambda () "Ouch!")))))
+(record-element! 'cactus cactus)
+
+(define door
+  (thing 'door
+         #f
+         (list
+          (cons open 
+                (lambda ()
+                  (if (have-thing? key)
+                      (begin
+                        (set-thing-state! door 'open)
+                        "The door is now unlocked and open.")
+                      "The door is locked.")))
+          (cons close 
+                (lambda ()
+                  (begin
+                    (set-thing-state! door #f)
+                    "The door is now closed.")))
+          (cons knock 
+                (lambda ()
+                  "No one is home.")))))
+(record-element! 'door door)
+
+(define key
+  (thing 'key
+         #f
+         (list
+          (cons get 
+                (lambda ()
+                  (if (have-thing? key)
+                      "You already have the key."
+                      (begin
+                        (take-thing! key)
+                        "You now have the key."))))
+          (cons put 
+                (lambda ()
+                  (if (have-thing? key)
+                      (begin
+                        (drop-thing! key)
+                        "You have dropped the key.")
+                      "You don't have the key."))))))
+(record-element! 'key key)
+
+(define trophy
+  (thing 'trophy
+         #f
+         (list
+          (cons get 
+                (lambda ()
+                  (begin
+                    (take-thing! trophy)
+                    "You win!"))))))
+(record-element! 'trophy trophy)
+
+;; Places ----------------------------------------
+;; Each place handles a set of non-transitive verbs.
+
+(define meadow
+  (place
+   "You're standing in a meadow. There is a house to the north."
+   (list)
+   (list
+    (cons north 
+          (lambda () house-front))
+    (cons south 
+          (lambda () desert)))))
+(record-element! 'meadow meadow)
+
+(define house-front
+  (place
+   "You are standing in front of a house."
+   (list door)
+   (list
+    (cons in 
+          (lambda ()
+            (if (eq? (thing-state door) 'open)
+                room
+                "The door is not open.")))
+    (cons south (lambda () meadow)))))
+(record-element! 'house-front house-front)
+
+(define desert
+  (place
+   "You're in a desert. There is nothing for miles around."
+   (list cactus key)
+   (list
+    (cons north (lambda () meadow))
+    (cons south (lambda () desert))
+    (cons east (lambda () desert))
+    (cons west (lambda () desert)))))
+(record-element! 'desert desert)
+
+(define room
+  (place
+   "You're in the house."
+   (list trophy)
+   (list (cons out (lambda () house-front)))))
+(record-element! 'room room)
+
+;; ============================================================
+;; Game state
+
+;; Things carried by the player:
+(define stuff null) ; list of things
+
+;; Current location:
+(define current-place meadow) ; place
+
+;; Fuctions to be used by verb responses:
+(define (have-thing? t)
+  (memq t stuff))
+(define (take-thing! t) 
+  (set-place-things! current-place (remq t (place-things current-place)))
+  (set! stuff (cons t stuff)))
+(define (drop-thing! t) 
+  (set-place-things! current-place (cons t (place-things current-place)))
+  (set! stuff (remq t stuff)))
+
+;; ============================================================
+;; Game execution
+
+;; Show the player the current place, then get a command:
+(define (do-place)
+  (show-current-place)
+  (do-verb))
+
+;; Show the current place:
+(define (show-current-place)
+  (printf "~a\n" (place-desc current-place))
+  (for-each (lambda (thing)
+              (printf "There is a ~a here.\n" (thing-name thing)))
+            (place-things current-place)))
+
+;; Get and handle a command:
+(define (do-verb)
+  (printf "> ")
+  (flush-output)
+  (let* ([line (read-line)]
+         [input (if (eof-object? line)
+                    '(quit)
+                    (let ([port (open-input-string line)])
+                      (for/list ([v (in-port read port)]) v)))])
+    (if (and (list? input)
+             (andmap symbol? input)
+             (<= 1 (length input) 2))
+        (let ([cmd (car input)])
+            (let ([response
+                   (cond
+                    [(= 2 (length input))
+                     (handle-transitive-verb cmd (cadr input))]
+                    [(= 1 (length input))
+                     (handle-intransitive-verb cmd)])])
+              (let ([result (response)])
+                (cond
+                 [(place? result)
+                  (set! current-place result)
+                  (do-place)]
+                 [(string? result)
+                  (printf "~a\n" result)
+                  (do-verb)]
+                 [else (do-verb)]))))
+          (begin
+            (printf "I don't undertand what you mean.\n")
+            (do-verb)))))
+
+;; Handle an intransitive-verb command:
+(define (handle-intransitive-verb cmd)
+  (or
+   (find-verb cmd (place-actions current-place))
+   (find-verb cmd everywhere-actions)
+   (using-verb 
+    cmd all-verbs
+    (lambda (verb)
+      (lambda () 
+        (if (verb-transitive? verb)
+            (format "~a what?" (string-titlecase (verb-desc verb)))
+            (format "Can't ~a here." (verb-desc verb))))))
+   (lambda ()
+     (format "I don't know how to ~a." cmd))))
+
+;; Handle a transitive-verb command:
+(define (handle-transitive-verb cmd obj)
+  (or (using-verb 
+       cmd all-verbs
+       (lambda (verb)
+         (and 
+          (verb-transitive? verb)
+          (cond
+           [(ormap (lambda (thing)
+                     (and (eq? (thing-name thing) obj)
+                          thing))
+                   (append (place-things current-place)
+                           stuff))
+            => (lambda (thing)
+                 (or (find-verb cmd (thing-actions thing))
+                     (lambda ()
+                       (format "Don't know how to ~a ~a."
+                               (verb-desc verb) obj))))]
+           [else
+            (lambda ()
+              (format "There's no ~a here to ~a." obj 
+                      (verb-desc verb)))]))))
+      (lambda ()
+        (format "I don't know how to ~a ~a." cmd obj))))
+
+;; Show what the player is carrying:
+(define (show-inventory)
+  (printf "You have")
+  (if (null? stuff)
+      (printf " no items.")
+      (for-each (lambda (thing)
+                  (printf "\n  a ~a" (thing-name thing)))
+                stuff))
+  (printf "\n"))
+
+;; Look for a command match in a list of verb--response pairs,
+;; and returns the response thunk if a match is found:
+(define (find-verb cmd actions)
+  (ormap (lambda (a)
+           (and (memq cmd (verb-aliases (car a)))
+                (cdr a)))
+         actions))
+
+;; Looks for a command in a list of verbs, and
+;; applies `suucess-k' to the verb if one is found:
+(define (using-verb cmd verbs success-k)
+  (ormap (lambda (vrb)
+           (and (memq cmd (verb-aliases vrb))
+                (success-k vrb)))
+         verbs))
+
+;; Print help information:
+(define (show-help)
+  (printf "Use `look' to look around.\n")
+  (printf "Use `inventory' to see what you have.\n")
+  (printf "Use `save' or `load' to save or restore your game.\n")
+  (printf "There are some other verbs, and you can name a thing after some verbs.\n"))
+
+;; ============================================================
+;; Save and load
+
+;; Prompt the user for a filename and apply `proc' to it,
+;; catching errors to report a reasonably nice message:
+(define (with-filename proc)
+  (printf "File name: ")
+  (flush-output)
+  (let ([v (read-line)])
+    (unless (eof-object? v)
+      (with-handlers ([exn? (lambda (exn)
+                              (printf "~a\n" (exn-message exn)))])
+        (unless (path-string? v)
+          (raise-user-error "bad filename"))
+        (proc v)))))
+
+;; Save the current game state:
+(define (save-game)
+  (with-filename
+   (lambda (v)
+     (with-output-to-file v
+       (lambda ()
+         (write
+          (list
+           (map element->name stuff)
+           (element->name current-place)
+           (hash-map names
+                     (lambda (k v)
+                       (cons k
+                             (cond
+                              [(place? v) (map element->name (place-things v))]
+                              [(thing? v) (thing-state v)]
+                              [else #f])))))))))))
+
+;; Restore a game state:
+(define (load-game)
+  (with-filename
+   (lambda (v)
+     (let ([v (with-input-from-file v read)])
+       (set! stuff (map name->element (car v)))
+       (set! current-place (name->element (cadr v)))
+       (for-each
+        (lambda (p)
+          (let ([v (name->element (car p))]
+                [state (cdr p)])
+            (cond
+             [(place? v) (set-place-things! v (map name->element state))]
+             [(thing? v) (set-thing-state! v state)])))
+        (caddr v))))))
+
+;; ============================================================
+;; Go!
+
+(do-place)

beautiful-racket/br/demo/txtadv/1-monolith/README.txt

@@ -0,0 +1,4 @@
+The difference in "txtadv+world.rkt" compared to the previous version
+is a new "Macros for constructing and registering elements" section
+and a revised "The world" section.
+

beautiful-racket/br/demo/txtadv/1-monolith/txtadv+world.rkt

@@ -0,0 +1,369 @@
+#lang racket
+
+;; ============================================================
+;; Model:
+
+;; Elements of the world:
+(struct verb (aliases       ; list of symbols
+              desc          ; string
+              transitive?)) ; boolean
+(struct thing (name         ; symbol
+               [state #:mutable] ; any value
+               actions))    ; list of verb--thunk pairs
+(struct place (desc         ; string
+               [things #:mutable] ; list of things
+               actions))    ; list of verb--thunk pairs
+
+;; Tables mapping names<->things for save and load
+(define names (make-hash))
+(define elements (make-hash))
+
+(define (record-element! name val)
+  (hash-set! names name val)
+  (hash-set! elements val name))
+
+(define (name->element name) (hash-ref names name #f))
+(define (element->name obj) (hash-ref elements obj #f))
+
+;; ============================================================
+;; Macros for constructing and registering elements:
+
+(define-syntax-rule (define-verbs all-id
+                      [id spec ...] ...)
+  (begin
+    (define-one-verb id spec ...) ...
+    (record-element! 'id id) ...
+    (define all-id (list id ...))))
+
+(define-syntax define-one-verb
+  (syntax-rules (= _)
+    [(define-one-verb id (= alias ...) desc)
+     (define id (verb (list 'id 'alias ...) desc #f))]
+    [(define-one-verb id _ (= alias ...) desc)
+     (define id (verb (list 'id 'alias ...) desc #t))]
+    [(define-one-verb id)
+     (define id (verb (list 'id) (symbol->string 'id) #f))]
+    [(define-one-verb id _)
+     (define id (verb (list 'id) (symbol->string 'id) #t))]))
+
+
+(define-syntax-rule (define-thing id 
+                      [vrb expr] ...)
+  (begin
+    (define id 
+      (thing 'id #f (list (cons vrb (lambda () expr)) ...)))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-place id 
+                      desc 
+                      (thng ...) 
+                      ([vrb expr] ...))
+  (begin
+    (define id (place desc
+                      (list thng ...)
+                      (list (cons vrb (lambda () expr)) ...)))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-everywhere id ([vrb expr] ...))
+  (define id (list (cons vrb (lambda () expr)) ...)))
+
+;; ============================================================
+;; The world:
+
+;; Verbs ----------------------------------------
+;; Declare all the verbs that can be used in the game.
+;; Each verb has a canonical name, a `_' if it needs
+;; a thing (i.e., a transitive verb), a set of aliases, 
+;; and a printed form.
+
+(define-verbs all-verbs
+  [north (= n) "go north"]
+  [south (= s) "go south"]
+  [east (= e) "go east"]
+  [west (= w) "go west"]
+  [up (=) "go up"]
+  [down (=) "go down"]
+  [in (= enter) "enter"]
+  [out (= leave) "leave"]  
+  [get _ (= grab take) "take"]
+  [put _ (= drop leave) "drop"]
+  [open _ (= unlock) "open"]
+  [close _ (= lock) "close"]
+  [knock _]
+  [quit (= exit) "quit"]
+  [look (= show) "look"]
+  [inventory (=) "check inventory"]
+  [help]
+  [save]
+  [load])
+
+;; Global actions ----------------------------------------
+;; Handle verbs that work anywhere.
+
+(define-everywhere everywhere-actions
+  ([quit (begin (printf "Bye!\n") (exit))]
+   [look (show-current-place)]
+   [inventory (show-inventory)]
+   [save (save-game)]
+   [load (load-game)]
+   [help (show-help)]))
+
+;; Things ----------------------------------------
+;; Each thing handles a set of transitive verbs.
+
+(define-thing cactus
+  [get "Ouch!"])
+
+(define-thing door
+  [open (if (have-thing? key)
+            (begin
+              (set-thing-state! door 'open)
+              "The door is now unlocked and open.")
+            "The door is locked.")]
+  [close (begin
+           (set-thing-state! door #f)
+           "The door is now closed.")]
+  [knock "No one is home."])
+
+(define-thing key
+  [get (if (have-thing? key)
+           "You already have the key."
+           (begin
+             (take-thing! key)
+             "You now have the key."))]
+  [put (if (have-thing? key)
+           (begin
+             (drop-thing! key)
+             "You have dropped the key.")
+           "You don't have the key.")])
+
+(define-thing trophy
+  [get (begin
+         (take-thing! trophy)
+         "You win!")])
+
+;; Places ----------------------------------------
+;; Each place handles a set of non-transitive verbs.
+
+(define-place meadow
+  "You're standing in a meadow. There is a house to the north."
+  []
+  ([north house-front]
+   [south desert]))
+
+(define-place house-front
+  "You are standing in front of a house."
+  [door]
+  ([in (if (eq? (thing-state door) 'open)
+           room
+           "The door is not open.")]
+   [south meadow]))
+
+(define-place desert
+  "You're in a desert. There is nothing for miles around."
+  [cactus key]
+  ([north meadow]
+   [south desert]
+   [east desert]
+   [west desert]))
+
+(define-place room
+  "You're in the house."
+  [trophy]
+  ([out house-front]))
+
+;; ============================================================
+;; Game state
+
+;; Things carried by the player:
+(define stuff null) ; list of things
+
+;; Current location:
+(define current-place meadow) ; place
+
+;; Fuctions to be used by verb responses:
+(define (have-thing? t)
+  (memq t stuff))
+(define (take-thing! t) 
+  (set-place-things! current-place (remq t (place-things current-place)))
+  (set! stuff (cons t stuff)))
+(define (drop-thing! t) 
+  (set-place-things! current-place (cons t (place-things current-place)))
+  (set! stuff (remq t stuff)))
+
+;; ============================================================
+;; Game execution
+
+;; Show the player the current place, then get a command:
+(define (do-place)
+  (show-current-place)
+  (do-verb))
+
+;; Show the current place:
+(define (show-current-place)
+  (printf "~a\n" (place-desc current-place))
+  (for-each (lambda (thing)
+              (printf "There is a ~a here.\n" (thing-name thing)))
+            (place-things current-place)))
+
+;; Get and handle a command:
+(define (do-verb)
+  (printf "> ")
+  (flush-output)
+  (let* ([line (read-line)]
+         [input (if (eof-object? line)
+                    '(quit)
+                    (let ([port (open-input-string line)])
+                      (for/list ([v (in-port read port)]) v)))])
+    (if (and (list? input)
+             (andmap symbol? input)
+             (<= 1 (length input) 2))
+        (let ([cmd (car input)])
+            (let ([response
+                   (cond
+                    [(= 2 (length input))
+                     (handle-transitive-verb cmd (cadr input))]
+                    [(= 1 (length input))
+                     (handle-intransitive-verb cmd)])])
+              (let ([result (response)])
+                (cond
+                 [(place? result)
+                  (set! current-place result)
+                  (do-place)]
+                 [(string? result)
+                  (printf "~a\n" result)
+                  (do-verb)]
+                 [else (do-verb)]))))
+          (begin
+            (printf "I don't undertand what you mean.\n")
+            (do-verb)))))
+
+;; Handle an intransitive-verb command:
+(define (handle-intransitive-verb cmd)
+  (or
+   (find-verb cmd (place-actions current-place))
+   (find-verb cmd everywhere-actions)
+   (using-verb 
+    cmd all-verbs
+    (lambda (verb)
+      (lambda () 
+        (if (verb-transitive? verb)
+            (format "~a what?" (string-titlecase (verb-desc verb)))
+            (format "Can't ~a here." (verb-desc verb))))))
+   (lambda ()
+     (format "I don't know how to ~a." cmd))))
+
+;; Handle a transitive-verb command:
+(define (handle-transitive-verb cmd obj)
+  (or (using-verb 
+       cmd all-verbs
+       (lambda (verb)
+         (and 
+          (verb-transitive? verb)
+          (cond
+           [(ormap (lambda (thing)
+                     (and (eq? (thing-name thing) obj)
+                          thing))
+                   (append (place-things current-place)
+                           stuff))
+            => (lambda (thing)
+                 (or (find-verb cmd (thing-actions thing))
+                     (lambda ()
+                       (format "Don't know how to ~a ~a."
+                               (verb-desc verb) obj))))]
+           [else
+            (lambda ()
+              (format "There's no ~a here to ~a." obj 
+                      (verb-desc verb)))]))))
+      (lambda ()
+        (format "I don't know how to ~a ~a." cmd obj))))
+
+;; Show what the player is carrying:
+(define (show-inventory)
+  (printf "You have")
+  (if (null? stuff)
+      (printf " no items.")
+      (for-each (lambda (thing)
+                  (printf "\n  a ~a" (thing-name thing)))
+                stuff))
+  (printf "\n"))
+
+;; Look for a command match in a list of verb--response pairs,
+;; and returns the response thunk if a match is found:
+(define (find-verb cmd actions)
+  (ormap (lambda (a)
+           (and (memq cmd (verb-aliases (car a)))
+                (cdr a)))
+         actions))
+
+;; Looks for a command in a list of verbs, and
+;; applies `suucess-k' to the verb if one is found:
+(define (using-verb cmd verbs success-k)
+  (ormap (lambda (vrb)
+           (and (memq cmd (verb-aliases vrb))
+                (success-k vrb)))
+         verbs))
+
+;; Print help information:
+(define (show-help)
+  (printf "Use `look' to look around.\n")
+  (printf "Use `inventory' to see what you have.\n")
+  (printf "Use `save' or `load' to save or restore your game.\n")
+  (printf "There are some other verbs, and you can name a thing after some verbs.\n"))
+
+;; ============================================================
+;; Save and load
+
+;; Prompt the user for a filename and apply `proc' to it,
+;; catching errors to report a reasonably nice message:
+(define (with-filename proc)
+  (printf "File name: ")
+  (flush-output)
+  (let ([v (read-line)])
+    (unless (eof-object? v)
+      (with-handlers ([exn? (lambda (exn)
+                              (printf "~a\n" (exn-message exn)))])
+        (unless (path-string? v)
+          (raise-user-error "bad filename"))
+        (proc v)))))
+
+;; Save the current game state:
+(define (save-game)
+  (with-filename
+   (lambda (v)
+     (with-output-to-file v
+       (lambda ()
+         (write
+          (list
+           (map element->name stuff)
+           (element->name current-place)
+           (hash-map names
+                     (lambda (k v)
+                       (cons k
+                             (cond
+                              [(place? v) (map element->name (place-things v))]
+                              [(thing? v) (thing-state v)]
+                              [else #f])))))))))))
+
+;; Restore a game state:
+(define (load-game)
+  (with-filename
+   (lambda (v)
+     (let ([v (with-input-from-file v read)])
+       (set! stuff (map name->element (car v)))
+       (set! current-place (name->element (cadr v)))
+       (for-each
+        (lambda (p)
+          (let ([v (name->element (car p))]
+                [state (cdr p)])
+            (cond
+             [(place? v) (set-place-things! v (map name->element state))]
+             [(thing? v) (set-thing-state! v state)])))
+        (caddr v))))))
+
+;; ============================================================
+;; Go!
+
+(do-place)

beautiful-racket/br/demo/txtadv/2-modules/README.txt

@@ -0,0 +1,8 @@
+The old "txtadv+world.rkt" module is now split into two parts:
+"txtadv.rkt" and "world.rkt". Aside from the split and necessary
+`provide' and `require' declarations, the only change to engine and
+world descriptions is the `start-game' call at the end of "world.rkt",
+which passes to the game engine all of the declarations that it
+formerly used directly.
+
+To play the game, run the "world.rkt" module.

beautiful-racket/br/demo/txtadv/2-modules/txtadv.rkt

@@ -0,0 +1,293 @@
+#lang racket
+
+(provide define-verbs
+         define-thing
+         define-place
+         define-everywhere
+         
+         show-current-place
+         show-inventory
+         save-game
+         load-game
+         show-help
+
+         have-thing?
+         take-thing!
+         drop-thing!
+         thing-state
+         set-thing-state!
+          
+         start-game)
+
+;; ============================================================
+;; Model:
+
+;; Elements of the world:
+(struct verb (aliases       ; list of symbols
+              desc          ; string
+              transitive?)) ; boolean
+(struct thing (name         ; symbol
+               [state #:mutable] ; any value
+               actions))    ; list of verb--thunk pairs
+(struct place (desc         ; string
+               [things #:mutable] ; list of things
+               actions))    ; list of verb--thunk pairs
+
+;; Tables mapping names<->things for save and load
+(define names (make-hash))
+(define elements (make-hash))
+
+(define (record-element! name val)
+  (hash-set! names name val)
+  (hash-set! elements val name))
+
+(define (name->element name) (hash-ref names name #f))
+(define (element->name obj) (hash-ref elements obj #f))
+
+;; ============================================================
+;; Macros for constructing and registering elements:
+
+(define-syntax-rule (define-verbs all-id
+                      [id spec ...] ...)
+  (begin
+    (define-one-verb id spec ...) ...
+    (record-element! 'id id) ...
+    (define all-id (list id ...))))
+
+(define-syntax define-one-verb
+  (syntax-rules (= _)
+    [(define-one-verb id (= alias ...) desc)
+     (define id (verb (list 'id 'alias ...) desc #f))]
+    [(define-one-verb id _ (= alias ...) desc)
+     (define id (verb (list 'id 'alias ...) desc #t))]
+    [(define-one-verb id)
+     (define id (verb (list 'id) (symbol->string 'id) #f))]
+    [(define-one-verb id _)
+     (define id (verb (list 'id) (symbol->string 'id) #t))]))
+
+
+(define-syntax-rule (define-thing id 
+                      [vrb expr] ...)
+  (begin
+    (define id 
+      (thing 'id #f (list (cons vrb (lambda () expr)) ...)))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-place id 
+                      desc 
+                      (thng ...) 
+                      ([vrb expr] ...))
+  (begin
+    (define id (place desc
+                      (list thng ...)
+                      (list (cons vrb (lambda () expr)) ...)))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-everywhere id ([vrb expr] ...))
+  (define id (list (cons vrb (lambda () expr)) ...)))
+
+;; ============================================================
+;; Game state
+
+;; Initialized on startup:
+(define all-verbs null)          ; list of verbs
+(define everywhere-actions null) ; list of verb--thunk pairs
+
+;; Things carried by the player:
+(define stuff null) ; list of things
+
+;; Current location:
+(define current-place #f) ; place (or #f until started)
+
+;; Fuctions to be used by verb responses:
+(define (have-thing? t)
+  (memq t stuff))
+(define (take-thing! t) 
+  (set-place-things! current-place (remq t (place-things current-place)))
+  (set! stuff (cons t stuff)))
+(define (drop-thing! t) 
+  (set-place-things! current-place (cons t (place-things current-place)))
+  (set! stuff (remq t stuff)))
+
+;; ============================================================
+;; Game execution
+
+;; Show the player the current place, then get a command:
+(define (do-place)
+  (show-current-place)
+  (do-verb))
+
+;; Show the current place:
+(define (show-current-place)
+  (printf "~a\n" (place-desc current-place))
+  (for-each (lambda (thing)
+              (printf "There is a ~a here.\n" (thing-name thing)))
+            (place-things current-place)))
+
+;; Get and handle a command:
+(define (do-verb)
+  (printf "> ")
+  (flush-output)
+  (let* ([line (read-line)]
+         [input (if (eof-object? line)
+                    '(quit)
+                    (let ([port (open-input-string line)])
+                      (for/list ([v (in-port read port)]) v)))])
+    (if (and (list? input)
+             (andmap symbol? input)
+             (<= 1 (length input) 2))
+        (let ([vrb (car input)])
+            (let ([response
+                   (cond
+                    [(= 2 (length input))
+                     (handle-transitive-verb vrb (cadr input))]
+                    [(= 1 (length input))
+                     (handle-intransitive-verb vrb)])])
+              (let ([result (response)])
+                (cond
+                 [(place? result)
+                  (set! current-place result)
+                  (do-place)]
+                 [(string? result)
+                  (printf "~a\n" result)
+                  (do-verb)]
+                 [else (do-verb)]))))
+          (begin
+            (printf "I don't undertand what you mean.\n")
+            (do-verb)))))
+
+;; Handle an intransitive-verb command:
+(define (handle-intransitive-verb vrb)
+  (or
+   (find-verb vrb (place-actions current-place))
+   (find-verb vrb everywhere-actions)
+   (using-verb 
+    vrb all-verbs
+    (lambda (verb)
+      (lambda () 
+        (if (verb-transitive? verb)
+            (format "~a what?" (string-titlecase (verb-desc verb)))
+            (format "Can't ~a here." (verb-desc verb))))))
+   (lambda ()
+     (format "I don't know how to ~a." vrb))))
+
+;; Handle a transitive-verb command:
+(define (handle-transitive-verb vrb obj)
+  (or (using-verb 
+       vrb all-verbs
+       (lambda (verb)
+         (and 
+          (verb-transitive? verb)
+          (cond
+           [(ormap (lambda (thing)
+                     (and (eq? (thing-name thing) obj)
+                          thing))
+                   (append (place-things current-place)
+                           stuff))
+            => (lambda (thing)
+                 (or (find-verb vrb (thing-actions thing))
+                     (lambda ()
+                       (format "Don't know how to ~a ~a."
+                               (verb-desc verb) obj))))]
+           [else
+            (lambda ()
+              (format "There's no ~a here to ~a." obj 
+                      (verb-desc verb)))]))))
+      (lambda ()
+        (format "I don't know how to ~a ~a." vrb obj))))
+
+;; Show what the player is carrying:
+(define (show-inventory)
+  (printf "You have")
+  (if (null? stuff)
+      (printf " no items.")
+      (for-each (lambda (thing)
+                  (printf "\n  a ~a" (thing-name thing)))
+                stuff))
+  (printf "\n"))
+
+;; Look for a command match in a list of verb--response pairs,
+;; and returns the response thunk if a match is found:
+(define (find-verb cmd actions)
+  (ormap (lambda (a)
+           (and (memq cmd (verb-aliases (car a)))
+                (cdr a)))
+         actions))
+
+;; Looks for a command in a list of verbs, and
+;; applies `suucess-k' to the verb if one is found:
+(define (using-verb cmd verbs success-k)
+  (ormap (lambda (vrb)
+           (and (memq cmd (verb-aliases vrb))
+                (success-k vrb)))
+         verbs))
+
+;; Print help information:
+(define (show-help)
+  (printf "Use `look' to look around.\n")
+  (printf "Use `inventory' to see what you have.\n")
+  (printf "Use `save' or `load' to save or restore your game.\n")
+  (printf "There are some other verbs, and you can name a thing after some verbs.\n"))
+
+;; ============================================================
+;; Save and load
+
+;; Prompt the user for a filename and apply `proc' to it,
+;; catching errors to report a reasonably nice message:
+(define (with-filename proc)
+  (printf "File name: ")
+  (flush-output)
+  (let ([v (read-line)])
+    (unless (eof-object? v)
+      (with-handlers ([exn? (lambda (exn)
+                              (printf "~a\n" (exn-message exn)))])
+        (unless (path-string? v)
+          (raise-user-error "bad filename"))
+        (proc v)))))
+
+;; Save the current game state:
+(define (save-game)
+  (with-filename
+   (lambda (v)
+     (with-output-to-file v
+       (lambda ()
+         (write
+          (list
+           (map element->name stuff)
+           (element->name current-place)
+           (hash-map names
+                     (lambda (k v)
+                       (cons k
+                             (cond
+                              [(place? v) (map element->name (place-things v))]
+                              [(thing? v) (thing-state v)]
+                              [else #f])))))))))))
+
+;; Restore a game state:
+(define (load-game)
+  (with-filename
+   (lambda (v)
+     (let ([v (with-input-from-file v read)])
+       (set! stuff (map name->element (car v)))
+       (set! current-place (name->element (cadr v)))
+       (for-each
+        (lambda (p)
+          (let ([v (name->element (car p))]
+                [state (cdr p)])
+            (cond
+             [(place? v) (set-place-things! v (map name->element state))]
+             [(thing? v) (set-thing-state! v state)])))
+        (caddr v))))))
+
+;; ============================================================
+;; To go:
+
+(define (start-game in-place
+                    in-all-verbs
+                    in-everywhere-actions)
+  (set! current-place in-place)
+  (set! all-verbs in-all-verbs)
+  (set! everywhere-actions in-everywhere-actions)
+  (do-place))

beautiful-racket/br/demo/txtadv/2-modules/world.rkt

@@ -0,0 +1,111 @@
+#lang racket
+(require "txtadv.rkt")
+
+;; Verbs ----------------------------------------
+;; Declare all the verbs that can be used in the game.
+;; Each verb has a canonical name, a `_' if it needs
+;; an object (i.e., a transitive verb), a set of aliases, 
+;; and a printed form.
+
+(define-verbs all-verbs
+  [north (= n) "go north"]
+  [south (= s) "go south"]
+  [east (= e) "go east"]
+  [west (= w) "go west"]
+  [up (=) "go up"]
+  [down (=) "go down"]
+  [in (= enter) "enter"]
+  [out (= leave) "leave"]  
+  [get _ (= grab take) "take"]
+  [put _ (= drop leave) "drop"]
+  [open _ (= unlock) "open"]
+  [close _ (= lock) "close"]
+  [knock _]
+  [quit (= exit) "quit"]
+  [look (= show) "look"]
+  [inventory (=) "check inventory"]
+  [help]
+  [save]
+  [load])
+
+;; Global actions ----------------------------------------
+;; Handle verbs that work anywhere.
+
+(define-everywhere everywhere-actions
+  ([quit (begin (printf "Bye!\n") (exit))]
+   [look (show-current-place)]
+   [inventory (show-inventory)]
+   [save (save-game)]
+   [load (load-game)]
+   [help (show-help)]))
+
+;; Objects ----------------------------------------
+;; Each object handles a set of transitive verbs.
+
+(define-thing cactus
+  [get "Ouch!"])
+
+(define-thing door
+  [open (if (have-thing? key)
+            (begin
+              (set-thing-state! door 'open)
+              "The door is now unlocked and open.")
+            "The door is locked.")]
+  [close (begin
+           (set-thing-state! door #f)
+           "The door is now closed.")]
+  [knock "No one is home."])
+
+(define-thing key
+  [get (if (have-thing? key)
+           "You already have the key."
+           (begin
+             (take-thing! key)
+             "You now have the key."))]
+  [put (if (have-thing? key)
+           (begin
+             (drop-thing! key)
+             "You have dropped the key.")
+           "You don't have the key.")])
+
+(define-thing trophy
+  [get (begin
+         (take-thing! trophy)
+         "You win!")])
+
+;; Places ----------------------------------------
+;; Each place handles a set of non-transitive verbs.
+
+(define-place meadow
+  "You're standing in a meadow. There is a house to the north."
+  []
+  ([north house-front]
+   [south desert]))
+
+(define-place house-front
+  "You are standing in front of a house."
+  [door]
+  ([in (if (eq? (thing-state door) 'open)
+           room
+           "The door is not open.")]
+   [south meadow]))
+
+(define-place desert
+  "You're in a desert. There is nothing for miles around."
+  [cactus key]
+  ([north meadow]
+   [south desert]
+   [east desert]
+   [west desert]))
+
+(define-place room
+  "You're in the house."
+  [trophy]
+  ([out house-front]))
+
+
+;; Go! ---------------------------------------------------
+
+(start-game meadow
+            all-verbs
+            everywhere-actions)

beautiful-racket/br/demo/txtadv/3-module-lang/README.txt

@@ -0,0 +1,8 @@
+The starting line of "world.rkt" has changed, and the ending call to
+`start-game' has been replaced by just the starting place name. The
+content of "world.rkt" is also constrained to have a `define-verbs'
+form followed by a `define-everywhere' form, but the previous version
+fit that constraint anyway.
+
+The "txtadv.rkt" module changed only in defining `module-begin' and
+exporting it as a replacement `#%module-begin'.

beautiful-racket/br/demo/txtadv/3-module-lang/world.rkt

@@ -100,4 +100,4 @@
 ;; Starting place ----------------------------------
 
 ;; The module must end with the starting place name:
-meadow
+desert

beautiful-racket/br/demo/txtadv/4-type/README.txt

@@ -0,0 +1,4 @@
+The "world.rkt" module is unchanged. The "txtadv.rkt" module has a new
+"Simple type layer" section with compile time code, which is now used
+in the macros if the "Macros for constructing and registering
+elements" section.

beautiful-racket/br/demo/txtadv/4-type/txtadv.rkt

@@ -0,0 +1,343 @@
+#lang racket
+
+(provide define-verbs
+         define-thing
+         define-place
+         define-everywhere
+         
+         show-current-place
+         show-inventory
+         save-game
+         load-game
+         show-help
+
+         have-thing?
+         take-thing!
+         drop-thing!
+         thing-state
+         set-thing-state!
+          
+         (except-out (all-from-out racket) #%module-begin)
+         (rename-out [module-begin #%module-begin]))
+
+;; ============================================================
+;; Overall module:
+
+(define-syntax module-begin
+  (syntax-rules (define-verbs define-everywhere)
+    [(_ (define-verbs all-verbs cmd ...)
+        (define-everywhere everywhere-actions act ...)
+        decl ...
+        id)
+     (#%module-begin
+      (define-verbs all-verbs cmd ...)
+      (define-everywhere everywhere-actions act ...)
+      decl ...
+      (start-game (check-type id "place")
+                  all-verbs
+                  everywhere-actions))]))
+
+;; ============================================================
+;; Model:
+
+;; Elements of the world:
+(struct verb (aliases       ; list of symbols
+              desc          ; string
+              transitive?)) ; boolean
+(struct thing (name         ; symbol
+               [state #:mutable] ; any value
+               actions))    ; list of verb--thunk pairs
+(struct place (desc         ; string
+               [things #:mutable] ; list of things
+               actions))    ; list of verb--thunk pairs
+
+;; Tables mapping names<->things for save and load
+(define names (make-hash))
+(define elements (make-hash))
+
+(define (record-element! name val)
+  (hash-set! names name val)
+  (hash-set! elements val name))
+
+(define (name->element name) (hash-ref names name #f))
+(define (element->name obj) (hash-ref elements obj #f))
+
+;; ============================================================
+;; Simple type layer:
+
+(begin-for-syntax 
+ (struct typed (id type) 
+   #:property prop:procedure (lambda (self stx) (typed-id self))
+   #:omit-define-syntaxes))
+
+(define-syntax (check-type stx)
+  (syntax-case stx ()
+    [(check-type id type)
+     (let ([v (and (identifier? #'id)
+                   (syntax-local-value #'id (lambda () #f)))])
+       (unless (and (typed? v)
+                    (equal? (syntax-e #'type) (typed-type v)))
+         (raise-syntax-error
+          #f
+          (format "not defined as ~a" (syntax-e #'type))
+          #'id))
+       #'id)]))
+
+;; ============================================================
+;; Macros for constructing and registering elements:
+
+(define-syntax-rule (define-verbs all-id
+                      [id spec ...] ...)
+  (begin
+    (define-one-verb id spec ...) ...
+    (record-element! 'id id) ...
+    (define all-id (list id ...))))
+
+(define-syntax define-one-verb
+  (syntax-rules (= _)
+    [(define-one-verb id (= alias ...) desc)
+     (begin
+       (define gen-id (verb (list 'id 'alias ...) desc #f))
+       (define-syntax id (typed #'gen-id "intransitive verb")))]
+    [(define-one-verb id _ (= alias ...) desc)
+     (begin
+       (define gen-id (verb (list 'id 'alias ...) desc #t))
+       (define-syntax id (typed #'gen-id "transitive verb")))]
+    [(define-one-verb id)
+     (define-one-verb id (=) (symbol->string 'id))]
+    [(define-one-verb id _)
+     (define-one-verb id _ (=) (symbol->string 'id))]))
+
+(define-syntax-rule (define-thing id 
+                      [vrb expr] ...)
+  (begin
+    (define gen-id 
+      (thing 'id #f (list (cons (check-type vrb "transitive verb")
+                                (lambda () expr)) ...)))
+    (define-syntax id (typed #'gen-id "thing"))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-place id 
+                      desc 
+                      (thng ...) 
+                      ([vrb expr] ...))
+  (begin
+    (define gen-id 
+      (place desc
+             (list (check-type thng "thing") ...)
+             (list (cons (check-type vrb "intransitive verb")
+                         (lambda () expr)) 
+                   ...)))
+    (define-syntax id (typed #'gen-id "place"))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-everywhere id ([vrb expr] ...))
+  (define id (list (cons (check-type vrb "intransitive verb")
+                         (lambda () expr)) 
+                   ...)))
+
+;; ============================================================
+;; Game state
+
+;; Initialized on startup:
+(define all-verbs null)          ; list of verbs
+(define everywhere-actions null) ; list of verb--thunk pairs
+
+;; Things carried by the player:
+(define stuff null) ; list of things
+
+;; Current location:
+(define current-place #f) ; place (or #f until started)
+
+;; Fuctions to be used by verb responses:
+(define (have-thing? t)
+  (memq t stuff))
+(define (take-thing! t) 
+  (set-place-things! current-place (remq t (place-things current-place)))
+  (set! stuff (cons t stuff)))
+(define (drop-thing! t) 
+  (set-place-things! current-place (cons t (place-things current-place)))
+  (set! stuff (remq t stuff)))
+
+;; ============================================================
+;; Game execution
+
+;; Show the player the current place, then get a command:
+(define (do-place)
+  (show-current-place)
+  (do-verb))
+
+;; Show the current place:
+(define (show-current-place)
+  (printf "~a\n" (place-desc current-place))
+  (for-each (lambda (thing)
+              (printf "There is a ~a here.\n" (thing-name thing)))
+            (place-things current-place)))
+
+;; Get and handle a command:
+(define (do-verb)
+  (printf "> ")
+  (flush-output)
+  (let* ([line (read-line)]
+         [input (if (eof-object? line)
+                    '(quit)
+                    (let ([port (open-input-string line)])
+                      (for/list ([v (in-port read port)]) v)))])
+    (if (and (list? input)
+             (andmap symbol? input)
+             (<= 1 (length input) 2))
+        (let ([vrb (car input)])
+            (let ([response
+                   (cond
+                    [(= 2 (length input))
+                     (handle-transitive-verb vrb (cadr input))]
+                    [(= 1 (length input))
+                     (handle-intransitive-verb vrb)])])
+              (let ([result (response)])
+                (cond
+                 [(place? result)
+                  (set! current-place result)
+                  (do-place)]
+                 [(string? result)
+                  (printf "~a\n" result)
+                  (do-verb)]
+                 [else (do-verb)]))))
+          (begin
+            (printf "I don't undertand what you mean.\n")
+            (do-verb)))))
+
+;; Handle an intransitive-verb command:
+(define (handle-intransitive-verb vrb)
+  (or
+   (find-verb vrb (place-actions current-place))
+   (find-verb vrb everywhere-actions)
+   (using-verb 
+    vrb all-verbs
+    (lambda (verb)
+      (lambda () 
+        (if (verb-transitive? verb)
+            (format "~a what?" (string-titlecase (verb-desc verb)))
+            (format "Can't ~a here." (verb-desc verb))))))
+   (lambda ()
+     (format "I don't know how to ~a." vrb))))
+
+;; Handle a transitive-verb command:
+(define (handle-transitive-verb vrb obj)
+  (or (using-verb 
+       vrb all-verbs
+       (lambda (verb)
+         (and 
+          (verb-transitive? verb)
+          (cond
+           [(ormap (lambda (thing)
+                     (and (eq? (thing-name thing) obj)
+                          thing))
+                   (append (place-things current-place)
+                           stuff))
+            => (lambda (thing)
+                 (or (find-verb vrb (thing-actions thing))
+                     (lambda ()
+                       (format "Don't know how to ~a ~a."
+                               (verb-desc verb) obj))))]
+           [else
+            (lambda ()
+              (format "There's no ~a here to ~a." obj 
+                      (verb-desc verb)))]))))
+      (lambda ()
+        (format "I don't know how to ~a ~a." vrb obj))))
+
+;; Show what the player is carrying:
+(define (show-inventory)
+  (printf "You have")
+  (if (null? stuff)
+      (printf " no items.")
+      (for-each (lambda (thing)
+                  (printf "\n  a ~a" (thing-name thing)))
+                stuff))
+  (printf "\n"))
+
+;; Look for a command match in a list of verb--response pairs,
+;; and returns the response thunk if a match is found:
+(define (find-verb cmd actions)
+  (ormap (lambda (a)
+           (and (memq cmd (verb-aliases (car a)))
+                (cdr a)))
+         actions))
+
+;; Looks for a command in a list of verbs, and
+;; applies `suucess-k' to the verb if one is found:
+(define (using-verb cmd verbs success-k)
+  (ormap (lambda (vrb)
+           (and (memq cmd (verb-aliases vrb))
+                (success-k vrb)))
+         verbs))
+
+;; Print help information:
+(define (show-help)
+  (printf "Use `look' to look around.\n")
+  (printf "Use `inventory' to see what you have.\n")
+  (printf "Use `save' or `load' to save or restore your game.\n")
+  (printf "There are some other verbs, and you can name a thing after some verbs.\n"))
+
+;; ============================================================
+;; Save and load
+
+;; Prompt the user for a filename and apply `proc' to it,
+;; catching errors to report a reasonably nice message:
+(define (with-filename proc)
+  (printf "File name: ")
+  (flush-output)
+  (let ([v (read-line)])
+    (unless (eof-object? v)
+      (with-handlers ([exn? (lambda (exn)
+                              (printf "~a\n" (exn-message exn)))])
+        (unless (path-string? v)
+          (raise-user-error "bad filename"))
+        (proc v)))))
+
+;; Save the current game state:
+(define (save-game)
+  (with-filename
+   (lambda (v)
+     (with-output-to-file v
+       (lambda ()
+         (write
+          (list
+           (map element->name stuff)
+           (element->name current-place)
+           (hash-map names
+                     (lambda (k v)
+                       (cons k
+                             (cond
+                              [(place? v) (map element->name (place-things v))]
+                              [(thing? v) (thing-state v)]
+                              [else #f])))))))))))
+
+;; Restore a game state:
+(define (load-game)
+  (with-filename
+   (lambda (v)
+     (let ([v (with-input-from-file v read)])
+       (set! stuff (map name->element (car v)))
+       (set! current-place (name->element (cadr v)))
+       (for-each
+        (lambda (p)
+          (let ([v (name->element (car p))]
+                [state (cdr p)])
+            (cond
+             [(place? v) (set-place-things! v (map name->element state))]
+             [(thing? v) (set-thing-state! v state)])))
+        (caddr v))))))
+
+;; ============================================================
+;; To go:
+
+(define (start-game in-place
+                    in-all-verbs
+                    in-everywhere-actions)
+  (set! current-place in-place)
+  (set! all-verbs in-all-verbs)
+  (set! everywhere-actions in-everywhere-actions)
+  (do-place))

beautiful-racket/br/demo/txtadv/4-type/world.rkt

@@ -0,0 +1,103 @@
+#lang s-exp "txtadv.rkt"
+
+;; Verbs ----------------------------------------
+
+;; This declaration must be first:
+(define-verbs all-verbs
+  [north (= n) "go north"]
+  [south (= s) "go south"]
+  [east (= e) "go east"]
+  [west (= w) "go west"]
+  [up (=) "go up"]
+  [down (=) "go down"]
+  [in (= enter) "enter"]
+  [out (= leave) "leave"]  
+  [get _ (= grab take) "take"]
+  [put _ (= drop leave) "drop"]
+  [open _ (= unlock) "open"]
+  [close _ (= lock) "close"]
+  [knock _]
+  [quit (= exit) "quit"]
+  [look (= show) "look"]
+  [inventory (=) "check inventory"]
+  [help]
+  [save]
+  [load])
+
+;; Global actions ----------------------------------------
+
+;; This declaration must be second:
+(define-everywhere everywhere-actions
+  ([quit (begin (printf "Bye!\n") (exit))]
+   [look (show-current-place)]
+   [inventory (show-inventory)]
+   [save (save-game)]
+   [load (load-game)]
+   [help (show-help)]))
+
+;; Objects ----------------------------------------
+
+(define-thing cactus
+  [get "Ouch!"])
+
+(define-thing door
+  [open (if (have-thing? key)
+            (begin
+              (set-thing-state! door 'open)
+              "The door is now unlocked and open.")
+            "The door is locked.")]
+  [close (begin
+           (set-thing-state! door #f)
+           "The door is now closed.")]
+  [knock "No one is home."])
+
+(define-thing key
+  [get (if (have-thing? key)
+           "You already have the key."
+           (begin
+             (take-thing! key)
+             "You now have the key."))]
+  [put (if (have-thing? key)
+           (begin
+             (drop-thing! key)
+             "You have dropped the key.")
+           "You don't have the key.")])
+
+(define-thing trophy
+  [get (begin
+         (take-thing! trophy)
+         "You win!")])
+
+;; Places ----------------------------------------
+
+(define-place meadow
+  "You're standing in a meadow. There is a house to the north."
+  []
+  ([north house-front]
+   [south desert]))
+
+(define-place house-front
+  "You are standing in front of a house."
+  [door]
+  ([in (if (eq? (thing-state door) 'open)
+           room
+           "The door is not open.")]
+   [south meadow]))
+
+(define-place desert
+  "You're in a desert. There is nothing for miles around."
+  [cactus key]
+  ([north meadow]
+   [south desert]
+   [east desert]
+   [west desert]))
+
+(define-place room
+  "You're in the house."
+  [trophy]
+  ([out house-front]))
+
+;; Starting place ----------------------------------
+
+;; The module must end with the starting place name:
+meadow

beautiful-racket/br/demo/txtadv/5-lang/README.txt

@@ -0,0 +1,10 @@
+The "world.rkt" module now uses a non-S-expression syntax, as enabled
+through the change of the first line to
+
+  #lang reader "txtadv-reader.rkt"
+
+The new "txtadv-reader.rkt" module parses the syntax of "world.rkt"
+and generates the original form as a syntax object.
+
+The "txtadv.rkt" module language is unchanged, since
+"txtadv-reader.rkt" converts "world.rkt" to its old form.

beautiful-racket/br/demo/txtadv/5-lang/txtadv-reader.rkt

@@ -0,0 +1,148 @@
+#lang racket
+(require syntax/readerr)
+
+(provide (rename-out [txtadv-read-syntax read-syntax]))
+
+(define (txtadv-read-syntax src in)
+  (expect-section src in "VERBS")
+  (define verbs (in-section src in read-verb))
+  (expect-section src in "EVERYWHERE")
+  (define actions (in-section src in read-action))
+  (expect-section src in "THINGS")
+  (define things (in-section src in read-thing))
+  (expect-section src in "PLACES")
+  (define places (in-section src in read-place))
+  (datum->syntax
+   #f
+   `(module world "txtadv.rkt"
+      (define-verbs all-verbs
+        ,@verbs)
+      (define-everywhere everywhere-actions
+        ,actions)
+      ,@things
+      ,@places
+      ,(if (null? places)
+           (complain src in "no places defined")
+           (cadar places)))))
+
+(define (complain src in msg)
+  (define-values (line col pos) (port-next-location in))
+  (raise-read-error msg src line col pos 1))
+
+(define (skip-whitespace in)
+  (regexp-try-match #px"^\\s+" in))
+      
+(define (expect-section src in name)
+  (skip-whitespace in)
+  (unless (regexp-match-peek (pregexp (format "^===~a===\\s" name))
+                             in)
+    (complain src in (format "expected a ===~a=== section" name)))
+  (read-line in)
+  (read-line in))
+
+(define (in-section src in reader)
+  (skip-whitespace in)
+  (if (or (regexp-match-peek #rx"^===" in)
+          (eof-object? (peek-byte in)))
+      null
+      (cons (reader src in)
+            (in-section src in reader))))
+
+(define (in-defn src in reader)
+  (skip-whitespace in)
+  (if (or (regexp-match-peek #rx"^(===|---)" in)
+          (eof-object? (peek-byte in)))
+      null
+      (cons (reader src in)
+            (in-defn src in reader))))
+
+(define (read-name src in)
+  (if (regexp-match-peek #px"^[A-Za-z-]+(?=:$|\\s|[],])" in)
+      (read-syntax src in)
+      (complain src in "expected a name")))
+
+(define (read-name-sequence src in transitive)
+  (let loop ([names null] [transitive transitive])
+    (define s (read-name src in))
+    (define is-trans?
+      (cond
+       [(regexp-match-peek #rx"^ _" in)
+        (if (or (eq? transitive 'unknown)
+                (eq? transitive #t))
+            (begin
+              (read-char in)
+              (read-char in)
+              #t)
+            (begin
+              (read-char in)
+              (complain src in "unexpected underscore")))]
+       [else
+        (if (eq? transitive #t)
+            (complain src in "inconsistent transitivity")
+            #f)]))
+    (if (regexp-match-peek #rx"^, " in)
+        (begin
+          (read-char in)
+          (read-char in)
+          (loop (cons s names) is-trans?))
+        (values (reverse (cons s names)) is-trans?))))
+
+(define (read-verb src in)
+  (skip-whitespace in)
+  (define-values (names is-transitive?)
+    (read-name-sequence src in 'unknown))
+  (skip-whitespace in)
+  (define desc
+    (if (regexp-match-peek #rx"^\"" in)
+        (read-syntax src in)
+        (symbol->string (syntax-e (car names)))))
+  `[,(car names) 
+    ,@(if is-transitive? '(_) '())
+    (= ,@(cdr names))
+    ,desc])
+
+(define (read-action src in)
+  (skip-whitespace in)
+  (define name (read-name src in))
+  (define expr (read-syntax src in))
+  `[,name ,expr])
+
+(define (read-defn-name src in what)
+  (skip-whitespace in)
+  (unless (regexp-match-peek #px"^---[A-Za-z][A-Za-z0-9-]*---\\s"
+                             in)
+    (complain src in (format "expected a ~a definition of the form ---name---" what)))
+  (read-string 3 in)
+  (define-values (line col pos) (port-next-location in))
+  (define name-str (bytes->string/utf-8 (cadr (regexp-match #px"^(.*?)---\\s" in))))
+  (datum->syntax #f
+                 (string->symbol name-str)
+                 (vector src line col pos (string-length name-str))
+                 orig-props))
+(define orig-props (read-syntax 'src (open-input-string "orig")))
+
+(define (read-thing src in)
+  (define name (read-defn-name src in "thing"))
+  (define actions (in-defn src in read-action))
+  `(define-thing ,name
+     ,@actions))
+
+(define (read-place src in)
+  (define name (read-defn-name src in "place"))
+  (skip-whitespace in)
+  (define desc (if (regexp-match-peek #rx"^\"" in)
+                   (read-syntax src in)
+                   (complain src in "expected description string")))
+  (skip-whitespace in)
+  (unless (regexp-match-peek #rx"^[[]" in)
+    (complain src in "expected a square bracket to start a list of things for a place"))
+  (read-char in)
+  (define-values (things _) 
+    (if (regexp-match-peek #rx"^[]]" in)
+        (values null #f)
+        (read-name-sequence src in #f)))
+  (unless (regexp-match-peek #rx"^[]]" in)
+    (complain src in "expected a square bracket to end a list of things for a place"))
+  (read-char in)
+  (define actions (in-defn src in read-action))
+  `(define-place ,name ,desc ,things ,actions))

beautiful-racket/br/demo/txtadv/5-lang/txtadv.rkt

@@ -0,0 +1,343 @@
+#lang racket
+
+(provide define-verbs
+         define-thing
+         define-place
+         define-everywhere
+         
+         show-current-place
+         show-inventory
+         save-game
+         load-game
+         show-help
+
+         have-thing?
+         take-thing!
+         drop-thing!
+         thing-state
+         set-thing-state!
+          
+         (except-out (all-from-out racket) #%module-begin)
+         (rename-out [module-begin #%module-begin]))
+
+;; ============================================================
+;; Overall module:
+
+(define-syntax module-begin
+  (syntax-rules (define-verbs define-everywhere)
+    [(_ (define-verbs all-verbs cmd ...)
+        (define-everywhere everywhere-actions act ...)
+        decl ...
+        id)
+     (#%module-begin
+      (define-verbs all-verbs cmd ...)
+      (define-everywhere everywhere-actions act ...)
+      decl ...
+      (start-game (check-type id "place")
+                  all-verbs
+                  everywhere-actions))]))
+
+;; ============================================================
+;; Model:
+
+;; Elements of the world:
+(struct verb (aliases       ; list of symbols
+              desc          ; string
+              transitive?)) ; boolean
+(struct thing (name         ; symbol
+               [state #:mutable] ; any value
+               actions))    ; list of verb--thunk pairs
+(struct place (desc         ; string
+               [things #:mutable] ; list of things
+               actions))    ; list of verb--thunk pairs
+
+;; Tables mapping names<->things for save and load
+(define names (make-hash))
+(define elements (make-hash))
+
+(define (record-element! name val)
+  (hash-set! names name val)
+  (hash-set! elements val name))
+
+(define (name->element name) (hash-ref names name #f))
+(define (element->name obj) (hash-ref elements obj #f))
+
+;; ============================================================
+;; Simple type layer:
+
+(begin-for-syntax 
+ (struct typed (id type) 
+   #:property prop:procedure (lambda (self stx) (typed-id self))
+   #:omit-define-syntaxes))
+
+(define-syntax (check-type stx)
+  (syntax-case stx ()
+    [(check-type id type)
+     (let ([v (and (identifier? #'id)
+                   (syntax-local-value #'id (lambda () #f)))])
+       (unless (and (typed? v)
+                    (equal? (syntax-e #'type) (typed-type v)))
+         (raise-syntax-error
+          #f
+          (format "not defined as ~a" (syntax-e #'type))
+          #'id))
+       #'id)]))
+
+;; ============================================================
+;; Macros for constructing and registering elements:
+
+(define-syntax-rule (define-verbs all-id
+                      [id spec ...] ...)
+  (begin
+    (define-one-verb id spec ...) ...
+    (record-element! 'id id) ...
+    (define all-id (list id ...))))
+
+(define-syntax define-one-verb
+  (syntax-rules (= _)
+    [(define-one-verb id (= alias ...) desc)
+     (begin
+       (define gen-id (verb (list 'id 'alias ...) desc #f))
+       (define-syntax id (typed #'gen-id "intransitive verb")))]
+    [(define-one-verb id _ (= alias ...) desc)
+     (begin
+       (define gen-id (verb (list 'id 'alias ...) desc #t))
+       (define-syntax id (typed #'gen-id "transitive verb")))]
+    [(define-one-verb id)
+     (define-one-verb id (=) (symbol->string 'id))]
+    [(define-one-verb id _)
+     (define-one-verb id _ (=) (symbol->string 'id))]))
+
+(define-syntax-rule (define-thing id 
+                      [vrb expr] ...)
+  (begin
+    (define gen-id 
+      (thing 'id #f (list (cons (check-type vrb "transitive verb")
+                                (lambda () expr)) ...)))
+    (define-syntax id (typed #'gen-id "thing"))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-place id 
+                      desc 
+                      (thng ...) 
+                      ([vrb expr] ...))
+  (begin
+    (define gen-id 
+      (place desc
+             (list (check-type thng "thing") ...)
+             (list (cons (check-type vrb "intransitive verb")
+                         (lambda () expr)) 
+                   ...)))
+    (define-syntax id (typed #'gen-id "place"))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-everywhere id ([vrb expr] ...))
+  (define id (list (cons (check-type vrb "intransitive verb")
+                         (lambda () expr)) 
+                   ...)))
+
+;; ============================================================
+;; Game state
+
+;; Initialized on startup:
+(define all-verbs null)          ; list of verbs
+(define everywhere-actions null) ; list of verb--thunk pairs
+
+;; Things carried by the player:
+(define stuff null) ; list of things
+
+;; Current location:
+(define current-place #f) ; place (or #f until started)
+
+;; Fuctions to be used by verb responses:
+(define (have-thing? t)
+  (memq t stuff))
+(define (take-thing! t) 
+  (set-place-things! current-place (remq t (place-things current-place)))
+  (set! stuff (cons t stuff)))
+(define (drop-thing! t) 
+  (set-place-things! current-place (cons t (place-things current-place)))
+  (set! stuff (remq t stuff)))
+
+;; ============================================================
+;; Game execution
+
+;; Show the player the current place, then get a command:
+(define (do-place)
+  (show-current-place)
+  (do-verb))
+
+;; Show the current place:
+(define (show-current-place)
+  (printf "~a\n" (place-desc current-place))
+  (for-each (lambda (thing)
+              (printf "There is a ~a here.\n" (thing-name thing)))
+            (place-things current-place)))
+
+;; Get and handle a command:
+(define (do-verb)
+  (printf "> ")
+  (flush-output)
+  (let* ([line (read-line)]
+         [input (if (eof-object? line)
+                    '(quit)
+                    (let ([port (open-input-string line)])
+                      (for/list ([v (in-port read port)]) v)))])
+    (if (and (list? input)
+             (andmap symbol? input)
+             (<= 1 (length input) 2))
+        (let ([vrb (car input)])
+            (let ([response
+                   (cond
+                    [(= 2 (length input))
+                     (handle-transitive-verb vrb (cadr input))]
+                    [(= 1 (length input))
+                     (handle-intransitive-verb vrb)])])
+              (let ([result (response)])
+                (cond
+                 [(place? result)
+                  (set! current-place result)
+                  (do-place)]
+                 [(string? result)
+                  (printf "~a\n" result)
+                  (do-verb)]
+                 [else (do-verb)]))))
+          (begin
+            (printf "I don't undertand what you mean.\n")
+            (do-verb)))))
+
+;; Handle an intransitive-verb command:
+(define (handle-intransitive-verb vrb)
+  (or
+   (find-verb vrb (place-actions current-place))
+   (find-verb vrb everywhere-actions)
+   (using-verb 
+    vrb all-verbs
+    (lambda (verb)
+      (lambda () 
+        (if (verb-transitive? verb)
+            (format "~a what?" (string-titlecase (verb-desc verb)))
+            (format "Can't ~a here." (verb-desc verb))))))
+   (lambda ()
+     (format "I don't know how to ~a." vrb))))
+
+;; Handle a transitive-verb command:
+(define (handle-transitive-verb vrb obj)
+  (or (using-verb 
+       vrb all-verbs
+       (lambda (verb)
+         (and 
+          (verb-transitive? verb)
+          (cond
+           [(ormap (lambda (thing)
+                     (and (eq? (thing-name thing) obj)
+                          thing))
+                   (append (place-things current-place)
+                           stuff))
+            => (lambda (thing)
+                 (or (find-verb vrb (thing-actions thing))
+                     (lambda ()
+                       (format "Don't know how to ~a ~a."
+                               (verb-desc verb) obj))))]
+           [else
+            (lambda ()
+              (format "There's no ~a here to ~a." obj 
+                      (verb-desc verb)))]))))
+      (lambda ()
+        (format "I don't know how to ~a ~a." vrb obj))))
+
+;; Show what the player is carrying:
+(define (show-inventory)
+  (printf "You have")
+  (if (null? stuff)
+      (printf " no items.")
+      (for-each (lambda (thing)
+                  (printf "\n  a ~a" (thing-name thing)))
+                stuff))
+  (printf "\n"))
+
+;; Look for a command match in a list of verb--response pairs,
+;; and returns the response thunk if a match is found:
+(define (find-verb cmd actions)
+  (ormap (lambda (a)
+           (and (memq cmd (verb-aliases (car a)))
+                (cdr a)))
+         actions))
+
+;; Looks for a command in a list of verbs, and
+;; applies `suucess-k' to the verb if one is found:
+(define (using-verb cmd verbs success-k)
+  (ormap (lambda (vrb)
+           (and (memq cmd (verb-aliases vrb))
+                (success-k vrb)))
+         verbs))
+
+;; Print help information:
+(define (show-help)
+  (printf "Use `look' to look around.\n")
+  (printf "Use `inventory' to see what you have.\n")
+  (printf "Use `save' or `load' to save or restore your game.\n")
+  (printf "There are some other verbs, and you can name a thing after some verbs.\n"))
+
+;; ============================================================
+;; Save and load
+
+;; Prompt the user for a filename and apply `proc' to it,
+;; catching errors to report a reasonably nice message:
+(define (with-filename proc)
+  (printf "File name: ")
+  (flush-output)
+  (let ([v (read-line)])
+    (unless (eof-object? v)
+      (with-handlers ([exn? (lambda (exn)
+                              (printf "~a\n" (exn-message exn)))])
+        (unless (path-string? v)
+          (raise-user-error "bad filename"))
+        (proc v)))))
+
+;; Save the current game state:
+(define (save-game)
+  (with-filename
+   (lambda (v)
+     (with-output-to-file v
+       (lambda ()
+         (write
+          (list
+           (map element->name stuff)
+           (element->name current-place)
+           (hash-map names
+                     (lambda (k v)
+                       (cons k
+                             (cond
+                              [(place? v) (map element->name (place-things v))]
+                              [(thing? v) (thing-state v)]
+                              [else #f])))))))))))
+
+;; Restore a game state:
+(define (load-game)
+  (with-filename
+   (lambda (v)
+     (let ([v (with-input-from-file v read)])
+       (set! stuff (map name->element (car v)))
+       (set! current-place (name->element (cadr v)))
+       (for-each
+        (lambda (p)
+          (let ([v (name->element (car p))]
+                [state (cdr p)])
+            (cond
+             [(place? v) (set-place-things! v (map name->element state))]
+             [(thing? v) (set-thing-state! v state)])))
+        (caddr v))))))
+
+;; ============================================================
+;; To go:
+
+(define (start-game in-place
+                    in-all-verbs
+                    in-everywhere-actions)
+  (set! current-place in-place)
+  (set! all-verbs in-all-verbs)
+  (set! everywhere-actions in-everywhere-actions)
+  (do-place))

beautiful-racket/br/demo/txtadv/5-lang/world.rkt

@@ -0,0 +1,176 @@
+#lang reader "txtadv-reader.rkt"
+
+===VERBS===
+
+north, n
+ "go north"
+
+south, s
+ "go south"
+
+east, e
+ "go east"
+
+west, w
+ "go west"
+
+up
+ "go up"
+
+down
+ "go down"
+
+in, enter
+ "enter"
+
+out, leave
+ "leave"
+
+get _, grab _, take _
+ "take"
+
+put _, drop _, leave _
+ "drop"
+
+open _, unlock _
+ "open"
+
+close _, lock _
+ "close"
+
+knock _
+
+quit, exit
+ "quit"
+
+look, show
+ "look"
+
+inventory
+ "check inventory"
+
+help
+
+save
+
+load
+
+
+===EVERYWHERE===
+
+quit 
+ (begin
+  (printf "Bye!\n")
+  (exit))
+
+look 
+ (show-current-place)
+
+inventory 
+ (show-inventory)
+
+save
+ (save-game)
+
+load
+ (load-game)
+
+help
+ (show-help)
+
+
+===THINGS===
+
+---cactus---
+get
+  "Ouch!"
+
+---door---
+open 
+  (if (have-thing? key)
+      (begin
+        (set-thing-state! door 'open)
+        "The door is now unlocked and open.")
+      "The door is locked.")
+
+close
+  (begin
+   (set-thing-state! door #f)
+   "The door is now closed.")
+
+knock
+  "No one is home."
+
+---key---
+
+get
+  (if (have-thing? key)
+      "You already have the key."
+      (begin
+        (take-thing! key)
+        "You now have the key."))
+
+put
+  (if (have-thing? key)
+      (begin
+        (drop-thing! key)
+        "You have dropped the key.")
+      "You don't have the key.")
+
+---trophy---
+
+get
+  (begin
+   (take-thing! trophy)
+   "You win!")
+
+
+===PLACES===
+
+---meadow---
+"You're standing in a meadow. There is a house to the north."
+[]
+
+north
+ house-front
+
+south
+ desert
+
+
+---house-front---
+"You are standing in front of a house."
+[door]
+
+in 
+  (if (eq? (thing-state door) 'open)
+      room
+      "The door is not open.")
+
+south
+  meadow
+
+
+---desert---
+"You're in a desert. There is nothing for miles around."
+[cactus, key]
+
+north
+  meadow
+
+south
+  desert
+
+east
+  desert
+
+west
+  desert
+
+
+---room---
+"You're in the house."
+[trophy]
+
+out
+  house-front

beautiful-racket/br/demo/txtadv/6-color/README.txt

@@ -0,0 +1,21 @@
+To make this version work, you need the directory containing this file
+to be installed as the "txtadv" collection. One way to do that is with
+the shell command
+
+   raco link --name txtadv .
+
+in the directory containing this file.
+
+
+The "world.rkt" module is the same as before, except that its first
+line is now
+
+  #lang txtadv
+
+The "txtadv.rkt" module is unchanged.
+
+Compared to the previous implementation, "txtadv-reader.rkt" is now
+"lang/reader.rkt", which is required to match Racket's protocol for
+resolving `#lang txtadv' to its reader module. The only other change
+is that a `get-info' function points to the "color.rkt" module in
+"lang" to implement syntax coloring.

beautiful-racket/br/demo/txtadv/6-color/reader.rkt

@@ -16,7 +16,7 @@
   (define places (in-section src in read-place))
   (datum->syntax
    #f
-   `(module world br/demo/txtadv/expander
+   `(module world "txtadv.rkt"
       (define-verbs all-verbs
         ,@verbs)
       (define-everywhere everywhere-actions

beautiful-racket/br/demo/txtadv/6-color/txtadv.rkt

@@ -0,0 +1,343 @@
+#lang racket
+
+(provide define-verbs
+         define-thing
+         define-place
+         define-everywhere
+         
+         show-current-place
+         show-inventory
+         save-game
+         load-game
+         show-help
+
+         have-thing?
+         take-thing!
+         drop-thing!
+         thing-state
+         set-thing-state!
+          
+         (except-out (all-from-out racket) #%module-begin)
+         (rename-out [module-begin #%module-begin]))
+
+;; ============================================================
+;; Overall module:
+
+(define-syntax module-begin
+  (syntax-rules (define-verbs define-everywhere)
+    [(_ (define-verbs all-verbs cmd ...)
+        (define-everywhere everywhere-actions act ...)
+        decl ...
+        id)
+     (#%module-begin
+      (define-verbs all-verbs cmd ...)
+      (define-everywhere everywhere-actions act ...)
+      decl ...
+      (start-game (check-type id "place")
+                  all-verbs
+                  everywhere-actions))]))
+
+;; ============================================================
+;; Model:
+
+;; Elements of the world:
+(struct verb (aliases       ; list of symbols
+              desc          ; string
+              transitive?)) ; boolean
+(struct thing (name         ; symbol
+               [state #:mutable] ; any value
+               actions))    ; list of verb--thunk pairs
+(struct place (desc         ; string
+               [things #:mutable] ; list of things
+               actions))    ; list of verb--thunk pairs
+
+;; Tables mapping names<->things for save and load
+(define names (make-hash))
+(define elements (make-hash))
+
+(define (record-element! name val)
+  (hash-set! names name val)
+  (hash-set! elements val name))
+
+(define (name->element name) (hash-ref names name #f))
+(define (element->name obj) (hash-ref elements obj #f))
+
+;; ============================================================
+;; Simple type layer:
+
+(begin-for-syntax 
+ (struct typed (id type) 
+   #:property prop:procedure (lambda (self stx) (typed-id self))
+   #:omit-define-syntaxes))
+
+(define-syntax (check-type stx)
+  (syntax-case stx ()
+    [(check-type id type)
+     (let ([v (and (identifier? #'id)
+                   (syntax-local-value #'id (lambda () #f)))])
+       (unless (and (typed? v)
+                    (equal? (syntax-e #'type) (typed-type v)))
+         (raise-syntax-error
+          #f
+          (format "not defined as ~a" (syntax-e #'type))
+          #'id))
+       #'id)]))
+
+;; ============================================================
+;; Macros for constructing and registering elements:
+
+(define-syntax-rule (define-verbs all-id
+                      [id spec ...] ...)
+  (begin
+    (define-one-verb id spec ...) ...
+    (record-element! 'id id) ...
+    (define all-id (list id ...))))
+
+(define-syntax define-one-verb
+  (syntax-rules (= _)
+    [(define-one-verb id (= alias ...) desc)
+     (begin
+       (define gen-id (verb (list 'id 'alias ...) desc #f))
+       (define-syntax id (typed #'gen-id "intransitive verb")))]
+    [(define-one-verb id _ (= alias ...) desc)
+     (begin
+       (define gen-id (verb (list 'id 'alias ...) desc #t))
+       (define-syntax id (typed #'gen-id "transitive verb")))]
+    [(define-one-verb id)
+     (define-one-verb id (=) (symbol->string 'id))]
+    [(define-one-verb id _)
+     (define-one-verb id _ (=) (symbol->string 'id))]))
+
+(define-syntax-rule (define-thing id 
+                      [vrb expr] ...)
+  (begin
+    (define gen-id 
+      (thing 'id #f (list (cons (check-type vrb "transitive verb")
+                                (lambda () expr)) ...)))
+    (define-syntax id (typed #'gen-id "thing"))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-place id 
+                      desc 
+                      (thng ...) 
+                      ([vrb expr] ...))
+  (begin
+    (define gen-id 
+      (place desc
+             (list (check-type thng "thing") ...)
+             (list (cons (check-type vrb "intransitive verb")
+                         (lambda () expr)) 
+                   ...)))
+    (define-syntax id (typed #'gen-id "place"))
+    (record-element! 'id id)))
+
+
+(define-syntax-rule (define-everywhere id ([vrb expr] ...))
+  (define id (list (cons (check-type vrb "intransitive verb")
+                         (lambda () expr)) 
+                   ...)))
+
+;; ============================================================
+;; Game state
+
+;; Initialized on startup:
+(define all-verbs null)          ; list of verbs
+(define everywhere-actions null) ; list of verb--thunk pairs
+
+;; Things carried by the player:
+(define stuff null) ; list of things
+
+;; Current location:
+(define current-place #f) ; place (or #f until started)
+
+;; Fuctions to be used by verb responses:
+(define (have-thing? t)
+  (memq t stuff))
+(define (take-thing! t) 
+  (set-place-things! current-place (remq t (place-things current-place)))
+  (set! stuff (cons t stuff)))
+(define (drop-thing! t) 
+  (set-place-things! current-place (cons t (place-things current-place)))
+  (set! stuff (remq t stuff)))
+
+;; ============================================================
+;; Game execution
+
+;; Show the player the current place, then get a command:
+(define (do-place)
+  (show-current-place)
+  (do-verb))
+
+;; Show the current place:
+(define (show-current-place)
+  (printf "~a\n" (place-desc current-place))
+  (for-each (lambda (thing)
+              (printf "There is a ~a here.\n" (thing-name thing)))
+            (place-things current-place)))
+
+;; Get and handle a command:
+(define (do-verb)
+  (printf "> ")
+  (flush-output)
+  (let* ([line (read-line)]
+         [input (if (eof-object? line)
+                    '(quit)
+                    (let ([port (open-input-string line)])
+                      (for/list ([v (in-port read port)]) v)))])
+    (if (and (list? input)
+             (andmap symbol? input)
+             (<= 1 (length input) 2))
+        (let ([vrb (car input)])
+            (let ([response
+                   (cond
+                    [(= 2 (length input))
+                     (handle-transitive-verb vrb (cadr input))]
+                    [(= 1 (length input))
+                     (handle-intransitive-verb vrb)])])
+              (let ([result (response)])
+                (cond
+                 [(place? result)
+                  (set! current-place result)
+                  (do-place)]
+                 [(string? result)
+                  (printf "~a\n" result)
+                  (do-verb)]
+                 [else (do-verb)]))))
+          (begin
+            (printf "I don't undertand what you mean.\n")
+            (do-verb)))))
+
+;; Handle an intransitive-verb command:
+(define (handle-intransitive-verb vrb)
+  (or
+   (find-verb vrb (place-actions current-place))
+   (find-verb vrb everywhere-actions)
+   (using-verb 
+    vrb all-verbs
+    (lambda (verb)
+      (lambda () 
+        (if (verb-transitive? verb)
+            (format "~a what?" (string-titlecase (verb-desc verb)))
+            (format "Can't ~a here." (verb-desc verb))))))
+   (lambda ()
+     (format "I don't know how to ~a." vrb))))
+
+;; Handle a transitive-verb command:
+(define (handle-transitive-verb vrb obj)
+  (or (using-verb 
+       vrb all-verbs
+       (lambda (verb)
+         (and 
+          (verb-transitive? verb)
+          (cond
+           [(ormap (lambda (thing)
+                     (and (eq? (thing-name thing) obj)
+                          thing))
+                   (append (place-things current-place)
+                           stuff))
+            => (lambda (thing)
+                 (or (find-verb vrb (thing-actions thing))
+                     (lambda ()
+                       (format "Don't know how to ~a ~a."
+                               (verb-desc verb) obj))))]
+           [else
+            (lambda ()
+              (format "There's no ~a here to ~a." obj 
+                      (verb-desc verb)))]))))
+      (lambda ()
+        (format "I don't know how to ~a ~a." vrb obj))))
+
+;; Show what the player is carrying:
+(define (show-inventory)
+  (printf "You have")
+  (if (null? stuff)
+      (printf " no items.")
+      (for-each (lambda (thing)
+                  (printf "\n  a ~a" (thing-name thing)))
+                stuff))
+  (printf "\n"))
+
+;; Look for a command match in a list of verb--response pairs,
+;; and returns the response thunk if a match is found:
+(define (find-verb cmd actions)
+  (ormap (lambda (a)
+           (and (memq cmd (verb-aliases (car a)))
+                (cdr a)))
+         actions))
+
+;; Looks for a command in a list of verbs, and
+;; applies `suucess-k' to the verb if one is found:
+(define (using-verb cmd verbs success-k)
+  (ormap (lambda (vrb)
+           (and (memq cmd (verb-aliases vrb))
+                (success-k vrb)))
+         verbs))
+
+;; Print help information:
+(define (show-help)
+  (printf "Use `look' to look around.\n")
+  (printf "Use `inventory' to see what you have.\n")
+  (printf "Use `save' or `load' to save or restore your game.\n")
+  (printf "There are some other verbs, and you can name a thing after some verbs.\n"))
+
+;; ============================================================
+;; Save and load
+
+;; Prompt the user for a filename and apply `proc' to it,
+;; catching errors to report a reasonably nice message:
+(define (with-filename proc)
+  (printf "File name: ")
+  (flush-output)
+  (let ([v (read-line)])
+    (unless (eof-object? v)
+      (with-handlers ([exn? (lambda (exn)
+                              (printf "~a\n" (exn-message exn)))])
+        (unless (path-string? v)
+          (raise-user-error "bad filename"))
+        (proc v)))))
+
+;; Save the current game state:
+(define (save-game)
+  (with-filename
+   (lambda (v)
+     (with-output-to-file v
+       (lambda ()
+         (write
+          (list
+           (map element->name stuff)
+           (element->name current-place)
+           (hash-map names
+                     (lambda (k v)
+                       (cons k
+                             (cond
+                              [(place? v) (map element->name (place-things v))]
+                              [(thing? v) (thing-state v)]
+                              [else #f])))))))))))
+
+;; Restore a game state:
+(define (load-game)
+  (with-filename
+   (lambda (v)
+     (let ([v (with-input-from-file v read)])
+       (set! stuff (map name->element (car v)))
+       (set! current-place (name->element (cadr v)))
+       (for-each
+        (lambda (p)
+          (let ([v (name->element (car p))]
+                [state (cdr p)])
+            (cond
+             [(place? v) (set-place-things! v (map name->element state))]
+             [(thing? v) (set-thing-state! v state)])))
+        (caddr v))))))
+
+;; ============================================================
+;; To go:
+
+(define (start-game in-place
+                    in-all-verbs
+                    in-everywhere-actions)
+  (set! current-place in-place)
+  (set! all-verbs in-all-verbs)
+  (set! everywhere-actions in-everywhere-actions)
+  (do-place))

beautiful-racket/br/demo/txtadv/6-color/world.rkt

@@ -1,4 +1,4 @@
-#lang br/demo/txtadv
+#lang reader "reader.rkt"
 
 ===VERBS===
 
@@ -49,6 +49,12 @@ look, show
 inventory
  "check inventory"
 
+help
+
+save
+
+load
+
 
 ===EVERYWHERE===
 
@@ -63,6 +69,14 @@ look
 inventory 
  (show-inventory)
 
+save
+ (save-game)
+
+load
+ (load-game)
+
+help
+ (show-help)
 
 
 ===THINGS===

beautiful-racket/br/demo/txtadv/expander.rkt

@@ -32,8 +32,9 @@
 
 (provide verb-section)
 (define-inverting #'(verb-section _heading _verb-entry ...)
+  (inject-syntax ([#'all-verbs (shared-syntax 'all-verbs)])
                  #'(define-verbs all-verbs
-       _verb-entry ...))
+                     _verb-entry ...)))
 
 (provide verb-item)
 (define-inverting #'(verb-item (_name0 _transitive0?) (_name _transitive?) ... _desc)
@@ -80,7 +81,6 @@
 (define #'(place-id _id) #'_id)
 
 (provide place-descrip)
-(require sugar/debug)
 (define #'(place-descrip _desc) #'_desc)
 
 (provide place-items)
@@ -105,9 +105,10 @@
 
 (provide start-section)
 (define #'(start-section _heading _where)
+  (inject-syntax ([#'all-verbs (shared-syntax 'all-verbs)])
                  #'(init-game _where
                               all-verbs
-                  everywhere-actions))
+                              everywhere-actions)))
 
 ;; ============================================================
 ;; Model:
@@ -115,13 +116,13 @@
 ;; Elements of the world:
 (struct verb (aliases       ; list of symbols
               desc          ; string
-              transitive?)) ; boolean
+              transitive?) #:transparent) ; boolean
 (struct thing (name         ; symbol
                [state #:mutable] ; any value
-               actions))    ; list of verb--thunk pairs
+               actions) #:transparent)    ; list of verb--thunk pairs
 (struct place (desc         ; string
                [things #:mutable] ; list of things
-               actions))    ; list of verb--thunk pairs
+               actions) #:transparent)    ; list of verb--thunk pairs
 
 ;; Tables mapping names<->things for save and load
 (define names (make-hash))

beautiful-racket/br/demo/txtadv/flatt-acm.webloc

@@ -0,0 +1,8 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+	<key>URL</key>
+	<string>http://queue.acm.org/detail.cfm?id=2068896</string>
+</dict>
+</plist>

beautiful-racket/br/demo/txtadv/footest.rkt

@@ -1 +0,0 @@
-#lang racket

beautiful-racket/br/demo/txtadv/world-sexp.rkt

@@ -0,0 +1,103 @@
+#lang s-exp "expander.rkt"
+
+;; Verbs ----------------------------------------
+
+;; This declaration must be first:
+(define-verbs all-verbs
+  [north (= n) "go north"]
+  [south (= s) "go south"]
+  [east (= e) "go east"]
+  [west (= w) "go west"]
+  [up (=) "go up"]
+  [down (=) "go down"]
+  [in (= enter) "enter"]
+  [out (= leave) "leave"]  
+  [get _ (= grab take) "take"]
+  [put _ (= drop leave) "drop"]
+  [open _ (= unlock) "open"]
+  [close _ (= lock) "close"]
+  [knock _]
+  [quit (= exit) "quit"]
+  [look (= show) "look"]
+  [inventory (=) "check inventory"]
+  [help]
+  [save]
+  [load])
+
+;; Global actions ----------------------------------------
+
+;; This declaration must be second:
+(define-everywhere everywhere-actions
+  ([quit (begin (printf "Bye!\n") (exit))]
+   [look (show-current-place)]
+   [inventory (show-inventory)]
+   [save (save-game)]
+   [load (load-game)]
+   [help (show-help)]))
+
+;; Objects ----------------------------------------
+
+(define-thing cactus
+  [get "Ouch!"])
+
+(define-thing door
+  [open (if (have-thing? key)
+            (begin
+              (set-thing-state! door 'open)
+              "The door is now unlocked and open.")
+            "The door is locked.")]
+  [close (begin
+           (set-thing-state! door #f)
+           "The door is now closed.")]
+  [knock "No one is home."])
+
+(define-thing key
+  [get (if (have-thing? key)
+           "You already have the key."
+           (begin
+             (take-thing! key)
+             "You now have the key."))]
+  [put (if (have-thing? key)
+           (begin
+             (drop-thing! key)
+             "You have dropped the key.")
+           "You don't have the key.")])
+
+(define-thing trophy
+  [get (begin
+         (take-thing! trophy)
+         "You win!")])
+
+;; Places ----------------------------------------
+
+(define-place meadow
+  "You're standing in a meadow. There is a house to the north."
+  []
+  ([north house-front]
+   [south desert]))
+
+(define-place house-front
+  "You are standing in front of a house."
+  [door]
+  ([in (if (eq? (thing-state door) 'open)
+           room
+           "The door is not open.")]
+   [south meadow]))
+
+(define-place desert
+  "You're in a desert. There is nothing for miles around."
+  [cactus key]
+  ([north meadow]
+   [south desert]
+   [east desert]
+   [west desert]))
+
+(define-place room
+  "You're in the house."
+  [trophy]
+  ([out house-front]))
+
+;; Starting place ----------------------------------
+
+;; The module must end with the starting place name:
+meadow

beautiful-racket/br/demo/txtadv/world0-test.rkt

@@ -1,41 +0,0 @@
-#lang at-exp racket
-(require rackunit)
-(require "world0.rkt")
-
-(check-equal? (with-output-to-string (λ _ (do-place)))
-              "You're standing in a meadow. There is a house to the north.\n")
-
-(define-syntax-rule (check-cmd? cmd result)
-  (check-equal? (with-output-to-string (λ _ (do-verb cmd))) result))
-
-(check-cmd?
- "s"
- "You're in a desert. There is nothing for miles around.\nThere is a cactus here.\nThere is a key here.\n")
-
-(check-cmd?
- "get cactus"
- "Ouch!\n")
-
-(check-cmd?
- "get key"
- "You now have the key.\n")
-
-(check-cmd?
- "n"
- "You're standing in a meadow. There is a house to the north.\n")
-
-(check-cmd?
- "n"
- "You are standing in front of a house.\nThere is a door here.\n")
-
-(check-cmd?
- "open door"
- "The door is now unlocked and open.\n")
-
-(check-cmd?
- "enter"
- "You're in the house.\nThere is a trophy here.\n")
-
-(check-cmd?
- "get trophy"
- "You win!\n")