Living-Room.script

#|

./main.lisp 
=> the room named |Living Room| is empty go

ROOM => 
|Living Room| => 
EMPTY => 
:COMMITTING 
:DONE => |Living Room|

A ROOM named |Living Room|. 

T => *it*

|Living Room| 

T => the cat named |Sally| is grey go

CAT => 
|Sally| => 
GREY => 
:COMMITTING 
:DONE => *it*

|Sally| 

T => |Sally|

A CAT named |Sally|. 

T => put |Sally| in the room go

OR

put |Sally| in the |Living Room| go

|#

(defpackage :main
  (:use :cl)
  (:shadow :ROOM)
  (:export "MAIN"))
(in-package :main)

(defvar *things* ())
(defvar *rooms* ())
(defvar *keys* ())
(defvar *computers* ())

(defconstant *user-id* 0)

(defclass Thing ()
  (
   (name :accessor name :initarg :name)
   (value :accessor value :initarg :value)

   (who :accessor who :initform *user-id*)
   (what :accessor what :initarg :what)
   (where :accessor where :initarg :where)
   ;(when :accessor when :initform (get-universal-time))
   (why :accessor why :initarg :why)

   #|
   who - created or last modified the object
   what - is the object
   where - ?
   when - what time was the object created at 
   why - was the object created
   |#
   
   (description :accessor description :initarg :description)
   (parameters :accessor parameters :initarg :contents :initform ())

   (on :accessor on :initarg :on :initform () )
   (under :accessor under :initarg :under :initform ())

   (inside :accessor inside :initarg :inside :initform ())

   (ingredients :accessor ingredients :initarg :ingredients :initform ())
   )
  )


(defmethod print-object ((thing Thing) s)
  (print (name thing)) s)
;(defmethod print-object ((thing Thing) s)
;  (format s "A ~S named ~S.~%~%" (what thing) (name thing))
;  (format s "It is ~A." (description thing)))

#|
(defmethod print-object ((object Thing) stream)
(format stream "~S: ~S" (name object) (what object))
(when (description object) 
(format stream "~A~%" (description object)))
(when (on object) (format stream "On: ~S~%" (on object)))
(when (under object) (format stream "Under: ~S~%" (under object)))
(when (inside object)
(format stream "Inside: ~S~%" (ingredients object)))
(when (parameters object) 
(format stream "Parameters: ~S~%" (parameters object)))
(when (ingredients object) 
(format stream "Ingredients: ~S~%" (inside object)))
)
|# 

(defclass Room (Thing)
  ((exits :accessor Room-exits :initarg :exits :initform ()))
  )

;;(defmethod print-object ((object Room) stream)
;;  (format stream "~S~%" (Room-exits object)))

(defmethod put-in ((object Room) (inside Thing))
  (push inside (inside object)))

(defmethod put-on ((surface Thing) (object Thing))
  (push object (on surface)))

(defmethod put-under ((surface Thing) (object Thing))
  (push object (under surface)))

(defmethod make-of ((surface Thing) (object Thing))
  (push object (ingredients surface)))

(defmethod connect ((from Room) (to Room) &key locked)
  (pushnew to (Room-exits from)))

