fix transitive verbs

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

@@ -23,12 +23,17 @@
 
 (define #'(module-begin (txtadv-program _section ...))
   #'(#%module-begin
-     _section ...))
+     _section ...
+     
+       (provide do-verb do-place)
+       (module+ main
+         (parameterize ([cmd-line-mode? #t])
+           (do-place)))))
 
 (provide verb-section)
 (define-inverting #'(verb-section _heading _verb-entry ...)
-  #''(define-verbs all-verbs
+  #'(define-verbs all-verbs
-        _verb-entry ...))
+       _verb-entry ...))
 
 (provide verb-item)
 (define-inverting #'(verb-item (_name0 _transitive0?) (_name _transitive?) ... _desc)
@@ -44,8 +49,8 @@
 
 (provide everywhere-section)
 (define-inverting #'(everywhere-section _heading [_name _desc] ...)
-  #''(define-everywhere everywhere-actions
+  #'(define-everywhere everywhere-actions
-        ([_name _desc] ...)))
+       ([_name _desc] ...)))
 
 (provide everywhere-item)
 (define-inverting #'(everywhere-item _name _desc)
@@ -57,12 +62,38 @@
 
 (provide thing-item)
 (define-inverting #'(thing-item (thing-id _thingname) (_actionname _actiondesc) ...)
-  #''(define-thing _thingname [_actionname _actiondesc] ...))
+  #'(define-thing _thingname [_actionname _actiondesc] ...))
 
 (provide thing-action)
 (define-inverting #'(thing-action _actionname _actiondesc)
   #'(_actionname _actiondesc))
 
+(provide places-section)
+(define-inverting #'(places-section _heading _placeitem ...)
+  #'(begin _placeitem ...))
+
+(provide place-item)
+(define-inverting #'(place-item _place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...)
+  #'(define-place _place-id _place-desc [_place-item ...] ([_actionname _actiondesc] ...)))
+
+(provide place-id)
+(define #'(place-id _id) #'_id)
+
+(provide place-descrip)
+(require sugar/debug)
+(define #'(place-descrip _desc) #'_desc)
+
+(provide place-items)
+(define-inverting #'(place-items "[" _id ... "]") #'(_id ...))
+
+(provide place-name)
+(define-cases #'place-name
+  [#'(_ "," _id) #'_id]
+  [#'(_ _id) #'_id])
+  
+(provide place-action)
+(define-inverting #'(place-action _id _desc) #'(_id _desc))
+
 (provide desc)
 (define #'(desc _d) #'_d)
 
@@ -72,22 +103,11 @@
   [#'(_ _sx) #'_sx])
 
 
-
+(provide start-section)
-#;(define #'(module-begin (define-verbs _all-verbs _cmd ...)
+(define #'(start-section _heading _where)
-                        (define-everywhere _everywhere-actions _act ...)
+  #'(init-game _where
-                        _decl ...
+                  all-verbs
-                        _id)
+                  everywhere-actions))
-  #'(#%module-begin
-     (define-verbs _all-verbs _cmd ...)
-     (define-everywhere _everywhere-actions _act ...)
-     _decl ...
-     (init-game (check-type _id "place")
-                _all-verbs
-                _everywhere-actions)
-     (provide do-verb do-place)
-     (module+ main
-       (parameterize ([cmd-line-mode? #t])
-         (do-place)))))
 
 ;; ============================================================
 ;; Model:
@@ -114,25 +134,6 @@
 (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 (λ (self stx) (typed-id self))
-    #:omit-define-syntaxes))
-
-(define #'(check-type _id _type)
-  (let ([v (and (identifier? #'_id)
-                (syntax-local-value #'_id (λ () #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:
 
@@ -144,44 +145,39 @@
 
 
 ;; todo: the underscore arguments in cases 2 & 4 should be literal underscores, not wildcards
-(define-cases #'define-one-verb
+(define-syntax define-one-verb
-  [#'(_ _id (= _alias ...) _desc)
+  (syntax-rules (= _)
-   #'(begin
+    [(define-one-verb id (= alias ...) desc)
-       (define gen-id (verb (list '_id '_alias ...) _desc #f))
+     (define id (verb (list 'id 'alias ...) desc #f))]
-       (define-syntax _id (typed #'gen-id "intransitive verb")))]
+    [(define-one-verb id _ (= alias ...) desc)
-  [#'(_ _id _ (= _alias ...) _desc)
+     (define id (verb (list 'id 'alias ...) desc #t))]
-   #'(begin
+    [(define-one-verb id)
-       (define gen-id (verb (list '_id '_alias ...) _desc #t))
+     (define id (verb (list 'id) (symbol->string 'id) #f))]
-       (define-syntax _id (typed #'gen-id "transitive verb")))]
+    [(define-one-verb id _)
-  [#'(_ _id)
+     (define id (verb (list 'id) (symbol->string 'id) #t))]))
-   #'(define-one-verb _id (=) (symbol->string '_id))]
+
-  [#'(_ _id _)
+
-   #'(define-one-verb _id _ (=) (symbol->string '_id))])
+(define-syntax-rule (define-thing id 
-
+                      [vrb expr] ...)
-
+  (begin
-(define #'(define-thing _id [_verb _expr] ...)
+    (define id 
-  #'(begin
+      (thing 'id #f (list (cons vrb (lambda () expr)) ...)))
-      (define gen-id 
+    (record-element! 'id id)))
-        (thing '_id #f (list (cons (check-type _verb "transitive verb")
+
-                                   (λ () _expr)) ...)))
+
-      (define-syntax _id (typed #'gen-id "thing"))
+(define-syntax-rule (define-place id 
-      (record-element! '_id _id)))
+                      desc 
-
+                      (thng ...) 
-
+                      ([vrb expr] ...))
-(define #'(define-place _id _desc (_thing ...) ([_verb _expr] ...))
+  (begin
-  #'(begin
+    (define id (place desc
-      (define gen-id 
+                      (list thng ...)
-        (place _desc
+                      (list (cons vrb (lambda () expr)) ...)))
-               (list (check-type _thing "thing") ...)
+    (record-element! 'id id)))
-               (list (cons (check-type _verb "intransitive verb")
+
-                           (λ () _expr)) 
+
-                     ...)))
+(define-syntax-rule (define-everywhere id ([vrb expr] ...))
-      (define-syntax _id (typed #'gen-id "place"))
+  (define id (list (cons vrb (lambda () expr)) ...)))
-      (record-element! '_id _id)))
-
-
-(define #'(define-everywhere _id ([_verb _expr] ...))
-  #'(define _id (list (cons (check-type _verb "intransitive verb") (λ () _expr)) ...)))
 
 ;; ============================================================
 ;; Game state

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

@@ -1,6 +1,6 @@
 #lang ragg
 
-txtadv-program : [verb-section] [everywhere-section] [things-section]
+txtadv-program : [verb-section] [everywhere-section] [things-section] places-section start-section
 
 verb-section : "===VERBS===" verb-item+
 
@@ -16,10 +16,26 @@ things-section : "===THINGS===" thing-item+
 
 thing-item : thing-id thing-action+
 
-thing-id : THING-NAME
+thing-id : DASHED-NAME
 
 thing-action : ID desc
 
+places-section : "===PLACES===" place-item+
+
+place-item : place-id place-descrip place-items place-action+
+
+place-id : DASHED-NAME
+
+place-descrip : STRING ; place-desc is already used in expander
+
+place-items : "[" place-name* "]" ; place-things is already used
+
+place-name : [","] ID
+
+place-action : ID desc
+
+start-section : "===START===" place-name
+
 desc : s-exp
 
 s-exp : ID | STRING | ("(" | "[" | "{") s-exp* (")" | "]" | "}")

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

@@ -0,0 +1,311 @@
+#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 id
+                  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))
+
+;; ============================================================
+;; 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/tokenizer.rkt

@@ -15,11 +15,11 @@
         (token 'COMMENT lexeme #:skip? #t)]
        [(union #\tab #\space #\newline) (get-token input-port)]
        [(repetition 1 +inf.0 (union upper-case (char-set "="))) lexeme]
-       [(seq "\"" (complement (seq any-string "\"" any-string)) "\"") (token 'STRING lexeme)]
+       [(seq "\"" (complement (seq any-string "\"" any-string)) "\"") (token 'STRING (string-trim lexeme "\""))]
        [(seq "---"
              (repetition 1 +inf.0 (union alphabetic numeric punctuation))
-             "---") (token 'THING-NAME (string->symbol (string-trim lexeme "-" #:repeat? #t)))]
+             "---") (token 'DASHED-NAME (string->symbol (string-trim lexeme "-" #:repeat? #t)))]
-       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-!?.#")))
+       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-!?.#'")))
         (token 'ID (read (open-input-string lexeme)))]
        [any-char lexeme]))
     (get-token input-port))  

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

@@ -1,6 +1,5 @@
 #lang reader "reader.rkt"
 
-/*
 ===VERBS===
 
 north, n
@@ -77,9 +76,9 @@ get
 
 ---door---
 open 
-  (if 
+  (if (have-thing? key)
       (begin
-        (set-thing-state! door open)
+        (set-thing-state! door 'open)
         "The door is now unlocked and open.")
       "The door is locked.")
 
@@ -118,7 +117,6 @@ get
 
 
 
-*/
 
 
 ===PLACES===
@@ -127,6 +125,7 @@ get
 "You're standing in a meadow. There is a house to the north."
 []
 
+
 north
  house-front
 
@@ -170,3 +169,8 @@ west
 
 out
   house-front
+
+
+===START===
+
+meadow

beautiful-racket/br/demo/txtadv/world0-sexp.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