slimey2.cl

(defparameter *database*
  (make-hash-table :test 'equal))

(defparameter *id-index* 0)

(defun new-index ()
  (let ((n *id-index*))
    (incf *id-index*)
    n))

(defun relationships (from relation)
  (gethash (cons from relation) *database*))

(defun relate (from relation to)
  (if (relationships from relation)
      (adjoin to (relationships from relation))
      (setf (gethash (cons from relation) *database*) (list to)))
  nil)

(defun relation (from relation to)
  (not (null (member to (relationships from relation)))))

(defun unrelate (from relation to)
  (if (relation from relation to)
      (remove to (gethash (cons from relation) *database*))))

(defun unrelate-all (from relation)
  (remhash (cons from relation) *database*))

(defun relate-symmetrically (from relation backrelation to)
  (relate from relation to)
  (relate to backrelation from))

(defun relate-exclusively (from relation to)
  (unrelate-all from relation)
  (relate from relation to))

(defun relate-exclusively-symmetrically (from relation backrelation to)
  (unrelate-all from relation)
  (unrelate-all to backrelation)
  (relate-symmetrically from relation backrelation to))

(defun template (name &rest templates)
  (relate name 'parents templates))

(defun set-value (name tag value)
  (relate-exclusively name tag value))

(defun get-values (name relation)
  (let ((values (relationships name relation)))
    (if (not (null values))
	values
	(let ((templates (relationships name 'parents)))
	  (if (null templates)
	      nil
	      (labels ((template-search (template-list)
			 (let ((values
				(get-values (car template-list) relation)))
			   (if (null values)
			       (template-search (cdr template-list))
			       values))))
		(template-search templates)))))))
	      
(defun get-value (name value)
  (let ((values (get-values name value)))
    (if (null values)
	nil
	(car values))))

(defun instantiate-template (name)
  (let ((index (new-index)))
    (template index name)
    (the integer index)))

(defun build-named (template name)
  (let ((instance (instantiate-template template)))
    (set-value instance 'name name)
    instance))

(template 'room)

(set-value 'room 'description `(an unfinished room))

(defun build-room (name)
  (build-named 'room name))

(template 'object)

(set-value 'object 'description `(an unfinished object))

(defun build-object (name place)
  (let ((object (build-named 'object name)))
    (set-value object 'place place)
    object))

(defun description (name description)
  (set-value name 'description description))

(let ((quarry (build-room 'quarry)))
  (description quarry `(a large stone quarry)))

(defun hash-memberp (obj hash-table)
  (not (eq :nonesuch (gethash obj hash-table :nonesuch))))

(defun instancep (num)
  (and (numberp num)
       (hash-memberp num *database*)))

(template 'connection)
(description 'connection `(a simple passage))

(defun build-connection (name from to)
  (let ((connection (build-named 'connection name)))
    (relate connection from to)
    connection))

(defun route (connection from to)
  (relate connection from to))

(defun dig (from via to)
  (if (and (instancep from)
	   (instancep to))
      (let ((connection (build-connection via from to)))
	(relate from 'connection connection))))