;; Bigloo SI module - physical unit type checking
;; Tested with Bigloo v3.0a
;; Copyright 2007 - Rudolf Olah
;; Version: 0.1
;; Date: 8 Sept 2007
(module
 si
 (export
  unit-prefixes
  ; Conversion functions
  (si->string x)
  (inch->si x::real) (foot->si x::real)
  (yard->si x::real) (mile->si x::real)
  (convert-to x new-unit::symbol)
  (convert-to! x new-unit::symbol)
  ; Math functions
  (.+ x y)
  (.- x y)
  (./ x y)
  (.* x y)
  ; Unit creator functions
  (make-si-length q::real unit::symbol)
  (make-si-mass q::real unit::symbol)
  (make-si-time q::real unit::symbol)
  (make-si-current q::real unit::symbol)
  (make-si-temp q::real unit::symbol)
  (make-si-amount q::real unit::symbol)
  (make-si-lumint q::real unit::symbol)
  )
 )

(define-struct si-unit quantity prefix suffix)

(define unit-prefixes (make-hashtable))
;; SI unit prefixes convenience functions

;; Sets up the alias, the single character prefix of the unit, and the
;; base 10 exponent of the SI unit prefix
;; The value stored is the pair (alias exponenet)
(define (prefix-set! unit-sym::symbol alias::bstring exponent::bint)
  (hashtable-put! unit-prefixes
		  (symbol->string unit-sym) (list alias exponent)))
;; Returns the alias/exponent pair for the SI unit prefix given
(define (prefix-get unit-sym::symbol)
  (hashtable-get unit-prefixes (symbol->string unit-sym)))
;; Returns the alias string of the prefix
(define (prefix-alias unit-sym::symbol)
  (car (hashtable-get unit-prefixes (symbol->string unit-sym))))
;; Returns the base 10 exponent of the prefix
(define (prefix-exp unit-sym::symbol)
  (cadr (hashtable-get unit-prefixes (symbol->string unit-sym))))

(prefix-set! 'nil "" 0)
(prefix-set! 'tera "T" 12)
(prefix-set! 'giga "G" 9)
(prefix-set! 'mega "M" 6)
(prefix-set! 'kilo "k" 3)
(prefix-set! 'hecto "h" 2)
(prefix-set! 'deka "da" 1)
(prefix-set! 'deci "d" -1)
(prefix-set! 'centi "c" -2)
(prefix-set! 'milli "m" -3)
(prefix-set! 'micro "µ" -6)
(prefix-set! 'nano "n" -9)
(prefix-set! 'pico "p" -12)

; Returns formatted SI Unit in the format [q] [p][s]
; where q = quantity, p = prefix, s = suffix
(define (si->string x)
  (format "~a ~a~a" (si-unit-quantity x)
	  (prefix-alias (si-unit-prefix x))
	  (si-unit-suffix x)))

; Imperial unit conversions
; 1 inch = 2.54 cm
(define (inch->si x) (make-si-length (* x 2.54) 'centi))
; 1 foot = 3.04800 dm
(define (foot->si x) (make-si-length (* x 3.04800) 'deci))
; 1 yard = 9.14400 dm
(define (yard->si x) (make-si-length (* x 9.14400) 'deci))
; 1 mile = 1.609344 km
(define (mile->si x) (make-si-length (* x 1.609344) 'kilo))

; Convenience function to create si-unit
(define (new-si-unit quantity prefix suffix)
  (let ((blah (make-si-unit)))
    (si-unit-set! blah quantity prefix suffix)
    blah))

; Convenience function to set si-unit fields
(define (si-unit-set! x quantity prefix suffix)
  (si-unit-quantity-set! x quantity)
  (si-unit-prefix-set! x prefix)
  (si-unit-suffix-set! x suffix))

(define (convert-to x new-unit)
  (new-si-unit
   (/ (si-unit-quantity x)
      (expt 10 (- (prefix-exp new-unit) (prefix-exp (si-unit-prefix x)))))
   new-unit
   (si-unit-suffix x)))

(define (convert-to! x new-unit)
  (si-unit-quantity-set! x
			 (/ (si-unit-quantity x)
			    (expt 10 (- (prefix-exp new-unit)
					(prefix-exp (si-unit-prefix x))))))
  (si-unit-prefix-set! x new-unit)
  x)

(define (make-si-length q unit) (new-si-unit q unit "m"))
(define (make-si-mass q unit) (new-si-unit q unit "g"))
(define (make-si-time q unit) (new-si-unit q unit "s"))
(define (make-si-current q unit) (new-si-unit q unit "A"))
(define (make-si-temp q unit) (new-si-unit q unit "K"))
(define (make-si-amount q unit) (new-si-unit q unit "mol"))
(define (make-si-lumint q unit) (new-si-unit q unit "cd"))

(define-macro (make-si-operator func-name func)
  `(define (,func-name x y)
     (cond
      ((and (number? x) (number? y))
       (,func x y))
      ((and (number? x) (si-unit? y)) ; example: 3 ?? + 25 m = 28 m
       (new-si-unit (,func x (si-unit-quantity (convert-to y 'nil)))
		    'nil
		   (si-unit-suffix y)))
     ((and (si-unit? x) (number? y)) ; example: 4 cm + 1 ?? = 104 cm
					;    (new-si-unit (+ (si-unit-quantity x)
      x)
     ((string=? (si-unit-suffix x) (si-unit-suffix y)) ; Same unit types
      (new-si-unit (,func (si-unit-quantity x)
		      (si-unit-quantity (convert-to y (si-unit-prefix x))))
		   (si-unit-prefix x)
		   (si-unit-suffix x)))
     (else
      (error (symbol->string ',func-name) "Mismatched SI units: "
	     (format "~a != ~a" (si-unit-suffix x) (si-unit-suffix y)))))))

(make-si-operator .+ +)
(make-si-operator .- -)
(make-si-operator ./ /)
(make-si-operator .* *)