(deftype object () 'hash-table)

;;; utility routines for working with objects

(defun objectp (obj)
       (typep obj 'object))

(defun object-declare-slots (object declarations)
       (when declarations
           (setf (object-primitive-lookup object (first declarations))
	         (second declarations))
           (object-declare-slots object (rest (rest declarations)))))

(defun make-object (&rest declarations)
       (let ((object (make-hash-table :test #'equal)))
            (object-declare-slots object declarations)
	    object))

(defun object-clone (object &rest declarations)
       (apply #'make-object "parent" object
                            "meta"   (object-primitive-lookup object "meta")
		            declarations))

(defun mapobject (fun obj &rest params)
       (apply #'maphash fun obj params))

;;; lookup half of protocol

(defun object-primitive-lookup (object selector)
       (multiple-value-bind (value exists) (gethash selector object)
                (if exists
		    value
		    (multiple-value-bind (parent exists) (gethash "parent" object)
		                         (when (and exists (not (eq parent object)))
					     (object-primitive-lookup parent selector))))))

(defun object-set-primitive-lookup (object selector new-value)
       (setf (gethash selector object) new-value))

(defsetf object-primitive-lookup object-set-primitive-lookup)

(defun object-lookup (object selector)
       (if (null (object-primitive-lookup (object-primitive-lookup object "meta") "lookup"))
           (object-primitive-lookup object selector)
	   (object-meta-lookup object selector)))

;;; (object selector') => <lookup> method' ::= ((object meta) (lookup (selector : selector') (in : object)))
;;;                       <apply>  ((object meta) (apply (method : method') (to : object)))
;;; NOTE: for now, slots of the method are primitively assigned...

(defun object-meta-lookup (object selector)
       (let* ((meta (object-primitive-lookup object "meta"))
              (lookup-method (object-clone (object-lookup meta "lookup")
	                                   "selector" selector
                                           "in"       object)))
	     (object-apply meta lookup-method)))
            
;;; apply half of protocol

(defun object-primitive-apply (object method)
       (let ((result (object-lookup method "result")))
            (if result
	          (funcall (object-lookup method "result") object method)
		  method)))
 
(defun object-apply (object method)
       (if (null (object-primitive-lookup (object-primitive-lookup object "meta") "apply"))
           (object-primitive-apply object method)
	   (object-meta-apply object method)))

(defun object-meta-apply (object method)
      (let* ((meta (object-primitive-lookup object "meta"))
             (apply-method (object-clone (object-lookup meta "apply")
	                                 "method" method
					 "to"     object)))
	    (object-apply meta apply-method)))

;;; primitive root objects

(defvar *slate-root*
        (make-object "name" "root"))

(setf (object-primitive-lookup *slate-root* "parent") *slate-root*)

(defvar *slate-top*
        (make-object "name"   "top"
	             "parent" *slate-root*))

(setf (object-primitive-lookup *slate-top* "meta") *slate-top*)
(setf (object-primitive-lookup *slate-root* "meta") *slate-top*)

(defvar *slate-method*
        (object-clone *slate-root*
	              "name"  "method"))

(defun slate-clone-result (object method)
        (object-clone object
	              "name"  (concatenate 'string (object-lookup object "name") "-clone")))

(defvar *slate-clone*
        (object-clone *slate-method*
	              "name"   "clone"
		      "result" #'slate-clone-result))

(setf (object-primitive-lookup *slate-root* "clone") *slate-clone*)

;;; primitive utility objects

(defun slate-print-result (object method)
        (format t "slate-print-result: ~A~%" (object-lookup object "name"))
	object)

(defvar *slate-print*
        (object-clone *slate-method*
	              "name"   "print"
	              "result" #'slate-print-result))

(setf (object-primitive-lookup *slate-root* "print") *slate-print*)

(defun slate-view-result (object method)
       (format t "view: ~A~%" (object-lookup object "name"))
       (mapobject #'(lambda (name value)
                            (format t "      ~A => ~A~%" name (if (objectp value) (object-lookup value "name") value)))
		  object)
       object)
       
(defvar *slate-view*
        (object-clone *slate-method*
	              "name"   "view"
		      "result" #'slate-view-result))

(setf (object-primitive-lookup *slate-root* "view") *slate-view*)

(defvar *slate-world*
        (object-clone *slate-root*
	              "name"   "world"
	              "top"    *slate-top*
		      "root"   *slate-root*
		      "method" *slate-method*
		      "print"  *slate-print*
		      "clone"  *slate-clone*
		      "view"   *slate-view*))

(setf (object-primitive-lookup *slate-world* "world") *slate-world*)
(setf (object-primitive-lookup *slate-world* "workspace") *slate-world*)

(defun slate-/-result (object method)
       (setf (object-primitive-lookup object "..") 
             (object-clone *slate-method*
                           "name"   (concatenate 'string (object-lookup object "name") "-..")
                           "result" (let ((old-world (object-primitive-lookup *slate-world* "workspace")))
			                 #'(lambda (object method)
	                                           (setf (object-primitive-lookup *slate-world* "workspace") old-world)))))
       (setf (object-primitive-lookup *slate-world* "workspace") object)
       object)

(defvar *slate-/*
        (object-clone *slate-method*
                      "name"   "/"
                      "result" #'slate-/-result))

(setf (object-primitive-lookup *slate-root* "/") *slate-/*)
(setf (object-primitive-lookup *slate-world* "/") *slate-/*)
(setf (object-primitive-lookup *slate-world* "..") *slate-world*)

;;; code evaluation

(defun evaluate (namespace code)
       (labels ((evaluate-rest (value code)
                               (if code
			           (evaluate-rest (evaluate value (first code)) (rest code))
				   value))
		(evaluate-first (namespace code)
		                (if (consp (first code))
			            (evaluate-rest (evaluate-first namespace (first code)) (rest code))
				    (object-apply namespace (evaluate-rest (object-lookup namespace (first code)) (rest code))))))
                                   
             (if (consp code)
	         (evaluate-first namespace code)
	         (object-apply namespace (object-lookup namespace code)))))

(defun slate-char-p (c)
       (and (not (or (eq #\( c)
                     (eq #\) c)
		     (eq #\Newline c)
		     (eq #\Space c)))
            (or (alpha-char-p c)
	        (graphic-char-p c)
		(digit-char-p c))))

(defun slate-read-string (string)
       (if (slate-char-p (peek-char))
           (slate-read-string (cons (read-char) string))
	   (map 'string #'identity (nreverse string))))

(defun slate-read-list (list)
       (let ((item (slate-read-item)))
            (if (characterp item)
	        (nreverse list)
		(slate-read-list (cons item list)))))

(defun slate-read-item ()
       (let ((c (peek-char)))
            (cond
	         ((alpha-char-p c)    (slate-read-string nil))
		 ((eq #\( c)          (read-char) (slate-read-list '()))
		 ((eq #\) c)	      (read-char) #\))
		 ((eq #\Newline c)    #\Newline)
		 ((eq #\Space c)      (read-char) (slate-read-item))
		 ((graphic-char-p c)  (slate-read-string nil))
		 ((digit-char-p c)    (slate-read-string nil))
		 (t                   (read-char) (slate-read-item)))))             

(defun slate-read ()
       (let ((result (slate-read-list nil)))
            (if (or (eq result #\Newline) (eq result nil))
	        (progn (read-char)
		       (slate-read))
		result)))
	        

(defun slate ()
       (format t "> ")
       (let ((code (slate-read)))
            (when (not (equal code '("quit")))
	          (format t "~A~%" (object-lookup (evaluate (object-primitive-lookup *slate-world* "workspace") code) "name"))
		  (slate))))