;; File:    a02.scm
;; Author:  Robert Keller
;; Purpose: Implement Unicalc API (multiply and divide) in Scheme
;; 

(load "tester.scm")
(load "unicalc-db.scm")

;; Unicalc is a unit-based calculator. It consists of a set of functions
;; for finding the expansion of a unit within a database of equations,
;; provided as an association list, and for performing arithmetic
;; on Quantities constructed from such units.

;; Data abstraction for Quantity
;; Quantities are 3-lists: numeric multiplier, numerator, denominator
;; Both numerator and denominator are lists of unit symbols.

;; Most functions return normalized quantities, defined as:
;;    Units are in sorted order
;;    No units common to numerator and denominator
;;    All units are basic (not defined in terms of others)

;; The four required functions are listed first.
;; Helping functions follow.

;; Lookup a unit, returning a corresponding normalized quantity

(define (normalize-unit unit)
  (let (
        (found (assoc unit unicalc-db))
        )
    (if found
        (normalize (second found))
        (make-unit-quantity unit))))


;; Normalize a possibly-unnormalized quantity.
;; Each of the units in the numerator and denominator
;; is normalized recursively, then multiplied together. 
;; The result is simplified within the final multiply.

(define (normalize quantity)
  (let (
        (multiplier (multiplier  quantity))
        (numer      (numer       quantity))
        (denom      (denom       quantity))
        )
      (multiply
        (make-numeric-quantity multiplier) 
        (divide
          (normalize-all numer)
          (normalize-all denom)))))


;; Multiply two normalized quantities, giving a normalized quantity.
;; The two numerators are merged, the two denominators are merged,

(define (multiply quantity1 quantity2)
  (let (
        (multiplier1 (multiplier quantity1))
        (numer1      (numer      quantity1))
        (denom1      (denom      quantity1))
        
        (multiplier2 (multiplier quantity2))
        (numer2      (numer      quantity2))
        (denom2      (denom      quantity2))
        )
    (simplify
      (make-raw-quantity 
          (* multiplier1 multiplier2)
          (merge numer1 numer2)
          (merge denom1 denom2)))))


;; Divide one normalized quantity by another, giving a normalized quantity.
;; The method is similar to that of multiply.

(define (divide quantity1 quantity2)
  (let (
        (multiplier1 (multiplier quantity1))
        (numer1      (numer      quantity1))
        (denom1      (denom      quantity1))
        
        (multiplier2 (multiplier quantity2))
        (numer2      (numer      quantity2))
        (denom2      (denom      quantity2))
        )
    (simplify
     (make-raw-quantity 
          (/ multiplier1 multiplier2)
          (merge numer1 denom2)
          (merge denom1 numer2)))))



;; Make a quantity that is normalized, in the sense that the
;; numerator and denominator do not have any common units
;; and the units both are in alphabetic order.

(define (make-quantity multiplier numer denom)
   (multiply
    (make-numeric-quantity multiplier) 
    (divide
     (normalize-all numer)
     (normalize-all denom))))


;; Functions multiplier, numerator, and denominator extract the corresponding
;; components of a quantity.

(define (multiplier quantity) (first  quantity))
(define (numer quantity)      (second quantity))
(define (denom quantity)      (third  quantity))


;; Function make-raw-quantity constructs an unnormalized quantity from a 
;; multiplier, numerator, and denominator.
;; The first must be a number and the latter two must be lists.

(define (make-raw-quantity multiplier numer denom)
  (list multiplier numer denom))


;; Function make-unit-quantity is a convenience for making a quantity from a single unit.

(define (make-unit-quantity unit) 
  (make-raw-quantity 1 (list unit) ()))


;; Function make-numeric-quantity is a convenience for making a quantity from a single number.

(define (make-numeric-quantity number) 
  (make-raw-quantity number () ()))


;; Constant one is a dimensionless quantity with value 1.

(define one (make-raw-quantity 1 ()()))


;; Simplify a quantity, 
;; by cancelling units that are common to the numerator and denominator
;; Note: simplify does no normalization.

(define (simplify quantity)
  (let (
        (multiplier (multiplier  quantity))
        (numer      (numer   quantity))
        (denom      (denom quantity))
        )
  (make-raw-quantity 
   multiplier 
   (cancel-from denom numer) 
   (cancel-from numer denom))))


;; Merge two lists of units
;; requirement: both lists are already sorted
;; guarantee: the result will be sorted

(define (merge M N)
  (cond
    ((null? M) N)
    ((null? N) M)
    ((symbol<? (first M) (first N)) (cons (first M) (merge (rest M) N)))
    (else                           (cons (first N) (merge M (rest N))))))


;; Cancel the items in list of units M from those in list of units N
;; requirement: both lists are already sorted
;; guarantee: the result will be sorted

(define (cancel-from M N)
  (cond 
    ((null? M) N)  ; nothing to cancel, return N as is
    ((null? N) ()) ; nothing from which to cancel, return ()
    ((symbol<? (first M) (first N)) (cancel-from (rest M) N))        ; (first M) does not occur in N
    ((eq?      (first M) (first N)) (cancel-from (rest M) (rest N))) ; successful cancellation
    (else                           (cons (first N) (cancel-from M (rest N)))))) ; keep (first M)


