netbsd/pr.txt: update
[mmondor.git] / mmsoftware / cl / test / symbol-game3.lisp
1 ;;; $Id: symbol-game3.lisp,v 1.17 2010/02/10 02:00:30 mmondor Exp $
2 ;;;
3 ;;; Copyright (c) 2009, Matthew Mondor
4 ;;; ALL RIGHTS RESERVED.
5 ;;;
6 ;;; This game-symbol implementation is designed for interactive development.
7 ;;; All references are held via a keyword symbol, which is resolved by a
8 ;;; custom function to the internal object and/or keyword object.
9 ;;; It then becomes easy to modify existing objects, or to create new ones
10 ;;; (items, entities, rooms) interactively and dynamically with minimal
11 ;;; hassle, i.e. using C-c C-c.
12 ;;;
13 ;;; XXX Maybe
14 ;;; - Add notes/clues object type
15 ;;; - Add a notebook item collecting found clues
16 ;;; - Allow the fun definition of object-actions to allow things like
17 ;;; eat bread | unlock object with|using object | open coffin | etc?
18 ;;; instead of only use object [on object].
19
20 (setf *load-verbose* nil)
21
22 (defpackage :symbol-game
23 (:use :cl)
24 (:shadow #:room)
25 (:export #:main-loop))
26
27 (in-package :symbol-game)
28
29
30 (defparameter *aliases* (make-hash-table :test #'eq)
31 "Used to hold name aliases created by DEFINE-OBJECT and resolved by
32 RESOLVE-SYMBOL.")
33
34 (defmacro define-object (object item)
35 "Provides syntactic sugar to easily define a new object, instanciating
36 the structure OBJECT. ITEM's first element contains a list with the name
37 of the DEFPARAMETER bound variable in package OBJECT, along with optional
38 alias names (transparently added to *ALIASES*). The rest of the list
39 contain keyword arguments and their values passed to MAKE-OBJECT."
40 (let ((%symbol (intern (symbol-name (caar item)) object)))
41 `(progn
42 (defparameter ,%symbol
43 (,(intern (format nil "MAKE-~A" (symbol-name object)))
44 ,@(rest item)))
45 (setf
46 ,@(mapcan #'(lambda (i)
47 `((gethash ',(intern (symbol-name i) object) *aliases*)
48 ',%symbol))
49 (cdar item))))))
50
51 (defmacro define-objects (object &rest items)
52 "Allows to easily define multiple objects with the same format as
53 DEFINE-OBJECT."
54 `(progn
55 ,@(mapcar #'(lambda (i)
56 (macroexpand `(define-object ,object ,i)))
57 items)))
58
59
60 (defmacro do-plist ((key-var val-var plist) &body body)
61 "Iterates over property list PLIST, binding the variables KEY-VAR and
62 VAL-VAR to the key and value of every property pair, executing BODY at
63 each iteration."
64 `(loop
65 for (,key-var ,val-var) on ,plist by #'cddr
66 do
67 ,@body))
68
69 (defun mapplist (function plist)
70 "Runs through every property in PLIST and calls (FUNCTION key val) for
71 each, which may return:
72 - No value, in which case property is discarded in the result
73 - One value, in which case the property's value is changed in the result
74 - Two values, in which case the property's key and value are changed.
75 Returns a fresh new property list.
76 Signals an error if FUNCTION returns an unexpected value."
77 (assert (and (listp plist)
78 (evenp (length plist)))
79 (plist)
80 "~S is not a property list." plist)
81 (let ((rplist '()))
82 (do-plist (k v plist)
83 (let* ((rv (multiple-value-list (funcall function k v)))
84 (len (length rv)))
85 (cond ((zerop len)
86 ())
87 ((= 1 len)
88 (setf (getf rplist k) (first rv)))
89 ((= 2 len)
90 (setf (getf rplist (first rv)) (second rv)))
91 (t
92 (error "~S returned an unexpected value." function)))))
93 rplist))
94
95
96 ;;; The following deals with serializing back the current world in the same
97 ;;; format it can be defined.
98
99 (defparameter *struct-slots* (make-hash-table :test #'eq)
100 "Used to hold the slot name symbols for structures created using
101 DEFINE-STRUCT for portable reflectivity, in order to serialize those
102 using WRITE-ITEM(S).")
103
104 (defmacro define-struct (name &rest slots)
105 "DEFSTRUCT thin wrapper which also stores a list of SLOTS into the
106 hash-table *STRUCT-SLOTS* under the key NAME, in order to provide enough
107 reflectivity for our custom serialisers."
108 `(progn
109 (setf (gethash ',name *struct-slots*) '(,@slots))
110 (defstruct ,name
111 ,@slots)))
112
113 (defun write-item (symbol)
114 "Serializes a single item to the same representation needed by
115 DEFINE-OBJECT."
116 (labels ((serialize-place (place)
117 "Quote place as needed."
118 (typecase place
119 (list `',place)
120 (t place)))
121 (intern-keyword (symbol)
122 (intern (symbol-name symbol) :keyword))
123 (alias-symbols ()
124 "Returns list of alias symbols."
125 (loop
126 for key being each hash-key of *aliases* using (hash-value val)
127 when (eq symbol val)
128 collect (intern-keyword key))))
129 (let ((value (symbol-value symbol)))
130 `(define-object ,(intern (package-name (symbol-package symbol)) :keyword)
131 ((,@(list (intern-keyword symbol))
132 ,@(alias-symbols))
133 ,@(mapcan #'(lambda (slot)
134 `(,(intern-keyword slot)
135 ,(serialize-place (slot-value value slot))))
136 (remove-if #'(lambda (slot)
137 (null (slot-value value slot)))
138 (gethash (type-of (symbol-value symbol))
139 *struct-slots*))))))))
140
141 (defun write-items (package)
142 "Serializes all symbols of specified package to the representation of
143 DEFINE-OBJECT inside a PROGN."
144 (flet ((map-bound-symbols (function)
145 "Call FUNCTION on every BOUNDP non-NIL symbol of PACKAGE."
146 (let ((local-nil (intern "NIL" package)))
147 (loop
148 for symbol being each symbol in package
149 when (and (not (eq local-nil symbol))
150 (boundp symbol))
151 collect (funcall function symbol)))))
152 `(progn
153 ,@(map-bound-symbols #'write-item))))
154
155
156 (defpackage :object
157 (:use))
158
159 (define-struct object
160 short-descriptions
161 long-description
162 immutable-p)
163
164 (define-object :object
165 ((:key)
166 :short-descriptions '("a key" "keys")
167 :long-description "Some old rusted key."))
168
169 (define-object :object
170 ((:coin)
171 :short-descriptions '("a coin" "coins")
172 :long-description "Looks like an old gold coin of significant value."))
173
174 (define-object :object
175 ((:oddity)
176 :short-descriptions '("an oddity" "oddities")
177 :long-description "A very odd item."
178 :immutable-p t))
179
180 (define-object :object
181 ((:bread :loaf)
182 :short-descriptions '("a loaf of bread" "bread loaves")
183 :long-description "An awesome loaf of fresh bread."))
184
185 (define-object :object
186 ((:note)
187 :short-descriptions '("a note" "notes")
188 :long-description "The note appears to contain a clue."))
189
190 (define-object :object
191 ((:treasure)
192 :short-descriptions '("a treasure" "treasures")
193 :long-description "An awesome treasure."))
194
195
196 (defpackage :entity
197 (:use))
198
199 (define-struct entity
200 name
201 short-description
202 long-description
203 known-p
204 hello
205 bye
206 job
207 unknown
208 dictionary)
209
210 (define-object :entity
211 ((:matt :gentleman)
212 :name "Matt"
213 :short-description "A well mannered gentleman"
214 :long-description
215 "The gentleman is a geek even if he looks like a knight."
216 :hello "Welcome, adventurer! How may I help you?"
217 :bye "Farewell!"
218 :job "I code this world. Oh, and I give presents."
219 :unknown "You are not authorized to obtain that information."
220 :dictionary '(:asl "Really!?"
221 :coin "They're lovely, indeed!")))
222
223
224 (defpackage :room
225 (:use))
226
227 (define-struct room
228 short-description
229 long-description
230 north
231 east
232 south
233 west
234 up
235 down
236 objects
237 entities)
238
239 (define-object :room
240 ((:house)
241 :short-description "Small house"
242 :long-description
243 "You are inside a small yet cosy house. A lit fireplace gives a comforting
244 smell of burning wood. A chair can be seen near the fireplace along with a
245 small table. There is a ladder here going to the cellar. The exit is to
246 your south."
247 :south :house-entrance
248 :up :house-cellar
249 :objects '(:bread 2)))
250
251 (define-object :room
252 ((:house-entrance)
253 :short-description "House entrance"
254 :long-description
255 "You are in front of a small house. The entrance is north."
256 :north :house
257 :east "The forest is too dense to go east."
258 :south :forest
259 :west "High mountains block the passage."))
260
261 (define-object :room
262 ((:forest)
263 :short-description "Forest"
264 :long-description
265 "You are in a rather dense forest. At the west are mountains. To the
266 north can be seen what appears to be a house. The forest continues to the
267 south and a road begins to the east."
268 :north :house-entrance
269 :east :road
270 :south "The forest is too thick."
271 :west "High mountains block the passage."))
272
273 (define-object :room
274 ((:house-cellar)
275 :short-description "Cellar"
276 :long-description "The dark cellar smells of dust."
277 :down :house
278 :objects '(:key 1
279 :note 1)))
280
281 (define-object :room
282 ((:road)
283 :short-description "Road"
284 :long-description
285 "This earth road leads west and east. The sun makes the soil quite hot.
286 A forest begins to the west. At the east appears to be a large building
287 far away."
288 :east :castle-entrance
289 :west :forest
290 :objects '(:oddity 1)))
291
292 (define-object :room
293 ((:castle-entrance)
294 :short-description "Castle entrance"
295 :long-description
296 "You are at the entrance of a large castle. Its walls are high, its
297 entrance huge and its towers very high. The entrance appears to be open,
298 with the bridge drawn over some small river that surrounds the castle."
299 :east "The game is still in construction!"
300 :west :road
301 :objects '(:coin 5)
302 :entities '(:matt)))
303
304 (define-object :room
305 ((:castle)
306 :short-description "Awesome castle"
307 :long-description
308 "You are inside an awesome castle! Unfortunately, you appear to be locked
309 here. At least you are now very rich. Giving those two coins away sure
310 was a great investment!"
311 :objects '(:treasure 100)))
312
313
314 (defun resolve-symbol (symbol package)
315 "Returns the SYMBOL-VALUE of SYMBOL from PACKAGE if it exists,
316 as well as the keyword symbol in a second value, after resolving aliases
317 as necessary (via *ALIASES*, populated by DEFINE-OBJECT(S))."
318 (flet ((resolve-symbol-alias (symbol)
319 (multiple-value-bind (value presentp)
320 (gethash symbol *aliases*)
321 (if presentp
322 value
323 symbol))))
324 (if (and symbol
325 (symbolp symbol))
326 (let ((s (resolve-symbol-alias (find-symbol (symbol-name symbol)
327 package))))
328 (values
329 (symbol-value s)
330 (intern (symbol-name s) :keyword)))
331 symbol)))
332
333
334 (define-condition game-error
335 (simple-error)
336 ())
337
338 (defun game-error (fmt &rest args)
339 "Instanciates and signals a condition of type GAME-ERROR, which we
340 internally use to easily escape arbitrary game code back to the game
341 REPL after printing the error message. Syntax is like that of FORMAT."
342 (error (make-condition 'game-error
343 :format-control (apply #'format nil fmt args))))
344
345
346 (defvar *current-room* :forest
347 "Holds a keyword symbol specifying the room in which the user currently is.")
348 (defvar *inventory* '()
349 "A property list of keyword symbol (of item objects) and number pairs.")
350
351 (defvar *use-commands*
352 (make-hash-table :test #'equal)
353 "Table of keyword symbols list to function for DEFINE-USE-COMMAND.")
354 (defvar *give-commands*
355 (make-hash-table :test #'equal)
356 "Table of keyword symbols list to function for DEFINE-GIVE-COMMAND.")
357 (defvar *talk-commands*
358 (make-hash-table :test #'equal)
359 "Table of keyword symbols list to function for DEFINE-TALK-COMMAND.")
360
361
362 (defun current-room ()
363 "Returns the ROOM object of *CURRENT-ROOM* for convenience."
364 (resolve-symbol *current-room* :room))
365
366 (defun object-present-list-p (list object)
367 "Is OBJECT property present in plist LIST?"
368 (getf list object))
369
370 (defun object-in-inventory-p (object)
371 "Is OBJECT property present in *INVENTORY* plist?"
372 (object-present-list-p *inventory* object))
373
374 (defun object-in-room-p (object)
375 "Is OBJECT property present in current room's objects plist?"
376 (object-present-list-p (room-objects (current-room)) object))
377
378 (defun object-present-p (object)
379 "Is OBJECT property present in either *INVENTORY* or current room's plist?"
380 (or (object-in-inventory-p object)
381 (object-in-room-p object)))
382
383 (defun entity-present-p (entity)
384 "Is ENTITY present in the current room?"
385 (member entity (room-entities (current-room))))
386
387
388 ;;; The following need to be macros because they may reassign the list
389 ;;; variable as necessary, which side effect we don't want to be restricted
390 ;;; to the scope of the function. A drawback (or feature) of plists.
391
392 (defmacro add-object (list object)
393 "Adds OBJECT to plist LIST, incrementing its count if present."
394 `(if (getf ,list ,object)
395 (incf (getf ,list ,object))
396 (setf (getf ,list ,object) 1)))
397
398 (defmacro remove-object (list object)
399 "Decrease count of OBJECT in plist LIST, deleting it if 0."
400 `(when (and (getf ,list ,object)
401 (zerop (decf (getf ,list ,object))))
402 (remf ,list ,object)))
403
404 (defmacro take-object (object)
405 "Transfers OBJECT from current room's objects plist to inventory plist."
406 `(progn
407 (remove-object (room-objects (current-room)) ,object)
408 (add-object *inventory* ,object)))
409
410 (defmacro drop-object (object)
411 "Transfers OBJECT from inventory plist to current room's plist."
412 `(progn
413 (remove-object *inventory* ,object)
414 (add-object (room-objects (current-room)) ,object)))
415
416 (defmacro forget-object (object)
417 "Remove OBJECT from inventory plist."
418 `(remove-object *inventory* ,object))
419
420
421 (defun describe-objects (list)
422 "Prints the list of objects held by the LIST plist to the user."
423 (when list
424 (format t "~%You see:~%")
425 (mapplist #'(lambda (item count)
426 (let ((o (resolve-symbol item :object)))
427 (if (= 1 count)
428 (format t " - ~A~%"
429 (first (object-short-descriptions o)))
430 (format t " - ~R ~A~%"
431 count
432 (second (object-short-descriptions o))))))
433 list)))
434
435 (defun describe-object-item (item)
436 "Prints the long description of ITEM object to the user."
437 (format t "~A~%" (object-long-description (resolve-symbol item :object))))
438
439 (defun describe-entities ()
440 "Prints the list of entities in the current room's plist to the user."
441 (let ((list (room-entities (current-room))))
442 (when list
443 (format t "~%")
444 (dolist (entity list)
445 (let ((o (resolve-symbol entity :entity)))
446 (format t "~A is here.~%" (if (entity-known-p o)
447 (entity-name o)
448 (entity-short-description o))))))))
449
450 (defun describe-entity (entity)
451 "Prints the long desription of ENTITY entity to the user."
452 (format t "~A~%" (entity-long-description (resolve-symbol entity :entity))))
453
454 (defun describe-room ()
455 "Prints the general description of the current room, its objects and entities
456 to the user."
457 (let ((room (current-room)))
458 (format t " ~A~%~%~A~%"
459 (room-short-description room)
460 (room-long-description room))
461 (describe-entities)
462 (describe-objects (room-objects room))))
463
464 (defun change-room (room)
465 "Switch the current room to ROOM and print its descrition to the user."
466 (setf *current-room* room)
467 (describe-room))
468
469 (defun entity-word (entity word)
470 "Implements basic communication with an entity in the current room.
471 ENTITY and WORD must be keyword symbols."
472 (multiple-value-bind (e s)
473 (resolve-symbol entity :entity)
474 (let ((w (intern (symbol-name word) :keyword)))
475 (unless e
476 (game-error "Your word echoes unnoticed."))
477 (unless (entity-present-p s)
478 (game-error "You're too far away."))
479 (case w
480 ((:hi :hello)
481 (format t "- ~A~%" (entity-hello e)))
482 (:bye
483 (format t "- ~A~%" (entity-bye e)))
484 (:name
485 (format t "- My name is ~A.~%" (entity-name e))
486 (setf (entity-known-p e) t))
487 (:job
488 (format t "- ~A~%" (entity-job e)))
489 (otherwise
490 (let ((text (getf (entity-dictionary e) w))
491 (function (gethash `(,w ,s) *talk-commands*)))
492 (cond (function
493 (funcall function))
494 (text
495 (format t "- ~A~%" text))
496 (t
497 (format t "- ~A~%" (entity-unknown e))))))))))
498
499 (defun list<-string (string)
500 "Converts a string of words to a list of keyword symbols for convenient
501 manipulation."
502 (let* ((ustring (string-upcase string))
503 (len (length ustring))
504 (start 0))
505 (declare (type fixnum len start))
506 (loop
507 for i of-type fixnum from 0 below len
508 while (setf start (position-if-not #'(lambda (c)
509 (char= #\Space c))
510 ustring
511 :start i))
512 collect (intern (subseq ustring
513 start
514 (setf i (or (position #\Space
515 ustring
516 :start start)
517 len)))
518 :keyword))))
519
520
521 (defpackage :command
522 (:use))
523
524 (defmacro define-command (name args &body body)
525 "Helper macro to define user commands."
526 (let ((name-sym (intern (symbol-name name) :command)))
527 `(setf (symbol-function ',name-sym)
528 (compile nil #'(lambda ,args
529 ,@body)))))
530
531 (defun apply-command (list)
532 "Interprets a user command, simply applying to the corresponding function
533 if it exists, or signalling an error."
534 (let ((function-sym (find-symbol (symbol-name (first list)) :command)))
535 (unless (and function-sym (fboundp function-sym))
536 (error "Unknown command"))
537 (apply function-sym (rest list))))
538
539
540 (defparameter *quit* nil)
541 (define-command quit ()
542 (setf *quit* t))
543
544 (define-command inventory ()
545 (if *inventory*
546 (describe-objects *inventory*)
547 (format t "You are not carrying anything.~%")))
548 (define-command i ()
549 (command::inventory))
550
551 (define-command look (&rest rest)
552 (flet ((resolve-symbol2 (s p)
553 (second (multiple-value-list (resolve-symbol s p)))))
554 (cond ((and (= 2 (length rest))
555 (eq :at (first rest)))
556 (let* ((sym (second rest))
557 (object (resolve-symbol2 sym :object))
558 (entity (resolve-symbol2 sym :entity)))
559 (cond ((object-present-p object)
560 (describe-object-item object))
561 ((entity-present-p entity)
562 (describe-entity entity))
563 (t
564 (format t "You cannot see that here.~%")))))
565 (t
566 (describe-room)))))
567
568 (define-command go (direction)
569 (let* ((direction
570 ;; Map keyword symbol to symbol-game symbol if matching
571 (first (member direction '(north east south west up down)
572 :test #'(lambda (a b)
573 (eq b
574 (find-symbol (symbol-name a)
575 :symbol-game))))))
576 (destination
577 (cond ((null direction)
578 (game-error "I don't know where that is."))
579 (t
580 (slot-value (current-room) direction)))))
581 (cond ((null destination)
582 (format t "You cannot go that way.~%"))
583 ((stringp destination)
584 (format t "~A~%" destination))
585 (t
586 (change-room destination)))))
587 (define-command n ()
588 (command::go :north))
589 (define-command e ()
590 (command::go :east))
591 (define-command s ()
592 (command::go :south))
593 (define-command w ()
594 (command::go :west))
595 (define-command u ()
596 (command::go :up))
597 (define-command d ()
598 (command::go :down))
599
600 (define-command take (item)
601 (multiple-value-bind (object symbol)
602 (resolve-symbol item :object)
603 (let ((item-string (string-downcase (symbol-name item))))
604 (unless (object-in-room-p symbol)
605 (game-error "You cannot see that item here."))
606 (when (object-immutable-p object)
607 (game-error "You cannot take the ~A." item-string))
608 (take-object symbol)
609 (format t "You take the ~A.~%" item-string))))
610
611 (define-command drop (item)
612 (multiple-value-bind (object symbol)
613 (resolve-symbol item :object)
614 (declare (ignore object))
615 (let ((item-string (string-downcase (symbol-name item))))
616 (unless (object-in-inventory-p symbol)
617 (game-error "You do not hold that item."))
618 (drop-object symbol)
619 (format t "You drop the ~A.~%" item-string))))
620
621 (define-command say (word to entity)
622 (unless (eq :to to)
623 (game-error "Sorry, your mumbling isn't intelligible."))
624 (entity-word entity word))
625 (define-command tell (entity about word)
626 (unless (eq :about about)
627 (game-error "Sorry, your mumbling isn't intelligible."))
628 (entity-word entity word))
629 (define-command ask (entity about word)
630 (command::tell entity about word))
631
632 (define-command give (object to entity)
633 (unless (eq :to to)
634 (game-error "I do not know who you want to give to."))
635 (flet ((resolve-symbol2 (s p)
636 (second (multiple-value-list (resolve-symbol s p)))))
637 (let ((o (resolve-symbol2 object :object))
638 (e (resolve-symbol2 entity :entity)))
639 (unless (object-in-inventory-p o)
640 (game-error "You do not hold that item."))
641 (unless (entity-present-p e)
642 (game-error "You're too far away."))
643 (let ((function (gethash `(,o ,e) *give-commands*)))
644 (unless function
645 (game-error "- Thanks, but I wouldn't know what to do with it."))
646 (forget-object o)
647 (funcall function)))))
648
649 (define-command use (&rest rest)
650 (let ((items (cond ((and (= 3 (length rest))
651 (eq :on (second rest)))
652 `(,(first rest) ,(third rest)))
653 ((= 1 (length rest))
654 rest)
655 (t nil))))
656 (unless items
657 (game-error "I don't understand what you want to do."))
658 (let ((list (mapcar #'(lambda (i)
659 (second (multiple-value-list
660 (resolve-symbol i :object))))
661 items)))
662 (unless (object-in-inventory-p (first list))
663 (game-error "You do not hold the ~A."
664 (string-downcase (symbol-name (first items)))))
665 (when (and (= 2 (length list))
666 (not (object-present-p (second list))))
667 (game-error "You cannot see the ~A here."
668 (string-downcase (symbol-name (second items)))))
669 (let ((function (gethash list *use-commands*)))
670 (unless function
671 (game-error "That is not possible."))
672 (funcall function)))))
673
674 (define-command help ()
675 (format t
676 "Available commands:
677
678 Movement:
679 - go <north|east|south|west|up|down>
680 - n|e|s|w|u|d
681
682 Items:
683 - i|inventory
684 - look [at <item|character>]
685 - take <item>
686 - drop <item>
687 - use <item> [on <item>]
688 - give <item> to <character>
689
690 Communication:
691 - ask <character> about <word>
692 - tell <character> about <word>
693 - say <word> to <character>
694 Special words implemented for every character are:
695 - hi|hello
696 - bye
697 - name
698 - job
699
700 Game:
701 - ?|help
702 - load
703 - save
704 - quit
705 "))
706 (define-command ? ()
707 (command::help))
708
709
710 (defmacro define-use-command (objects &body body)
711 "Helper macro to define USE <foo> [on <bar>] commands."
712 `(setf (gethash ',objects *use-commands*)
713 (compile nil #'(lambda ()
714 ,@body))))
715
716
717 (define-use-command (:bread)
718 (forget-object :bread)
719 (format t "You eat the loaf of bread.~%"))
720
721 (define-use-command (:key)
722 (cond ((eq *current-room* :castle)
723 (format t "If only there was a keyhole somewhere...~%"))
724 (t
725 (format t "There is no lock to unlock here.~%"))))
726 (define-use-command (:key :coin)
727 (format t "I wish this was useful, but...~%"))
728 (define-use-command (:key :treasure)
729 (format t "The treasure is not a locked coffin.~%"))
730
731 (define-use-command (:note)
732 (format t "The note reads: \"Matt likes old golden coins\".~%"))
733
734 (define-use-command (:treasure)
735 (format t "How would you use the treasure?~%"))
736
737
738 (defmacro define-give-command ((object entity) &body body)
739 "Helper macro to define GIVE <object> to <entity> actions."
740 `(setf (gethash '(,object ,entity) *give-commands*)
741 (compile nil #'(lambda ()
742 ,@body))))
743
744 (defvar *matt-coins* 0)
745 (define-give-command (:coin :matt)
746 (cond ((> (incf *matt-coins*) 1)
747 (format t "- Okay. The castle was now written for two coins.~%")
748 (setf (room-east room::castle-entrance) :castle))
749 (t
750 (format t
751 "- Why thanks, sir! With more of this I could write more!~%"))))
752
753
754 (defmacro define-talk-command ((word entity) &body body)
755 "Helper macro to define ASK <entity> about <word> actions."
756 `(setf (gethash '(,word ,entity) *talk-commands*)
757 (compile nil #'(lambda ()
758 ,@body))))
759
760
761 (define-talk-command (:present :matt)
762 (format t "- Here!~%")
763 (add-object *inventory* :treasure))
764
765
766 (defun custom-read-line (&optional (stream *standard-input*) (max 4096))
767 "Reads a single line from STREAM (defaulting to *STANDARD-INPUT*),
768 limiting the line up to MAX number of characters (defaults to 4096),
769 ignoring any #\RETURN characters and stopping at #\NEWLINE, not including
770 it as part of the returned line. Also handles unicode decoding errors
771 according to the implementation: for ECL, return #\Ufffd characters but
772 on SBCL assume an invalid sequence consists of ISO-8859 characters,
773 converting and including them."
774 (declare (type fixnum max))
775 (flet ((read-more ()
776 "Read at least one character from STREAM, returning a list."
777 (let ((chars '()))
778 #+ecl(push (handler-case
779 (read-char stream)
780 (simple-error ()
781 #\Ufffd))
782 chars)
783 #+sbcl(handler-bind
784 ((sb-int:stream-decoding-error
785 #'(lambda (e)
786 (mapc #'(lambda (c)
787 (when (> c 127)
788 (push c chars)))
789 (sb-int:character-decoding-error-octets e))
790 (invoke-restart 'sb-int:attempt-resync))))
791 (push (read-char stream) chars))
792 #-(or ecl sbcl)(push (read-char stream) chars)
793 chars)))
794 (let ((total 0))
795 (declare (type fixnum total))
796 (map 'string
797 #'identity
798 (loop
799 for chars = (read-more)
800 until (or (> (incf total (length chars)) max)
801 (char= #\Newline (first chars)))
802 nconc (remove-if #'(lambda (c)
803 (char= #\Return c))
804 chars))))))
805
806 (defun main-loop ()
807 "Main game REPL."
808 (setf (stream-external-format *standard-input*) '(:LATIN-1 :LF))
809 (setf *quit* nil)
810 (format t "~%Type \"?\" or \"help\" for instructions.~%~%")
811 (describe-room)
812 (loop until *quit*
813 do
814 (format t "~%Command: ")
815 (finish-output)
816 (let ((command (list<-string (custom-read-line))))
817 (format t "~%")
818 (handler-case
819 (apply-command command)
820 (game-error (e)
821 (format t "~A~%" e))
822 (t ()
823 (format t "I don't understand.~%"))))))
824
825
826 #+standalone(unwind-protect
827 (handler-case
828 (symbol-game:main-loop)
829 (t (e)
830 (format t "~A~%" e)))
831 (ext:quit))