beautiful-racket/beautiful-racket-demo/txtadv/6-color/txtadv.rkt

#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))