Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Land of lisp!

  • Loading branch information...
commit 56285f9b96a1d7492a8549852ef537c47c904164 1 parent f016787
Jason Frame authored

Showing 2 changed files with 72 additions and 0 deletions. Show diff stats Hide diff stats

  1. +2 0  .gitignore
  2. +70 0 land-of-lisp/05/text-adventure.lisp
2  .gitignore
... ... @@ -0,0 +1,2 @@
  1 +*~
  2 +
70 land-of-lisp/05/text-adventure.lisp
... ... @@ -0,0 +1,70 @@
  1 +(defparameter *nodes* '((living-room (you are in the living-room.
  2 + a wizard is snoring loudly on the couch.))
  3 + (garden (you are in a beautiful garden.
  4 + there is a well in front of you.))
  5 + (attic (you are in the attic.
  6 + there is a giant wleding torch in the corner))))
  7 +
  8 +(defparameter *edges* '((living-room (garden west door)
  9 + (attic upstairs ladder))
  10 + (garden (living-room east door))
  11 + (attic (living-room downstairs ladder))))
  12 +
  13 +(defparameter *objects* '(whiskey bucket frog chain))
  14 +(defparameter *object-locations* '((whiskey living-room)
  15 + (bucket living-room)
  16 + (chain garden)
  17 + (frog garden)))
  18 +
  19 +(defparameter *location* 'living-room)
  20 +
  21 +(defun describe-location (location nodes)
  22 + (cadr (assoc location nodes)))
  23 +
  24 +(defun describe-path (edge)
  25 + `(there is a ,(caddr edge) going ,(cadr edge) from here.))
  26 +
  27 +(defun describe-paths (location edges)
  28 + (apply #'append (mapcar #'describe-path (cdr (assoc location edges)))))
  29 +
  30 +(defun objects-at (loc objs obj-locs)
  31 + (labels ((at-loc-p (obj)
  32 + (eq loc (cadr (assoc obj obj-locs)))))
  33 + (remove-if-not #'at-loc-p objs)))
  34 +
  35 +(defun describe-objects (loc objs obj-locs)
  36 + (labels ((describe-obj (obj)
  37 + `(you see a ,obj on the floor.)))
  38 + (apply #'append (mapcar #'describe-obj (objects-at loc objs obj-locs)))))
  39 +
  40 +(defun look()
  41 + (append (describe-location *location* *nodes*)
  42 + (describe-paths *location* *edges*)
  43 + (describe-objects *location* *objects* *object-locations*)))
  44 +
  45 +(defun walk (direction)
  46 + (let ((next (find direction
  47 + (cdr (assoc *location* *edges*))
  48 + :key #'cadr)))
  49 + (if next
  50 + (progn (setf *location* (car next))
  51 + (look))
  52 + '(you cannot go that way.))))
  53 +
  54 +(defun pickup (object)
  55 + (cond
  56 + ((member object (objects-at *location* *objects* *object-locations*))
  57 + (push (list object 'body) *object-locations*)
  58 + `(you are now carrying the ,object))
  59 + (t '(you cannot get that.))))
  60 +
  61 +(defun drop (object)
  62 + (cond
  63 + ((member object (objects-at 'body *objects* *object-locations*))
  64 + (push (list object *location*) *object-locations*)
  65 + `(you have dropped the ,object))
  66 + (t `(you are not carrying the ,object))))
  67 +
  68 +(defun inventory ()
  69 + (cons 'items- (objects-at 'body *objects* *object-locations*)))
  70 +

0 comments on commit 56285f9

Please sign in to comment.
Something went wrong with that request. Please try again.