working

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

@@ -21,19 +21,23 @@
 ;; ============================================================
 ;; Overall module:
 
-(define #'(module-begin (txtadv-program _section ...))
+(define #'(module-begin _lines ...)
   #'(#%module-begin
-     _section ...
+     _lines ...
      
      (provide do-verb do-place)
      (module+ main
        (parameterize ([cmd-line-mode? #t])
          (do-place)))))
 
+(provide txtadv-program)
+(define #'(txtadv-program _section ...)
+  #'(module-begin _section ...))
+
 (provide verb-section)
 (define-inverting #'(verb-section _heading _verb-entry ...)
-  (inject-syntax ([#'all-verbs (shared-syntax 'all-verbs)])
+  (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)])
-                 #'(define-verbs all-verbs
+                 #'(define-verbs in-verbs
                      _verb-entry ...)))
 
 (provide verb-item)
@@ -105,9 +109,9 @@
 
 (provide start-section)
 (define #'(start-section _heading _where)
-  (inject-syntax ([#'all-verbs (shared-syntax 'all-verbs)])
+  (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)])
                  #'(init-game _where
-                              all-verbs
+                              in-verbs
                               everywhere-actions)))
 
 ;; ============================================================
@@ -120,10 +124,14 @@
 (struct thing (name         ; symbol
                [state #:mutable] ; any value
                actions) #:transparent)    ; list of verb--thunk pairs
+
 (struct place (desc         ; string
                [things #:mutable] ; list of things
                actions) #:transparent)    ; list of verb--thunk pairs
 
+(define action-verb car)
+(define action-response cdr)
+
 ;; Tables mapping names<->things for save and load
 (define names (make-hash))
 (define elements (make-hash))
@@ -146,39 +154,34 @@
 
 
 ;; todo: the underscore arguments in cases 2 & 4 should be literal underscores, not wildcards
-(define-syntax define-one-verb
+(define-cases #'define-one-verb
-  (syntax-rules (= _)
+  [#'(_ _id (= _alias ...) _desc)
-    [(define-one-verb id (= alias ...) desc)
+   #'(define _id (verb (list '_id '_alias ...) _desc #f))]
-     (define id (verb (list 'id 'alias ...) desc #f))]
+  [#'(_ _id _ (= _alias ...) _desc)
-    [(define-one-verb id _ (= alias ...) desc)
+   #'(define _id (verb (list '_id '_alias ...) _desc #t))]
-     (define id (verb (list 'id 'alias ...) desc #t))]
+  [#'(_ _id)
-    [(define-one-verb id)
+   #'(define _id (verb (list '_id) (symbol->string '_id) #f))]
-     (define id (verb (list 'id) (symbol->string 'id) #f))]
+  [#'(_ _id _)
-    [(define-one-verb id _)
+   #'(define _id (verb (list '_id) (symbol->string '_id) #t))])
-     (define id (verb (list 'id) (symbol->string 'id) #t))]))
+
-
+
-
+(define #'(define-thing _id [_vrb _expr] ...)
-(define-syntax-rule (define-thing id 
+  #'(begin
-                      [vrb expr] ...)
+      (define _id
-  (begin
+        (thing '_id #f (list (cons _vrb (λ () _expr)) ...)))
-    (define id 
+      (record-element! '_id _id)))
-      (thing 'id #f (list (cons vrb (lambda () expr)) ...)))
+
-    (record-element! 'id id)))
+
-
+(define #'(define-place _id _desc (_thng ...) ([_vrb _expr] ...))
-
+  #'(begin
-(define-syntax-rule (define-place id 
+      (define _id (place _desc
-                      desc 
+                         (list _thng ...)
-                      (thng ...) 
+                         (list (cons _vrb (λ () _expr)) ...)))
-                      ([vrb expr] ...))
+      (record-element! '_id _id)))
-  (begin
+
-    (define id (place desc
+
-                      (list thng ...)
+(define #'(define-everywhere _id ([_vrb _expr] ...))
-                      (list (cons vrb (lambda () expr)) ...)))
+  #'(define _id (list (cons _vrb (λ () _expr)) ...)))
-    (record-element! 'id id)))
-
-
-(define-syntax-rule (define-everywhere id ([vrb expr] ...))
-  (define id (list (cons vrb (lambda () expr)) ...)))
 
 ;; ============================================================
 ;; Game state
@@ -186,7 +189,7 @@
 (define cmd-line-mode? (make-parameter #f))
 
 ;; Initialized on startup:
-(define all-verbs null)          ; list of verbs
+(define game-verbs null)          ; list of verbs
 (define everywhere-actions null) ; list of verb--thunk pairs
 
 ;; Things carried by the player:
@@ -261,7 +264,7 @@
    (find-verb verb (place-actions current-place))
    (find-verb verb everywhere-actions)
    (using-verb 
-    verb all-verbs
+    verb game-verbs
     (λ (verb)
       (λ () (if (verb-transitive? verb)
                 (format "~a what?" (string-titlecase (verb-desc verb)))
@@ -271,7 +274,7 @@
 ;; Handle a transitive-verb command:
 (define (handle-transitive-verb verb-in obj)
   (or (using-verb 
-       verb-in all-verbs
+       verb-in game-verbs
        (λ (verb)
          (and 
           (verb-transitive? verb)
@@ -304,26 +307,24 @@
 ;; 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 (λ (a)
+  (for/first ([action (in-list actions)]
-           (and (memq cmd (verb-aliases (car a)))
+              #:when (memq cmd (verb-aliases (action-verb action))))
-                (cdr a)))
+             (action-response action)))
-         actions))
 
 ;; Looks for a command in a list of verbs, and
-;; applies `success-k' to the verb if one is found:
+;; applies `success-func' to the verb if one is found:
-(define (using-verb cmd verbs success-k)
+(define (using-verb cmd verbs success-func)
-  (ormap (λ (vrb)
+  (for/first ([verb (in-list verbs)]
-           (and (memq cmd (verb-aliases vrb))
+              #:when (memq cmd (verb-aliases verb)))
-                (success-k vrb)))
+             (success-func verb)))
-         verbs))
 
 
 ;; ============================================================
 ;; To go:
 
 (define (init-game in-place
-                   in-all-verbs
+                   in-verbs
                    in-everywhere-actions)
   (set! current-place in-place)
-  (set! all-verbs in-all-verbs)
+  (set! game-verbs in-verbs)
   (set! everywhere-actions in-everywhere-actions))

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

@@ -30,10 +30,7 @@
 (define-everywhere everywhere-actions
   ([quit (begin (printf "Bye!\n") (exit))]
    [look (show-current-place)]
-   [inventory (show-inventory)]
+   [inventory (show-inventory)]))
-   [save (save-game)]
-   [load (load-game)]
-   [help (show-help)]))
 
 ;; Objects ----------------------------------------