;; symbol comparison utility, used in cancel-from, for example

(define (symbol<? x y)
  (string<? (symbol->string x) (symbol->string y)))


;; normalize-all normalizes a list of units
;; It is mutually recursive with normalize

(define (normalize-all L) (foldr multiply one (map normalize-unit L)))


;; Define conversions

(define (convert Q1 Q2) (divide (normalize Q1) (normalize Q2)))

(define (convert-unit U1 U2) (convert (make-unit-quantity U1) (make-unit-quantity U2)))


;; Unicalc Test cases

(test (normalize-unit 'second) '(1 (second)()))

(test (normalize-unit 'gram) '(1/1000 (kg) ()))

(test (normalize-unit 'kilometer) '(1000 (meter) ()))

(test (normalize-unit 'day) '(86400 (second) ()))

(test (normalize-unit 'newton) '(1 (kg meter) (second second)))


(test (normalize '(1 (mile)(hour))) '(0.447031923888 (meter) (second)))

(test (normalize '(1e6 (pound)(mile mile))) '(0.1751393211439157 (kg) (meter meter)))

(test (normalize '(1 (newton meter)(second))) '(1 (kg meter meter) (second second second)))

(test (normalize '(1 (volt)())) '(1 (kg meter meter) (ampere second second second)))


(test (multiply (normalize '(1 (foot) ())) (normalize '(1 (acre) ()))) '(1233.414987438996 (meter meter meter) ()))

(test (multiply '(1 () ()) '(1 (kg meter)(second))) '(1 (kg meter)(second)))

(test (multiply '(1 (chicken) (meter meter)) '(100 (meter meter) ())) '(100 (chicken) ()))

(test (multiply (normalize '(100 (tadpole) (gallon))) '(1 (meter meter meter) ())) '(26418.63702726775 (tadpole) ()))


(test (divide (normalize '(1 (yard)())) (normalize '(1 (foot)()))) '(3.0 ()()))

(test (divide (normalize '(1 (mile)())) (normalize '(1 (foot)()))) '(5280.0 () ()))


(test (simplify (make-raw-quantity 1 '(foot pound) '(pound second))) '(1 (foot)(second)))

(test (simplify (make-raw-quantity 1 '(foot meter pound pound) '(foot pound second))) '(1 (meter pound)(second)))

(test (make-quantity 1 '(foot) '(second)) '(0.30479449356 (meter) (second)))


(test (multiply 
          (make-quantity 1 '(foot meter pound pound) '(foot pound second))
          (make-quantity 1 '(pound second second) '(meter newton))) 
      '(0.20574603812221692 (kg second second second) (meter)))
      
(test (divide
       (make-quantity 1 '(foot meter pound pound) '(foot pound second))
       (make-quantity 1 '(pound second second) '(meter newton)))
      '(1.0 (kg meter meter meter) (second second second second second)))

(test (convert-unit 'kg 'gram) '(1000 () ()))

(test (convert-unit 'pound 'ounce)'(16.0 () ()))

(test (convert-unit 'pound 'gram)'(453.59237 () ()))

(tester 'show)

(load "acid-tester.scm")

(define tolerance 1e-6)

(define (relative-error x y)
  (cond ((= x y) 0)
        ((not (= x 0)) (/ (abs (- x y)) x))
        (else (/ (abs (- x y) y)))))

(define (close-enough Quantity1 Quantity2)
  (or (equal? Quantity1 Quantity2)
      (and (equal? (rest Quantity1) (rest Quantity2))
           (< (relative-error (first Quantity1) (first Quantity2) ) tolerance))))

;; acid-test 1
(acid-test (close-enough
      (normalize
       '(1.0 (psi) ()))
       '(6895.006417815267 (kg) (meter second second))) #t )

;; acid-test 2
(acid-test (close-enough
       (multiply
        (normalize '(20.0 (babies quadrant) (revolution)))
        (normalize '(1.0 (babies pica) (section))))
                    '(8.1421103385676e-09 (babies babies) (meter))) #t)

;; acid-test 3
(acid-test (close-enough
       (divide
        (normalize '(2.8 (meter) (second)))
        (normalize '(19200.0 (inch) (year)))) 
                    '(181066.26322347263 () ())) #t)

;; acid-test 4
(acid-test (close-enough
      (normalize
       '(1.0 (hectare) (are)))
       '(100.0 () ())) #t)

;; acid-test 5
(acid-test (close-enough
       (divide
        (normalize '(27.0 (chains) (bbl)))
        (normalize '(95.0 (chains) (gallon))))
       '(0.009022556390977442 () ())) #t)

;; acid-test 6
(acid-test (close-enough
    (normalize '(42.0 (btu) (day)))
    '(0.5128763888888889 (kg meter meter) (second second second))) #t)

;; acid-test 7
(acid-test (close-enough
    (divide (normalize '(8.0 (mile) ())) 
            (normalize '(16.0 (kilometer) ())))
    '(0.8046574629984 () ())) #t)

;; acid-test 8
(acid-test (close-enough
    (divide (normalize '(18.0 (minute) (mile))) 
            (normalize '(13.0 (meter) (day))))
    '(4460.187398933269 (second second) (meter meter))) #t)

;; acid-test 9
(acid-test (close-enough
    (normalize-unit 'stadion)
    '(189.58217499431998 (meter) ())) #t)

;; acid-test 10
(acid-test (close-enough
    (normalize-unit 'yard)
    '(0.91438348068 (meter) ())) #t)

;; acid-test 11
(acid-test (close-enough
 (multiply
   (normalize '(1.0 (furlong furlong furlong meter meter parsec) (barn parsec)))
   (normalize '(2.5 (barn) (furlong furlong meter))))
 '(502.9109143740001 (meter meter) ()))  #t)

;; acid-test 12
(acid-test
 (close-enough
  (normalize '(42.0 (furlong meter furlong meter furlong parsec) 
                  (parsec meter meter furlong barn)))  
  '(1.6996182859924314e+34 () ()))    #t)

;; acid-test 13
(acid-test
 (close-enough
  (normalize '(42.0 (duck duck duck duck goose fire duck duck parsec parsec) (fire quack barn)))  
  '(3.99898907029818e+62 (duck duck duck duck duck duck goose) (quack)))
 #t)

;; acid-test 14
(acid-test (close-enough 
 (normalize '(47.0 () ()))
 '(47.0 () ()))  #t)

;; acid-test 15
(acid-test  (close-enough
 (multiply '(7.0 () ())
      '(7.0 () ()))
 '(49.0 () ()))  #t)

;; acid-test 16
(acid-test  (close-enough
 (divide '(7.0 () ())
           '(-12.0 () ()))
 '(-0.5833333333333334 () ()))  #t)

;; acid-test 17
(acid-test (close-enough
 (multiply '(3.0 () ())
           '(7.0 () ()))
 '(21.0 () ())) #t)

;; acid-test 18
(acid-test (close-enough
 (multiply '(3.0 (foo) ())
           '(7.0 () (foo)))
 '(21.0 () ()))  #t)

;; acid-test 19
(acid-test  (close-enough
 (divide '(7.0 () ())
         '(7.0 () ()))
 '(1.0 () ()))  #t)

;; acid-test 20
(acid-test  (close-enough
 (divide '(7.0 (foo) ())
         '(7.0 (foo) ()))
 '(1.0 () ()))  #t)

;; acid-test 21
(acid-test  (close-enough
 (normalize-unit 'foo)
 '(1.0 (foo) ()))  #t)

;; acid-test 22
(acid-test (close-enough
    (multiply
     (normalize  '(1 (hectare) (meter furlong centare)))
     (normalize  '(2 (yard mile yard yard inch) (fathom))))
     '(1698.918715480711 (meter meter) ())) #t)

;; acid-test 23
(acid-test (close-enough
    (divide
     (normalize  '(.00001 (meter) ()))
     (normalize  '(10000.0 (parsec) ())))
     '(3.2407799001645344e-26 () ())) #t)

;; acid-test 24
(acid-test (close-enough
       (divide (multiply 
                 (normalize '(15.0 (kilogram) ()))
                 (normalize '(10.0 () (gram)) ) )
               (multiply 
                 (normalize '(15000.0 (kilogram) ()))
                 (normalize '(.01 () (gram)) ) ) )
       '(1.0 () ())) #t)

;; acid-test 25
(acid-test (close-enough
       (multiply (multiply 
                 (normalize '(15.0 (kilogram) ()))
                 (normalize '(10.0 () (gram)) ) )
               (multiply 
                 (normalize '(15000.0 (kilogram) ()))
                 (normalize '(.01 () (gram)) ) ) )
       '(22500000000.0 () ())) #t)

;; acid-test 26
(acid-test (close-enough
    (normalize (multiply 
                (divide 
                 (divide 
                    (normalize '(3141.0 (speed-of-light) (reyn))) 
                    (normalize '(1618.0 (Plank_constant) (pennywieght parsec)))) 
                 (normalize '(.5 (pica maxwell) (gilbert hogshead))))
               (multiply 
                (normalize '(1.0 (chicken) ()))
                (normalize '(1.0 (road) ())))
               ))
    '(9.824983020784133e+022 (ampere ampere chicken meter meter pennywieght road second second second second second second second speed-of-light turn) (Plank_constant kg kg)))
    #t)

;; acid-test 27
(acid-test (close-enough 
  (divide '(7.0 (meter) ()) 
          '(0.16666666666666666666666667 (meter) (answertolifetheuniverseandeverything)))
     '(42.0 (answertolifetheuniverseandeverything) ())) #t)

;; acid-test 28
(acid-test (close-enough (normalize-unit 'inch) '(0.02539954113 (meter) ())) #t)

;; acid-test 29
(acid-test (close-enough (normalize '(1.0 (c) ())) '(299792445.8 (meter) (second))) #t)

;; acid-test 30
(acid-test (close-enough (normalize-unit 'radian) '(1.0 (radian) ())) #t)

(acid-tester 'show)