mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

edit

Browse Source
dev-elider-3
Matthew Butterick 9 years ago
parent 2d2ac10654
commit 6de2df5ceb
3 changed files with 105 additions and 187 deletions
Show Stats Download Patch File Download Diff File

2
beautiful-racket/br/demo/txtadv.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang br #lang br
(module+ reader (module reader br
(require "txtadv/reader.rkt") (require "txtadv/reader.rkt")
(provide (all-from-out "txtadv/reader.rkt"))) (provide (all-from-out "txtadv/reader.rkt")))

276
beautiful-racket/br/demo/txtadv/expander.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang racket #lang br
(provide define-verbs (provide define-verbs
define-thing define-thing
@ -7,9 +7,6 @@
show-current-place show-current-place
show-inventory show-inventory
save-game
load-game
show-help
have-thing? have-thing?
take-thing! take-thing!
@ -17,29 +14,27 @@
thing-state thing-state
set-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])) (rename-out [module-begin #%module-begin]))
;; ============================================================ ;; ============================================================
;; Overall module: ;; Overall module:
(define-syntax module-begin (define #'(module-begin (define-verbs _all-verbs _cmd ...)
(syntax-rules (define-verbs define-everywhere) (define-everywhere _everywhere-actions _act ...)
[(_ (define-verbs all-verbs cmd ...) _decl ...
(define-everywhere everywhere-actions act ...) _id)
decl ... #'(#%module-begin
id) (define-verbs _all-verbs _cmd ...)
(#%module-begin (define-everywhere _everywhere-actions _act ...)
(define-verbs all-verbs cmd ...) _decl ...
(define-everywhere everywhere-actions act ...) (init-game (check-type _id "place")
decl ... _all-verbs
(init-game (check-type id "place") _everywhere-actions)
all-verbs (provide do-verb do-place)
everywhere-actions) (module+ main
(provide do-verb do-place) (parameterize ([cmd-line-mode? #t])
(module+ main (do-place)))))
(cmd-line-mode? #t)
(do-place)))]))
;; ============================================================ ;; ============================================================
;; Model: ;; Model:
@ -74,97 +69,91 @@
#:property prop:procedure (λ (self stx) (typed-id self)) #:property prop:procedure (λ (self stx) (typed-id self))
#:omit-define-syntaxes)) #:omit-define-syntaxes))
(define-syntax (check-type stx) (define #'(check-type _id _type)
(syntax-case stx () (let ([v (and (identifier? #'_id)
[(_ id type) (syntax-local-value #'_id (λ () #f)))])
(let ([v (and (identifier? #'id) (unless (and (typed? v)
(syntax-local-value #'id (λ _ #f)))]) (equal? (syntax-e #'_type) (typed-type v)))
(unless (and (typed? v) (raise-syntax-error
(equal? (syntax-e #'type) (typed-type v))) #f
(raise-syntax-error (format "not defined as ~a" (syntax-e #'_type))
#f #'_id))
(format "not defined as ~a" (syntax-e #'type)) #'_id))
#'id))
#'id)]))
;; ============================================================ ;; ============================================================
;; Macros for constructing and registering elements: ;; Macros for constructing and registering elements:
(define-syntax-rule (define-verbs all-id (define #'(define-verbs _all-id [_id _spec ...] ...)
[id spec ...] ...) #'(begin
(begin (define-one-verb _id _spec ...) ...
(define-one-verb id spec ...) ... (record-element! '_id _id) ...
(record-element! 'id id) ... (define _all-id (list _id ...))))
(define all-id (list id ...))))
(define-syntax define-one-verb ;; todo: the underscore arguments in cases 2 & 4 should be literal underscores, not wildcards
(syntax-rules (= _) (define-cases #'define-one-verb
[(define-one-verb id (= alias ...) desc) [#'(_ _id (= _alias ...) _desc)
(begin #'(begin
(define gen-id (verb (list 'id 'alias ...) desc #f)) (define gen-id (verb (list '_id '_alias ...) _desc #f))
(define-syntax id (typed #'gen-id "intransitive verb")))] (define-syntax _id (typed #'gen-id "intransitive verb")))]
[(define-one-verb id _ (= alias ...) desc) [#'(_ _id _ (= _alias ...) _desc)
(begin #'(begin
(define gen-id (verb (list 'id 'alias ...) desc #t)) (define gen-id (verb (list '_id '_alias ...) _desc #t))
(define-syntax id (typed #'gen-id "transitive verb")))] (define-syntax _id (typed #'gen-id "transitive verb")))]
[(define-one-verb id) [#'(_ _id)
(define-one-verb id (=) (symbol->string 'id))] #'(define-one-verb _id (=) (symbol->string '_id))]
[(define-one-verb id _) [#'(_ _id _)
(define-one-verb id _ (=) (symbol->string 'id))])) #'(define-one-verb _id _ (=) (symbol->string '_id))])
(define-syntax-rule (define-thing id
[vrb expr] ...) (define #'(define-thing _id [_verb _expr] ...)
(begin #'(begin
(define gen-id (define gen-id
(thing 'id #f (list (cons (check-type vrb "transitive verb") (thing '_id #f (list (cons (check-type _verb "transitive verb")
(λ _ expr)) ...))) (λ () _expr)) ...)))
(define-syntax id (typed #'gen-id "thing")) (define-syntax _id (typed #'gen-id "thing"))
(record-element! 'id id))) (record-element! '_id _id)))
(define-syntax-rule (define-place id (define #'(define-place _id _desc (_thing ...) ([_verb _expr] ...))
desc #'(begin
(thng ...) (define gen-id
([vrb expr] ...)) (place _desc
(begin (list (check-type _thing "thing") ...)
(define gen-id (list (cons (check-type _verb "intransitive verb")
(place desc (λ () _expr))
(list (check-type thng "thing") ...) ...)))
(list (cons (check-type vrb "intransitive verb") (define-syntax _id (typed #'gen-id "place"))
(λ _ expr)) (record-element! '_id _id)))
...)))
(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-rule (define-everywhere id ([vrb expr] ...))
(define id (list (cons (check-type vrb "intransitive verb")
(λ _ expr))
...)))
;; ============================================================ ;; ============================================================
;; Game state ;; Game state
(define cmd-line-mode? (make-parameter #f)) (define cmd-line-mode? (make-parameter #f))
;; Initialized on startup: ;; Initialized on startup:
(define all-verbs null) ; list of verbs (define all-verbs null) ; list of verbs
(define everywhere-actions null) ; list of verb--thunk pairs (define everywhere-actions null) ; list of verb--thunk pairs
;; Things carried by the player: ;; Things carried by the player:
(define stuff null) ; list of things (define player-inventory null) ; list of things
;; Current location: ;; Current location:
(define current-place #f) ; place (or #f until started) (define current-place #f) ; place (or #f until started)
;; Fuctions to be used by verb responses: ;; Fuctions to be used by verb responses:
(define (have-thing? t) (define (have-thing? thing)
(memq t stuff)) (memq thing player-inventory))
(define (take-thing! t) (define (take-thing! thing)
(set-place-things! current-place (remq t (place-things current-place))) (set-place-things! current-place (remq thing (place-things current-place)))
(set! stuff (cons t stuff))) (set! player-inventory (cons thing player-inventory)))
(define (drop-thing! t) (define (drop-thing! thing)
(set-place-things! current-place (cons t (place-things current-place))) (set-place-things! current-place (cons thing (place-things current-place)))
(set! stuff (remq t stuff))) (set! player-inventory (remq thing player-inventory)))
;; ============================================================ ;; ============================================================
;; Game execution ;; Game execution
@ -172,15 +161,14 @@
;; Show the player the current place, then get a command: ;; Show the player the current place, then get a command:
(define (do-place) (define (do-place)
(show-current-place) (show-current-place)
(when (cmd-line-mode?) (when (cmd-line-mode?) (do-verb)))
(do-verb)))
;; Show the current place: ;; Show the current place:
(define (show-current-place) (define (show-current-place)
(printf "~a\n" (place-desc current-place)) (printf "~a\n" (place-desc current-place))
(for-each (λ (thing) (for-each
(printf "There is a ~a here.\n" (thing-name thing))) (λ (thing) (printf "There is a ~a here.\n" (thing-name thing)))
(place-things current-place))) (place-things current-place)))
;; Get and handle a command: ;; Get and handle a command:
@ -197,13 +185,13 @@
(if (and (list? input) (if (and (list? input)
(andmap symbol? input) (andmap symbol? input)
(<= 1 (length input) 2)) (<= 1 (length input) 2))
(let* ([vrb (car input)] (let* ([verb (car input)]
[response [response
(cond (cond
[(= 2 (length input)) [(= 2 (length input))
(handle-transitive-verb vrb (cadr input))] (handle-transitive-verb verb (cadr input))]
[(= 1 (length input)) [(= 1 (length input))
(handle-intransitive-verb vrb)])] (handle-intransitive-verb verb)])]
[result (response)]) [result (response)])
(cond (cond
[(place? result) [(place? result)
@ -225,15 +213,15 @@
(using-verb (using-verb
verb all-verbs verb all-verbs
(λ (verb) (λ (verb)
(λ _ (if (verb-transitive? verb) (λ () (if (verb-transitive? verb)
(format "~a what?" (string-titlecase (verb-desc verb))) (format "~a what?" (string-titlecase (verb-desc verb)))
(format "Can't ~a here." (verb-desc verb)))))) (format "Can't ~a here." (verb-desc verb))))))
(λ _ (format "I don't know how to ~a." verb)))) (λ () (format "I don't know how to ~a." verb))))
;; Handle a transitive-verb command: ;; Handle a transitive-verb command:
(define (handle-transitive-verb vrb obj) (define (handle-transitive-verb verb-in obj)
(or (using-verb (or (using-verb
vrb all-verbs verb-in all-verbs
(λ (verb) (λ (verb)
(and (and
(verb-transitive? verb) (verb-transitive? verb)
@ -242,25 +230,25 @@
(and (eq? (thing-name thing) obj) (and (eq? (thing-name thing) obj)
thing)) thing))
(append (place-things current-place) (append (place-things current-place)
stuff)) player-inventory))
=> (λ (thing) => (λ (thing)
(or (find-verb vrb (thing-actions thing)) (or (find-verb verb-in (thing-actions thing))
(λ _ (λ ()
(format "Don't know how to ~a ~a." (format "Don't know how to ~a ~a."
(verb-desc verb) obj))))] (verb-desc verb) obj))))]
[else [else
(λ _ (format "There's no ~a here to ~a." obj (λ () (format "There's no ~a here to ~a." obj
(verb-desc verb)))])))) (verb-desc verb)))]))))
(λ _ (format "I don't know how to ~a ~a." vrb obj)))) (λ () (format "I don't know how to ~a ~a." verb-in obj))))
;; Show what the player is carrying: ;; Show what the player is carrying:
(define (show-inventory) (define (show-inventory)
(printf "You have") (printf "You have")
(if (null? stuff) (if (null? player-inventory)
(printf " no items.") (printf " no items.")
(for-each (λ (thing) (for-each (λ (thing)
(printf "\n a ~a" (thing-name thing))) (printf "\n a ~a" (thing-name thing)))
stuff)) player-inventory))
(printf "\n")) (printf "\n"))
;; Look for a command match in a list of verb--response pairs, ;; Look for a command match in a list of verb--response pairs,
@ -279,62 +267,6 @@
(success-k vrb))) (success-k vrb)))
verbs)) 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: ;; To go:

14
beautiful-racket/br/demo/txtadv/world.rkt
Unescape Escape View File

@ -49,12 +49,6 @@ look, show
inventory inventory
"check inventory" "check inventory"
help
save
load
===EVERYWHERE=== ===EVERYWHERE===
@ -69,14 +63,6 @@ look
inventory inventory
(show-inventory) (show-inventory)
save
(save-game)
load
(load-game)
help
(show-help)
===THINGS=== ===THINGS===

Write Preview
Loading…
Cancel
Save