#lang racket

;; File:    a03.rkt + lambda (user-defined function) handling
;; Author:  Robert Keller
;; Purpose: Implement Unicalc API and CLI (Command-Line Interface)
;; 

(require htdp/testing)
(require (lib "trace.ss"))

(require "unicalc-db.rkt")


;; 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.

; A global environment is used in the case of (repl), but not (pure-repl '())
(define global-environment '())

; The symbol used at the start of an identifier to signify a variable,
; as opposed to a unit.

(define variable-escape #\$)

; reserved symbols for the CLI

(define definition-symbol 'define)
(define lambda-symbol     'lambda)
(define closure-symbol    '*closure*)

; REPL = Read-Eval-Print Loop. repl repeatedly reads an expression,
; determines whether or not it is a defintion, and evaluates
; non-definitions.
; 
; Definitions modify the global-environment by adding a new binding.

; Version of repl for debugging. If there is an error,
; it is not caught and the repl will stop.

;(define (repl)
;  (begin
;    (prompt)
;    (let (
;          (expression (read))
;          )
;      (if (eof-object? expression)
;          expression
;          (begin
;           (top-level expression)
;           (repl)
;           ))
;      )
;    ))


; A relatively-functional read-eval-print loop
; Only the print part is non-functional.

(define (pure-repl env)
  (begin
    (prompt)
    (let (
          (expression (read))
          )
      (if (eof-object? expression)
          expression
          (pure-repl (pure-top-level expression env))))))

; Production version of repl:
; does the following repeatedly, until end-of-file:
;     prompt for entry
;     read an expression
;     evaluate the expression
;     print the value
;     If there is an error, it is shown, but the program continues.

(define (repl)
  (begin
    (prompt)
    (let* (
          (expression (read))
          )
      (if (eof-object? expression)
          expression
          (begin
           (with-handlers (((lambda(x) #t) ueval-error-handler))
             (top-level expression))
           (repl)
           ))
      )
    ))


;; Prompt the user to enter an expression.

(define (prompt)
  (begin 
    (newline)
    (display "> ")))


; ueval-error is an interface for error messages.
; Currently it just calls the built-in error function, which throws an exception, 
; printing a message, then stopping.

(define (ueval-error msg exp)
  (raise-user-error (string-append msg ": " (item->string exp))))


; Define error handler

; This display the message and value part of the exception.
; The user does not want to see the rest.

(define (ueval-error-handler exception)
   (display (string-append "*** error:" (exn-message exception))))


; Create a string from a fairly arbitrary data item.

(define (item->string x)
  (cond
    ((number? x) (number->string x))
    ((symbol? x) (symbol->string x))
    ((list? x)   (apply string-append (map item->string x)))
    (else "unconvertible S-expression")))


; Determine whether the quantity has an empty numerator and denominator

(define (pure-numeric? quantity)
  (and (quantity? quantity)
       (null? (num quantity))
       (null? (den quantity))))


; Determine whether argument is the right internal form to be a Unicalc quantity:
; (<number> (<symbol> ...) (<symbol> ...))

(define (quantity? x)
  (and 
   (list? x)
   (length3? x)
   (number? (first x))
   (symbol-list? (second x))
   (symbol-list? (third x))))


; Determine whether or not the argument is a user-defined variable.

(define (variable-symbol? exp)
  (and (symbol? exp) 
       (char=? variable-escape (string-ref (symbol->string exp) 0))))


; Top-level evaluator decides whether we have a user definition or not.
; If a definition, pass to handle-definition, otherwise to handle-evaluation.

(define (top-level expression)
  (if (user-definition? expression)
     (handle-definition expression)
     (handle-evaluation expression)))


; pure-top-level evaluator decides whether we have a user definition or not.
; If a definition, pass to handle-definition, 
; otherwise pass to handle-evaluation.

(define (pure-top-level expression env)
  (if (user-definition? expression)
     (pure-handle-definition expression env)
     (begin 
       (print (ueval expression env))
       env)))                          ; return env unchanged


; Determine whether or not expression is a user definition, 
; in the form (define <var> <expression>)

(define (user-definition? expression)
  (and (length3? expression)                         ; a length-3 list
       (equal? definition-symbol (first expression)) ; beginning with def-symbol
       (variable-symbol? (second expression))))      ; then a variable symbol
       

; Handle a user definition, already established to be
; in the form (define <var> <expression>)

(define (handle-definition definition)
  (let (
        (variable (second definition))
        (result (ueval (third definition) global-environment)) ; RHS value
        )
    (begin
      (set! global-environment 
            (newenv variable result global-environment))
      (print result)
      result)))


; Handle a user definition, already established to be
; in the form (define <var> <expression>)

(define (pure-handle-definition definition env)
  (let (
        (variable (second definition))
        (result (ueval (third definition) env)) ; RHS value
        )
    (begin
      (print result)
      (newenv variable result env)))) ; return new environment


; Return a new environment in which variable is bound to a value

(define (newenv variable value env)
  (cons (list variable value) env))


; Handle evaluation of a "pure" expression, which is not a user definition.
; Calls ueval on the expression, then prints the value.

(define (handle-evaluation expression)
  (let (
        (value (ueval expression global-environment))
        )
    (begin
      (print value)
      value)))


; ueval evaluates a Unicalc language expression in the indicated env
; Definitions are assumed to be handled outside this, so that
; ueval is pure functional programming.

(define (ueval expression env)
  (cond 
    ((number? expression)          (make-numeric-quantity expression))
    ((variable-symbol? expression) (get-value expression env))
    ((symbol? expression)          (normalize-unit expression))
    ((lambda? expression)          (eval-lambda expression env))
    ((non-empty-list? expression)  (eval-operator 
                                     (first expression) 
                                     (rest expression) 
                                     env))
    (else (ueval-error "expression not understood:" expression))))


; Check whether the expression is a lambda expression.

(define (lambda? expression)
  (and
   (not (null? expression))
   (equal? lambda-symbol (first expression))))


; Evaluate a lambda expression.

(define (eval-lambda expression env)    ; e.g. (lambda (x y) (* x (/ y z)))
  (let ((vars-body (rest expression) )) ; e.g. ((x y) (* x (/ y z)))
  (if (and
        (not (null? vars-body))
        (flat-list? (first vars-body))   ; vars, e.g. (x y)
        (not (null? (rest vars-body)))   ; body, e.g. ((x y) (* x (/ y z)))
        (null? (rest (rest vars-body))))
      (make-closure 
        (first vars-body) 
        (second vars-body) 
        env)
      (ueval-error "lambda expression mal-formed: " expression))))


; Make a closure out of a list a variables, a body, and an environment

(define (make-closure vars body env)
  (list closure-symbol vars body env))


; Check whether an expression is a closure
; (could be made more secure).

(define (closure? expression)
  (and
   (list?  expression)
   (not (null? expression))
   (equal? closure-symbol (first expression))))


; Return the list of formal variables in a closure.

(define (get-vars closure)
  (second closure))


; Return the body of a closure.

(define (get-body closure)
  (third closure))


; Return the environment of a closure.

(define (get-env closure)
  (fourth closure))


; Determine whether the argument is a flat list of symbols

(define (flat-list? L)
  (or
   (null? L)
   (and 
    (symbol? (first L))
    (flat-list? (rest L)))))


; same-length? checks whether two lists are the same length

(define (same-length? L M)
  (cond ((null? L) (null? M))
        ((null? M) #f)
        (else (same-length? (rest L) (rest M)))))


; add-bindings adds bindings to an environment based on 
; a list of variables L and a list of values M.

(define (add-bindings L M env)
  (if (null? L)
      env
      (newenv (first L) (first M) (add-bindings (rest L) (rest M) env))))


; eval-operator deals with the special case of an operator applied
; to some arguments, args, which are "formal" unevaluated arguments.

(define (eval-operator operator args env)
      (case operator
        ('/ (eval-divide args env))    ;; handle built-ins first
        ('* (eval-multiply args env))
        (else
          (eval-user-function operator args env))))


; eval-user-function handles the case of a user-defined
; function in the operator position.
; That must be a variable that evaluates to a closure.

(define (eval-user-function operator args env)
  (apply-closure
    (get-value operator env)  ; Get variable binding from environment
    (ueval-list args env)))   ; Evaluate arguments


; apply-closure applies a closure to list of argument values

(define (apply-closure closure args)
  (if (same-length? (get-vars closure) args)
      (ueval
        (get-body closure)
        (add-bindings (get-vars closure) args (get-env closure)))
      (ueval-error "variable-argument mismatch in application:" (cons closure args))))


; ueval-list evaluates a list of arguments in a common environment.

(define (ueval-list args env)
  (map (lambda(exp) (ueval exp env)) args))


; eval-divide deals with the divide operator only.
; there must be exactly two formal arguments.

(define (eval-divide L env)
  (if (length2? L)
      (divide (ueval (first L) env) 
              (ueval (second L) env))
      (ueval-error "improper arguments to divide:" L)))


; eval-multiply deals with the multiply operator only.
; L is the list of formal arguments.

(define (eval-multiply L env)
  (foldl multiply one (map (lambda(exp) (ueval exp env)) L)))


; get-value gets the value of a variable in the environment.

(define (get-value var env)
  (let (
        (found (assoc var env))
        )
    (if found
        (second found)
        (ueval-error "unbound variable:" var))))


; Determine whether or not the argument is a non-empty list.

(define (non-empty-list? exp)
  (and (list? exp) (not (null? exp))))


; length2? is true just when its argument is a list of two elements.

(define (length2? x)
  (and 
   (list? x) 
   (not (null? x)) 
   (not (null? (rest x))) 
   (null? (rest (rest x)))))


; length3? is true just when its argument is a list of three elements.
       
(define (length3? x)
  (and
   (list? x)
   (not (or (null? x) (null? (rest x)) (null? (rest (rest x)))))
   (null? (rest (rest (rest x))))))


;; True for a list of only symbols

(define (symbol-list? x)
  (and
   (list? x)
   (all? symbol? x)))


;; True for a list in which every element satisfies P.

(define (all? P L)
  (foldl (lambda(x y) (and x y)) #t (map P L)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The Unicalc API begins here. ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

; Functions multiplier, num, and den extract the corresponding
; components of a quantity.

(define (multiplier quantity)  (first  quantity))
(define (num quantity)   (second quantity))
(define (den quantity) (third  quantity))


; 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))
        (num (num quantity))
        (den (den quantity))
        )
      (multiply
        (make-numeric-quantity multiplier) 
        (divide
         (normalize-all num)
         (normalize-all den)))))


; 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))
        (num1 (num quantity1))
        (den1 (den quantity1))
        
        (multiplier2 (multiplier quantity2))
        (num2 (num quantity2))
        (den2 (den quantity2))
        )
    (simplify
      (make-raw-quantity 
          (* multiplier1 multiplier2)
          (merge num1 num2)
          (merge den1 den2)))))


; 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))
        (num1 (num quantity1))
        (den1 (den quantity1))
        
        (multiplier2 (multiplier quantity2))
        (num2 (num quantity2))
        (den2 (den quantity2))
        )
    (simplify
     (make-raw-quantity 
          (/ multiplier1 multiplier2)
          (merge num1 den2)
          (merge den1 num2)))))



