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