Land of Lisp 第5章

game_repl.lisp

;; *** REPL ***
(defun game-repl ()
  (let ((cmd (game-read)))
    (unless (eq (car cmd) 'quit)
    (game-print (game-eval cmd))
    (game-repl))))

;; 入力に対して()を補い第二引数以降をシンボルとする
;; ex. walk east far => (WALK 'EAST 'FAR)
(defun game-read ()
  (let ((cmd (read-from-string
               (concatenate 'string "(" (read-line) ")" ))))
    (flet ((quote-it (x)
            (list 'quote x))) ;; (quote x) は 'x と同じ
      (cons (car cmd) (mapcar #'quote-it (cdr cmd))))))

(defparameter *allowed-commands* '(look walk pickup inventory))
(defun game-eval (sexp)
  (if (member (car sexp) *allowed-commands*)
    (eval sexp)
    '(i do not know that command.)))

;; lst 一文字ずつのリスト
;; caps 大文字変換のフラグ
;; lit ""に囲われた「文字列」を変換しない為のフラグ
(defun tweak-text (lst caps lit)
  (when lst
    (let ((item (car lst))
          (rest (cdr lst)))
      (cond 
        ;; 「spece」の場合はそのまま次へ
        ((eql item #\space) (cons item (tweak-text rest caps lit)))
        ;; 「!?.」の場合はcapsをtにする
        ((member item '(#\! #\? #\.)) (cons item (tweak-text rest t lit)))
        ;; 「"」の場合はlitを反転させる
        ((eql item #\") (tweak-text rest caps (not lit)))
        ;; litがtなら次は変換しない
        (lit (cons item (tweak-text rest nil lit)))
        ;; capsがtなら大文字に変換
        (caps (cons (char-upcase item) (tweak-text rest nil lit)))
        ;; その他の場合は全て小文字に変換
        (t (cons (char-downcase item) (tweak-text rest nil nil)))))))

(defun game-print (lst)
  (princ (coerce (tweak-text (coerce (string-trim "() " 
                                      (prin1-to-string lst))
                              'list)
                  t
                  nil)
          'string))
  (fresh-line))

;; *** 変数 ***
;; 場所 alist
(defparameter *nodes* '((living-room 
                          (you are in the living-room. 
                            a wizard is noring loudly on the couch.))
                        (garden 
                          (you are in a beautiful garden.
                            there is a well in front of you.))
                        (attic 
                          (you are in the attic.
                            thre is a giant welding torch in the corner.))))
;; 通り道 alist
(defparameter *edges* '((living-room 
                          (garden west door)
                          (attic upstairs ladder))
                        (garden 
                          (living-room east door))
                        (attic 
                          (living-room downstairs ladder))))
;; オブジェクト
(defparameter *objects* '(whiskey bucket frog chain))
;; オブジェクトの場所 alist
(defparameter *object-locations* '((whiskey living-room)
                                   (bucket living-room)
                                   (frog garden)
                                   (chain garden)))
;; 現在地 
(defparameter *location* 'living-room)


;; *** アクション ***
;; 辺りを見渡す
(defun look ()
  (append (describe-location *location* *nodes*)
          (describe-paths *location* *edges*)
          (describe-objects *location* *objects* *object-locations*)))

;; 移動する
(defun walk (direction)
  ;; ex. next => (garden west door)
  (let ((next (find direction
                (cdr (assoc *location* *edges*))
                :key #'cadr)))
    (if next
      (progn (setf *location* (car next))
             (look))
      '(you cannot go that way.))))

;; オブジェクトを手に取る
(defun pickup (object)
  (cond ((member object
                  (objects-at *location* *objects* *object-locations*))
          ;; pushするとobjectの情報が重複する可能性があるが、
          ;; objects-at()ではassocしているので先頭要素を確認しており問題ない。
          ;; push/assocはちょっとしたイディオムらしい。
          (push (list object 'body) *object-locations*)
          `(you are now carrying the ,object))
         (t '(you cannot get that.))))

;; 持ち物を調べる
(defun inventory ()
  (cons 'items- (objects-at 'body *objects* *object-locations*)))

;; *** 内部関数 ***
;; 場所の描写
(defun describe-location (location nodes)
  (cadr (assoc location nodes)))

;; 通り道の描写
(defun describe-paths (location edges)
  (flet ((describe-path (edge)
    `(there is a ,(caddr edge) going ,(cadr edge) from here.)))
  (apply #'append (mapcar #'describe-path (cdr (assoc location edges))))))

;; 見えるオブジェクトのリストを返す
(defun objects-at (loc objs obj-locs)
  (flet ((at-loc-p (obj)
          (eq (cadr (assoc obj obj-locs)) loc)))
    (remove-if-not #'at-loc-p objs)))

;; オブジェクトの描写
(defun describe-objects (loc objs obj-loc)
  (flet ((describe-obj (obj)
          `(you see a ,obj on the floor.)))
  (apply #'append (mapcar #'describe-obj (objects-at loc objs obj-loc)))))

(game-repl)