(defstruct unary-mic
  (key nil :type (or wm-map null))
  (value nil :type (or wm-object null)))

#-ecl
(defmethod make-load-form ((s unary-mic) &optional env)
  '(make-unary-mic))

(defmacro mic-invoke-unary-method (selector argument)
  (let ((arg-sym (%gensym)) 
        (args-sym (%gensym))
        (map-sym (%gensym)) 
        (meth-sym (%gensym)) 
#-ecl
        (cache (make-unary-mic))
#+ecl
        (cache `(%load-form ,(%gensym) (make-unary-mic)))
        (index (wm-slot-index (gethash '|code| (wm-map-slots (wm-object-map *primitive-method*))))))
    `(let* ((,arg-sym ,argument)
            (,map-sym (wm-object-map ,arg-sym))
            ,meth-sym)
       (if (eq ,map-sym (unary-mic-key ,cache))
           (setf ,meth-sym (unary-mic-value ,cache))
           (let ((,args-sym (cons ,arg-sym nil)))
             (setf ,meth-sym (dispatch-method ,selector nil t ,args-sym))
             (cond
               ((eq (car ,args-sym) ,arg-sym)
                 (setf (unary-mic-key ,cache) ,map-sym)
                 (setf (unary-mic-value ,cache) ,meth-sym))
               (t
                 (setf ,arg-sym (car ,args-sym))))))
       (funcall (the function (svref (wm-object-slots ,meth-sym) ,index)) ,meth-sym ,arg-sym))))
 
(defstruct unary-pic
  (color 0 :type fixnum)
  (a-key nil :type t)
  (a-value nil :type (or wm-object null))
  (b-key nil :type t)
  (b-value nil :type (or wm-object null))
  (c-key nil :type t)
  (c-value nil :type (or wm-object null)))

#-ecl
(defmethod make-load-form ((s unary-pic) &optional env)
  '(make-unary-pic))

(defmacro pic-invoke-unary-method (selector argument)
  (let ((arg-sym (%gensym))
        (args-sym (%gensym))
        (map-sym (%gensym))
        (meth-sym (%gensym))
#-ecl
        (cache (make-unary-pic))
#+ecl
        (cache `(%load-form ,(%gensym) (make-unary-pic)))
        (index (wm-slot-index (gethash '|code| (wm-map-slots (wm-object-map *primitive-method*))))))
    `(let* ((,arg-sym ,argument)
            (,map-sym 
              (cond 
                ((integerp ,arg-sym) (wm-object-map *traits-integer*))
                ((wm-object-p ,arg-sym) (wm-object-map ,arg-sym))
                (t ,arg-sym)))
            ,meth-sym)
             (cond
               ((eq ,map-sym (unary-pic-a-key ,cache))
                 (setf ,meth-sym (unary-pic-a-value ,cache)))
               ((eq ,map-sym (unary-pic-b-key ,cache))
                 (setf ,meth-sym (unary-pic-b-value ,cache)))
               ((eq ,map-sym (unary-pic-c-key ,cache))
                 (setf ,meth-sym (unary-pic-c-value ,cache)))
               (t
                 (let ((,args-sym (cons ,arg-sym nil)))
                   (setf ,meth-sym (dispatch-method ,selector nil t ,args-sym))
                   (if (eq (car ,args-sym) ,arg-sym)
                     (case (unary-pic-color ,cache)
                       (0
                         (setf (unary-pic-a-key ,cache) ,map-sym)
                         (setf (unary-pic-a-value ,cache) ,meth-sym)
                         (setf (unary-pic-color ,cache) 1))
                       (1
                         (setf (unary-pic-b-key ,cache) ,map-sym)
                         (setf (unary-pic-b-value ,cache) ,meth-sym)
                         (setf (unary-pic-color ,cache) 2))
                       (2
                         (setf (unary-pic-c-key ,cache) ,map-sym)
                         (setf (unary-pic-c-value ,cache) ,meth-sym)
                         (setf (unary-pic-color ,cache) 0)))
                     (setf ,arg-sym (car ,args-sym))))))
       (funcall (the function (svref (wm-object-slots ,meth-sym) ,index)) ,meth-sym ,arg-sym))))

(defstruct binary-pic
  (color 0 :type fixnum)
  (a0-key nil :type t)
  (a1-key nil :type t)
  (a-value nil :type (or wm-object null))
  (b0-key nil :type t)
  (b1-key nil :type t)
  (b-value nil :type (or wm-object null))
  (c0-key nil :type t)
  (c1-key nil :type t)
  (c-value nil :type (or wm-object null)))

#-ecl
(defmethod make-load-form ((s binary-pic) &optional env)
  '(make-binary-pic))

(defmacro pic-invoke-binary-method (selector a b)
  (let ((a-sym (%gensym))
        (b-sym (%gensym))
        (args-sym (%gensym))
        (am-sym (%gensym))
        (bm-sym (%gensym))
        (meth-sym (%gensym))
#-ecl
        (cache (make-binary-pic))
#+ecl
        (cache `(%load-form ,(%gensym) (make-binary-pic)))
        (index (wm-slot-index (gethash '|code| (wm-map-slots (wm-object-map *primitive-method*))))))
    `(let ((,a-sym ,a) (,b-sym ,b) ,meth-sym)
           (let ((,am-sym
                   (cond
                     ((integerp ,a-sym) (wm-object-map *traits-integer*))
                     ((wm-object-p ,a-sym) (wm-object-map ,a-sym))
                     (t ,a-sym)))
                 (,bm-sym
                   (cond
                     ((integerp ,b-sym) (wm-object-map *traits-integer*))
                     ((wm-object-p ,b-sym) (wm-object-map ,b-sym))
                     (t ,b-sym))))
             (cond
               ((and (eq ,am-sym (binary-pic-a0-key ,cache))
                     (eq ,bm-sym (binary-pic-a1-key ,cache)))
                 (setf ,meth-sym (binary-pic-a-value ,cache)))
               ((and (eq ,am-sym (binary-pic-b0-key ,cache))
                     (eq ,bm-sym (binary-pic-b1-key ,cache)))
                 (setf ,meth-sym (binary-pic-b-value ,cache)))
               ((and (eq ,am-sym (binary-pic-c0-key ,cache))
                     (eq ,bm-sym (binary-pic-c1-key ,cache)))
                 (setf ,meth-sym (binary-pic-c-value ,cache)))
               (t
                 (let ((,args-sym (cons ,a-sym (cons ,b-sym nil))))
                   (setf ,meth-sym (dispatch-method ,selector nil t ,args-sym))
                   (if (eq (car ,args-sym) ,a-sym)
                     (case (binary-pic-color ,cache)
                       (0
                         (setf (binary-pic-a0-key ,cache) ,am-sym)
                         (setf (binary-pic-a1-key ,cache) ,bm-sym)
                         (setf (binary-pic-a-value ,cache) ,meth-sym)
                         (setf (binary-pic-color ,cache) 1))
                       (1
                         (setf (binary-pic-b0-key ,cache) ,am-sym)
                         (setf (binary-pic-b1-key ,cache) ,bm-sym)
                         (setf (binary-pic-b-value ,cache) ,meth-sym)
                         (setf (binary-pic-color ,cache) 2))
                       (2
                         (setf (binary-pic-c0-key ,cache) ,am-sym)
                         (setf (binary-pic-c1-key ,cache) ,bm-sym)
                         (setf (binary-pic-c-value ,cache) ,meth-sym)
                         (setf (binary-pic-color ,cache) 0)))
                     (setf ,a-sym (car ,args-sym)))))))
       (funcall (the function (svref (wm-object-slots ,meth-sym) ,index)) ,meth-sym ,a-sym ,b-sym))))

(defstruct trinary-pic
  (color 0 :type fixnum)
  (a0-key nil :type t)
  (a1-key nil :type t)
  (a2-key nil :type t)
  (a-value nil :type (or wm-object null))
  (b0-key nil :type t)
  (b1-key nil :type t)
  (b2-key nil :type t)
  (b-value nil :type (or wm-object null))
  (c0-key nil :type t)
  (c1-key nil :type t)
  (c2-key nil :type t)
  (c-value nil :type (or wm-object null)))

#-ecl
(defmethod make-load-form ((s trinary-pic) &optional env)
  '(make-trinary-pic))

(defmacro pic-invoke-trinary-method (selector a b c)
  (let ((a-sym (%gensym))
        (b-sym (%gensym))
        (c-sym (%gensym))
        (args-sym (%gensym))
        (am-sym (%gensym))
        (bm-sym (%gensym))
        (cm-sym (%gensym))
        (meth-sym (%gensym))
#-ecl
        (cache (make-trinary-pic))
#+ecl
        (cache `(%load-form ,(%gensym) (make-trinary-pic)))
        (index (wm-slot-index (gethash '|code| (wm-map-slots (wm-object-map *primitive-method*))))))
    `(let ((,a-sym ,a) (,b-sym ,b) (,c-sym ,c) ,meth-sym)
           (let ((,am-sym
                   (cond
                     ((integerp ,a-sym) (wm-object-map *traits-integer*))
                     ((wm-object-p ,a-sym) (wm-object-map ,a-sym))
                     (t ,a-sym)))
                 (,bm-sym
                   (cond
                     ((integerp ,b-sym) (wm-object-map *traits-integer*))
                     ((wm-object-p ,b-sym) (wm-object-map ,b-sym))
                     (t ,b-sym)))
                 (,cm-sym
                   (cond
                     ((integerp ,c-sym) (wm-object-map *traits-integer*))
                     ((wm-object-p ,c-sym) (wm-object-map ,c-sym))
                     (t ,c-sym))))
             (cond
               ((and (eq ,am-sym (trinary-pic-a0-key ,cache))
                     (eq ,bm-sym (trinary-pic-a1-key ,cache))
                     (eq ,cm-sym (trinary-pic-a2-key ,cache)))
                 (setf ,meth-sym (trinary-pic-a-value ,cache)))
               ((and (eq ,am-sym (trinary-pic-b0-key ,cache))
                     (eq ,bm-sym (trinary-pic-b1-key ,cache))
                     (eq ,cm-sym (trinary-pic-b2-key ,cache)))
                 (setf ,meth-sym (trinary-pic-b-value ,cache)))
               ((and (eq ,am-sym (trinary-pic-c0-key ,cache))
                     (eq ,bm-sym (trinary-pic-c1-key ,cache))
                     (eq ,cm-sym (trinary-pic-c2-key ,cache)))
                 (setf ,meth-sym (trinary-pic-c-value ,cache)))
               (t
                 (setf ,meth-sym (dispatch-method ,selector nil t (cons ,a-sym (cons ,b-sym (cons ,c-sym nil)))))
                 (case (trinary-pic-color ,cache)
                   (0
                     (setf (trinary-pic-a0-key ,cache) ,am-sym)
                     (setf (trinary-pic-a1-key ,cache) ,bm-sym)
                     (setf (trinary-pic-a2-key ,cache) ,cm-sym)
                     (setf (trinary-pic-a-value ,cache) ,meth-sym)
                     (setf (trinary-pic-color ,cache) 1))
                   (1
                     (setf (trinary-pic-b0-key ,cache) ,am-sym)
                     (setf (trinary-pic-b1-key ,cache) ,bm-sym)
                     (setf (trinary-pic-b2-key ,cache) ,cm-sym)
                     (setf (trinary-pic-b-value ,cache) ,meth-sym)
                     (setf (trinary-pic-color ,cache) 2))
                   (2
                     (setf (trinary-pic-c0-key ,cache) ,am-sym)
                     (setf (trinary-pic-c1-key ,cache) ,bm-sym)
                     (setf (trinary-pic-c2-key ,cache) ,cm-sym)
                     (setf (trinary-pic-c-value ,cache) ,meth-sym)
                     (setf (trinary-pic-color ,cache) 0))))))
       (funcall (the function (svref (wm-object-slots ,meth-sym) ,index)) ,meth-sym ,a-sym ,b-sym ,c-sym))))