units.clj

(ns party.units
  (:refer-clojure :exclude [+ - * /])
  (:require [clojure.algo.generic.arithmetic :as ari :use [+ - * /]]
            [clojure.algo.generic.math-functions :refer [pow]]
            [clojure.repl :refer [doc source apropos dir find-doc]]))

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

(defn mt
  ([factor] (Measurement. nil factor {}))
  ([factor units] (Measurement. nil factor units))
  ([sym factor units] (Measurement. sym factor units)))

(defmethod print-method Measurement
  [{:keys [sym factor units]} w]
  (.write w (pr-str (or sym (list 'mt factor (when (seq units) units))))))

(defmethod pow [Long Long] [x p]
  (if (neg? p)
    (/ (long (Math/pow x (- p))))
    (long (Math/pow x p))))
(defmethod pow [Measurement Number] [{:keys [sym factor units] :as m} power]
  (if sym
    (mt 1 {m power})
    (mt (pow factor power) (zipmap (keys units) (map #(* % power) (vals units))))))

(defmacro ^:private def-unit-method [sym]
  `(do (defmethod ~sym [Measurement Object] [a# b#] (~sym a# (mt b#)))
       (defmethod ~sym [Object Measurement] [a# b#] (~sym (mt a#) b#))))

(def-unit-method *)
(defmethod * [Measurement Measurement] [a b]
  (let [{named true, unnamed false} (group-by #(boolean (:sym %)) [a b])]
    (mt (apply * (map :factor unnamed))
        (apply merge-with + (concat (map :units unnamed)
                                    (for [unit named] {unit 1}))))))

(def-unit-method /)
(defmethod / Measurement [a] (pow a -1))
(defmethod / [Measurement Measurement] [a b] (* a (/ b)))

(defn with-normalized-units
  "Returns the given measurement with zero-power units removed. Leaves derived
  units untouched and the factour."
  [{:keys [sym factor units]}]
  (mt sym factor (remove (fn [[_ p]] (zero? p)) units)))

(defn with-base-units
  "Returns the given measurement converted to base units. The factor may be
  different than given. The sym of the returned measurement will be nil."
  [{:keys [factor units] :as m}]
  (->> units
    (map (fn [[u p]]
           (if (symbol? u)
             (mt 1 {u p})
             (pow (with-base-units u) p))))
    (apply * factor)
    (with-normalized-units)))

(defn assert-identical-units [a b]
  (when-not (= (:units a) (:units b))
    (throw (ex-info "Incompatible units"
                    {:base-units [(:units a) (:units b)]}))))

(defn with-compatible-units
  "Returns the given measurements as a vector pair, each converted so that their
  units are identical. This may require converting them both of them to base
  units."
  [a b]
  (if (= (:units a) (:units b)) ;; identical units
    [a b]
    (let [[na nb] (map with-normalized-units [a b])] ;; extra zero powers
      (if (= (:units na) (:units nb))
        (let [u (apply merge-with #(or %1 %2) (map :units [a b]))]
          [(assoc a :units u) (assoc b :units u)])
        (let [[ba bb] (map with-base-units [a b])]
          (assert-identical-units ba bb)
          [ba bb])))))

(def-unit-method +)
(defmethod + [Measurement Measurement] [a b]
  (let [[a b] (with-compatible-units a b)]
    (mt (+ (:factor a) (:factor b)) (:units a))))

(def-unit-method -)
(defmethod - Measurement [{:keys [factor units]}]
  (mt (- factor) units))
(defmethod - [Measurement Measurement] [a b]
  (let [[a b] (with-compatible-units a b)]
    (mt (- (:factor a) (:factor b)) (:units a))))

(defmacro defunit [name doc & [value]]
  (let [full-name (symbol (str (.-name *ns*)) (str name))]
    `(def ~(with-meta name {:doc (str doc "\n  " (pr-str value))})
      (assoc ~(if value
                value
                `(mt 1 {'~full-name 1}))
        :sym '~full-name))))

(defunit  m "Standard metric meter, base unit of length")
(defunit cm "Standard metric centimeter" (/ m 100))
(defunit km "Standard metric kilometer" (* m 1000))

(defunit  g "Standard metric gram, base unit of mass")
(defunit kg "Standard metric kilogram" (* g 1000))
(defunit  t "Standard metric ton" (* kg 1000))

(defunit s "Second, base unit of time")
(defunit minute "Minute" (* 60 s))
(defunit hour "Hour" (* 60 minute))

(defunit G "Gravity on Earth at sea level" (/ (* 9.8 m) s s))

(defn convert [source-measurement target-measurement]
  (let [source-base (with-base-units source-measurement)
        target-base (with-base-units target-measurement)]
    (assert-identical-units source-base target-base)
    (mt (/ (:factor source-base) (:factor target-base))
        (:units (* 1 target-measurement)))))

(comment
  (pow km 2)
  (* 5 km)
  (with-base-units t)
  (convert (/ (* 50 10 km) hour) (/ km hour))

  (+ (* 50 km) (* 75 km))
  (+ (* 50 km) (* 75 km)) (* 100 (/ km hour))
  (convert (/ (+ (* 50 km) (* 75 km)) (* 100 (/ km hour))) hour)

  (+ (km 5) (m 10))

  (require '[imprecise.core :as imp])
  (imp/e 1 0.1)
  (+ (* (imp/e 1 0.1) m) (* (imp/e 4 0.1) m))

  (/ (* (imp/e 4 0.1) m) (* 10 s))

  0)