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.4(全てを描写する)を Scheme で取り組んでみる。

5.4(全てを描写する)

コード(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 (livving-room downstairs ladder)))))
  (define *object-locations* (quote ((whiskey living-room)
                                     (bucket living-room)
                                     (chain garden)
                                     (frog garden))))  
  
  (define *location* (quote living-room))  
  (define look
    (lambda ()
      (append (describe-location *location* *nodes*)
              (describe-paths *location* *edges*)
              (describe-objects *location* *objects* *object-locations*))))

  (print (look))

  (quote done))

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

$ kscheme < sample4.scm
kscm> 
(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.)
done
kscm> $