Text Adventure Game in Land of Lisp
August 1, 2016
Common Lisp
Land of LiSP 这本书里面的第五章和第六章构建了一个字符冒险游戏，游戏截图如下：
;; 2016.07.30 23:22:41 PM
;; Sabastian
;; building a text adventure game engine
;; ====================
;; location
(defparameter *nodes*
'((living-room (you are in the living-room.
a wizard is snoring 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.
there is a giant welding torch in the corner.))))
(defun describe-location (location nodes)
"location is a symbol.
nodes is the global variable."
(cadr (assoc location nodes)))
;; ====================
;; edges
(defparameter *edges*
'((living-room
(garden west door)
(attic upstairs ladder))
(garden
(living-room east door))
(attic
(living-room downstairs ladder))))
(defun describe-path (edge)
`(there is a ,(caddr edge) going ,(cadr edge) from here.))
(defun describe-paths (location edges)
"location is a symbol.
edges is the global variable"
(apply #'append
(mapcar #'describe-path
(cdr (assoc location edges)))))
;; ====================
;; objects
(defparameter *objects* '(whiskey bucket frog chain))
(defparameter *object-locations* '((whiskey living-room)
(bucket living-room)
(chain garden)
(frog garden)))
;; One Way to write OBJECTS-AT function
;; (defun object-at-location-p (object location object-locations)
;; "object and location are symbols.
;; object-locations is a global variable"
;; (eq (cadr (assoc object object-locations))
;; location))
;; if the test function in REMOVE-IF-NOT require more than one
;; arguments, then use a lambda to wrap the function. ;-)
;; (defun objects-at (location objects object-locations)
;; (remove-if-not #'(lambda (object)
;; (object-at-location-p object
;; location
;; object-locations))
;; objects))
;; A better way for OBJECTS-AT function
(defun objects-at (location objects object-locations)
"location is a symbol.
objects and object-locations are global variables.
return a list of objects in the current location."
(labels ((at-location-p (object)
(eq location
(cadr (assoc object object-locations)))))
(remove-if-not #'at-location-p objects)))
(defun describe-objects (location objects object-locations)
"location is a symbol.
objects and object-locations are global variables."
(apply #'append
(mapcar #'(lambda (object)
`(you see a ,object on the floor.))
(objects-at location objects
object-locations))))
;; ====================
;; Describing it ALL
(defparameter *location* 'living-room)
(defun look ()
(append (describe-location *location* *nodes*)
(describe-paths *location* *edges*)
(describe-objects *location* *objects*
*object-locations*)))
;; Walking Around in Our World
(defun walk (direction)
(let ((next
(find direction
(cdr (assoc *location* *edges*))
:key #'cadr)))
(cond (next
(setf *location* (car next))
(look))
(t
'(you cannot go that way.)))))
;; ====================
;; Pick Up Objects
(defun pickup (object)
"object is a symbol.
push a new list to *object-locations*, return a message list"
(cond ((member
object
(objects-at *location* *objects*
*object-locations*))
(push `(,object body) *object-locations*)
`(you are now carrying the ,object))
(t '(you cannot get that.))))
;; ====================
;; Checking Our Inventory
(defun inventory ()
(cons 'items- (objects-at 'body *objects* *object-locations*)))
(defun game-read ()
(let ((cmd
(read-from-string
(concatenate 'string "(" (read-line) ")"))))
(cons (car cmd)
(mapcar #'(lambda (x)
`',x)
(cdr cmd)))))
(defun tweak-text (lst capital-p literal-p)
(let ((item (car lst))
(rest (rest lst)))
(if item
(cond ((member item '(#\! #\? #\.))
(cons item (tweak-text rest t nil)))
((eq item #\")
(cons item (tweak-text rest nil (not literal-p))))
(literal-p
(cons item (tweak-text rest nil literal-p)))
(capital-p
(cons (char-upcase item)
(if (alpha-char-p item)
(tweak-text rest nil literal-p)
(tweak-text rest t literal-p))))
(t
(cons (char-downcase item)
(tweak-text rest nil literal-p)))))))
(defun game-print (lst)
(princ
(coerce
(tweak-text
(coerce (string-trim "() "
(prin1-to-string lst))
'list)
t nil)
'string))
(fresh-line))
(defparameter *allowed-commands* '(look walk pickup inventory))
(defun game-eval (sexp)
(if (member (first sexp)
*allowed-commands*)
(eval sexp)
'(i do not know that command.)))
(defun game-repl ()
(let ((cmd (game-read)))
(unless (eq (car cmd)
'quit)
(game-print (game-eval cmd))
(game-repl))))
在第七章里，把游戏里面的位置位置关系通过有向图的形式用第三方库画出来：
;; 2016/08/01 11:48:58 AM
;; Xueyang Liu
(defparameter *wizard-nodes*
'((living-room (you are in the living-room.
a wizard is snoring 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.
there is a giant welding torch in the corner.))))
(defparameter *wizard-edges*
'((living-room
(garden west door)
(attic upstairs ladder))
(garden
(living-room east door))
(attic
(living-room downstairs ladder))))
(defun dot-name (sexp)
(string-downcase
(substitute-if #\_ (complement #'alphanumericp)
(prin1-to-string sexp))))
(defparameter *max-label-length* 30)
(defun dot-label (sexp)
(if sexp
(let ((s (write-to-string sexp
:pretty nil)))
(if (> (length s)
*max-label-length*)
(concatenate 'string
(string-downcase
(subseq s
0 (- *max-label-length* 3)))
"...")
s))
""))
(defun nodes->dot (nodes)
(mapc (lambda (sexp)
(fresh-line)
(princ (dot-name (car sexp)))
(princ "[label=\"")
(princ (dot-label sexp))
(princ "\"];"))
nodes))
(defun edges->dot (edges)
(mapc (lambda (node)
(mapc (lambda (edge)
(fresh-line)
(princ (dot-name (car node)))
(princ "->")
(princ (dot-name (car edge)))
(princ "[label=\"")
(princ (string-downcase
(prin1-to-string (cdr edge))))
(princ "\"];"))
(cdr node)))
edges))
(defun uedges->dot (edges)
(maplist (lambda (lst)
(mapc (lambda (edge)
(unless (assoc (car edge)
lst)
(fresh-line)
(princ (dot-name (caar lst)))
(princ "--")
(princ (dot-name (car edge)))
(princ "[label=\"")
(princ (string-downcase
(prin1-to-string (cdr edge))))
(princ "\"];")))
(cdar lst)))
edges))
(defun graph->dot (nodes edges)
(princ "digraph{")
(nodes->dot nodes)
(edges->dot edges)
(princ "}"))
(defun ugraph->dot (nodes edges)
(princ "graph{")
(nodes->dot nodes)
(uedges->dot edges)
(princ "}"))
(defun dot->png (fname thunk)
(with-open-file (*standard-output*
fname
:direction :output
:if-exists :supersede)
(funcall thunk))
(ext:shell (concatenate 'string
"dot -Tpng -O " fname)))
(defun graph->png (fname nodes edges)
(dot->png fname
(lambda ()
(graph->dot nodes edges))))
(defun ugraph->png (fname nodes edges)
(dot->png fname
(lambda ()
(ugraph->dot nodes edges))))