stuart-sierras double dispatch with defrecord and protocols...

complex.clj

(defmacro adapt-double
  "Adds a class or type to the set of types accepted by the                                                                                                                        
   2-argument-dispatch function sym."
  [sym type-or-class]
  (let [general-protocol (symbol (str sym "-double-protocol"))
        function-name (symbol (str sym "-for-" (name type-or-class)))]
    `(do (defprotocol ~(symbol (str (name sym) "-double-protocol-for-"
                                    (name type-or-class)))
           (~function-name [~'x ~'y]))
         (extend ~type-or-class ~general-protocol
                 {~(keyword (name sym))
                  (fn [x# y#] (~function-name y# x#))}))))

(defmacro extend-double
  "Sets a function to be used in the 2-argument-dispatch function sym                                                                                                              
  for the given types."
  [sym type1 type2 f]
  (let [general-protocol (symbol (str sym "-double-protocol"))
        type1-protocol (symbol (str sym "-double-protocol-for-"
                                    (name type1)))
        type2-protocol (symbol (str sym "-double-protocol-for-"
                                    (name type2)))
        type1-function-name (str sym "-for-" (name type1))
        type2-function-name (str sym "-for-" (name type2))]
    `(extend ~type1
       ~type2-protocol
       {~(keyword type2-function-name) ~f})))


(defrecord Complex [r i])

(defdouble c+)
(adapt-double c+ Number)
(adapt-double c+ Complex)
(extend-double c+ Number Number +)
(extend-double c+ Complex Complex (fn [c1 c2] (Complex. (+ (:r c1) (:r c2)) (+ (:i c1) (:i c2)))))
(extend-double c+ Number Complex (fn [r c] (Complex. (+ r (:r c)) (:i c))))
(extend-double c+ Complex Number (fn [c r] (Complex. (+ (:r c) r) (:i c))))


(defdouble c-)
(adapt-double c- Number)
(adapt-double c- Complex)
(extend-double c- Number Number -)
(extend-double c- Complex Complex (fn [c1 c2] (Complex. (- (:r c1) (:r c2)) (- (:i c1) (:i c2)))))
(extend-double c- Number Complex (fn [r c] (Complex. (- r (:r c)) (- (:i c)))))
(extend-double c- Complex Number (fn [c r] (Complex. (- (:r c) r) (:i c))))

(c- (Complex. 1 3) 3) ;=> #:isomorphism.complex-d.Complex{:r 2, :i -3}  ... 
;;I was expecting  #:isomorphism.complex-d.Complex{:r -2, :i 3}                                              
(c- 3 (Complex. 1 3)) ;=> #:isomorphism.complex-d.Complex{:r -2, :i 3}  ... 
;;I was expecting  #:isomorphism.complex-d.Complex{:r 2, :i -3}