;;; Cros by Andrew Kuehn, August 25-29, 2002
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A simple prototype-based, message-passing
;;; object system. Don't take it too seriously,
;;; as it is one of my first attempts...


(defmacro second-value (&rest values)
  `(cadr (multiple-value-list ,@values)))

(defun slot-exists? (slot obj)
  (if (second-value (gethash slot obj))
      t 
    nil)) 

;;; Looks for slot in obj, and then in parents, left to right-
;;; only one value can be returned
(defun get* (slot obj)
  (if (slot-exists? slot obj)
      (gethash slot obj)
    (loop for parent in (gethash :parents obj)
          when (second-value (gethash slot parent))
          return (gethash slot parent))))
 
(defmacro get-slot (obj slot)
  `(get* (quote ,slot) ,obj))

(defmacro set-slot ((obj slot) value)
  `(setf (gethash (quote ,slot) ,obj) (quote ,value)))

(declaim (special self))

(defmacro pass-message (obj message &rest args)
  `(let ((self ,obj))
     (apply (get* (quote ,message) ,obj) (quote ,args))))

(defmacro new-object (name (&rest parents))
  `(prog1 (setq ,name (make-hash-table :test #'equal))
     (setf (gethash :parents ,name) (list ,@parents))))

(defmacro define-method (obj (name &rest args) &body body)
  `(setf (gethash (quote ,name) ,obj) (lambda ,args ,@body)))

;;; Don't use this.
(defmacro define-macro-method (obj (name &rest args) &body body)
  `(define-method ,obj (,name ,args) (eval ,@body)))

;;; defdelim and ddfn are from Paul Graham's book _On Lisp_
(defmacro defdelim (pair params &body body)
  `(ddfn ,(car pair)
         ,(cadr pair)
         #'(lambda ,params ,@body)))

(let ((rpar (get-macro-character #\))))
  (defun ddfn (left right fn)
    (set-macro-character right rpar)
    (set-macro-character left
                         #'(lambda (stream char)
                             (declare (ignore char))
                             (apply fn
                                    (read-delimited-list right stream t)))
                         t)))

;;; Some syntax for message passing and slot-access
(defdelim (#\[ #\]) (obj message &rest args)
  `(pass-message ,obj ,message ,@args))

(defdelim (#\{ #\}) (obj slot)
  `(get-slot ,obj ,slot))

#|

 Examples:

 (new-object dog ())
 (set-slot (dog name) "Charles")

 (define-method dog (woof &key polite)
   (if polite (format t "~&Bowow. My name is ~A.~%" {self name})
     (format t "~&Hooooooowl! Woof Woof!~%")))

 (new-object cow ())
 (set-slot (cow name) "Isabell")
 
 (define-method cow (moo &key polite)
   (if polite (format t "~&Moo. My name is ~A.~%" {self name})
     (format t "~&MOOOOOOoOOOOOOOOooooOOOOOOO!~%")))

 (new-object dogcow (dog cow))
 (set-slot (dogcow name) "Zarf")

 (define-method dogcow (moof &key polite)
   (if polite 
       (progn [self moo :polite t]
         [self woof :polite t])
     (progn [self moo]
       [self woof])))

 -------------------------------------------

 CL-USER > [dogcow moof]
 MOOOOOOoOOOOOOOOooooOOOOOOO!
 Hooooooowl! Woof Woof!
 NIL

 CL-USER > [dogcow moof :polite t]
 Moo. My name is Zarf.
 Bowow. My name is Zarf.
 NIL

|#