diff --git a/beautiful-racket/br/demo/txtadv/expander.rkt b/beautiful-racket/br/demo/txtadv/expander.rkt index c8049b1..98f8af4 100644 --- a/beautiful-racket/br/demo/txtadv/expander.rkt +++ b/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 - _verb-entry ...)) + #'(define-verbs all-verbs + _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 - ([_name _desc] ...))) + #'(define-everywhere everywhere-actions + ([_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]) - -#;(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))))) +(provide start-section) +(define #'(start-section _heading _where) + #'(init-game _where + all-verbs + everywhere-actions)) ;; ============================================================ ;; 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 - [#'(_ _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)) ...))) +(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 diff --git a/beautiful-racket/br/demo/txtadv/parser.rkt b/beautiful-racket/br/demo/txtadv/parser.rkt index 14530f5..cc0bb9d 100644 --- a/beautiful-racket/br/demo/txtadv/parser.rkt +++ b/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* (")" | "]" | "}") \ No newline at end of file diff --git a/beautiful-racket/br/demo/txtadv/static.rkt b/beautiful-racket/br/demo/txtadv/static.rkt new file mode 100644 index 0000000..947aec1 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/beautiful-racket/br/demo/txtadv/tokenizer.rkt b/beautiful-racket/br/demo/txtadv/tokenizer.rkt index cccab08..b54b0a3 100644 --- a/beautiful-racket/br/demo/txtadv/tokenizer.rkt +++ b/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)))] - [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-!?.#"))) + "---") (token 'DASHED-NAME (string->symbol (string-trim lexeme "-" #:repeat? #t)))] + [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-!?.#'"))) (token 'ID (read (open-input-string lexeme)))] [any-char lexeme])) (get-token input-port)) diff --git a/beautiful-racket/br/demo/txtadv/world.rkt b/beautiful-racket/br/demo/txtadv/world.rkt index 2d15fe5..61c2a52 100644 --- a/beautiful-racket/br/demo/txtadv/world.rkt +++ b/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 \ No newline at end of file diff --git a/beautiful-racket/br/demo/txtadv/world0-sexp.rkt b/beautiful-racket/br/demo/txtadv/world0-sexp.rkt new file mode 100644 index 0000000..34b8a0a --- /dev/null +++ b/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 \ No newline at end of file