work it
parent
40afae1c8f
commit
69df1b4ac0
@ -0,0 +1,9 @@
|
||||
The "txtadv+world.rkt" is the initial implementation of the
|
||||
text-adventure game in Racket. The file name foreshadows a split of
|
||||
the program into two modules later.
|
||||
|
||||
The "Model" section of the code is described in the article. The "The
|
||||
world" section is the verbose world description that we will improve
|
||||
in the next step. Sections from "Game state" on implement the game
|
||||
engine, and those parts will remain essentially unchanged as we
|
||||
improve the language for describing worlds.
|
||||
@ -0,0 +1,409 @@
|
||||
#lang racket
|
||||
|
||||
;; ============================================================
|
||||
;; 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))
|
||||
|
||||
;; ============================================================
|
||||
;; The world:
|
||||
|
||||
;; Verbs ----------------------------------------
|
||||
;; Declare all the verbs that can be used in the game.
|
||||
;; Each verb has a canonical name, a set of aliases,
|
||||
;; a printed form, and a boolean indincating whether it
|
||||
;; is transitive.
|
||||
|
||||
(define north (verb (list 'north 'n) "go north" #f))
|
||||
(record-element! 'north north)
|
||||
|
||||
(define south (verb (list 'south 's) "go south" #f))
|
||||
(record-element! 'south south)
|
||||
|
||||
(define east (verb (list 'east 'e) "go east" #f))
|
||||
(record-element! 'east east)
|
||||
|
||||
(define west (verb (list 'west 'w) "go west" #f))
|
||||
(record-element! 'west west)
|
||||
|
||||
(define up (verb (list 'up) "go up" #f))
|
||||
(record-element! 'up up)
|
||||
|
||||
(define down (verb (list 'down) "go down" #f))
|
||||
(record-element! 'down down)
|
||||
|
||||
(define in (verb (list 'in 'enter) "enter" #f))
|
||||
(record-element! 'in in)
|
||||
|
||||
(define out (verb (list 'out 'leave) "leave" #f))
|
||||
(record-element! 'out out)
|
||||
|
||||
(define get (verb (list 'get 'grab 'take) "take" #t))
|
||||
(record-element! 'get get)
|
||||
|
||||
(define put (verb (list 'put 'drop 'leave) "drop" #t))
|
||||
(record-element! 'put put)
|
||||
|
||||
(define open (verb (list 'open 'unlock) "open" #t))
|
||||
(record-element! 'open open)
|
||||
|
||||
(define close (verb (list 'close 'lock) "close" #t))
|
||||
(record-element! 'close close)
|
||||
|
||||
(define knock (verb (list 'knock) (symbol->string 'knock) #t))
|
||||
(record-element! 'knock knock)
|
||||
|
||||
(define quit (verb (list 'quit 'exit) "quit" #f))
|
||||
(record-element! 'quit quit)
|
||||
|
||||
(define look (verb (list 'look 'show) "look" #f))
|
||||
(record-element! 'look look)
|
||||
|
||||
(define inventory (verb (list 'inventory) "check inventory" #f))
|
||||
(record-element! 'inventory inventory)
|
||||
|
||||
(define help (verb (list 'help) (symbol->string 'help) #f))
|
||||
(record-element! 'help help)
|
||||
|
||||
(define save (verb (list 'save) (symbol->string 'save) #f))
|
||||
(record-element! 'save save)
|
||||
|
||||
(define load (verb (list 'load) (symbol->string 'load) #f))
|
||||
(record-element! 'load load)
|
||||
|
||||
(define all-verbs
|
||||
(list north south east west up down in out
|
||||
get put open close knock quit
|
||||
look inventory help save load))
|
||||
|
||||
;; Global actions ----------------------------------------
|
||||
;; Handle verbs that work anywhere.
|
||||
|
||||
(define everywhere-actions
|
||||
(list
|
||||
(cons quit (lambda () (begin (printf "Bye!\n") (exit))))
|
||||
(cons look (lambda () (show-current-place)))
|
||||
(cons inventory (lambda () (show-inventory)))
|
||||
(cons save (lambda () (save-game)))
|
||||
(cons load (lambda () (load-game)))
|
||||
(cons help (lambda () (show-help)))))
|
||||
|
||||
;; Things ----------------------------------------
|
||||
;; Each thing handles a set of transitive verbs.
|
||||
|
||||
(define cactus
|
||||
(thing 'cactus
|
||||
#f
|
||||
(list (cons get (lambda () "Ouch!")))))
|
||||
(record-element! 'cactus cactus)
|
||||
|
||||
(define door
|
||||
(thing 'door
|
||||
#f
|
||||
(list
|
||||
(cons open
|
||||
(lambda ()
|
||||
(if (have-thing? key)
|
||||
(begin
|
||||
(set-thing-state! door 'open)
|
||||
"The door is now unlocked and open.")
|
||||
"The door is locked.")))
|
||||
(cons close
|
||||
(lambda ()
|
||||
(begin
|
||||
(set-thing-state! door #f)
|
||||
"The door is now closed.")))
|
||||
(cons knock
|
||||
(lambda ()
|
||||
"No one is home.")))))
|
||||
(record-element! 'door door)
|
||||
|
||||
(define key
|
||||
(thing 'key
|
||||
#f
|
||||
(list
|
||||
(cons get
|
||||
(lambda ()
|
||||
(if (have-thing? key)
|
||||
"You already have the key."
|
||||
(begin
|
||||
(take-thing! key)
|
||||
"You now have the key."))))
|
||||
(cons put
|
||||
(lambda ()
|
||||
(if (have-thing? key)
|
||||
(begin
|
||||
(drop-thing! key)
|
||||
"You have dropped the key.")
|
||||
"You don't have the key."))))))
|
||||
(record-element! 'key key)
|
||||
|
||||
(define trophy
|
||||
(thing 'trophy
|
||||
#f
|
||||
(list
|
||||
(cons get
|
||||
(lambda ()
|
||||
(begin
|
||||
(take-thing! trophy)
|
||||
"You win!"))))))
|
||||
(record-element! 'trophy trophy)
|
||||
|
||||
;; Places ----------------------------------------
|
||||
;; Each place handles a set of non-transitive verbs.
|
||||
|
||||
(define meadow
|
||||
(place
|
||||
"You're standing in a meadow. There is a house to the north."
|
||||
(list)
|
||||
(list
|
||||
(cons north
|
||||
(lambda () house-front))
|
||||
(cons south
|
||||
(lambda () desert)))))
|
||||
(record-element! 'meadow meadow)
|
||||
|
||||
(define house-front
|
||||
(place
|
||||
"You are standing in front of a house."
|
||||
(list door)
|
||||
(list
|
||||
(cons in
|
||||
(lambda ()
|
||||
(if (eq? (thing-state door) 'open)
|
||||
room
|
||||
"The door is not open.")))
|
||||
(cons south (lambda () meadow)))))
|
||||
(record-element! 'house-front house-front)
|
||||
|
||||
(define desert
|
||||
(place
|
||||
"You're in a desert. There is nothing for miles around."
|
||||
(list cactus key)
|
||||
(list
|
||||
(cons north (lambda () meadow))
|
||||
(cons south (lambda () desert))
|
||||
(cons east (lambda () desert))
|
||||
(cons west (lambda () desert)))))
|
||||
(record-element! 'desert desert)
|
||||
|
||||
(define room
|
||||
(place
|
||||
"You're in the house."
|
||||
(list trophy)
|
||||
(list (cons out (lambda () house-front)))))
|
||||
(record-element! 'room room)
|
||||
|
||||
;; ============================================================
|
||||
;; Game state
|
||||
|
||||
;; Things carried by the player:
|
||||
(define stuff null) ; list of things
|
||||
|
||||
;; Current location:
|
||||
(define current-place meadow) ; place
|
||||
|
||||
;; 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 ([cmd (car input)])
|
||||
(let ([response
|
||||
(cond
|
||||
[(= 2 (length input))
|
||||
(handle-transitive-verb cmd (cadr input))]
|
||||
[(= 1 (length input))
|
||||
(handle-intransitive-verb cmd)])])
|
||||
(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 cmd)
|
||||
(or
|
||||
(find-verb cmd (place-actions current-place))
|
||||
(find-verb cmd everywhere-actions)
|
||||
(using-verb
|
||||
cmd 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." cmd))))
|
||||
|
||||
;; Handle a transitive-verb command:
|
||||
(define (handle-transitive-verb cmd obj)
|
||||
(or (using-verb
|
||||
cmd 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 cmd (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." cmd 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))))))
|
||||
|
||||
;; ============================================================
|
||||
;; Go!
|
||||
|
||||
(do-place)
|
||||
@ -0,0 +1,4 @@
|
||||
The difference in "txtadv+world.rkt" compared to the previous version
|
||||
is a new "Macros for constructing and registering elements" section
|
||||
and a revised "The world" section.
|
||||
|
||||
@ -0,0 +1,369 @@
|
||||
#lang racket
|
||||
|
||||
;; ============================================================
|
||||
;; 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)) ...)))
|
||||
|
||||
;; ============================================================
|
||||
;; The world:
|
||||
|
||||
;; Verbs ----------------------------------------
|
||||
;; Declare all the verbs that can be used in the game.
|
||||
;; Each verb has a canonical name, a `_' if it needs
|
||||
;; a thing (i.e., a transitive verb), a set of aliases,
|
||||
;; and a printed form.
|
||||
|
||||
(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 ----------------------------------------
|
||||
;; Handle verbs that work anywhere.
|
||||
|
||||
(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)]))
|
||||
|
||||
;; Things ----------------------------------------
|
||||
;; Each thing handles a set of transitive verbs.
|
||||
|
||||
(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 ----------------------------------------
|
||||
;; Each place handles a set of non-transitive verbs.
|
||||
|
||||
(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]))
|
||||
|
||||
;; ============================================================
|
||||
;; Game state
|
||||
|
||||
;; Things carried by the player:
|
||||
(define stuff null) ; list of things
|
||||
|
||||
;; Current location:
|
||||
(define current-place meadow) ; place
|
||||
|
||||
;; 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 ([cmd (car input)])
|
||||
(let ([response
|
||||
(cond
|
||||
[(= 2 (length input))
|
||||
(handle-transitive-verb cmd (cadr input))]
|
||||
[(= 1 (length input))
|
||||
(handle-intransitive-verb cmd)])])
|
||||
(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 cmd)
|
||||
(or
|
||||
(find-verb cmd (place-actions current-place))
|
||||
(find-verb cmd everywhere-actions)
|
||||
(using-verb
|
||||
cmd 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." cmd))))
|
||||
|
||||
;; Handle a transitive-verb command:
|
||||
(define (handle-transitive-verb cmd obj)
|
||||
(or (using-verb
|
||||
cmd 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 cmd (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." cmd 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))))))
|
||||
|
||||
;; ============================================================
|
||||
;; Go!
|
||||
|
||||
(do-place)
|
||||
@ -0,0 +1,8 @@
|
||||
The old "txtadv+world.rkt" module is now split into two parts:
|
||||
"txtadv.rkt" and "world.rkt". Aside from the split and necessary
|
||||
`provide' and `require' declarations, the only change to engine and
|
||||
world descriptions is the `start-game' call at the end of "world.rkt",
|
||||
which passes to the game engine all of the declarations that it
|
||||
formerly used directly.
|
||||
|
||||
To play the game, run the "world.rkt" module.
|
||||
@ -0,0 +1,293 @@
|
||||
#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!
|
||||
|
||||
start-game)
|
||||
|
||||
;; ============================================================
|
||||
;; 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))
|
||||
@ -0,0 +1,111 @@
|
||||
#lang racket
|
||||
(require "txtadv.rkt")
|
||||
|
||||
;; Verbs ----------------------------------------
|
||||
;; Declare all the verbs that can be used in the game.
|
||||
;; Each verb has a canonical name, a `_' if it needs
|
||||
;; an object (i.e., a transitive verb), a set of aliases,
|
||||
;; and a printed form.
|
||||
|
||||
(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 ----------------------------------------
|
||||
;; Handle verbs that work anywhere.
|
||||
|
||||
(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 ----------------------------------------
|
||||
;; Each object handles a set of transitive verbs.
|
||||
|
||||
(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 ----------------------------------------
|
||||
;; Each place handles a set of non-transitive verbs.
|
||||
|
||||
(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]))
|
||||
|
||||
|
||||
;; Go! ---------------------------------------------------
|
||||
|
||||
(start-game meadow
|
||||
all-verbs
|
||||
everywhere-actions)
|
||||
@ -0,0 +1,8 @@
|
||||
The starting line of "world.rkt" has changed, and the ending call to
|
||||
`start-game' has been replaced by just the starting place name. The
|
||||
content of "world.rkt" is also constrained to have a `define-verbs'
|
||||
form followed by a `define-everywhere' form, but the previous version
|
||||
fit that constraint anyway.
|
||||
|
||||
The "txtadv.rkt" module changed only in defining `module-begin' and
|
||||
exporting it as a replacement `#%module-begin'.
|
||||
@ -0,0 +1,4 @@
|
||||
The "world.rkt" module is unchanged. The "txtadv.rkt" module has a new
|
||||
"Simple type layer" section with compile time code, which is now used
|
||||
in the macros if the "Macros for constructing and registering
|
||||
elements" section.
|
||||
@ -0,0 +1,343 @@
|
||||
#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 (check-type id "place")
|
||||
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))
|
||||
|
||||
;; ============================================================
|
||||
;; Simple type layer:
|
||||
|
||||
(begin-for-syntax
|
||||
(struct typed (id type)
|
||||
#:property prop:procedure (lambda (self stx) (typed-id self))
|
||||
#:omit-define-syntaxes))
|
||||
|
||||
(define-syntax (check-type stx)
|
||||
(syntax-case stx ()
|
||||
[(check-type id type)
|
||||
(let ([v (and (identifier? #'id)
|
||||
(syntax-local-value #'id (lambda () #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")
|
||||
(lambda () 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")
|
||||
(lambda () 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")
|
||||
(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))
|
||||
@ -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
|
||||
@ -0,0 +1,10 @@
|
||||
The "world.rkt" module now uses a non-S-expression syntax, as enabled
|
||||
through the change of the first line to
|
||||
|
||||
#lang reader "txtadv-reader.rkt"
|
||||
|
||||
The new "txtadv-reader.rkt" module parses the syntax of "world.rkt"
|
||||
and generates the original form as a syntax object.
|
||||
|
||||
The "txtadv.rkt" module language is unchanged, since
|
||||
"txtadv-reader.rkt" converts "world.rkt" to its old form.
|
||||
@ -0,0 +1,148 @@
|
||||
#lang racket
|
||||
(require syntax/readerr)
|
||||
|
||||
(provide (rename-out [txtadv-read-syntax read-syntax]))
|
||||
|
||||
(define (txtadv-read-syntax src in)
|
||||
(expect-section src in "VERBS")
|
||||
(define verbs (in-section src in read-verb))
|
||||
(expect-section src in "EVERYWHERE")
|
||||
(define actions (in-section src in read-action))
|
||||
(expect-section src in "THINGS")
|
||||
(define things (in-section src in read-thing))
|
||||
(expect-section src in "PLACES")
|
||||
(define places (in-section src in read-place))
|
||||
(datum->syntax
|
||||
#f
|
||||
`(module world "txtadv.rkt"
|
||||
(define-verbs all-verbs
|
||||
,@verbs)
|
||||
(define-everywhere everywhere-actions
|
||||
,actions)
|
||||
,@things
|
||||
,@places
|
||||
,(if (null? places)
|
||||
(complain src in "no places defined")
|
||||
(cadar places)))))
|
||||
|
||||
(define (complain src in msg)
|
||||
(define-values (line col pos) (port-next-location in))
|
||||
(raise-read-error msg src line col pos 1))
|
||||
|
||||
(define (skip-whitespace in)
|
||||
(regexp-try-match #px"^\\s+" in))
|
||||
|
||||
(define (expect-section src in name)
|
||||
(skip-whitespace in)
|
||||
(unless (regexp-match-peek (pregexp (format "^===~a===\\s" name))
|
||||
in)
|
||||
(complain src in (format "expected a ===~a=== section" name)))
|
||||
(read-line in)
|
||||
(read-line in))
|
||||
|
||||
(define (in-section src in reader)
|
||||
(skip-whitespace in)
|
||||
(if (or (regexp-match-peek #rx"^===" in)
|
||||
(eof-object? (peek-byte in)))
|
||||
null
|
||||
(cons (reader src in)
|
||||
(in-section src in reader))))
|
||||
|
||||
(define (in-defn src in reader)
|
||||
(skip-whitespace in)
|
||||
(if (or (regexp-match-peek #rx"^(===|---)" in)
|
||||
(eof-object? (peek-byte in)))
|
||||
null
|
||||
(cons (reader src in)
|
||||
(in-defn src in reader))))
|
||||
|
||||
(define (read-name src in)
|
||||
(if (regexp-match-peek #px"^[A-Za-z-]+(?=:$|\\s|[],])" in)
|
||||
(read-syntax src in)
|
||||
(complain src in "expected a name")))
|
||||
|
||||
(define (read-name-sequence src in transitive)
|
||||
(let loop ([names null] [transitive transitive])
|
||||
(define s (read-name src in))
|
||||
(define is-trans?
|
||||
(cond
|
||||
[(regexp-match-peek #rx"^ _" in)
|
||||
(if (or (eq? transitive 'unknown)
|
||||
(eq? transitive #t))
|
||||
(begin
|
||||
(read-char in)
|
||||
(read-char in)
|
||||
#t)
|
||||
(begin
|
||||
(read-char in)
|
||||
(complain src in "unexpected underscore")))]
|
||||
[else
|
||||
(if (eq? transitive #t)
|
||||
(complain src in "inconsistent transitivity")
|
||||
#f)]))
|
||||
(if (regexp-match-peek #rx"^, " in)
|
||||
(begin
|
||||
(read-char in)
|
||||
(read-char in)
|
||||
(loop (cons s names) is-trans?))
|
||||
(values (reverse (cons s names)) is-trans?))))
|
||||
|
||||
(define (read-verb src in)
|
||||
(skip-whitespace in)
|
||||
(define-values (names is-transitive?)
|
||||
(read-name-sequence src in 'unknown))
|
||||
(skip-whitespace in)
|
||||
(define desc
|
||||
(if (regexp-match-peek #rx"^\"" in)
|
||||
(read-syntax src in)
|
||||
(symbol->string (syntax-e (car names)))))
|
||||
`[,(car names)
|
||||
,@(if is-transitive? '(_) '())
|
||||
(= ,@(cdr names))
|
||||
,desc])
|
||||
|
||||
(define (read-action src in)
|
||||
(skip-whitespace in)
|
||||
(define name (read-name src in))
|
||||
(define expr (read-syntax src in))
|
||||
`[,name ,expr])
|
||||
|
||||
(define (read-defn-name src in what)
|
||||
(skip-whitespace in)
|
||||
(unless (regexp-match-peek #px"^---[A-Za-z][A-Za-z0-9-]*---\\s"
|
||||
in)
|
||||
(complain src in (format "expected a ~a definition of the form ---name---" what)))
|
||||
(read-string 3 in)
|
||||
(define-values (line col pos) (port-next-location in))
|
||||
(define name-str (bytes->string/utf-8 (cadr (regexp-match #px"^(.*?)---\\s" in))))
|
||||
(datum->syntax #f
|
||||
(string->symbol name-str)
|
||||
(vector src line col pos (string-length name-str))
|
||||
orig-props))
|
||||
(define orig-props (read-syntax 'src (open-input-string "orig")))
|
||||
|
||||
(define (read-thing src in)
|
||||
(define name (read-defn-name src in "thing"))
|
||||
(define actions (in-defn src in read-action))
|
||||
`(define-thing ,name
|
||||
,@actions))
|
||||
|
||||
(define (read-place src in)
|
||||
(define name (read-defn-name src in "place"))
|
||||
(skip-whitespace in)
|
||||
(define desc (if (regexp-match-peek #rx"^\"" in)
|
||||
(read-syntax src in)
|
||||
(complain src in "expected description string")))
|
||||
(skip-whitespace in)
|
||||
(unless (regexp-match-peek #rx"^[[]" in)
|
||||
(complain src in "expected a square bracket to start a list of things for a place"))
|
||||
(read-char in)
|
||||
(define-values (things _)
|
||||
(if (regexp-match-peek #rx"^[]]" in)
|
||||
(values null #f)
|
||||
(read-name-sequence src in #f)))
|
||||
(unless (regexp-match-peek #rx"^[]]" in)
|
||||
(complain src in "expected a square bracket to end a list of things for a place"))
|
||||
(read-char in)
|
||||
(define actions (in-defn src in read-action))
|
||||
`(define-place ,name ,desc ,things ,actions))
|
||||
@ -0,0 +1,343 @@
|
||||
#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 (check-type id "place")
|
||||
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))
|
||||
|
||||
;; ============================================================
|
||||
;; Simple type layer:
|
||||
|
||||
(begin-for-syntax
|
||||
(struct typed (id type)
|
||||
#:property prop:procedure (lambda (self stx) (typed-id self))
|
||||
#:omit-define-syntaxes))
|
||||
|
||||
(define-syntax (check-type stx)
|
||||
(syntax-case stx ()
|
||||
[(check-type id type)
|
||||
(let ([v (and (identifier? #'id)
|
||||
(syntax-local-value #'id (lambda () #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")
|
||||
(lambda () 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")
|
||||
(lambda () 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")
|
||||
(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))
|
||||
@ -0,0 +1,176 @@
|
||||
#lang reader "txtadv-reader.rkt"
|
||||
|
||||
===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
|
||||
|
||||
|
||||
===EVERYWHERE===
|
||||
|
||||
quit
|
||||
(begin
|
||||
(printf "Bye!\n")
|
||||
(exit))
|
||||
|
||||
look
|
||||
(show-current-place)
|
||||
|
||||
inventory
|
||||
(show-inventory)
|
||||
|
||||
save
|
||||
(save-game)
|
||||
|
||||
load
|
||||
(load-game)
|
||||
|
||||
help
|
||||
(show-help)
|
||||
|
||||
|
||||
===THINGS===
|
||||
|
||||
---cactus---
|
||||
get
|
||||
"Ouch!"
|
||||
|
||||
---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."
|
||||
|
||||
---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.")
|
||||
|
||||
---trophy---
|
||||
|
||||
get
|
||||
(begin
|
||||
(take-thing! trophy)
|
||||
"You win!")
|
||||
|
||||
|
||||
===PLACES===
|
||||
|
||||
---meadow---
|
||||
"You're standing in a meadow. There is a house to the north."
|
||||
[]
|
||||
|
||||
north
|
||||
house-front
|
||||
|
||||
south
|
||||
desert
|
||||
|
||||
|
||||
---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
|
||||
|
||||
|
||||
---desert---
|
||||
"You're in a desert. There is nothing for miles around."
|
||||
[cactus, key]
|
||||
|
||||
north
|
||||
meadow
|
||||
|
||||
south
|
||||
desert
|
||||
|
||||
east
|
||||
desert
|
||||
|
||||
west
|
||||
desert
|
||||
|
||||
|
||||
---room---
|
||||
"You're in the house."
|
||||
[trophy]
|
||||
|
||||
out
|
||||
house-front
|
||||
@ -0,0 +1,21 @@
|
||||
To make this version work, you need the directory containing this file
|
||||
to be installed as the "txtadv" collection. One way to do that is with
|
||||
the shell command
|
||||
|
||||
raco link --name txtadv .
|
||||
|
||||
in the directory containing this file.
|
||||
|
||||
|
||||
The "world.rkt" module is the same as before, except that its first
|
||||
line is now
|
||||
|
||||
#lang txtadv
|
||||
|
||||
The "txtadv.rkt" module is unchanged.
|
||||
|
||||
Compared to the previous implementation, "txtadv-reader.rkt" is now
|
||||
"lang/reader.rkt", which is required to match Racket's protocol for
|
||||
resolving `#lang txtadv' to its reader module. The only other change
|
||||
is that a `get-info' function points to the "color.rkt" module in
|
||||
"lang" to implement syntax coloring.
|
||||
@ -0,0 +1,343 @@
|
||||
#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 (check-type id "place")
|
||||
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))
|
||||
|
||||
;; ============================================================
|
||||
;; Simple type layer:
|
||||
|
||||
(begin-for-syntax
|
||||
(struct typed (id type)
|
||||
#:property prop:procedure (lambda (self stx) (typed-id self))
|
||||
#:omit-define-syntaxes))
|
||||
|
||||
(define-syntax (check-type stx)
|
||||
(syntax-case stx ()
|
||||
[(check-type id type)
|
||||
(let ([v (and (identifier? #'id)
|
||||
(syntax-local-value #'id (lambda () #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")
|
||||
(lambda () 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")
|
||||
(lambda () 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")
|
||||
(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))
|
||||
@ -0,0 +1,8 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>URL</key>
|
||||
<string>http://queue.acm.org/detail.cfm?id=2068896</string>
|
||||
</dict>
|
||||
</plist>
|
||||
@ -1 +0,0 @@
|
||||
#lang racket
|
||||
@ -0,0 +1,103 @@
|
||||
#lang s-exp "expander.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
|
||||
@ -1,41 +0,0 @@
|
||||
#lang at-exp racket
|
||||
(require rackunit)
|
||||
(require "world0.rkt")
|
||||
|
||||
(check-equal? (with-output-to-string (λ _ (do-place)))
|
||||
"You're standing in a meadow. There is a house to the north.\n")
|
||||
|
||||
(define-syntax-rule (check-cmd? cmd result)
|
||||
(check-equal? (with-output-to-string (λ _ (do-verb cmd))) result))
|
||||
|
||||
(check-cmd?
|
||||
"s"
|
||||
"You're in a desert. There is nothing for miles around.\nThere is a cactus here.\nThere is a key here.\n")
|
||||
|
||||
(check-cmd?
|
||||
"get cactus"
|
||||
"Ouch!\n")
|
||||
|
||||
(check-cmd?
|
||||
"get key"
|
||||
"You now have the key.\n")
|
||||
|
||||
(check-cmd?
|
||||
"n"
|
||||
"You're standing in a meadow. There is a house to the north.\n")
|
||||
|
||||
(check-cmd?
|
||||
"n"
|
||||
"You are standing in front of a house.\nThere is a door here.\n")
|
||||
|
||||
(check-cmd?
|
||||
"open door"
|
||||
"The door is now unlocked and open.\n")
|
||||
|
||||
(check-cmd?
|
||||
"enter"
|
||||
"You're in the house.\nThere is a trophy here.\n")
|
||||
|
||||
(check-cmd?
|
||||
"get trophy"
|
||||
"You win!\n")
|
||||
Loading…
Reference in New Issue