start txtadv tutorial
parent
6a5e7a8366
commit
2d2ac10654
@ -0,0 +1,5 @@
|
|||||||
|
#lang br
|
||||||
|
|
||||||
|
(module+ reader
|
||||||
|
(require "txtadv/reader.rkt")
|
||||||
|
(provide (all-from-out "txtadv/reader.rkt")))
|
||||||
@ -0,0 +1,196 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require parser-tools/lex
|
||||||
|
syntax-color/scheme-lexer
|
||||||
|
(prefix-in : parser-tools/lex-sre))
|
||||||
|
|
||||||
|
(provide color-lexer)
|
||||||
|
|
||||||
|
(define-lex-abbrevs
|
||||||
|
[id (:: (:/ #\A #\Z #\a #\z) (:* (:or (:/ #\A #\Z #\a #\z #\0 #\9) #\-)))]
|
||||||
|
|
||||||
|
[digit8 (:/ "0" "7")]
|
||||||
|
[digit16 (:/ "af" "AF" "09")]
|
||||||
|
|
||||||
|
[unicode (:or (:: "u" (:** 1 4 digit16))
|
||||||
|
(:: "U" (:** 1 6 digit16)))]
|
||||||
|
|
||||||
|
[str (:: "\"" (:* string-element (:: "\\" unicode)) "\"")]
|
||||||
|
[string-element (:or (:~ "\"" "\\")
|
||||||
|
"\\\""
|
||||||
|
"\\\\"
|
||||||
|
"\\a"
|
||||||
|
"\\b"
|
||||||
|
"\\t"
|
||||||
|
"\\n"
|
||||||
|
"\\v"
|
||||||
|
"\\f"
|
||||||
|
"\\r"
|
||||||
|
"\\e"
|
||||||
|
"\\'"
|
||||||
|
(:: "\\" (:** 1 3 digit8))
|
||||||
|
(:: "\\x" (:** 1 2 digit16))
|
||||||
|
(:: "\\" #\newline))])
|
||||||
|
|
||||||
|
(define errors
|
||||||
|
(lexer
|
||||||
|
[any-char
|
||||||
|
(values lexeme 'error #f (position-offset start-pos) (position-offset end-pos)
|
||||||
|
1 (list inc-errors 1))]
|
||||||
|
[(eof)
|
||||||
|
(values lexeme 'eof #f #f #f 0 #f)]))
|
||||||
|
|
||||||
|
(define (inc-errors in back)
|
||||||
|
(define-values (lexeme type data new-token-start new-token-end backup mode)
|
||||||
|
(errors in))
|
||||||
|
(values lexeme type data new-token-start new-token-end
|
||||||
|
(+ 1 (car back))
|
||||||
|
(list inc-errors (+ 1 (car back)))))
|
||||||
|
|
||||||
|
(define-syntax-rule (lexer/error [pat (_values kind next)] ...)
|
||||||
|
(lexer
|
||||||
|
[pat
|
||||||
|
(values lexeme kind #f (position-offset start-pos) (position-offset end-pos) 0 next)]
|
||||||
|
...
|
||||||
|
[any-char
|
||||||
|
(values lexeme 'error #f (position-offset start-pos) (position-offset end-pos) 0 errors)]
|
||||||
|
[(eof)
|
||||||
|
(values lexeme 'eof #f #f #f 0 #f)]))
|
||||||
|
|
||||||
|
(define-syntax-rule (lexer/whitespace ws clause ...)
|
||||||
|
(lexer/error
|
||||||
|
[(:+ whitespace)
|
||||||
|
(values lexeme ws)]
|
||||||
|
clause ...))
|
||||||
|
|
||||||
|
(define section-color 'other)
|
||||||
|
(define id-color 'symbol)
|
||||||
|
|
||||||
|
(define start
|
||||||
|
(lexer/whitespace
|
||||||
|
#f
|
||||||
|
["===VERBS===" (values section-color verbs)]))
|
||||||
|
|
||||||
|
(define verbs
|
||||||
|
(lexer/whitespace
|
||||||
|
verbs
|
||||||
|
[id (values id-color verb-trans)]
|
||||||
|
["===EVERYWHERE===" (values section-color everywhere)]))
|
||||||
|
|
||||||
|
(define verb-trans
|
||||||
|
(lexer/whitespace
|
||||||
|
verb-body
|
||||||
|
[" _" (values 'symbol verb-comma)]
|
||||||
|
[", " (values 'other verbs)]))
|
||||||
|
|
||||||
|
(define verb-comma
|
||||||
|
(lexer/whitespace
|
||||||
|
verb-body
|
||||||
|
[", " (values 'other verbs)]))
|
||||||
|
|
||||||
|
(define verb-body
|
||||||
|
(lexer/whitespace
|
||||||
|
verb-body
|
||||||
|
[str (values 'string verbs)]
|
||||||
|
[id (values id-color verb-trans)]
|
||||||
|
["===EVERYWHERE===" (values section-color everywhere)]))
|
||||||
|
|
||||||
|
(define everywhere
|
||||||
|
(lexer/whitespace
|
||||||
|
everywhere
|
||||||
|
[id (values id-color (list global-action))]
|
||||||
|
["===THINGS===" (values section-color things)]))
|
||||||
|
|
||||||
|
(define things
|
||||||
|
(lexer/whitespace
|
||||||
|
things
|
||||||
|
[(:: "---" id "---") (values id-color thing-operations)]
|
||||||
|
["===PLACES===" (values section-color places)]))
|
||||||
|
|
||||||
|
(define thing-operations
|
||||||
|
(lexer/whitespace
|
||||||
|
thing-operations
|
||||||
|
[id (values id-color (list thing-action))]
|
||||||
|
[(:: "---" id "---") (values id-color thing-operations)]
|
||||||
|
["===PLACES===" (values section-color places)]))
|
||||||
|
|
||||||
|
(define places
|
||||||
|
(lexer/whitespace
|
||||||
|
places
|
||||||
|
[(:: "---" id "---") (values id-color place)]))
|
||||||
|
|
||||||
|
(define place
|
||||||
|
(lexer/whitespace
|
||||||
|
place
|
||||||
|
[str (values 'string place-things)]))
|
||||||
|
|
||||||
|
(define place-things
|
||||||
|
(lexer/whitespace
|
||||||
|
place-things
|
||||||
|
["[" (values 'string place-thing-seq)]))
|
||||||
|
|
||||||
|
(define place-thing-seq
|
||||||
|
(lexer/whitespace
|
||||||
|
errors
|
||||||
|
[id (values id-color place-thing-seq-next)]
|
||||||
|
["]" (values 'string place-operations)]))
|
||||||
|
|
||||||
|
(define place-thing-seq-next
|
||||||
|
(lexer/whitespace
|
||||||
|
errors
|
||||||
|
[", " (values 'other place-thing-seq)]
|
||||||
|
["]" (values 'string place-operations)]))
|
||||||
|
|
||||||
|
(define place-operations
|
||||||
|
(lexer/whitespace
|
||||||
|
place-operations
|
||||||
|
[(:: "---" id "---") (values id-color place)]
|
||||||
|
[id (values id-color (list place-action))]))
|
||||||
|
|
||||||
|
(define (global-action in mode)
|
||||||
|
(action in mode global-action everywhere))
|
||||||
|
|
||||||
|
(define (thing-action in mode)
|
||||||
|
(action in mode thing-action thing-operations))
|
||||||
|
|
||||||
|
(define (place-action in mode)
|
||||||
|
(action in mode place-action place-operations))
|
||||||
|
|
||||||
|
(define (action in mode self next)
|
||||||
|
(define-values (lexeme type data new-token-start new-token-end status)
|
||||||
|
(scheme-lexer/status in))
|
||||||
|
(let ([mode (next-mode mode type data status)])
|
||||||
|
(values lexeme
|
||||||
|
(if (eq? mode 'error) 'error type)
|
||||||
|
data new-token-start new-token-end 0
|
||||||
|
(cond
|
||||||
|
[(list? mode) (cons self mode)]
|
||||||
|
[(eq? mode 'error) errors]
|
||||||
|
[else next]))))
|
||||||
|
|
||||||
|
(define (next-mode mode type data status)
|
||||||
|
(case type
|
||||||
|
[(parenthesis)
|
||||||
|
(case data
|
||||||
|
[(|(|) (cons '|)| mode)]
|
||||||
|
[(|[|) (cons '|]| mode)]
|
||||||
|
[(|{|) (cons '|}| mode)]
|
||||||
|
[else (if (and (pair? mode)
|
||||||
|
(eq? (car mode) data))
|
||||||
|
(if (and (null? (cdr mode))
|
||||||
|
(not (eq? status 'continue)))
|
||||||
|
'done
|
||||||
|
(cdr mode))
|
||||||
|
'error)])]
|
||||||
|
[(white-space comment) mode]
|
||||||
|
[else (if (and (null? mode)
|
||||||
|
(not (eq? status 'continue)))
|
||||||
|
'done
|
||||||
|
mode)]))
|
||||||
|
|
||||||
|
(define (color-lexer in offset mode)
|
||||||
|
(cond
|
||||||
|
[(not mode) (start in)]
|
||||||
|
[(pair? mode)
|
||||||
|
((car mode) in (cdr mode))]
|
||||||
|
[else
|
||||||
|
(mode in)]))
|
||||||
@ -0,0 +1,347 @@
|
|||||||
|
#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 ...
|
||||||
|
(init-game (check-type id "place")
|
||||||
|
all-verbs
|
||||||
|
everywhere-actions)
|
||||||
|
(provide do-verb do-place)
|
||||||
|
(module+ main
|
||||||
|
(cmd-line-mode? #t)
|
||||||
|
(do-place)))]))
|
||||||
|
|
||||||
|
;; ============================================================
|
||||||
|
;; 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 (λ (self stx) (typed-id self))
|
||||||
|
#:omit-define-syntaxes))
|
||||||
|
|
||||||
|
(define-syntax (check-type stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ id type)
|
||||||
|
(let ([v (and (identifier? #'id)
|
||||||
|
(syntax-local-value #'id (λ _ #f)))])
|
||||||
|
(unless (and (typed? v)
|
||||||
|
(equal? (syntax-e #'type) (typed-type v)))
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
(format "not defined as ~a" (syntax-e #'type))
|
||||||
|
#'id))
|
||||||
|
#'id)]))
|
||||||
|
|
||||||
|
;; ============================================================
|
||||||
|
;; Macros for constructing and registering elements:
|
||||||
|
|
||||||
|
(define-syntax-rule (define-verbs all-id
|
||||||
|
[id spec ...] ...)
|
||||||
|
(begin
|
||||||
|
(define-one-verb id spec ...) ...
|
||||||
|
(record-element! 'id id) ...
|
||||||
|
(define all-id (list id ...))))
|
||||||
|
|
||||||
|
(define-syntax define-one-verb
|
||||||
|
(syntax-rules (= _)
|
||||||
|
[(define-one-verb id (= alias ...) desc)
|
||||||
|
(begin
|
||||||
|
(define gen-id (verb (list 'id 'alias ...) desc #f))
|
||||||
|
(define-syntax id (typed #'gen-id "intransitive verb")))]
|
||||||
|
[(define-one-verb id _ (= alias ...) desc)
|
||||||
|
(begin
|
||||||
|
(define gen-id (verb (list 'id 'alias ...) desc #t))
|
||||||
|
(define-syntax id (typed #'gen-id "transitive verb")))]
|
||||||
|
[(define-one-verb id)
|
||||||
|
(define-one-verb id (=) (symbol->string 'id))]
|
||||||
|
[(define-one-verb id _)
|
||||||
|
(define-one-verb id _ (=) (symbol->string 'id))]))
|
||||||
|
|
||||||
|
(define-syntax-rule (define-thing id
|
||||||
|
[vrb expr] ...)
|
||||||
|
(begin
|
||||||
|
(define gen-id
|
||||||
|
(thing 'id #f (list (cons (check-type vrb "transitive verb")
|
||||||
|
(λ _ expr)) ...)))
|
||||||
|
(define-syntax id (typed #'gen-id "thing"))
|
||||||
|
(record-element! 'id id)))
|
||||||
|
|
||||||
|
|
||||||
|
(define-syntax-rule (define-place id
|
||||||
|
desc
|
||||||
|
(thng ...)
|
||||||
|
([vrb expr] ...))
|
||||||
|
(begin
|
||||||
|
(define gen-id
|
||||||
|
(place desc
|
||||||
|
(list (check-type thng "thing") ...)
|
||||||
|
(list (cons (check-type vrb "intransitive verb")
|
||||||
|
(λ _ expr))
|
||||||
|
...)))
|
||||||
|
(define-syntax id (typed #'gen-id "place"))
|
||||||
|
(record-element! 'id id)))
|
||||||
|
|
||||||
|
|
||||||
|
(define-syntax-rule (define-everywhere id ([vrb expr] ...))
|
||||||
|
(define id (list (cons (check-type vrb "intransitive verb")
|
||||||
|
(λ _ expr))
|
||||||
|
...)))
|
||||||
|
|
||||||
|
;; ============================================================
|
||||||
|
;; Game state
|
||||||
|
|
||||||
|
(define cmd-line-mode? (make-parameter #f))
|
||||||
|
;; Initialized on startup:
|
||||||
|
(define all-verbs null) ; list of verbs
|
||||||
|
(define everywhere-actions null) ; list of verb--thunk pairs
|
||||||
|
|
||||||
|
;; Things carried by the player:
|
||||||
|
(define stuff null) ; list of things
|
||||||
|
|
||||||
|
;; 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)
|
||||||
|
(when (cmd-line-mode?)
|
||||||
|
(do-verb)))
|
||||||
|
|
||||||
|
;; Show the current place:
|
||||||
|
(define (show-current-place)
|
||||||
|
(printf "~a\n" (place-desc current-place))
|
||||||
|
(for-each (λ (thing)
|
||||||
|
(printf "There is a ~a here.\n" (thing-name thing)))
|
||||||
|
(place-things current-place)))
|
||||||
|
|
||||||
|
;; Get and handle a command:
|
||||||
|
|
||||||
|
(define (get-line)
|
||||||
|
(printf "> ")
|
||||||
|
(flush-output)
|
||||||
|
(read-line))
|
||||||
|
|
||||||
|
(define (do-verb [line (and (cmd-line-mode?) (get-line))])
|
||||||
|
(define 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)]
|
||||||
|
[response
|
||||||
|
(cond
|
||||||
|
[(= 2 (length input))
|
||||||
|
(handle-transitive-verb vrb (cadr input))]
|
||||||
|
[(= 1 (length input))
|
||||||
|
(handle-intransitive-verb vrb)])]
|
||||||
|
[result (response)])
|
||||||
|
(cond
|
||||||
|
[(place? result)
|
||||||
|
(set! current-place result)
|
||||||
|
(do-place)]
|
||||||
|
[(string? result)
|
||||||
|
(printf "~a\n" result)
|
||||||
|
(when (cmd-line-mode?) (do-verb))]
|
||||||
|
[else (when (cmd-line-mode?) (do-verb))]))
|
||||||
|
(begin
|
||||||
|
(printf "I don't undertand what you mean.\n")
|
||||||
|
(when (cmd-line-mode?) (do-verb)))))
|
||||||
|
|
||||||
|
;; Handle an intransitive-verb command:
|
||||||
|
(define (handle-intransitive-verb verb)
|
||||||
|
(or
|
||||||
|
(find-verb verb (place-actions current-place))
|
||||||
|
(find-verb verb everywhere-actions)
|
||||||
|
(using-verb
|
||||||
|
verb all-verbs
|
||||||
|
(λ (verb)
|
||||||
|
(λ _ (if (verb-transitive? verb)
|
||||||
|
(format "~a what?" (string-titlecase (verb-desc verb)))
|
||||||
|
(format "Can't ~a here." (verb-desc verb))))))
|
||||||
|
(λ _ (format "I don't know how to ~a." verb))))
|
||||||
|
|
||||||
|
;; Handle a transitive-verb command:
|
||||||
|
(define (handle-transitive-verb vrb obj)
|
||||||
|
(or (using-verb
|
||||||
|
vrb all-verbs
|
||||||
|
(λ (verb)
|
||||||
|
(and
|
||||||
|
(verb-transitive? verb)
|
||||||
|
(cond
|
||||||
|
[(ormap (λ (thing)
|
||||||
|
(and (eq? (thing-name thing) obj)
|
||||||
|
thing))
|
||||||
|
(append (place-things current-place)
|
||||||
|
stuff))
|
||||||
|
=> (λ (thing)
|
||||||
|
(or (find-verb vrb (thing-actions thing))
|
||||||
|
(λ _
|
||||||
|
(format "Don't know how to ~a ~a."
|
||||||
|
(verb-desc verb) obj))))]
|
||||||
|
[else
|
||||||
|
(λ _ (format "There's no ~a here to ~a." obj
|
||||||
|
(verb-desc verb)))]))))
|
||||||
|
(λ _ (format "I don't know how to ~a ~a." vrb obj))))
|
||||||
|
|
||||||
|
;; Show what the player is carrying:
|
||||||
|
(define (show-inventory)
|
||||||
|
(printf "You have")
|
||||||
|
(if (null? stuff)
|
||||||
|
(printf " no items.")
|
||||||
|
(for-each (λ (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 (λ (a)
|
||||||
|
(and (memq cmd (verb-aliases (car a)))
|
||||||
|
(cdr a)))
|
||||||
|
actions))
|
||||||
|
|
||||||
|
;; Looks for a command in a list of verbs, and
|
||||||
|
;; applies `success-k' to the verb if one is found:
|
||||||
|
(define (using-verb cmd verbs success-k)
|
||||||
|
(ormap (λ (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? (λ (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:
|
||||||
|
|
||||||
|
(define (init-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))
|
||||||
@ -0,0 +1,5 @@
|
|||||||
|
#lang br
|
||||||
|
|
||||||
|
(module+ reader
|
||||||
|
(require "reader.rkt")
|
||||||
|
(provide (all-from-out "reader.rkt")))
|
||||||
@ -0,0 +1,160 @@
|
|||||||
|
#lang racket
|
||||||
|
(require syntax/readerr)
|
||||||
|
|
||||||
|
(provide (rename-out [txtadv-read-syntax read-syntax])
|
||||||
|
;; added at the end to link syntax to colorer:
|
||||||
|
get-info)
|
||||||
|
|
||||||
|
(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 br/demo/txtadv/expander
|
||||||
|
(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))
|
||||||
|
|
||||||
|
;; DrRacket asks `get-info' for a 'color-lexer module:
|
||||||
|
(require racket/runtime-path)
|
||||||
|
(define-runtime-path color-lexer-path "color.rkt")
|
||||||
|
(define (get-info in mod line col pos)
|
||||||
|
(lambda (key default)
|
||||||
|
(case key
|
||||||
|
[(color-lexer)
|
||||||
|
(dynamic-require color-lexer-path 'color-lexer)]
|
||||||
|
[else default])))
|
||||||
@ -0,0 +1,41 @@
|
|||||||
|
#lang at-exp racket
|
||||||
|
(require rackunit)
|
||||||
|
(require "world.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")
|
||||||
@ -0,0 +1,176 @@
|
|||||||
|
#lang br/demo/txtadv
|
||||||
|
|
||||||
|
===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
|
||||||
Loading…
Reference in New Issue