Cacher is the code snippet organizer for pro developers

;;; Author: Scott Jaderholm
;;; Created: 2009-12-18
;;;
;;; Short Description: Automates the creation of unit conversion
;;; functions and includes several common ones.
;;; 
;;; Detailed Description: So for inches, feet, and meters, if you
;;; provide equations for inches-to-feet and feet-to-meters, then this
;;; package will automatically create feet-to-inches, meters-to-feet,
;;; inches-to-meters, meters-to-inches, and all the corresponding
;;; sqfeet-to-sqmeters, cubicmeters-to-cubicfeet, etc.
;;; 
;;; This code is in the public domain and is distributed without
;;; warranty of any kind.

(ns com.jaderholm.units
  (:use [clojure.zip :as zip :only ()]
        [clojure.test]))

;;; maps functions to their inverses
(def invert-function
     (let [a {'+ '- '* '/}]
       (into a (clojure.set/map-invert a))))

(deftest test-invert-function
  (are [a b] (= (invert-function a) b)
       '+ '-
       '- '+
       '/ '*
       '* '/))

(defn- find-variable
  "Traverses a tree until it finds the symbol x, returns its location
  in zipper format."
  [lst]
  (loop [loc (zip/seq-zip lst)]
    (if (= 'x (zip/node loc))
      loc
      (recur (zip/next loc)))))

(defn- invert
  "Inverts a tree. Ex. converts (/ (- x 1) 2) to (+ (* x 2) 1)."
  [lst]
  (letfn [(inner [loc]
                 (if (zip/up loc) ; keep going if we're not at the top
                   ;; invert the function (convert + to - etc.)
                   (concat (list (invert-function (first (zip/lefts loc)))) 
                           (rest (zip/lefts loc))
                           ;; go up the tree and include the
                           ;; surrounding lists inside here
                           (list (inner (zip/up loc))) 
                           (zip/rights loc))
                   ;; once we get to the top of the tree include the
                   ;; symbol x at the deepest level
                   'x))] 
    (inner (find-variable lst))))

(deftest test-invert
  (are [a b] (= (invert a) b)
       '(/ (- x 1) 2) '(+ (* x 2) 1)
       '(- 1 (/ 2 x)) '(* 2 (+ 1 x))))

;;; TODO replace w/ macro or function w/o eval
(defn- create-function
  ""
  [s body]
  (eval (list 'defn
              (symbol s)
              '[x]
              body)))

(def conversions (atom {}))

(defn- register-conversion [[from to]]
  (swap! conversions update-in [from] conj to))

(defn- function-name [[from to]]
  (str from "-to-" to))

(defn defconv
  "Define a conversion between two units"
  [units eq]
  (doseq [[units eq] [[units eq]
                      [(reverse units) (invert eq)]]]
    (create-function (function-name units) eq)
    (register-conversion units)))

(defn- raise [lst n]
  (map #(if (number? %)
          (Math/pow % n)
          %)
       lst))

(defn defconv-3d
  ""
  [units eq]
  (defconv units eq)
  (defconv (map #(str "sq" %) units) (raise eq 2))
  (defconv (map #(str "cubic" %) units) (raise eq 3)))

;; TODO create-derived-conversion and derive-conversion-functions
;; could use better names (and better inner function names)
(defn- create-derived-conversion
  [units]
  ;; conversions between two units can't be derived, they must be defined
  (when (> (count units) 2)
    (letfn [(inner [units]
                   (if (and (seq units) (> (count units) 1))
                     (list (symbol (function-name [(last (butlast units))
                                                   (last units)]))
                           (inner (butlast units)))
                     'x))]
      (create-function (function-name [(first units) (last units)])
                       (inner units)))))

(defn- derive-conversion-functions
  [node]
  (let [done (atom #{node})
        traverse (fn traverse [traversed]
                   (let [todo (filter (complement @done)
                                      (@conversions (last traversed)))]
                     (when (seq todo)
                       (doseq [unit todo]
                         (let [new-traversed (conj traversed unit)]
                           (create-derived-conversion new-traversed)
                           (create-derived-conversion (reverse new-traversed))
                           (swap! done conj unit)
                           (traverse new-traversed))))))]
    (traverse [node])))

;;; Temperature
(defconv ["fahrenheit" "celsius"] '(/ (* (- x 32) 5) 9))
(defconv ["celsius" "kelvin"] '(+ x 273))

;;; Currency
(defconv ["dollars" "euros"] '(* x 0.6939))
(defconv ["dollars" "pesos-mexican"] '(* x 12.89))

;;; Length
(defconv-3d ["yards" "feet"] '(* x 3))
(defconv-3d ["feet" "inches"] '(* x 12))
(defconv-3d ["inches" "centimeters"] '(* x 2.54))
(defconv-3d ["meters" "centimeters"] '(* x 100))
(defconv-3d ["centimeters" "millimeters"] '(* x 10))
(defconv-3d ["kilometers" "meters"] '(* x 1000))
(defconv-3d ["feet" "miles"] '(/ x 5280))

;;; Time
(defconv ["millenium" "centuries"] '(* x 10))
(defconv ["centuries" "years"] '(* x 100))
(defconv ["years" "months"] '(* x 12))
(defconv ["months" "days"] '(* x 30.43))
(defconv ["days" "hours"] '(* x 24))
(defconv ["hours" "minutes"] '(* x 60))
(defconv ["minutes" "seconds"] '(* x 60))
(defconv ["seconds" "milliseconds"] '(* x 1000))
(defconv ["milliseconds" "nanoseconds"] '(* x 1000000))

;;; Weight
(defconv ["kilograms" "grams"] '(* x 1000))
(defconv ["kilograms" "pounds"] '(/ x 2.2046))
(defconv ["tons" "pounds"] '(* x 2000))
(defconv ["pounds" "ounces"] '(* x 16))

;;; Volume
(defconv ["gallons" "pints"] '(* x 8))
(defconv ["liters" "milliliters"] '(* x 1000))
(defconv ["liters" "quarts"] '(* x 1.056688))
(defconv ["quarts" "gallons"] '(* x 0.25))
(defconv ["gallons" "ounces-fluid"] '(* x 128))
(defconv ["cubicfeet" "gallons"] '(* x 7.4805))
;; cubicinches, cubicmeters, etc are defined automatically with
;; defconv-3d in length section

;;; Area
;; sqfeet, sqmiles, etc are defined automatically with defconv-3d in
;; length section

;; TODO could use a better name
(defn update-derived-conversions
  "Must be called after new conversions are defined in order for
  derived conversions to be created"
  []
  (doseq [unit (keys @conversions)]
    (derive-conversion-functions unit)))

(update-derived-conversions)

(deftest test-conversions
  (is (= 3 (yards-to-feet 1)) "defined function")
  (is (= 1 (feet-to-yards 3)) "inverted function")
  (is (= 1 (inches-to-feet 12)) "defined function")
  (is (= 12 (feet-to-inches 1)) "inverted function")
  (is (= 36 (yards-to-inches 1)) "derived function")
  (is (= 1 (inches-to-yards 36))  "derived function"))

(run-tests)