; 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 numerator denominator)
   (multiply
    (make-numeric-quantity multiplier) 
    (divide
     (normalize-all numerator)
     (normalize-all denominator))))


; 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 numerator denominator)
  (list multiplier numerator denominator))


; 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))
        (num   (num   quantity))
        (den (den quantity))
        )
  (make-raw-quantity 
   multiplier 
   (cancel-from den num) 
   (cancel-from num den))))


; 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)))


;; Unicalc internal Test cases

;
;(check-expect  (simplify (make-raw-quantity 1 '(foot pound) '(pound second))) '(1 (foot)(second)))
;
;(check-expect  (simplify (make-raw-quantity 1 '(foot meter pound pound) '(foot pound second))) '(1 (meter pound)(second)))
;
;(check-expect  (make-quantity 1 '(foot) '(second)) '(0.30479449356 (meter) (second)))
;
;
;(check-expect  (convert-unit 'kg 'gram) '(1000 () ()))
;
;(check-expect  (convert-unit 'pound 'ounce)'(16.0 () ()))
;
;(check-expect  (convert-unit 'pound 'gram)'(453.59237 () ()))


; API Tests Provided

; Relative to Version 2010 September 19, 10:07 PM

; Tests for normalize-unit

(check-expect  (normalize-unit 'second)    '(1 (second)()))
(check-expect  (normalize-unit 'kilometer) '(1000 (meter) ()))
(check-expect  (normalize-unit 'gram)      '(1/1000 (kg) ()))
(check-expect  (normalize-unit 'day)       '(86400 (second) ()))
(check-expect  (normalize-unit 'newton)    '(1 (kg meter) (second second)))
(check-within  (first (normalize-unit 'pound_force)) 4.44822162 1e-7)

; Tests for normalize

(check-expect (normalize '(1 (minute)()))        '(60 (second)()))
(check-expect (normalize '(1 (hour)()))          '(3600 (second)()))
(check-expect (normalize '(1 (day)()))           '(86400 (second)()))
(check-expect (normalize '(1 (year)()))          '(31536000 (second)()))
(check-expect (normalize '(1 (fortnight)(week))) '(2 ()()))
(check-expect (normalize '(1 (fortnight)()))     '(1209600 (second)()))
(check-expect (normalize '(1 (gram)(year)))      '(1/31536000000 (kg) (second)))
(check-expect (normalize '(1 (kg)(gram)))        '(1000 ()()))

(check-expect (normalize '(1 (weber)()))         '(1 (kg meter meter) 
                                          (ampere second second second second)))

(check-expect  (normalize '(1 (newton meter)(second))) 
               '(1 (kg meter meter) (second second second)))

(check-expect  (normalize '(1 (volt)())) 
               '(1 (kg meter meter) (ampere second second second)))

(check-within (first (normalize '(1 (inch)(meter))))        0.0254            0)
(check-within (first (normalize '(1 (foot)(meter))))        0.3048         1e-5)
(check-within (first (normalize '(1 (foot)(inch))))         12             1e-8)
(check-within (first (normalize '(1 (light_year)(inch))))   3.72461748e+17 1e13)
(check-within (first (normalize '(1 (btu)(calorie))))       252            1e-1)
(check-within (first (normalize '(1 (furlong)(meter))))     201.164        .005) 
(check-within (first (normalize '(1 (mile)(hour))))         0.44704        1e-5)
(check-within (first (normalize '(1e6 (pound)(mile mile)))) 0.175133       1e-5)
(check-within (first (normalize '(1 (fortnight meter)(furlong second)))) 
                                                            6012.88475        1)

; Tests for multiply

(check-expect  (multiply '(1 () ()) 
                         '(1 (kg meter)(second))) 
               '(1 (kg meter)(second)))

(check-expect  (multiply '(1 (chicken) (meter meter)) 
                         '(100 (meter meter) ())) 
               '(100 (chicken) ()))

(check-within (first (multiply (normalize '(1 (foot) ())) 
                               (normalize '(1 (acre) ()))))
                                                            1233.48184     1e-4)
; Tests for divide

(check-expect (divide '(1 (meter)())'(1 (second)())) 
              '(1 (meter)(second)))

(check-within (first (multiply (normalize '(100 (tadpole) (gallon))) 
                               (normalize '(1 (meter meter meter) ()))))
                                                               26417.2       .1)

(check-within (first (divide (normalize '(1 (foot)())) 
                             (normalize '(1 (inch)())))) 12 1e-6)

(check-within (first (divide 
          (normalize '(1 (foot meter pound pound) (foot pound second)))
          (normalize '(1 (pound second second) (meter newton))))) 
      1 1e-4)

(check-within (first (divide (normalize '(1 (yard)())) 
                             (normalize '(1 (foot)())))) 
              3.0 1e-10)

(check-expect  (divide (normalize '(1 (mile)())) (normalize '(1 (foot)()))) 
               '(5280.0 () ()))


;; Unicalc internal top-level tests
;; These test your top-level function without using the command-line interface.
;; Function top-level is the thing that is passed the expression read by
;; the (read) in the read-eval-print loop. 
;; It returns a Quantity, which can be rendered as desired.
;; The point of these test is to provide a way of debugging and testing without
;; using the read-eval-print-loop. There is a corresponding set of test that
;; can be provided as input to the program.
;
;
(check-expect  (top-level 1)                          '(1      ()            ()))
(check-expect  (top-level 'meter)                     '(1      (meter)       ()))
(check-expect  (top-level 'day)                       '(86400 (second)       ()))
(check-expect  (top-level '(/ meter second))          '(1      (meter)       (second)))
(check-expect  (top-level '(* kg meter))              '(1      (kg meter)    ()))
(check-expect  (top-level '(* meter kg))              '(1      (kg meter)    ()))
(check-expect  (top-level '(/ (* meter kg) second))   '(1      (kg meter)    (second)))
(check-expect  (top-level '(/ 24 6))                  '(4      ()            ()))
(check-expect  (top-level '(* 2 3 4 5))               '(120    ()            ()))
(check-expect  (top-level '(*))                       '(1      ()            ()))
(check-expect  (top-level '(/ 24 (* 2 3)))            '(4      ()            ()))
(check-expect  (top-level '(/ (* 8 3) (* 2 3)))       '(4      ()            ()))
(check-expect  (top-level '(define $a 999))           '(999    ()            ()))
(check-expect  (top-level '$a)                        '(999    ()            ()))
(check-expect  (top-level '(* $a 2))                  '(1998   ()            ()))
(check-expect  (top-level '(* $a $a))                 '(998001 ()            ()))
(check-expect  (top-level '(* $a meter))              '(999    (meter)       ()))
(check-expect  (top-level '(* $a (/ meter second)))   '(999    (meter)       (second)))
(check-expect  (top-level '(/ (* $a meter) second))   '(999    (meter)       (second)))
(check-expect  (top-level 'newton)                    '(1      (kg meter)    (second second)))
(check-expect  (top-level '(* newton second))         '(1      (kg meter)    (second)))
(check-expect  (top-level '(/ liter meter))           '(1/1000 (meter meter) ()))
(check-expect  (top-level '(/ liter (* meter meter))) '(1/1000 (meter)       ()))
(check-expect  (top-level '(define $x (* newton second)))  '(1      (kg meter)    (second)))
(check-expect  (top-level '(* $a $x))                 '(999    (kg meter)    (second)))


(generate-report)

; Choose (repl) or (pure-repl '()) for destructive or functional version respectively

; (repl)

; (pure-repl '())