(defun make-room (name description &rest exits)
  (make-instance 'Room :name name :description description :exits exits))

(defun make-thing (name description ingredients)
  (make-instance 'Thing :name name :description description :ingredients ingredients))

(defmacro defroom (name description &rest exits)
  `(progn
     (defvar ,name (make-room ',name ',description ,@exits))
     (push ,name *rooms*)
     ,name)
  )

(defmacro defthing (name description &rest ingredients)
  `(progn
     
     (defvar ,name
       (make-thing ,(symbol-name name) 
		   ',description 
		   ',(let (retvals)
		       (dolist (ingredient ingredients retvals)
			 (push (eval `(defvar ,(intern 
						(format nil "~A/~A"
							name
							(first ingredient)))
					,(second ingredient)))
			       retvals)))))
     (push ,name *things*)
     ,name)
  )

(defmacro defkey (name description)
  `(progn
     (defthing ,name ,description)
     (push ,name *keys*)
     ,name)
  )

(defroom |Living Room| "The Living Room.")
(defroom |Office| "The Office.")
(connect |Living Room| |Office|)
(defroom |Kitchen| "The Kitchen.")
(connect |Living Room| |Kitchen|)
(defroom |Bedroom| "The Bedroom.")
(connect |Living Room| |Bedroom|)
(defroom |Bathroom| "The Bathroom.")
(defroom |Entrance| "The foyer.")
(connect |Living Room| |Entrance|)
(connect |Entrance| |Bathroom|)
(defroom |Hallway| "The hallway.")
(connect |Entrance| |Hallway|)

(defroom |Elevator| "The elevator that goes to my floor in my building.")
(defroom |Main Lobby| "The Main Lobby to my condominium complex.")

(connect |Living Room| |Office|)
(connect |Living Room| |Bedroom|)
(connect |Living Room| |Kitchen|)
(connect |Kitchen| |Entrance|)
(connect |Entrance| |Bathroom|)
(connect |Entrance| |Hallway|)

(defthing |Piano| "A Casio piano with weighted keys."
  (|Keys| "The keys of the piano, both black and white.")
  (|Pedal| "The sustain pedal of the paino.")
  (|Power Cord| "The power cord of the piano.")
  (|Music Stand| "A place to put Learning To Play The Piano books."))

(defthing |The Sphere of Silence| "A handy tool for meetings." 
  (|Sphere| "The marble sphere of the Sphere of Silence.")
  (|Stand| "The triangular wire stand that the Sphere of Silence sits on."))

(defthing |A Statue of Money| "A heavy statue made of 2 pieces of art."
  (|12 Sided Piggy Bank| "A die shaped piggy bank filled with Pennies. $(.01xN). Metallic shiney finish.  May be painted in the future due to old finish being worn.")
  (|Bottom of Red Pyramd| "The bottom layer of a Pyramid structure. Hollow and macde of Wood. Finished in Red tiles with shihing finish."))

(defthing |Change| "A collection of Toonies $2.00 (Dubloonies), Loonies $1.00, Quarters $0.25, Dimes $0.10, and Nickels $0.05.")
(defthing |Pennies| "A collection of Pennies $0.01.")

(defthing |The Mona Lisa X Frame| "Something that will soon contain Mona Lisa X.")
(defthing |The Mona Lisa X (Unfinished)| "Parts of the Mona Lisa X.")

(put-on |Piano| |The Sphere of Silence|)
(put-on |Piano| |The Mona Lisa X Frame|)

(put-in |Living Room| |Piano|)
(put-in |Living Room| |Veriton|)

(defthing |The Void| "Where everything eminates from. Libre Chaos.")
(put-in |Living Room| |The Void|)

(defmethod what-is-on-it? ((object Thing))
  (format t "SURFACE: ~S~%" (name object))
  (dolist (thing (on object))
    (princ thing)
    (fresh-line)))

(defmethod what-is-under-it? ((object Thing))
  (dolist (thing (under object))
    (princ thing)
    (fresh-line)))


(defmethod what-is-in-it? ((object Thing))
  (dolist (thing (inside object))
    (princ thing)
    (fresh-line)))

(defmethod what-is-it-made-of? ((object Thing))
  (dolist (thing (ingredients object))
    (princ thing)
    (fresh-line)))

					;(print |Veriton|)
					;(what-is-on-it? |Piano|)

(defun command-ingredients (args)
  (let ((symbol (second args)))
    (format t "INGREDIENTS: ~S~%" symbol)
    (what-is-it-made-of? (eval symbol))
    (fresh-line)))

(defun command-objects (args)
  (declare (ignore args))
  (format t "OBJECTS~%~%")
  (dolist (thing *things*)
    (format t "~S: ~S~%" 
	    (name thing) 
	    (description thing))))

(defvar *home* |Living Room|)
(defvar *position* *home*)

(defun command-exits (args)
  (when (Room-exits *position*)
    (format t "EXITS~%~%~{~A~^, ~}" (Room-exits *position*))))

(defun command-look (args)
  (let ((location (or (second args) *position*)))
    (format t "LOOK~%~%~A~%~%" (description location))
    (dolist (thing (inside location))
      (print thing))))

(defun command-go (args)
  (setf *position* (eval (or (second args) *home*)))
  (print *position*))

(defun mud ()
  (catch :quit
    (fresh-line)
    (loop
     (let* ((line (progn (format t "|~A| $ " (name *position*))
			 (read-line)))
	    (expr (read-from-string
		   (concatenate :string "(" line ")"))))
       (case (and (listp expr) (first expr))
	     (go (command-go expr))
	     (ingredients (command-ingredients expr))
	     (objects (command-objects expr))
	     (exits (command-exits expr))
	     (things (command-things expr))
	     (look (command-look expr))
	     (quit (throw :quit nil))
	     (t (print (evaluate-symbol expr))))))))

(defvar *registers* (make-hash-table))

(defvar *it* |The Void|)
(defvar *what* nil)
(defvar *name* nil)

(defun read-a/an (word)
  ;; a/an *what*
  (setf *what* word))

(defun read-a (word)
  (read-a/an word))
(defun read-an (word)
  (read-a/an word))

(defun read-the ()
  (let* ((what (safe-read))
	 (thing (evaluate-symbol what)))
    (setf *what* thing
	  (gethash thing *registers*) thing)))

(defun read-in ()
  (let ((what (read-the))
	(in? (safe-read)))
    (unless (eq in? :in)
      (error "Expecting in."))
    (let ((where (read-the)))
      (push (inside (eval where)) (eval what)))))

(defun read-put ()
  (let ((what (read-the (safe-read)))
	(adjective? (safe-read)))
    (case adjective?
	  (in (push (inside where) what))
	  (on (push (surface where) what))
	  (t 
	   (error "Expecting adjective (in or on).")))))

(defun read-named ()
  (push (setf *name* (safe-read)) *names*))

(defun read-look ()
  (ignore-errors
    (let ((word (safe-read)))
      (setf *it* (evaluate-symbol word)
	    it *it)
      (format t "You see: ") 
      (case it
	    ((in inside)
	     (let ((thing (read-statement)))
	       (inside thing)))
	    ((on over)
	     (let ((thing (read-statement)))
	       (on thing)))
	    (under
	     (let ((thing (read-statement)))
	       (under thing)))
	    (at
	     (let ((thing (read-statement)))
	       (description thing)))
	    (go (description *positition*))))))

(defun safe-read (&optional prompt)
  (let (*read-eval*)
    (when prompt
      (princ prompt))
    (read)))

(defun evaluate-symbol (s registers)
  (setf *it* (multiple-value-bind (v found) (gethash s registers)
				  (if found
				      v
				    (make-instance :Thing
						   :name s)))))


(defvar *names*)
(defvar *whats*)

(defun commit ()
  (let* ((*name* (pop *names*))
	 (*what* (pop *whats*))
	 thing (make-instance :Thing
			      :name *name*
			      :what *what*)))
  
  (format t "Setting ~S to ~S.~%" *name* thing)
  
  (when *name*
    (set *name* thing))
  
  
  (setf (gethash *what* *registers*) thing
	*it* thing
	it *it*)))

(defvar me (make-instance :Thing 
			  :name :|Burton| 
			  :what :person 
			  :description "The Owner."))

(defun read-statement (&optional prompt)
  (let ((word (safe-read prompt))
	name what it (registers (make-hash-table)))
    (case word
	  ((go done end) (commit))
	  (is (push *name* *names*)
	      (push *what* *whats*)
	      (commit)
	      (read-statement))
	  (a (read-a (safe-read)))
	  (an (read-an (safe-read)))
	  (put (read-put))
	  (the (let ((thing (safe-read)))
		 (setf (gethash thing registers)
		       (evaluate-symbol thing registers))))
	  (look (format t "~A" (read-look)))
	  (named (read-named))
	  (t (format t "~A" (eval word))))))

(loop
 (print (read-statement "=> ")))