1 (setq *echo* NIL)      ;; echo the SEND messages
  2 (setq *echoall* NIL)   ;; echo all of the message passing including internals
  3 
  4 ;; add the classic putprop function using setf
  5 ;; putprop is the old name used by many lisps but
  6 ;; no longer available in common lisp.
  7 (defun putprop (sym value name) (setf (get sym name) value))
  8 (defun nl () (princ "
  9 ") T)
 10 
 11 
 12 ;;;; ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;
 13 ;;;;
 14 ;;;;  This file implements a subset of MMOO (The Moscow MOO)
 15 ;;;;
 16 ;;;;
 17 ;;;;
 18 ;;;;
 19 ;;;; ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;  ;;;;
 20 
 21 ;;; Each object is a symbol at the global level.  Properties for the
 22 ;;; symbol store both data and methods.  Messaging is done with a
 23 ;;; collection of send functions.  This will provide us with powerful
 24 ;;; data abstraction, but we don't get to control the access to the
 25 ;;; data this implementation.
 26 ;;;
 27 ;;; There is no distinction between class and instance in this
 28 ;;; implementation.  Any object can be subclassed (specialized).
 29 ;;; "Class objects" can be invoked as objects because they are
 30 ;;; objects.  This is kind of an unusual approach but it simplifies
 31 ;;; our life.
 32 ;;;
 33 ;;; Ultimately we will have these relations: isa, containment, and
 34 ;;; direction are implemented and every object has a set of methods
 35 ;;; stored in the the property verbs
 36 ;;;
 37 ;;; We test if a symbol is an object by testing if it has a non-nil
 38 ;;;   object property.
 39 ;;;
 40 ;;; THE PROPERTIES ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 
 41 ;;;
 42 ;;; NAME a printable name for the object
 43 ;;;     name - a STRING that is a few word description of the object
 44 ;;;
 45 ;;; ISA properties with EVERY OBJECT
 46 ;;;     children - a LIST of direct decendants to an object
 47 ;;;     parent - a SYMBOL that is the parent (NIL if the primordial object)
 48 ;;;
 49 ;;; METHODS on EVERY OBJECT are stored in the property:
 50 ;;;     verbs - an ALIST of verb name as a symbol and the code that implements
 51 ;;;              the action
 52 ;;;
 53 ;;; CONTAINMENT (ownership) properties with EVERY OBJECT
 54 ;;;    contains - a LIST of all of the things contained in this object
 55 ;;;    location - a SYMBOL of the object that contains this object (NIL
 56 ;;;                 if not contained)
 57 ;;;
 58 ;;; DIRECTION (links between objects) properties with EVERY PLACE OBJECT
 59 ;;;    direction - an ALIST whose key is the direction to go and whose
 60 ;;;                  data portion (second) is a list of description
 61 ;;;                  of what is in that direction and the object that
 62 ;;;                  is linked to in that direction.  For example:
 63 ;;;
 64 ;;;                     ((N (" on a path north" NPATH))
 65 ;;;                      (E (" to a fountain" SPATH))
 66 ;;;                      (S (" on a path south" SPATH))
 67 ;;;                      (W (" into a cabin" CABIN))
 68 ;;;                      (IN ("in the door of a rustic cabin" CABIN))
 69 ;;;                     )
 70 ;;;
 71 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
 72 
 73 ;; property accessors
 74 (defun objectp (sym) (get sym 'object))
 75 (defun myname (sym) (get sym 'name))
 76 (defun myparent (sym) (get sym 'parent))
 77 (defun mychildren (sym) (get sym 'children))
 78 (defun myverbs (sym) (mapcar 'first (get sym 'verbs)))
 79 (defun mydirs (sym) (get sym 'dirs))
 80 (defun mylocation (sym) (get sym 'location))
 81 (defun mycontains (sym) (get sym 'contains))
 82 
 83 
 84 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
 85 ;;;
 86 ;;; list utilities
 87 ;;;
 88 
 89 ;; print out a comma separate version of the list
 90 (defun princ-list (list)
 91   (cond ((atom list) (princ list))
 92         ((= 2 (length list)) (princ (car list))
 93          (princ " and ")
 94          (princ (car (cdr list)))
 95          )
 96         ((= 1 (length list)) (princ (car list)))
 97         ( T (princ (car list)) (princ ", ") (princ-list (cdr list)))
 98         )
 99   T
100   )
101 
102 
103 
104 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
105 ;;;
106 ;;; lisp expression utilities
107 ;;;
108 
109 ;; this will create a copy of a structure
110 (defun copy (l)
111   (cond ((atom l) l)
112         (T (mapcar 'copy l))
113         )
114   )
115 
116 
117 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
118 ;;;
119 ;;; alist utilities
120 ;;;
121 (princ "Alists tools")(nl)
122 
123 ;; replace the value of sym in the alist with value.  If sym not there then
124 ;; add it.
125 (defun subst-alist (sym value alist)
126   (cond ((null alist) (list (list sym value)))
127         ((eq (car (car alist)) sym) (cons (list sym value) (cdr alist)))
128         (T (cons (car alist) (subst-alist sym value (cdr alist))))
129         )
130   )
131 
132 ;; remove the sym from the alist
133 (defun rem-alist (sym alist)
134   (mapcan #'(lambda (x) (if (eq sym (car x)) NIL (list x))) alist)
135   )
136 
137 ;; get keys from an alist (a trivial function)
138 (defun get-keys-alist (alist)
139   (mapcar 'car alist)
140   )
141 
142 
143 ;; merge two a lists so the primary alist is augmented by any elements of secondary 
144 ;; which have indicators not found in the primary
145 (defun merge-alists (primary secondary)
146     (cond ((null secondary) primary)
147           ((assoc (first (first secondary)) primary) (merge-alists primary (rest secondary)))
148           (T (cons (first secondary) (merge-alists primary (rest secondary))))
149     ))
150 
151 
152 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
153 ;;;
154 ;;; property list tools
155 ;;;
156 ;;; directly manipulate lists that are associated with a property
157 ;;;
158 (princ "Property list tools")(nl)
159 
160 
161 ;; put the value onto the list associated with the symbol's property prop
162 (defun push-onto-prop (sym value prop)
163   (putprop sym (cons value (get sym prop)) prop)
164   )
165 
166 ;; remove the value from the list associated with the symbol's property prop
167 (defun rem-from-prop (sym value prop)
168   (putprop sym
169            (mapcan #'(lambda (x) (if (eq x value) NIL (list x)))
170                    (get sym prop)
171                    )
172            prop
173            )
174   )
175 
176 ;; get the list of properties of a symbol
177 (defun get-prop-syms-aux (proplist)
178   (cond ((null proplist) NIL)
179         (T (cons (car proplist) (get-prop-syms-aux (cdr (cdr proplist)))))
180         )
181   )
182 (defun get-prop-syms (sym) (get-prop-syms-aux (symbol-plist sym)))
183 
184 
185 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
186 ;;;
187 ;;; parenting (inheritance)
188 ;;;
189 ;;; atomic parenting ops
190 ;;;
191 (princ "Parenting (inheritance)")(nl)
192 
193 
194 ;; make parent-sym the parent of sym
195 (defun parent (sym parent-sym)
196   (push-onto-prop parent-sym sym 'children)
197   (putprop sym parent-sym 'parent)
198   )
199 
200 ;; undo the parent sym relationship
201 (defun unparent (sym)
202   (cond ((myparent sym)
203          (rem-from-prop (myparent sym) sym 'children)
204          (putprop sym NIL 'parent)
205          )
206         )
207   )
208 
209 ;; reparent an object
210 (defun reparent (sym newparent)
211   (unparent sym)
212   (parent sym newparent)
213   )
214 
215 
216 ;; ask if an object is of a given type
217 (defun isap (sym type)
218   (cond ((eq sym type))
219         ((myparent sym) (isap (myparent sym) type))
220         )
221   )
222 
223 
224 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
225 ;;;
226 ;;; send (message passing)
227 ;;;
228 ;;; If the method doesn't exist the send returns NIL but is otherwise
229 ;;;  quiet about it since this may be a ligit desire.
230 ;;;
231 ;;; Sending a message to a symbol that is not an object will report
232 ;;; an error and return NIL.
233 ;;;
234 ;;; Send-to is the workhorse of send.  It needs to keep track of not
235 ;;;  only the object to which the message is being sent but also the
236 ;;;  original object to which the message was sent called the
237 ;;;  truetype.  This is because a superclass of the truetype may 
238 ;;;  implement the called method and that may, in turn, invoke another
239 ;;;  method that is actually supported in the truetype.
240 ;;;
241 ;;; Send-super is like send-to in that it takes a truetype as well
242 ;;;  as the called type
243 ;;;
244 (princ "The send utilities")(nl)
245 
246 ;; SYM <- VERB,TYPE
247 (defun send-to (sym truetype verb &optional args)
248   (if *echoall* (print (list "SEND-TO:" sym truetype verb args)))
249   (cond ((not (objectp sym))
250          (princ "attempt to send ")
251          (princ verb)
252          (princ " to ")
253          (princ sym)
254          (princ " which is not an object.")(nl)
255          NIL
256          )
257         ((get-verb-func sym verb)
258          (cond (args (funcall (get-verb-func sym verb) truetype args))
259                (T           (funcall (get-verb-func sym verb) truetype))
260          ))
261         ((myparent sym)
262          (send-to (myparent sym) truetype verb args) ;; same as send-super
263          )
264         )
265   )
266 
267 
268 ;; SYM <- VERB
269 ;; note that both the object that receives the message and the
270 ;; truetype START OUT the same in the send-to call.
271 (defun send  (sym verb &optional args)
272   (if (or *echo* *echoall*) (print (list 'SEND sym verb args)))
273   (send-to sym sym verb args)
274   )
275 
276 
277 ;; PARENT(SYM) <- VERB
278 (defun send-super (sym truetype verb &optional args)
279   (if *echoall* (print (list 'SEND-SUPER sym truetype verb args)))
280   (cond ((myparent sym) (send-to (myparent sym) truetype verb args)))
281   )
282 
283 
284 ;; (LIST) <- VERB
285 ;; sends the same message and arg to each object in list
286 ;; Note that the return value is the value of list.
287 (defun send-list (list verb &optional args)
288   (mapc #'(lambda (x) (send x verb args)) list)
289   )
290 
291 
292 ;; returns the object that will support the given verb for
293 ;; the truetype object sym
294 (defun who-supports-verb (sym verb)
295   (cond ((get-verb-func sym verb) sym)
296         ((myparent sym)
297          (who-supports-verb (myparent sym) verb)
298          )
299         )
300 )
301 
302 ;; create an alist of all verbs supported and by who
303 (defun all-myverbs (sym) 
304         (merge-alists
305             (mapcar #'(lambda (x) (list (first x) sym)) (get sym 'verbs))
306             (if (myparent sym) (all-myverbs (myparent sym)) NIL)
307         )
308 )
309 
310 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
311 ;;;
312 ;;; MOO object creation and destruction
313 ;;;
314 ;;; objects have an isa hierarchy.
315 ;;;
316 ;;;  NOTE: and object named sym is created a (setq sym sym) is done
317 ;;;  which means that all future references to sym can be done unquoted.
318 ;;;  This means the first time you mention an object it must be quoted
319 ;;;  but need not be thereafter.
320 ;;;
321 ;;;  Also note that the function value of the symbol for the object
322 ;;;  is assigned a function that sends a message to the object.  This
323 ;;;  means that (send obj verb) can be done by saying (obj verb)
324 ;;;
325 (princ "MOO object creation and destruction")(nl)
326 
327 
328 ;; add an object to the world
329 (defun addo (sym name parent)
330   (mapc #'(lambda (x) (putprop sym NIL x)) ;; clone all the data names
331         (get-prop-syms parent)
332         )
333   (putprop sym T 'object)  ;; mark as an object
334   (putprop sym name 'name) ;; overwrite printable name
335   (parent sym parent) ;; parent the object
336   (set sym sym) ;; for convenience sym <- sym
337   (setf (symbol-function sym) #'(lambda (verb  &optional args)
338                                   (send sym verb args)))
339   )
340 
341 
342 ;; remove the object from the hierarchy
343 ;; NOTE: we remove all properties to reset the symbol destroying the object
344 (defun remo (sym)
345   (mapc #'(lambda (x) (reparent x (myparent sym)) x)
346         (mychildren sym)
347         )
348   (unparent sym)
349   (mapc #'(lambda (x) (remprop sym x)) (get-prop-syms sym))
350   (remprop sym 'object)   ;; remove the object marker
351   )
352 
353 
354 ;; insert the object into the hierarchy by placing the new object
355 ;; between the parentsym and its children
356 (defun inserto (parentsym new-object name)
357   (mapc #'(lambda (x) (if (not (eq x new-object)) (reparent x new-object)))
358         (mychildren parentsym)
359         )
360   (reparent new-object parentsym)
361   )
362 
363 
364 
365 ;; report the entire hierarchy below obj
366 (defun descendants (obj)
367    (if (mychildren obj) 
368        (cons obj (mapcar 'descendants (mychildren obj))) 
369         obj
370    )
371 )
372 
373 
374 ;; report where the object is in the hierarcy
375 (defun ancestors (obj)
376    (if (myparent obj) 
377        (cons obj (ancestors (myparent obj))) 
378        (list obj)
379    )
380 )
381 
382 
383 
384 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
385 ;;;
386 ;;; MOO verbs (methods)
387 ;;;
388 ;;;  The first time you mention a method name it must be quoted
389 ;;;  but you need not be thereafter.
390 ;;;
391 (princ "MOO verbs")(nl)
392 
393 
394 ;; utility get the code for method verb-name on a given function
395 ;; does not do inheritance (that is handled by the send commands).
396 ;; This can be used to see if a method is defined.
397 (defun get-verb-func (sym verb-name)
398   (second (assoc verb-name (get sym 'verbs)))
399   )
400 
401 
402 ;; add a method onto object sym
403 (defun addv (sym verb-name code)
404   (putprop sym
405            (subst-alist verb-name code (get sym 'verbs))
406            'verbs
407            )
408   (set verb-name verb-name)
409   )
410 
411 
412 ;; remove a verb
413 (defun remv (sym verb-name)
414   (putprop sym
415            (rem-alist verb-name (get sym 'verbs))
416            'verbs
417            )
418   verb-name
419   )
420 
421 
422 
423 
424 
425 
426 
427 ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
428 ;;
429 ;; directions
430 ;;
431 ;; how this is stored on the dir property:
432 ;; ((N (" on a path north" NPATH))
433 ;;  (E (" to a fountain" SPATH))
434 ;;  (S (" on a path south" SPATH))
435 ;;  (W (" into a cabin" CABIN))
436 ;;  (IN ("in the door of a rustic cabin" CABIN))
437 ;; )
438 ;;
439 (princ "Directions")(nl)
440 
441 ;; maintain a list of opposite directions for double linking space
442 (defun opposite-dir (dir)
443   (or (second (assoc dir '((n s)
444                            (s n)
445                            (e w)
446                            (w e)
447                            (up down)
448                            (down up)
449                            (in out)
450                            (out in)
451                            (under over)
452                            (over under)
453                            )
454                      ))
455       dir
456       )
457   )
458 
459 
460 ;; add a direction to an object sym.  The name of the direction is dirname
461 ;; the description of that direction is detail and going in that direction
462 ;; takes you to nextsym
463 (defun adddir (sym dirname detail nextsym)
464   (putprop sym
465            (subst-alist dirname (list detail nextsym) (get sym 'dirs))
466            'dirs
467            )
468   (set dirname dirname)
469   )
470 
471 
472 ;; get the directions available from an object sym
473 (defun getdirsym (sym dirname)
474   (if (assoc dirname (get sym 'dirs))
475       (second (second (assoc dirname (get sym 'dirs))))
476     )
477   )
478 
479 
480 
481 ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
482 ;;
483 ;; containment
484 ;;
485 ;; In this world location is maintained by containment
486 ;;
487 (princ "Containment")(nl)
488 
489 
490 ;; quietly ask if sym is at contained by loc
491 (defun isinp (sym loc)
492   (and (objectp sym)
493        (member sym (mycontains loc))
494        )
495   )
496 
497 
498 
499 ;; place object sym in location newloc
500 (defun place-in (newloc sym)
501   (cond ((isinp sym newloc)
502          (princ (myname sym))
503          (princ " is already in ")
504          (princ (myname newloc))
505          (princ ".")(nl)
506          NIL
507          )
508         (T
509          (push-onto-prop newloc sym 'contains)
510          (putprop sym newloc 'location)
511          )
512         )
513   )
514 
515 ;; drop an object
516 (defun unplace (sym)
517   (cond ((mylocation sym)
518          (rem-from-prop (mylocation sym) sym 'contains)
519          (putprop sym NIL 'location)
520          T
521          )
522         (T  (princ (myname sym))
523             (princ " has no location and so can't be moved.")(nl)
524             NIL
525             )
526         )
527   )
528 
529 ;; move object sym to a new location
530 (defun move (sym newloc)
531   (and (objectp sym) 
532        (objectp newloc)
533        (unplace sym)
534        (place-in newloc sym)
535        )
536   )
537 
538 
539 
540 
541 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
542 ;;;
543 ;;; object tree utilities
544 ;;;
545 
546 ;; list all the objects starting at obj and going down the tree
547 (defun listobj (obj) (cond ((mychildren obj) 
548                             (append (list obj) 
549                                     (mapcan 'listobj (mychildren obj))))
550                            (T (list obj))))
551 
552 ;; this is like mapc for the object hierarchy
553 ;; this also demonstrates the creation of a closure which defines one
554 ;; of two arguments to mapobj so it can be called with mapc
555 (defun mapobj (f obj) 
556   (funcall f obj)
557   (if (mychildren obj) 
558       (mapc #'(lambda (x) (mapobj f x)) (mychildren obj))
559     )
560   T
561 )
562 
563 ;;  these examples print the list of objects and their parents
564 ;;  and the objects and their verbs
565 ;; (mapobj #'(lambda (x) (print (list x (myparent x)))) thing)
566 ;; (mapobj #'(lambda (x) (print (if (myverbs x) 
567 ;;                                 (list x (myverbs x))
568 ;;                               (list x))))
569 ;;        thing)
570 
571 
572 ;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
573 ;;;
574 ;;; Define world
575 ;;;
576 (princ "Define world: the objects")(nl)
577 
578 
579 ;; THING  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
580 (princ "THING")(nl)
581 ;; data
582 (putprop 'thing T 'object)       ;; mark as object
583 (putprop 'thing "a thing" 'name) ;; my printable name
584 (putprop 'thing NIL 'parent)     ;; my parent
585 (putprop 'thing NIL 'children)   ;; my children
586 (putprop 'thing NIL 'contains)   ;; who I contain
587 (putprop 'thing NIL 'location)   ;; who contains me
588 (putprop 'thing NIL 'verbs)      ;; actions on me
589 (setq thing 'thing)              ;; all objects point to themselves
590 
591 
592 
593 ;; utilities
594 (defun listout (l)
595   (mapc #'(lambda (x)
596             (princ "There is ")
597             (princ (myname x))
598             (princ " (")
599             (princ x)
600             (princ ") ")
601             (princ " here.")(nl)
602             )
603         l
604         )
605   T
606   )
607 
608 (defun listdir (l)
609   (if l (princ "From here you can: ")(nl))
610   (mapc #'(lambda (x)
611             (princ "go ")
612             (princ (first x))
613             (princ " ")
614             (princ (first (second x)))
615             (princ ".")(nl)
616             )
617         l
618         )
619   T
620   )
621 
622 ;; methods
623 (addv thing 'hi
624       #'(lambda (self) (princ (myname self)) (princ " says hi")(nl) T)
625       )
626 
627 
628 (addv thing 'look
629       #'(lambda (self) (nl)(princ "You see ")
630           (princ (myname self))
631           (princ ".")(nl)
632           (listout (mycontains self))
633           T
634           )
635       )
636 
637 
638 
639 ;; ANIMAT ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
640 (princ "ANIMAT")(nl)
641 (addo 'animat "animated thing" thing)
642 
643 ;; methods
644 (addv animat 'go
645       #'(lambda (self arg)
646           (cond ((getdirsym (mylocation self) arg)
647                  (move self (getdirsym (mylocation self) arg))
648                  (send self look)
649                  )
650                 (T (princ "You can't go that way.")(nl)
651                    (listdir (mydirs (mylocation self)))
652                    )
653                 )
654 
655           )
656       )
657 
658 
659 (addv animat 'take
660       #'(lambda (self arg)
661           (cond ((isinp arg (mylocation self))
662                  (send arg 'taken)
663                  (move arg self)
664                  T
665                  )
666                 ( T (princ "I do not see ")
667                     (princ (myname arg))
668                     (princ " here.")(nl)
669                     NIL
670                     )
671                 )
672           )
673       )
674 
675 
676 (addv animat 'drop
677       #'(lambda (self arg)
678           (cond ((isinp arg self) (move arg (mylocation self))
679                  (send arg 'dropped self)
680                  T
681                  )
682                 ( T (princ "I see no ")
683                     (princ (myname arg))
684                     (princ " here.")(nl)
685                     NIL)
686                 )
687           )
688       )
689 
690 
691 
692 (addv animat 'dropin
693       #'(lambda (self item place)
694           (print (list self item place))
695           (cond ((isinp item self) (move item (mylocation self))
696                  (send item 'dropped self)
697                  T
698                  )
699                 ( T (princ "I see no ")
700                     (princ (myname item))
701                     (princ " here.")(nl)
702                     NIL)
703                 )
704           )
705       )
706 
707 
708 
709 
710 (addv animat 'list-have
711       #'(lambda (self)
712           (cond ((mycontains self)
713                  (mapc #'(lambda (x)
714                            (princ "You have ")
715                            (princ (myname x))
716                            (princ " (")
717                            (princ x)
718                            (princ ") ")(nl)
719                            )
720                        (mycontains self)
721                        )
722                  T
723                  )
724                 )
725           )
726       )
727 
728 
729 (addv animat look
730       #'(lambda (self) (send (mylocation self) 'look)
731           (send self list-have)
732           )
733       )
734 
735 
736 
737 
738 ;; PLACE ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
739 (princ "PLACE")(nl)
740 (addo 'place "place" thing)
741 ;; data
742 (putprop place NIL 'dirs) ;; alist of neighbors by direction
743 ;; methods
744 (addv place look
745       #'(lambda (self) (send-super 'place self 'look) (listdir (mydirs self)))
746       )
747 
748 
749 
750 
751 ;; CABIN ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
752 (princ "CABIN")(nl)
753 (addo 'cabin "the inside of a rustic cabin" place)
754 
755 (adddir cabin 'out "out the door" 'cabinext)
756 
757 
758 ;; CABINEXT  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
759 (princ "CABINEXT")(nl)
760 (addo 'cabinext "the outside of a rustic cabin in the woods" place)
761 
762 (adddir cabinext 'in "into the cabin" 'cabin)
763 (adddir cabinext 'n " on a path north" 'npath)
764 (adddir cabinext 'e " to a fountain" 'fountain)
765 (adddir cabinext 's " on a path south" 'spath)
766 (adddir cabinext 'w " to a twisty path" 'twisty)
767 
768 ;; NPATH  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
769 (princ "NPATH")(nl)
770 (addo 'npath "the frozen north" place)
771 (adddir npath 's " to a rustic cabin" cabinext)
772 
773 
774 
775 ;; SPATH  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
776 (princ "SPATH")(nl)
777 (addo 'spath "the desert south" place)
778 (adddir spath 'n " to a rustic cabin" cabinext)
779 
780 
781 
782 ;; FOUNTAIN  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
783 (princ "EPATH")(nl)
784 (addo 'fountain "an ornate stone fountain" place)
785 (adddir fountain 'w " to a rustic cabin" 'cabinext)
786 
787 ;; TWISTY  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
788 (princ "WPATH")(nl)
789 (addo 'twisty "a twisty path" place)
790 (adddir twisty 's " to a rustic cabin" 'cabinext) ;; not opposite dir
791 (adddir twisty 'n "a twisty path" twisty)
792 (adddir twisty 'e "a twisty path" twisty)
793 (adddir twisty 'w "a twisty path" twisty)
794 
795 
796 ;; MARBLE  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
797 (princ "MARBLE")(nl)
798 (addo 'marble "a shiny marble"  thing)
799 
800 (place-in cabin marble)
801 
802 
803 
804 ;; BALL  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
805 (princ "BALL")(nl)
806 (addo 'ball "a ball"  thing)
807 (defun mycolor (sym) (get sym 'color))
808 
809 (addv ball 'setcolor #'(lambda (self arg) (putprop self arg 'color)
810   (putprop self (concatenate 'string "a " (symbol-name arg) " ball") 'name)))
811 (addv ball 'bounce  #'(lambda (self) (princ "BOING Boing boing")(nl) T))
812 (addv ball 'dropped  #'(lambda (self arg) (send ball bounce)))
813 
814 
815 
816 ;; BALL  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
817 (princ "COLORFUL BALL")(nl)
818 (addo 'cball "a colorful ball" ball)
819 
820 (send cball setcolor 'red)
821 (place-in cabinext cball)
822 
823 
824 
825 ;; I  ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
826 (princ "I")(nl)
827 (addo 'I "me" animat)
828 (place-in cabin I)
829 
830 ;; methods
831 (addv I 'take
832       #'(lambda (self arg)
833           (cond ((send-super I self take arg)
834                  (princ "You take ")
835                  (princ (myname arg))
836                  (princ ".")(nl)
837                  T
838                  )
839                 )
840           )
841       )
842