Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 143 lines (113 sloc) 5.4 kB
3179e61 Initial checkin
Andrey Paramonov authored
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 welding 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
15 (defparameter *object-locations* '((whiskey living-room)
16 (bucket living-room)
17 (chain garden)
18 (frog garden)))
19
20 (defparameter *location* 'living-room)
21
22 (defun describe-location (location nodes)
23 (cadr (assoc location nodes)))
24
25 (defun describe-path (edge)
26 `(there is a ,(caddr edge) going ,(cadr edge) from here.))
27
28 (defun describe-paths (location edges)
29 (apply #'append (mapcar #'describe-path (cdr (assoc location edges)))))
30
31 (defun objects-at (loc objs obj-locs)
32 (labels ((at-loc-p (obj)
33 (eq (cadr (assoc obj obj-locs)) loc)))
34 (remove-if-not #'at-loc-p objs)))
35
36 (defun describe-objects (loc objs obj-loc)
37 (labels ((describe-obj (obj)
38 `(you see a ,obj on the floor.)))
39 (apply #'append (mapcar #'describe-obj (objects-at loc objs obj-loc)))))
40
41 (defun look ()
42 (append (describe-location *location* *nodes*)
43 (describe-paths *location* *edges*)
44 (describe-objects *location* *objects* *object-locations*)))
45
46 (defun walk (direction)
47 (let ((next (find direction
48 (cdr (assoc *location* *edges*))
49 :key #'cadr)))
50 (if next (progn (setf *location* (car next))
51 (look))
52 '(you cannot go that way.))))
53
54 (defun pickup (object)
55 (cond ((member object (objects-at *location* *objects* *object-locations*))
56 (push (list object 'body) *object-locations*)
57 `(you are now carrying the ,object))
58 (t '(you cannot get that.))))
59
60 (defun inventory ()
61 (cons 'items- (objects-at 'body *objects* *object-locations*)))
62
63 ;(defun game-repl ()
64 ; (loop (print (eval (read)))))
65
66 (defun game-repl ()
67 (let ((cmd (game-read)))
68 (unless (eq (car cmd) 'quit)
69 (game-print (game-eval cmd))
70 (game-repl))))
71
72 (defun game-read ()
73 (let ((cmd (read-from-string (concatenate 'string "(" (read-line) ")"))))
74 (flet ((quote-it (x) (list 'quote x)))
75 (cons (car cmd) (mapcar #'quote-it (cdr cmd))))))
76
77 (defparameter *allowed-commands* '(look walk pickup inventory))
78
79 (defun game-eval (sexp)
80 (if (member (car sexp) *allowed-commands*)
81 (eval sexp)
82 '(i do not know that command.)))
83
84 (defun tweak-text (lst caps lit)
85 (when lst
86 (let ((item (car lst))
87 (rest (cdr lst)))
88 (cond ((eq item #\space) (cons item (tweak-text rest caps lit)))
89 ((member item '(#\! #\? #\.)) (cons item (tweak-text rest t lit)))
90 ((eq item #\") (tweak-text rest caps (not lit)))
91 (lit (cons item (tweak-text rest nil lit)))
92 ((or caps lit) (cons (char-upcase item) (tweak-text rest nil lit)))
93 (t (cons (char-downcase item) (tweak-text rest nil nil)))))))
94
95 (defun game-print (lst)
96 (princ (coerce (tweak-text (coerce (string-trim "() "
97 (prin1-to-string lst))
98 'list)
99 t
100 nil)
101 'string))
102 (fresh-line))
103
52c0fe7 Chapter 17: merged wizard-special-actions into wizard.lisp
Andrey Paramonov authored
104 ; Special actions - sample of DSL
105
106 (defun have (object)
107 (member object (cdr (inventory))))
108
109 (defmacro game-action (command subj obj place &body body)
110 `(progn (defun ,command (subject object)
111 (if (and (eq *location* ',place)
112 (eq subject ',subj)
113 (eq object ',obj)
114 (have ',subj))
115 ,@body
116 '(i cant ,command like that.)))
117 (pushnew ',command *allowed-commands*)))
118
119 (defparameter *chain-welded* nil)
120
121 (game-action weld chain bucket attic
122 (if (and (have 'bucket) (not *chain-welded*))
123 (progn (setf *chain-welded* 't)
124 '(the chain is now securely welded to the bucket.))
125 '(you do not have a bucket.)))
126
127 (defparameter *bucket-filled* nil)
128
129 (game-action dunk bucket well garden
130 (if *chain-welded*
131 (progn (setf *bucket-filled* 't)
132 '(the bucket is now full of water))
133 '(the water level is too low to reach.)))
134
135 (game-action splash bucket wizard living-room
136 (cond ((not *bucket-filled*) '(the bucket has nothing in it.))
137 ((have 'frog) '(the wizard awakens and sees that you stole his frog.
138 he is so upset he banishes you to the
139 netherworlds- you lose! the end.))
140 (t '(the wizard awakens from his slumber and greets you warmly.
141 he hands you the magic low-carb donut- you win! the end.))))
142
Something went wrong with that request. Please try again.