;;; $Id: units.scm,v 1.2 2006/05/27 17:38:02 hoesterholt Exp $

(module units mzscheme
	(provide 
		 unit-convert 
		 unit-convert->string
		 unit-convert->rounded->string
		 )

;;#+pod
;
;=pod
;
;=syn scm,8
;
;=wikiwikiwiki
;
;=UNITS - Convert between units
;
;A module that can be used to convert between various units, e.g. #kg# to #g#.
;
;=Synopsis
;
;=verbatim scm,8
; > (require (planet "units.scm" ("oesterholt"  "ho-utils.plt"  1 0)))
; > (define a 100)
; > (unit-convert a 'kg 'g)
; 100000
; > (unit-convert a 'g 'kg)
; 1/10
;
; > (require (planet "units.scm" ("oesterholt"  "ho-utils.plt"  1 0)))
; > (define a 100)
; > (unit-convert a 'kg 'g)
; 100000
; > (unit-convert a 'kg 'g)
; 100000
; > (unit-convert a 'l '(dl cl ml) 100)
; dl
; 1000
; > (unit-convert a 'l '(dl cl ml) 10000)
; cl
; 10000
; > (unit-convert a 'l '(dl cl ml) 10001)
; ml
; 100000
; > (unit-convert a 'l '(dl cl ml))
; dl
; 1000
; >
;
; > (unit-convert->string a 'l '(dl cl ml))
; "1000dl"
; > (unit-convert->string a 'l '(dl cl ml) 10000)
; "10000cl"
; >
;
; > (define a 123.0)
; > (unit-convert->string a 'ml '(dl cl ml))
; "1.23dl"
; >
;
; > (define a 1235.2342)
; > (unit-convert->rounded->string a 'ml '(dl cl ml) 3)
; "12.352dl"
; > (unit-convert->rounded->string a 'ml '(dl cl ml) 2)
; "12.35dl"
; > (unit-convert->rounded->string a 'ml '(dl cl ml) 1)
; "12.4dl"
; > (unit-convert->rounded->string a 'ml '(dl cl ml) 1 15)
; "123.5cl"
; >
;
;> (unit-convert->rounded->string a 'ml 'cl 3)
;"123.523cl"
;=verbatim
;
;=API
;
;===#(unit-convert A from-unit to-unit(s) . threshold) : number | (values symbol number)#
;
;Converts #A# from #from-unit# to #to-unit# or one of #to-units#. It targets
;for the minimal number, bigger then #threshold# (which defaults to 1 if not given).
;#to-units# is a list of units.
;
;/Returns/ the converted A, if #to-unit# is only one unit. /Returns/ the unit A
;is converted to and the converted A, if #to-units# is a list
;of units.
;
;===#(unit-convert->string A from-unit to-unit(s) . threshold) : string#
;
;Calls #unit-convert# and makes a string of the result of #unit-convert#. See synopsis
;for more info.
;
;===#(unit-convert->rounded->string A from-unit to-unit(s) decimals . threshold) : string#
;
;Calls #unit-convert#, rounds the result to #decimals# decimals and makes a
;string of the result, like #unit-convert->string# does.
;
;=Supported Units
;
;Currently supported unit conversions.
;
; | computermemory | b (byte), kb (kilobyte), mb (megabyte), gb (gigabyte), tb (terabyte)
; | time           | w (week), d (day), h (hour), m (minute), s (second), ms (millisecond), mus (microsecond), ns (nanosecond)
; | mass           | g (gram), kg (kilogram)
; | distance       | m (meter), dm (decimeter), cm (centimeter), mm (millimeter), km (kilometer)
; | contents       | l (liter), dl (deciliter), cl (centiliter), ml (milliliter)
;
;=Info
;
;(c) 2005 Hans !Oesterholt-Dijkema. Distributed undef LGPL.
;Contact: send email to hans in domain elemental-programming.org.
;Homepage: [http://www.elemental-programming.org].
;
;=wikiwikiwiki
;
;=cut
;
;##

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; To units
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (find-all-conversion-paths L)
  (let ((H (make-hash-table))
	(paths (list)))

    (define (all-units L)
      (if (null? L)
	  (list)
	  (let ((from (hash-table-get H (caar L) (lambda () (caar L))))
		(to   (hash-table-get H (cadar L) (lambda () (cadar L)))))
	    (hash-table-put! H (caar L) #t)
	    (hash-table-put! H (cadar L) #t)
	    (cond 
	     ((and (symbol? from) (symbol? to))
	      (cons from (cons to (all-units (cdr L)))))
	     ((symbol? from)
	      (cons from (all-units (cdr L))))
	     ((symbol? to)
	      (cons to (all-units (cdr L))))
	     (else (all-units (cdr L)))))))

    (define (construct-paths streng units L)

      (define (can-and-should-reach? from to type L)
	(if (null? L)
	    #f
	    (let ((f (caar L))
		  (t (cadar L))
		  (tt (caddar L)))
	      (if (and (eq? f from) (eq? t to) (eq? tt type))
		  #t
		  (can-and-should-reach? from to type (cdr L))))))

      (define (type-of-streng streng)
	(car streng))

      (let ((last (car (reverse streng))))
	(let ((R
	       (apply append
		      (map (lambda (unit)
			     (if (can-and-should-reach? last unit (type-of-streng streng) L)
				 (let ((new-streng  (append streng (list unit))))
				   (cons new-streng (construct-paths new-streng units L)))
				 (list)))
			   units))))
	  ;(display (format "~a ~%" R))
	  R)))

    (define (identity-strengs units)
      (map (lambda (unit)
	     (list unit unit))
	   units))

    (let ((strengs (map (lambda (E)
			  (apply (lambda (from to type proc)
				   (list type from))
				 E))
			L))
	  (units   (all-units L)))

      (append (identity-strengs units)
	      (map (lambda (streng) (cdr streng))
		   (apply append
			  (map (lambda (streng)
				 (construct-paths streng units L))
			       strengs)))))))


(define (create-conversion streng L)

  (define (find-transition from to L)
    (if (eq? from to)
	(lambda (x) x)
	(if (null? L)
	    (error (format "Cannot find transition from ~a to ~a" from to))
	    (if (and (eq? (caar L) from) (eq? (cadar L) to))
		(cadddr (car L))
		(find-transition from to (cdr L))))))

  (define (make-calculation streng)
    (if (null? (cddr streng))
	(find-transition (car streng) (cadr streng) L)
	(let ((F (find-transition (car streng) (cadr streng) L))
	      (G (make-calculation (cdr streng))))
	  (lambda (x) (F (G x))))))

  (make-calculation streng))

(define (create-conversions strengs L)
  (let ((H (make-hash-table 'equal)))
    (for-each (lambda (streng)
		(let ((from (car streng))
		      (to   (car (reverse streng))))
		  (hash-table-put! H (list from to) (create-conversion streng L))))
	      strengs)
    H))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define MINIMAL-CONVERSIONS
  (list 
   `(kb b  ,(lambda (x) (* x 1024)) ,(lambda (x) (/ x 1024)))
   `(mb kb ,(lambda (x) (* x 1024)) ,(lambda (x) (/ x 1024)))
   `(gb mb ,(lambda (x) (* x 1024)) ,(lambda (x) (/ x 1024)))
   `(tb gb ,(lambda (x) (* x 1024)) ,(lambda (x) (/ x 1024)))
   `(w  d  ,(lambda (x) (* x 7))    ,(lambda (x) (/ x 7)))
   `(d  h  ,(lambda (x) (* x 24))   ,(lambda (x) (/ x 24)))
   `(h  m  ,(lambda (x) (* x 60))   ,(lambda (x) (/ x 60)))
   `(m  s  ,(lambda (x) (* x 60))   ,(lambda (x) (/ x 60)))
   `(s  ms ,(lambda (x) (* x 1000)) ,(lambda (x) (/ x 1000)))
   `(s  mus ,(lambda (x) (* x 1000)) ,(lambda (x) (/ x 1000)))
   `(mus ns ,(lambda (x) (* x 1000)) ,(lambda (x) (/ x 1000)))
   `(kg g  ,(lambda (x) (* x 1000)) ,(lambda (x) (/ x 1000)))
   `(l  dl ,(lambda (x) (* x 10))   ,(lambda (x) (/ x 10)))
   `(dl cl ,(lambda (x) (* x 10))   ,(lambda (x) (/ x 10)))
   `(cl ml ,(lambda (x) (* x 10))   ,(lambda (x) (/ x 10)))
   `(km m  ,(lambda (x) (* x 1000)) ,(lambda (x) (/ x 1000)))
   `(m  dm ,(lambda (x) (* x 10))   ,(lambda (x) (/ x 10)))
   `(dm cm ,(lambda (x) (* x 10))   ,(lambda (x) (/ x 10)))
   `(cm mm ,(lambda (x) (* x 10))   ,(lambda (x) (/ x 10)))
   ))

(define conversion-hash 
  (let ((MINCONVS 
	 (apply append
		(map (lambda (E)
		       (apply (lambda (from to smaller bigger)
				(list 
				 (list from to 'smaller smaller)
				 (list to from 'bigger  bigger)))
			      E))
		     MINIMAL-CONVERSIONS))))
    (create-conversions (find-all-conversion-paths MINCONVS)
			MINCONVS)))

(define q
  (let ((MINCONVS 
	 (apply append
		(map (lambda (E)
		       (apply (lambda (from to smaller bigger)
				(list 
				 (list from to 'smaller smaller)
				 (list to from 'bigger  bigger)))
			      E))
		     MINIMAL-CONVERSIONS))))
    (find-all-conversion-paths MINCONVS)))


(define (internal-convert A from to)
  (let ((convert (hash-table-get conversion-hash 
				 (list from to) 
				 (lambda () (lambda (x) #f)))))
    (convert A)))

(define (unit-convert A from to . threshold)
  (if (list? to)
      (let ((T (if (null? threshold) 1 (car threshold)))
	    (B #f)
	    (U (car to)))
	(for-each (lambda (t)
		    (let ((R (internal-convert A from t)))
		      (if (not (eq? R #f))
			  (if (eq? B #f)
			      (begin
				(set! B R)
				(set! U t))
			      (if (or (and (< R B) (>= R T))
				      (and (> T B) (>= R T)))
				  (begin
				    (set! B R)
				    (set! U t)))))))
		  to)
	(values U B))
      (internal-convert A from to)))


(define (unit-convert->string A from to . threshold)
  (call-with-values 
      (lambda () 
	(if (list? to)
	    (if (null? threshold)
		(unit-convert A from to)
		(unit-convert A from to (car threshold)))
	    (if (null? threshold)
		(values to (unit-convert A from to))
		(values to (unit-convert A from to (car threshold))))))
    (lambda (unit value)
      (let ((u (symbol->string unit)))
      (if (eq? #f value)
	  (string-append "?" u)
	  (string-append (number->string value) u))))))

(define (unit-convert->rounded->string A from to digits . threshold)
  (call-with-values 
      (lambda () 
	(if (list? to)
	    (if (null? threshold)
		(unit-convert A from to)
		(unit-convert A from to (car threshold)))
	    (if (null? threshold)
		(values to (unit-convert A from to))
		(values to (unit-convert A from to (car threshold))))))
    (lambda (unit value)
      (let ((u (symbol->string unit)))
      (if (eq? #f value)
	  (string-append "?" u)
	  (let ((fold (exact->inexact (expt 10 digits))))
	    (string-append (number->string (/ (round (* value fold)) fold)) u)))))))
  

)