2015年7月2日木曜日

開発環境

Land of Lisp (M.D. Conrad Barski (著)、川合 史朗 (翻訳)、オライリージャパン)の5章(世界とのインターフェース: Lisp でのデータの読み書き)、6.3(ゲームエンジンに専用のインタフェースを追加する)、6.4(さあこの素敵なゲームインタフェースを試してみよう)を Scheme で取り組んでみる。

6.3(ゲームエンジンに専用のインタフェースを追加する)、6.4(さあこの素敵なゲームインタフェースを試してみよう)

コード(Emacs)

(begin   
  (define print (lambda (x) (display x) (newline)))
  (define member
    (lambda (o items)
      (if (null? items)
          #f
          (let ((item (car items)))
            (if (equal? o item)
                items
                (member o (cdr items)))))))
  (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*))))))

  (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 inventory
    (lambda ()
      (cons (quote items-)
            (objects-at (quote body)
                        *objects*
                        *object-locations*))))

  ;; Common Lisp の eval と違って、Scheme の eval 手続きは、式と環境を渡す必要がある
  ;; かつ、kscheme に、環境(environment)と評価(eval)に関する手続きをまだ実装してない
  ;; ということで、とりあえず同様に機能する手続き等を定義していくことに
  (define game-repl
    (lambda ()
      (let ((cmd (game-read)))
        (if (eq? (car cmd) (quote quit))
            (quote bye)
            (begin (game-print (game-eval cmd))
                   (game-repl))))))

  (define args-one (quote (look inventory quit)))
  (define game-read
    (lambda ()
      (let ((proc-name (read))
            (arg #f))
        (if (not (memq proc-name args-one))
            (set! arg (read)))
        (cons proc-name arg))))
  
  (print (game-read))
  
  (define *allowed-commands* (list (cons (quote look)
                                         look)
                                   (cons (quote walk)
                                         walk)
                                   (cons (quote pickup)
                                         pickup)
                                   (cons (quote inventory)
                                         inventory)))
  (define game-eval
    (lambda (exp)
      (let ((record (assoc (car exp) *allowed-commands*)))
        (if record
            (let ((proc-name (car record))
                  (proc (cdr record)))
              (if (memq proc-name args-one)
                  (proc)
                  (proc (cdr exp))))
            (quote (I do not know that command.))))))

  (define game-print
    (lambda (items)
      (cond ((symbol? items)
             (display items) (newline))
            ((null? items) (newline))
            (else  (display (car items))
                   (display " ")
                   (game-print (cdr items))))))

  (game-print (quote (This is a sentence. What about this? Probably.)))
  (game-print (quote (Not only does this sentence have a "comma,"
                          it also mentions the "iPad.")))
  (game-repl)  
  (quote bye))

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

$ kscheme sample3.scm 
walk
east
(walk . east)
This is a sentence. What about this? Probably. 
Not only does this sentence have a comma, it also mentions the iPad. 
look
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. 
walk
west
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. 
pickup
chain
You are now carrying the chain 
scratch
head
I do not know that command. 
pickup
chicken
You cannot get that. 
walk
east
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. 
walk
upstairs
You are in the attic. There is a giant welding torch in the corner. There is a ladder going downstairs from here. 
inventory
items- chain 
walk
china
you cannot go that way. 
walk
downstairs
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. 
pickup
bucket
You are now carrying the bucket 
look
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. 
quit
bye
$

0 コメント:

コメントを投稿