From 6de2df5ceb6a6403a6bdb4698c2b3ec30803137d Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 2 May 2016 14:40:16 -0400 Subject: [PATCH] edit --- beautiful-racket/br/demo/txtadv.rkt | 2 +- beautiful-racket/br/demo/txtadv/expander.rkt | 276 +++++++------------ beautiful-racket/br/demo/txtadv/world.rkt | 14 - 3 files changed, 105 insertions(+), 187 deletions(-) diff --git a/beautiful-racket/br/demo/txtadv.rkt b/beautiful-racket/br/demo/txtadv.rkt index 6859b19..45f5dd3 100644 --- a/beautiful-racket/br/demo/txtadv.rkt +++ b/beautiful-racket/br/demo/txtadv.rkt @@ -1,5 +1,5 @@ #lang br -(module+ reader +(module reader br (require "txtadv/reader.rkt") (provide (all-from-out "txtadv/reader.rkt"))) diff --git a/beautiful-racket/br/demo/txtadv/expander.rkt b/beautiful-racket/br/demo/txtadv/expander.rkt index 677d843..1498624 100644 --- a/beautiful-racket/br/demo/txtadv/expander.rkt +++ b/beautiful-racket/br/demo/txtadv/expander.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang br (provide define-verbs define-thing @@ -7,9 +7,6 @@ show-current-place show-inventory - save-game - load-game - show-help have-thing? take-thing! @@ -17,29 +14,27 @@ thing-state set-thing-state! - (except-out (all-from-out racket) #%module-begin) + (except-out (all-from-out br) #%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 ... - (init-game (check-type id "place") - all-verbs - everywhere-actions) - (provide do-verb do-place) - (module+ main - (cmd-line-mode? #t) - (do-place)))])) +(define #'(module-begin (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 ... + (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: @@ -74,97 +69,91 @@ #:property prop:procedure (λ (self stx) (typed-id self)) #:omit-define-syntaxes)) -(define-syntax (check-type stx) - (syntax-case stx () - [(_ 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)])) +(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: -(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") - (λ _ 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") - (λ _ 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") - (λ _ expr)) - ...))) +(define #'(define-verbs _all-id [_id _spec ...] ...) + #'(begin + (define-one-verb _id _spec ...) ... + (record-element! '_id _id) ... + (define _all-id (list _id ...)))) + + +;; todo: the underscore arguments in cases 2 & 4 should be literal underscores, not wildcards +(define-cases #'define-one-verb + [#'(_ _id (= _alias ...) _desc) + #'(begin + (define gen-id (verb (list '_id '_alias ...) _desc #f)) + (define-syntax _id (typed #'gen-id "intransitive verb")))] + [#'(_ _id _ (= _alias ...) _desc) + #'(begin + (define gen-id (verb (list '_id '_alias ...) _desc #t)) + (define-syntax _id (typed #'gen-id "transitive verb")))] + [#'(_ _id) + #'(define-one-verb _id (=) (symbol->string '_id))] + [#'(_ _id _) + #'(define-one-verb _id _ (=) (symbol->string '_id))]) + + +(define #'(define-thing _id [_verb _expr] ...) + #'(begin + (define gen-id + (thing '_id #f (list (cons (check-type _verb "transitive verb") + (λ () _expr)) ...))) + (define-syntax _id (typed #'gen-id "thing")) + (record-element! '_id _id))) + + +(define #'(define-place _id _desc (_thing ...) ([_verb _expr] ...)) + #'(begin + (define gen-id + (place _desc + (list (check-type _thing "thing") ...) + (list (cons (check-type _verb "intransitive verb") + (λ () _expr)) + ...))) + (define-syntax _id (typed #'gen-id "place")) + (record-element! '_id _id))) + + +(define #'(define-everywhere _id ([_verb _expr] ...)) + #'(define _id (list (cons (check-type _verb "intransitive verb") (λ () _expr)) ...))) ;; ============================================================ ;; Game state (define cmd-line-mode? (make-parameter #f)) + ;; 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 +(define player-inventory 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))) +(define (have-thing? thing) + (memq thing player-inventory)) +(define (take-thing! thing) + (set-place-things! current-place (remq thing (place-things current-place))) + (set! player-inventory (cons thing player-inventory))) +(define (drop-thing! thing) + (set-place-things! current-place (cons thing (place-things current-place))) + (set! player-inventory (remq thing player-inventory))) ;; ============================================================ ;; Game execution @@ -172,15 +161,14 @@ ;; Show the player the current place, then get a command: (define (do-place) (show-current-place) - (when (cmd-line-mode?) - (do-verb))) + (when (cmd-line-mode?) (do-verb))) ;; Show the current place: (define (show-current-place) (printf "~a\n" (place-desc current-place)) - (for-each (λ (thing) - (printf "There is a ~a here.\n" (thing-name thing))) - (place-things current-place))) + (for-each + (λ (thing) (printf "There is a ~a here.\n" (thing-name thing))) + (place-things current-place))) ;; Get and handle a command: @@ -197,13 +185,13 @@ (if (and (list? input) (andmap symbol? input) (<= 1 (length input) 2)) - (let* ([vrb (car input)] + (let* ([verb (car input)] [response (cond [(= 2 (length input)) - (handle-transitive-verb vrb (cadr input))] + (handle-transitive-verb verb (cadr input))] [(= 1 (length input)) - (handle-intransitive-verb vrb)])] + (handle-intransitive-verb verb)])] [result (response)]) (cond [(place? result) @@ -225,15 +213,15 @@ (using-verb verb all-verbs (λ (verb) - (λ _ (if (verb-transitive? verb) - (format "~a what?" (string-titlecase (verb-desc verb))) - (format "Can't ~a here." (verb-desc verb)))))) - (λ _ (format "I don't know how to ~a." verb)))) + (λ () (if (verb-transitive? verb) + (format "~a what?" (string-titlecase (verb-desc verb))) + (format "Can't ~a here." (verb-desc verb)))))) + (λ () (format "I don't know how to ~a." verb)))) ;; Handle a transitive-verb command: -(define (handle-transitive-verb vrb obj) +(define (handle-transitive-verb verb-in obj) (or (using-verb - vrb all-verbs + verb-in all-verbs (λ (verb) (and (verb-transitive? verb) @@ -242,25 +230,25 @@ (and (eq? (thing-name thing) obj) thing)) (append (place-things current-place) - stuff)) + player-inventory)) => (λ (thing) - (or (find-verb vrb (thing-actions thing)) - (λ _ + (or (find-verb verb-in (thing-actions thing)) + (λ () (format "Don't know how to ~a ~a." (verb-desc verb) obj))))] [else - (λ _ (format "There's no ~a here to ~a." obj - (verb-desc verb)))])))) - (λ _ (format "I don't know how to ~a ~a." vrb obj)))) + (λ () (format "There's no ~a here to ~a." obj + (verb-desc verb)))])))) + (λ () (format "I don't know how to ~a ~a." verb-in obj)))) ;; Show what the player is carrying: (define (show-inventory) (printf "You have") - (if (null? stuff) + (if (null? player-inventory) (printf " no items.") (for-each (λ (thing) (printf "\n a ~a" (thing-name thing))) - stuff)) + player-inventory)) (printf "\n")) ;; Look for a command match in a list of verb--response pairs, @@ -279,62 +267,6 @@ (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? (λ (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 - (λ (v) - (with-output-to-file v - (λ _ - (write - (list - (map element->name stuff) - (element->name current-place) - (hash-map names - (λ (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 - (λ (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 - (λ (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: diff --git a/beautiful-racket/br/demo/txtadv/world.rkt b/beautiful-racket/br/demo/txtadv/world.rkt index ca75116..2f7d9a6 100644 --- a/beautiful-racket/br/demo/txtadv/world.rkt +++ b/beautiful-racket/br/demo/txtadv/world.rkt @@ -49,12 +49,6 @@ look, show inventory "check inventory" -help - -save - -load - ===EVERYWHERE=== @@ -69,14 +63,6 @@ look inventory (show-inventory) -save - (save-game) - -load - (load-game) - -help - (show-help) ===THINGS===