units.clj

(ns party.units
  (:refer-clojure :exclude [+ - * /])
  (:require [clojure.algo.generic.arithmetic :as ari :use [+ - * /]]))

(defrecord Measurement [factor units]
  clojure.lang.IFn
  (invoke [a b] (* a b)))

(defn ^:private short-name [sym]
  (if (= (namespace sym) (namespace `foo))
    (symbol (name sym))
    sym))

(defn ^:private repeat-pairs [pairs]
  (mapcat (fn [[sym power]] (repeat (Math/abs power) (short-name sym))) pairs))

(defn ^:private split-powers [pairs]
  (let [{top true, btm false} (group-by #(pos? (val %)) pairs)]
    [top btm]))

(defmethod print-method Measurement
  [{:keys [factor units]} w]
  (.write w
    (pr-str
      (let [[top btm] (split-powers units)
            top-form (list* '* factor (repeat-pairs top))]
        (if (empty? btm)
          top-form
          (list* '/ top-form (repeat-pairs btm)))))))

(defmethod * [Measurement Object] [a b] (* a (Measurement. b {})))
(defmethod * [Object Measurement] [a b] (* (Measurement. a {}) b))
(defmethod * [Measurement Measurement] [a b]
  (Measurement. (* (:factor a) (:factor b))
                (merge-with + (:units a) (:units b))))

(defmethod / Measurement [a] (/ 1 a))
(defmethod / [Measurement Object] [a b] (/ a (Measurement. b {})))
(defmethod / [Object Measurement] [a b] (/ (Measurement. a {}) b))
(defmethod / [Measurement Measurement] [a b]
  (Measurement. (/ (:factor a) (:factor b))
                (merge-with + (:units a) (zipmap (keys (:units b))
                                                 (map - (vals (:units b)))))))

(defmethod + [Measurement Object] [a b] (+ a (Measurement. b {})))
(defmethod + [Object Measurement] [a b] (+ (Measurement. a {}) b))
(defmethod + [Measurement Measurement] [a b]
  (when (not= (:units a) (:units b))
    (throw (ex-info "Can't add incompatible units"
                    {:op (list '+ a b)})))
  (Measurement. (+ (:factor a) (:factor b)) (:units a)))

(defmethod - Measurement [{:keys [factor units]}]
  (Measurement. (- factor) units))
(defmethod - [Measurement Object] [a b] (- a (Measurement. b {})))
(defmethod - [Object Measurement] [a b] (- (Measurement. a {}) b))
(defmethod - [Measurement Measurement] [a b]
  (when (not= (:units a) (:units b))
    (throw (ex-info "Can't subtract incompatible units"
                    {:op (list '- a b)})))
  (Measurement. (- (:factor a) (:factor b)) (:units a)))

(def  m "Standard metric meter" (Measurement. 1  {`m 1}))
(def cm "Metric centimeter" (/ m 100))
(def km "Metric kilometer" (* m 1000))

(def s (Measurement. 1  {`s 1}))
(def minute (* 60 s))
(def hour (* 60 minute))


(defn in-base-units [{:keys [factor units]}]
  (let [expanded (zipmap (map #(deref (or (resolve %) (throw (ex-info "bad" {:unit %}))))
                              (keys units))
                         (vals units))
        [top btm] (split-powers expanded)]
    (apply * factor
      (apply / 1 (mapcat (fn [[m p]] (repeat (- p) m)) btm))
      (mapcat (fn [[m p]] (repeat p m)) top))))

;; This expects the units in target-measurement to be symbols of non-base units.
;; Weird.
(defn convert-to-measurement [measurement target-measurement]
  (let [target (in-base-units target-measurement)]
    (when (not= (:units target) (:units measurement))
      (throw (ex-info "Can't convert to incompatible units"
                      {:op (list 'convert-to-measurement measurement target)})))
    (Measurement. (/ (:factor measurement) (:factor target))
                  (:units target-measurement))))

;; (convert-to-measurement (/ (* 50 10 km) hour) (Measurement. 1 `{km 1 hour -1}))