Scheme - Land of Scheme - テキストゲームのエンジンを作る(ゲームの世界を動き回る)

Land of Lisp
(オライリージャパン)
M.D. Conrad Barski (著) 川合 史朗 (翻訳)
原書: Land of LISP
Learn to Program in Lisp, One Game at a Time!

開発環境

• OS X Yosemite - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme, Gauche, GNU Guile (処理系)

Land of Lisp (M.D. Conrad Barski (著)、川合 史朗 (翻訳)、オライリージャパン)の5章(テキストゲームのエンジンを作る)、5.5(ゲームの世界を動き回る)を Scheme で取り組んでみる。

5.5(ゲームの世界を動き回る)

コード(Emacs)

(begin 
  (define print (lambda (x) (display x) (newline)))
  (newline)

  (define map
    (lambda (proc items)
      (if (null? items)
          (quote ())
          (cons (proc (car items))
                (map proc (cdr items))))))
  (define filter
    (lambda (pred items)
      (cond ((null? items) (quote ()))
            ((pred (car items))
             (cons (car items)
                   (filter pred (cdr items))))
            (else (filter pred (cdr items))))))
  
  (define assoc
    (lambda (obj alist)
      (if (null? alist)
          #f
          (let ((item (car alist)))
            (if (equal? obj (car item))
                item
                (assoc obj (cdr alist)))))))

  ;; ここから
  (define describe-location
    (lambda (location nodes)
      (let ((item (assoc location nodes)))
        (if item
            (cadr item)
            #f))))  
  (define describe-path
    (lambda (edge)
      (quasiquote (There is a (unquote (caddr edge)) going (unquote (cadr edge))
                         from here.))))  
  (define describe-paths
    (lambda (location edges)
      (apply append (map describe-path (cdr (assoc location edges))))))
  (define objects-at
    (lambda (loc objs obj-locs)
      (define at-loc?
        (lambda (obj)
          (let ((item (assoc obj obj-locs)))
            (and item
                 (eq? (cadr item) loc)))))
      (filter at-loc? objs)))  
  (define describe-objects
    (lambda (loc objs obj-loc)
      (define describe-obj
        (lambda (obj)
          (quasiquote (You see a (unquote obj) on the floor.))))
      (apply append
             (map describe-obj (objects-at loc objs obj-loc)))))

  ;; ここから
  (define *objects* (quote (whiskey bucket frog chain)))
  (define *nodes*
    (quote ((living-room (You are in the living-room. There is a wizard is
                              snoring loudly on the couch.))
            (garden (You are in a beatiful garden. There is a well in front of
                         you.))
            (attic (You are in the attic. There is a giant welding torch in
                        the corner.)))))
  (define *edges* (quote ((living-room (garden west door)
                                       (attic upstairs ladder))
                          (garden (living-room east door))
                          (attic (living-room downstairs ladder)))))
  (define *object-locations* (quote ((whiskey living-room)
                                     (bucket living-room)
                                     (chain garden)
                                     (frog garden))))  
  (define look
    (lambda ()
      (append (describe-location *location* *nodes*)
              (describe-paths *location* *edges*)
              (describe-objects *location* *objects* *object-locations*))))
  ;; Scheme (R7RS) には Common Lisp の組み込み手続き find はないっぽい。
  ;; (相当する機能の組み込み手続きはあるのかもしれない)
  (define find
    (lambda (pred items)
      (if (null? items)
          #f
          (let ((item (car items)))
            (if (pred item)
                item
                (find pred (cdr items)))))))
  (define walk
    (lambda (direction)
      (let ((edge (assoc *location* *edges*)))
        (if edge
            (let ((next (find (lambda (x) (eq? (cadr x) direction))
                              (cdr edge))))
              (if next
                  (begin (set! *location* (car next))
                         (look))
                  (quote (you cannot go that way.))))
            (quote (not found *location*))))))

  (define *location* (quote living-room))
  (print (walk (quote west)))           ; garden
  (print (walk (quote east)))           ; living-room
  (print (walk (quote upstairs)))       ; attic
  (print (walk (quote downstairs)))     ; living-room
  (print (walk (quote east)))
  
  (quote done))

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ kscheme < sample5.scm
kscm> 
(You are in a beatiful garden. There is a well in front of you. There is a door going east from here. You see a frog on the floor. You see a chain on the floor.)
(You are in the living-room. There is a wizard is snoring loudly on the couch. There is a door going west from here. There is a ladder going upstairs from here. You see a whiskey on the floor. You see a bucket on the floor.)
(You are in the attic. There is a giant welding torch in the corner. There is a ladder going downstairs from here.)
(You are in the living-room. There is a wizard is snoring loudly on the couch. There is a door going west from here. There is a ladder going upstairs from here. You see a whiskey on the floor. You see a bucket on the floor.)
(you cannot go that way.)
done
kscm> $