Browse files

Land of lisp!

  • Loading branch information...
1 parent f016787 commit 56285f9b96a1d7492a8549852ef537c47c904164 @jaz303 committed Apr 20, 2012
Showing with 72 additions and 0 deletions.
  1. +2 −0 .gitignore
  2. +70 −0 land-of-lisp/05/text-adventure.lisp
View
2 .gitignore
@@ -0,0 +1,2 @@
+*~
+
View
70 land-of-lisp/05/text-adventure.lisp
@@ -0,0 +1,70 @@
+(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 wleding torch in the corner))))
+
+(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))
+(defparameter *object-locations* '((whiskey living-room)
+ (bucket living-room)
+ (chain garden)
+ (frog garden)))
+
+(defparameter *location* 'living-room)
+
+(defun describe-location (location nodes)
+ (cadr (assoc location nodes)))
+
+(defun describe-path (edge)
+ `(there is a ,(caddr edge) going ,(cadr edge) from here.))
+
+(defun describe-paths (location edges)
+ (apply #'append (mapcar #'describe-path (cdr (assoc location edges)))))
+
+(defun objects-at (loc objs obj-locs)
+ (labels ((at-loc-p (obj)
+ (eq loc (cadr (assoc obj obj-locs)))))
+ (remove-if-not #'at-loc-p objs)))
+
+(defun describe-objects (loc objs obj-locs)
+ (labels ((describe-obj (obj)
+ `(you see a ,obj on the floor.)))
+ (apply #'append (mapcar #'describe-obj (objects-at loc objs obj-locs)))))
+
+(defun look()
+ (append (describe-location *location* *nodes*)
+ (describe-paths *location* *edges*)
+ (describe-objects *location* *objects* *object-locations*)))
+
+(defun walk (direction)
+ (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 (list object 'body) *object-locations*)
+ `(you are now carrying the ,object))
+ (t '(you cannot get that.))))
+
+(defun drop (object)
+ (cond
+ ((member object (objects-at 'body *objects* *object-locations*))
+ (push (list object *location*) *object-locations*)
+ `(you have dropped the ,object))
+ (t `(you are not carrying the ,object))))
+
+(defun inventory ()
+ (cons 'items- (objects-at 'body *objects* *object-locations*)))
+

0 comments on commit 56285f9

Please sign in to comment.