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.6(オブジェクトを手に取る)を Scheme で取り組んでみる。

5.6(オブジェクトを手に取る)

コード(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*))))
  (define member
    (lambda (o items)
      (if (null? items)
          #f
          (let ((item (car items)))
            (if (equal? o item)
                items
                (member o (cdr items)))))))
  ;; 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*))))))

  ;; Common Lisp の push 手続きは、Scheme にはないっぽい。
  (define push
    (lambda (o items)
      (let ((t (map (lambda (x) x) items)))
        (set-car! items o)
        (set-cdr! items t)
        items)))
  (define pickup
    (lambda (object)
      (cond ((member object
                     (objects-at *location*
                                 *objects*
                                 *object-locations*))
             (set! *object-locations*
                   (cons (list object (quote body))
                         *object-locations*))
             (quasiquote (You are now carrying the ,object)))
            (else (quote (you cannot get that.))))))
  (define *location* (quote living-room))

  (define *foo* (quote (1 2 3)))
  (print (push 7 *foo*))
  (print *foo*)

  (walk (quote west))
  (print (walk (quote east)))
  (print (pickup (quote whiskey)))

  (quote done))

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

$ kscheme < sample6.scm
kscm> 
(7 1 2 3)
(7 1 2 3)
(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 now carrying the whiskey)
done
kscm> $