Skip to content

Instantly share code, notes, and snippets.

@scottjad
Created January 13, 2010 23:13
Show Gist options
  • Save scottjad/276662 to your computer and use it in GitHub Desktop.
Save scottjad/276662 to your computer and use it in GitHub Desktop.
;;; 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment