(defpackage "PMD"
  (:use "COMMON-LISP")
  (:export 
    "WITH-MAP"
    "DEFINE-MAP"
    "CLONE-MAP"
    "WITH-OBJECT"
    "DEFINE-OBJECT"
    "CLONE-OBJECT"
    "ADD-SLOT"
    "GET-SLOT"
    "SET-SLOT"
    "ADD-ROLE"
    "DISPATCH-METHOD"
    "DEFINE-METHOD"))

(in-package "PMD")

(defstruct pmd-slot
  (name nil :type symbol)
  (type :data :type keyword)
  (index 0 :type fixnum)
  (roles '() :type list))
    
(defstruct pmd-map
  (slots (make-hash-table) :type hash-table))

(defstruct pmd-object
  (map nil :type pmd-map)
  (slots #() :type simple-vector))

(defstruct pmd-role
  (positions 0 :type fixnum)
  (method nil :type pmd-method))

(defstruct pmd-method
  (arguments 0 :type fixnum)
  (function nil :type function))

(defmacro with-map ((name &rest slots) &body body)
  `(let ((,name (make-pmd-map)))
     (prog ()
       ,@(loop for (slot-name slot-type) in slots
               and slot-index from 0
           collect 
             `(setf (gethash ',slot-name (pmd-map-slots ,name))
                (make-pmd-slot 
                  :name ',slot-name 
                  :type ,slot-type
                  :index ,slot-index))))
     ,@body))

(defmacro define-map (name &rest slots)
  `(defvar ,name
     (with-map (,name ,@slots)
       ,name)))

(defun clone-map (map)
  (let ((new-map (make-pmd-map)))
    (maphash 
      (lambda (slot-name slot)
        (setf (gethash slot-name (pmd-map-slots new-map)) slot))
      (pmd-map-slots map))
    new-map))

(defmacro with-object ((name &rest slots) &body body)
  (let ((map (gensym)))
    `(with-map (,map ,@slots)
       (let ((,name (make-pmd-object 
                      :map ,map 
                      :slots 
                        (make-array (hash-table-size (pmd-map-slots ,map))))))
         (prog ()
           ,@(loop for (slot-name slot-type slot-value) in slots
                   and slot-index from 0
               collect
                 `(setf (svref (pmd-object-slots ,name) ,slot-index) 
                    ,slot-value)))
         ,@body))))

(defmacro define-object (name &rest slots)
  `(defvar ,name
     (with-object (,name ,@slots)
       ,name)))

(defun clone-object (object)
  (make-pmd-object 
    :map (pmd-object-map object)
    :slots (copy-seq (pmd-object-slots object))))

(defun add-slot (object name type value)
  (let ((map (clone-map (pmd-object-map object))))
    (setf (gethash name (pmd-map-slots map))
      (make-pmd-slot
        :name name
        :type type
        :index (length (pmd-object-slots object))))
    (setf (pmd-object-map object) map)
    (setf (pmd-object-slots object)
      (concatenate 'simple-vector
        (pmd-object-slots object)
        (list value))))
  object)

(defun add-role (object name method position)
  (let* ((map (clone-map (pmd-object-map object)))
         (slot (or (gethash name (pmd-map-slots map))
                   (setf (gethash name (pmd-map-slots map))
                     (make-pmd-slot
                       :name name
                       :type :method)))))
    (setf (pmd-object-map object) map)
    (dolist (role (pmd-slot-roles slot))
      (when (eq (pmd-role-method role) method)
        (setf (pmd-role-positions role)
          (logior (pmd-role-positions role) positione))
        (return-from add-method object)))
    (push 
      (make-pmd-role :positions position :method method)
      (pmd-slot-roles slot))
    object))
      
(defun get-slot (object slot-name)
  (multiple-value-bind
    (slot exists)
    (gethash slot-name (pmd-map-slots (pmd-object-map object)))
    (when exists
      (setf exists (find (pmd-slot-type slot) '(:data :delegate))))
    (values
      (when exists
        (svref (pmd-object-slots object) (pmd-slot-index slot)))
      exists)))

(defun set-slot (object slot-name slot-value)
  (setf (svref (pmd-object-slots object)
          (pmd-slot-index (gethash slot-name (pmd-map-slots (pmd-object-map object)))))
    slot-value))

(defsetf get-slot set-slot)

(defun dispatch-method (name &rest arguments)
  (let ((methods (make-hash-table))
        (objects (copy-seq arguments))
        (delegations (make-array (length arguments) :initial-element '()))) 
    (do ()
        ((null (find-if (lambda (object) (not (null object))) objects)))
      (loop for object in objects
           and index from 0 
        when object
          do
            (multiple-value-bind 
              (slot exists)
              (gethash name (pmd-map-slots (pmd-object-map object)))
              (when (and exists (eq (pmd-slot-type slot) :method))
                (dolist (role (pmd-slot-roles slot))
                  (when (logbitp index (pmd-role-positions role))
                    (multiple-value-bind
                      (positions exists)
                      (gethash (pmd-role-method role) methods)
                      (when (= (setf (gethash (pmd-role-method role) methods)
                                 (logior (or positions 0) (ash 1 index)))
                               (pmd-method-arguments (pmd-role-method role)))
                        (return-from dispatch-method
                          (apply 
                            (pmd-method-function (pmd-role-method role))
                            arguments)))))))))
      (loop for object in objects
            and position on objects
            and index from 0
            and delegates = nil
        do
          (maphash
            (lambda (slot-name slot)
              (when (eq (pmd-slot-type slot) :delegate)
                (if delegates
                  (push 
                    (svref (pmd-object-slots object) (pmd-slot-index slot))
                    (svref delegations index))
                  (setf delegates 
                     (svref (pmd-object-slots object) (pmd-slot-index slot))))))
            (pmd-map-slots (pmd-object-map object)))
          (unless delegates
            (setf delegates (pop (svref delegations index))))
          (setf (first position) delegates)))
    (error "Failed to dispatch method ~A" name)))

(defmacro define-method (name arguments &body body)
  (let ((method (gensym)))
    `(let ((,method (make-pmd-method 
                      :arguments
                        ,(loop for argument in arguments
                               and index from 0
                           when (consp argument)
                             sum (ash 1 index))
                      :function 
                        (lambda 
                          ,(loop for argument in arguments
                             if (consp argument)
                               collect (first argument)
                             else
                               collect argument)
                          ,@body))))
       ,@(loop for argument in arguments
               and index from 0
           when (consp argument)
             collect `(add-role ,(second argument) ',name ,method ,(ash 1 index)))
       (defun ,name (&rest arguments)
         (apply #'dispatch-method ',name arguments)) 
       ',name)))

(define-map *test-map* (test :data))
(define-object *test-object* (test :data))
(add-slot *test-object* 'foo :data 777)
(define-object *quux-object* (quux :data))
(add-slot *quux-object* 'foo :data 666)
(define-method test-foo ((test *test-object*)) (get-slot test 'foo))
(define-method test-quux ((test *test-object*) (quux *quux-object*)) (values (get-slot test 'foo) (get-slot quux 'foo)))

(format t "test-foo: ~A test-quux: ~A~%" 
  (test-foo *test-object*)
  (multiple-value-list (test-quux *test-object* *quux-object*)))

(define-object *foo-object*)
(define-method greet ((foo *foo-object*)) (format t "Hello, foo!~%"))
(greet *foo-object*)
(define-object *bar-object* (foo :delegate *foo-object*))
(greet *bar-object*)
(define-method greet ((bar *bar-object*)) (format t "Hello, bar!~%"))
(greet *bar-object*)

(define-object *x-object*)
(define-object *y-object*)
(defvar *z-object* (add-slot (clone-object *y-object*) 'y :delegate *y-object*))

(define-method xyz (x (y *y-object*)) (format t "Y~%"))
(define-method xyz ((x *x-object*) (y *y-object*)) (format t "XY~%"))

(xyz *y-object* *y-object*)
(xyz *x-object* *y-object*)
(xyz *x-object* *z-object*)

(define-method xyz ((x *x-object*) (z *z-object*)) (format t "XZ~%"))

(xyz *x-object* *z-object*)
(dispatch-method 'xyz *x-object* *y-object*)