#lang racket

; file:    a05.rkt
; purpose: User-friendly Unicalc evaluator
; author:  Robert Keller

(require (lib "trace.ss"))
(require "unicalc-db.rkt")

; Unicalc symbols used in output

(define multiply-op '* )
(define divide-op   '/ )

; Classify important input characters in terminal alphabet

(define left-paren     #\()
(define right-paren    #\))
(define divide-char    #\/)
(define carat-char     #\^)
(define point-char     #\.)
(define e-char         #\e)
(define variable-start #\$)
(define equal-sign     #\=)
(define minus-sign     #\-)
(define plus-sign      #\+)

(define sign (string->list "+-"))

(define digit-char 
  (string->list "01234567789"))

(define alpha-char 
  (string->list "$abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"))

(define alpha-or-digit-char 
  (string->list "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_01234567789"))

(define define-word (string->list "define ")) ;; note that this ends in blank

; Read-Eval-Print loop that calls the parser, which calls the Unicalc evaluator.

(define (repl)
  (begin
    (prompt)
    (let (
          (string (read-line)) ; reads one line as a string
          )
      (if (eof-object? string)
          string
          (begin
           (parse-and-eval string)      ; call top-level parse with string
           (repl)
           ))
      )
    ))

;; Prompt the user to enter an expression.

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


; Parse function success and failure abstractions:
;
; RUI stands for "Remaining Unparsed Input".
; It will be a list of characters.
;
; The rule argument is used for instrumentation purposes in tracing,
; so that we can see which parse functions succeed or fail.

; Constant symbols for tracing purposes
(define success 'success)
(define failure 'failure)


; Call succeed to return in the case a parse function succeeds
; rule is a symbol representing the function.
; newRUI is the new value of remaining unparsed input.

(define (succeed rule newRUI result) 
  (list success rule newRUI result))


; Call fail to return in the case a parse function succeeds
; rule is a symbol representing the function.
; newRUI is the new value of remaining unparsed input.

(define (fail rule RUI)
  (list failure rule RUI))


; Call success? to determine whether a parse function result succeeded.

(define (success? result)
  (equal? success (first result)))


; Call failure? to determine whether a parse function result failed.

(define (failure? result)
  (equal? failure (first result)))


; Call residual to get the remaining unparsed input from a result.

(define (residual result)
  (third result))


; Call result to get the result, in the case of success

(define (result arg)
  (fourth arg))


; The top-level parse function.
; Given a string, attempts to parse the string.
; The string is first converted to a list of characters,
; which is used by the parse functions as their RUI argument.

(define (parse-and-eval string)
  (let (
        (RUI (skip-white (string->list string)))
        )
    (if (null? RUI)
        '()           ; case of a blank line: do nothing
        (begin 
          (display "line:        ")
          (display string)
          (newline)
    (let (
        (definition-result (parse-definition RUI))
        )
    (if (success? definition-result)
        (show-success definition-result string)
        (let (
              (S-result  (parse-S RUI))
              )
          (if (success? S-result )
              (show-success S-result  string)
              (display (string-append "parse of " string " failed"))))))))))


; Displays result when successful

(define (show-success outcome string)
    (if (success? outcome)
        (begin
          (display (string-append "syntax tree: "))
          (display (result outcome))
          (if (null? (residual outcome))
              '()
              (begin 
                (display " but with residual ")
                (display (list->string (residual outcome)))))
          (newline)
          (top-level (result outcome))
          )
        (display (string-append "parse of " string " failed"))))


; parser for definitions

(define (parse-definition RUI)
  (let (
        (initial (parse-word RUI define-word))
        )
    (if (success? initial)                             ; Do we have the word "define"?
        (let (
              (RUI (skip-white (residual initial)))
              )
          (if (starts-with variable-start RUI)         ; Do we have the variable-start?
              (let (                     
                    (var-result (parse-A-helper (rest RUI) (list variable-start)))
                    )
                (if (success? var-result)              ; Do we have a variable?
                    (let (
                          (RUI (skip-white (residual var-result)))
                          )
                      (if (starts-with equal-sign RUI) ; Is there an equal-sign?
                          (let (
                                (RHS (parse-S (rest RUI)))
                                )
                            (if (success? RHS)         ; Is there a right-hand side expresion.
                                (succeed 'definition (residual RHS) 
                                         (list 'define ; This def passed to ueval.
                                               (result var-result) 
                                               (result RHS)))
                                (fail 'definition RUI)))
                          (fail 'parse-top RUI)))
                    (fail 'parse-top RUI)))
                (fail 'definition RUI)))
          (fail 'definition RUI))))


;  Parser for S -> E {{space | /} E}* with grouping to the left.

(define (parse-S RUI)
  (let (
        (RUI (skip-white RUI))                ; Skip any initial whitespace.
        )
    (if (null? RUI)
        (fail 'S RUI)
        (let (
              (E-result (parse-E RUI))        ; Try the first E.
             )
          (if (failure? E-result)
              (fail 'S RUI)
              (parse-S-helper                 ; Call the helper below to finish up.
               (residual E-result) 
               (list (result E-result)))))))) ; with accumulator holding first E result.


; Helper function for parse-S: Handles {{space | /} E}*
; and groups to the left by using an accumulator.

(define (parse-S-helper RUI Acc)
  (let (
        (RUI (skip-white RUI))                ; Skip any whitespace.
        )
    (if (null? RUI)
        (succeed 'S RUI (finalize Acc))       ; Nothing more, so return accumulated result.
    (if (starts-with divide-char RUI)         ; Check for the / case.
        (let (
              (E-result (parse-E (rest RUI))) ; Have /, so divide by next E.
              )
          (if (success? E-result)
              (parse-S-helper 
                (residual E-result)
                (list (list divide-op         ; Create the expression representing division.
                            (finalize Acc) 
                            (result E-result))))
              (fail 'S RUI)))
        (let (                                ; Handle the non-divide case
              (E-result (parse-E RUI))
              )
          (if (success? E-result)             ; Is there another E?
              (parse-S-helper
                (residual E-result)
                (cons (result E-result) Acc)) ; Yes, so continue
              (succeed 'S RUI (finalize Acc)))))))) ; No E, so finish up.


; finalize finalizes the accumulator for parse-S-helper
; by reversing the list of that was accumulated using cons
; and putting the multiply operator on the front

(define (finalize Acc)
  (cond
    ((null? Acc)        1)                    ; If the list is empty, return 1
    ((null? (rest Acc)) (first Acc))          ; Avoid redundant multiply op for 1 unit.
    (else (cons multiply-op (reverse Acc))))) ; Do include multiply op.


; parse E -> P | P^I

(define (parse-E RUI)
  (cond
    ((null? RUI) (fail 'E RUI))
    (else (let (
                (P-result (parse-P (skip-white RUI)))           ; Try the initial P.
                )
            (if (success? P-result)
                (let (
                      (residue (skip-white (residual P-result))) 
                      )
                  (if (starts-with carat-char residue)          ; See if there's a carat.
                      (let (
                            (I-result (parse-I (rest residue))) ; Get the exponent.
                            )
                        (if (success? I-result)
                            (succeed 'E                         ; There was an exponent.
                                     (residual I-result) 
                                     (raise (result P-result) 
                                            (result I-result)))
                            (fail 'E RUI)))
                      (succeed 'E                               ; No carat or exponent.
                               (residual P-result) 
                               (result P-result)))) 
                (fail 'E RUI))))))                              ; No P.


; raise a primary to an integer (positive or negative) power
; This is used by parse-E

(define (raise A E)
  (if (>= E 0)
      (raise-helper A E '())                          ; non-negative power
      (list divide-op 1 (raise-helper A (- E) '())))) ; Negative power: indicates division.
  
; raise-helper achieves power by repeated multiplication.

(define (raise-helper A E Acc)
  (cond 
    ((= E 0) (cons multiply-op Acc))
    (else (raise-helper A (- E 1) (cons A Acc)))))


; parse an integer exponent: I -> {+ | - | empty} D D*

(define (parse-I RUI)
  (let (
        (RUI (skip-white RUI))
        )
    (if (starts-with minus-sign RUI)
        (let (
              (E-neg (parse-I (rest RUI)))
              )
          (if (success? E-neg)
              (succeed 'E (residual E-neg) (- (result E-neg)))
              (fail 'E RUI)))
    (if (starts-with plus-sign RUI)
        (let (
              (E-pos (parse-I (rest RUI)))
              )
          (if (success? E-pos)
              (succeed 'E (residual E-pos) (result E-pos))
              (fail 'E RUI)))
    (if (starts-with-a digit-char RUI)
        (let (
              (EH (parse-I-helper (rest RUI) (list (first RUI))))
              )
          (succeed 'E (residual EH)
          (string->number 
           (list->string 
            (reverse (result EH))))))
        (fail 'E RUI))))))

; parse-I-helper gets the remaining digits

(define (parse-I-helper RUI Acc)
  (if (starts-with-a digit-char RUI)
      (parse-I-helper (rest RUI) (cons (first RUI) Acc))
      (succeed 'E-helper RUI Acc)))

; parse a primary: P -> C | U  | V | '(' S ')'
; Note that both U and V are handled by parse-A-helper

(define (parse-P RUI)
  (cond
    ((null? RUI)  (fail 'P RUI))
    ((starts-with-a digit-char   RUI) (parse-C-helper1 (rest RUI) (list (first RUI)   )))
    ((starts-with point-char     RUI) (parse-C-helper2 (rest RUI) (list (first RUI))   ))
    ((starts-with-a alpha-char   RUI) (parse-A-helper  (rest RUI) (list (first RUI)   )))
    ((starts-with variable-start RUI) (parse-A-helper  (rest RUI) (list variable-start)))
    ((starts-with left-paren     RUI) 
     (let (
           (S-result (parse-S (rest RUI)))  ; Get what is between parens.
           )
       (if (success? S-result)
           (let (
                 (residue (skip-white (residual S-result)))
                 )
             (if (starts-with right-paren residue)
                 (succeed 'P (rest residue) (result S-result))
                 (fail 'P RUI)))
           (fail 'P RUI))))
    (else (fail 'P RUI))))


; parse-A handles strings of alpha or numeric chars, such as the tails of units or vars.

(define (parse-A RUI)
  (cond
    ((null? RUI)  (fail 'A RUI))
    ((starts-with-a alpha-char RUI) (parse-A-helper  (rest RUI) (list (first RUI))))
    ((starts-with-a digit-char RUI) (parse-C-helper1 (rest RUI) (list (first RUI))))
    ((starts-with point-char RUI)   (parse-C-helper2 (rest RUI) (list (first RUI))))
    (else                           (fail 'A RUI))))

(define (parse-A-helper RUI Acc)
  (if (or (null? RUI) (not (starts-with-a alpha-char RUI)))
      (succeed 'A RUI (list->symbol (reverse Acc)))
      (parse-A-helper (rest RUI) (cons (first RUI) Acc))))


; C is for "coefficient"
; There are several helper functions, to deal with the variety, e.g. whether
; there is a decimal point or scientific notation, e.g.  |+123.45e-67
; The vertical bar | in comments shows the part of the coefficient being parsed 
; in each rule, using +123.45e-67 as if generic.

(define (parse-C RUI)
  (cond
    ((null? RUI)                    (fail 'C RUI))
    ((starts-with-a sign RUI)       (parse-C-helper0 (rest RUI) (list (first RUI))))
    ((starts-with-a digit-char RUI) (parse-C-helper1 (rest RUI) (list (first RUI))))
    ((starts-with point-char RUI)   (parse-C-helper2 (rest RUI) (list (first RUI))))
    (else                           (fail 'C RUI))))

; parse-C-helper0 continues parsing when there was a sign +|123.45e-67

(define (parse-C-helper0 RUI)
  (cond
    ((null? RUI)                    (fail 'C RUI))                
    ((starts-with-a digit-char RUI) (parse-C-helper1  (rest RUI) (list (first RUI))))
    ((starts-with point-char RUI)   (parse-C-helper2 (rest RUI) (list (first RUI))))
    (else                           (fail 'C RUI))))

; parse-C-helper1 continues parsing when there was a non-fractional digit: +1|23.45e-67

(define (parse-C-helper1 RUI Acc)
  (cond 
    ((null? RUI)                    (succeed 'C RUI (finalize-C Acc)))
    ((starts-with-a digit-char RUI) (parse-C-helper1 (rest RUI) (cons (first RUI) Acc)))
    ((starts-with point-char RUI)   (parse-C-helper2 (rest RUI) (cons (first RUI) Acc)))
    ((starts-with e-char RUI)       (parse-C-helper3 (rest RUI) (cons (first RUI) Acc)))
    (else                           (succeed 'C RUI (finalize-C Acc)))))

; parse-C-helper2 continues parsing when there was a decimal point: +123.|45e-67

(define (parse-C-helper2 RUI Acc)
  (cond
    ((starts-with-a digit-char RUI) (parse-C-helper2 (rest RUI) (cons (first RUI) Acc)))
    ((starts-with e-char RUI)       (parse-C-helper3 (rest RUI) (cons (first RUI) Acc)))
    (else                           (succeed 'C RUI (finalize-C Acc)))))

; parse-C-helper3 continues parsing when there was an E (exponent) character: +123.45e|-67

(define (parse-C-helper3 RUI Acc)
  (cond
    ((starts-with-a sign RUI)       (parse-C-helper4 (rest RUI) (cons (first RUI) Acc)))
    ((starts-with-a digit-char RUI) (parse-C-helper5 (rest RUI) (cons (first RUI) Acc)))
    (else                           (fail 'C RUI))))

; parse-C-helper4 continues parsing when there was an exponent and maybe sign: +123.45e-|67

(define (parse-C-helper4 RUI Acc)
  (cond 
    ((starts-with-a digit-char RUI) (parse-C-helper5 (rest RUI) (cons (first RUI) Acc)))
    (else                           (fail 'C RUI))))

; parse-C-helper5 continues parsing the digits of an exponent: +123.45e-6|7

(define (parse-C-helper5 RUI Acc)
  (cond
    ((starts-with-a digit-char RUI) (parse-C-helper5 (rest RUI) (cons (first RUI) Acc)))
    (else                           (succeed 'C RUI (finalize-C Acc)))))

; finalize-C finalizes the accumulated result of parsing a coefficient
; by reversing the accumulated characters and converting to a number

(define (finalize-C Acc)
  (string->number (list->string (reverse Acc))))


; Utility to determine whether the RUI starts with a specific character
    
(define (starts-with char RUI)
  (and (not (null? RUI))
       (char=? char (first RUI))))


; Determine whether the RUI starts with a character IN a specified list of chars.

(define (starts-with-a L RUI)
  (and (not (null? RUI))
       (member (first RUI) L)))


; Determine whether the RUI starts with a specific list of characters.

(define (parse-word RUI list-of-chars)
  (parse-word-helper (skip-white RUI) list-of-chars))

(define (parse-word-helper RUI chars)
  (if (null? chars)
      (succeed 'parse-word RUI '())
      (if (char=? (first RUI) (first chars))
          (parse-word-helper (rest RUI) (rest chars))
          (fail 'parse-word RUI))))


; utility to convert list of characters to a string

(define (list->symbol L)
  (string->symbol (list->string L)))


; whitespace parser skipping function

(define (skip-white RUI)
  (cond
    ((null? RUI) '())
    ((char-whitespace? (first RUI)) (skip-white (rest RUI)))
    (else RUI)))


; Render the result for readability.
                    
(define (render output)
  (if (string? output)
      output
  (if (number? output)
      (number->string output)
  (if (quantity? output)
      (render-quantity output)
      (error "unrecognized output: " output)))))
      
; Render a quantity for readability.
                    
(define (render-quantity quantity)
      (let* (
             (multiplier (multiplier quantity))
             (mult-string (number->string multiplier))
             (numrator (num quantity))
             (denom (den quantity))
             )
        (cond ((zero? multiplier) mult-string)       ;; only show 0
              ((and (null? numrator) (null? denom)) 
                 mult-string)                        ;; only show multiplier
              ((null? denom) 
                 (render-list mult-string numrator)) ;; only show numrator
              ((null? numrator) (string-append 
                                  mult-string 
                                  (render-list " /" denom))) ;; Show multiplier/denom
              (else             (string-append 
                                   mult-string 
                                   (render-list "" numrator) 
                                   (render-list " /" denom)))))) ;; show everything


; render the numerator or denominator part of a list as a product
; of units, with exponents where the exponent is >1

(define (render-list mult-string L)
   (if (null? L)
       mult-string
       (render-list-helper (rest L) (first L) 1 mult-string)))

; render-list helper handles powers in the result.

(define (render-list-helper L Unit Exponent Acc)
  (if (null? L)
      (render-power Unit Exponent Acc)
      (if (equal? (first L) Unit)
          (render-list-helper (rest L) 
                              Unit 
                              (+ 1 Exponent) 
                              Acc)
          (render-list-helper (rest L) 
                              (first L) 
                              1 
                              (render-power Unit Exponent Acc)))))


; render a unit with an exponent that could be 0, 1, or higher

(define (render-power Unit Exponent Acc)
  (cond 
    ((= 0 Exponent) Acc)
    ((= 1 Exponent) (string-append Acc
                                   " " 
                                   (symbol->string Unit)))
    (else (string-append Acc 
                         " " 
                         (symbol->string Unit) 
                         "^" 
                         (number->string Exponent)))))


;; Render a list of units as a single string

(define (units->string L)
  (if (null? (rest L))
      (string-append " " (symbol->string (first L)))
      (string-append 
       " (" 
       (symbol->string (first L))
       (apply string-append (map (lambda(x) (string-append " " (symbol->string x))) (rest L)))
       ")"
       )))

;;;;;;;;;;;;;end parser stuff 

            
;;;;;;;;;;;;; begin a04 stuff 

;; File:    a04.rkt
;; Author:  Robert Keller
;; Purpose: Unicalc Language (with user-defined functions, let, etc.)
;; 

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

(define global-environment '())

(define variable-escape #\$)

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


; 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)
   (has-exactly-3-elements? 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)))


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

(define (user-definition? expression)
  (and (list? expression)                            ; a list
       (not (null? expression))                      ; that is non-empty
       (equal? definition-symbol (first expression)) ; beginning with def-symbol
       (not (null? (rest expression)))               ; with at least two elements:
       (variable-symbol? (second expression))        ; a variable symbol
       (not (null? (rest (rest expression))))        ; and another element
       (null? (rest (rest (rest expression))))))     ; but not more than three.
       

; 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))
      (display "defined ")
      (display variable)
      (display " as: ")
      (display (render result))
      (newline)
      result)))


; 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
      (display "raw result:  ")
      (display value)
      (newline)
      (display "rendered:    ")
      (display (render value))
      (newline)
      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))
    ((let? expression)             (eval-let expression env))
    ((let*? expression)            (eval-let* 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 let expression.

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

(define (eval-let expression env)
  (let ((eqns-body (rest expression)))
    (if (and
         (not (null? eqns-body))
         (equation-list? (first eqns-body))
         (not (null? (rest eqns-body)))
         (null? (rest (rest eqns-body))))
        (let* (
               (eqns (first eqns-body))
               (body (second eqns-body))
               (LHS (map first eqns))
               (RHS (ueval-list (map second eqns) env))
              )
           (ueval body (add-bindings LHS RHS env)))
        (ueval-error "invalid let-expression" expression))))

; Check whether L is a well-formed equation list.

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

; Check whether E is a well-fored equation.

(define (equation? E)
  (and (not (null? E))
       (symbol? (first E))
       (not (null? (rest E)))
       (null? (rest (rest E)))))


; Check whether the expression is a let* expression.

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

; Evaluate a let* epression

(define (eval-let* expression env)
  (let ((eqns-body (rest expression)))
    (if (and
          (not (null? eqns-body))
          (equation-list? (first eqns-body))
          (not (null? (rest eqns-body)))
          (null? (rest (rest eqns-body))))
        (eval-let*-helper (first eqns-body) (second eqns-body) env)
        (ueval-error "invalid let*-expression" expression))))

(define (eval-let*-helper eqns body env)
  (if (null? eqns)
      (ueval body env)
      (let* (
             (eqn (first eqns))
             (var (first eqn))
             (exp (second eqn))
             (value (ueval exp env))
             )
        (eval-let*-helper (rest eqns) body (newenv var value env)))))
        

; Check whether the expression is a lambda expression.

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


; Evaluate a lambda expression, returning a closure.

(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
        ('if (eval-if args env))
        ('/ (eval-divide args env))    ;; handle built-ins first
        ('* (eval-multiply args env))
        ('< (eval-compatible operator args env))
        ('> (eval-compatible operator args env))
        ('= (eval-compatible operator args env))
        (else
          (eval-user-function operator args env))))

; Evaluate an 'if expression.

(define (eval-if args env)
  (if (and
       (not (null? args))
       (not (null? (rest args)))
       (not (null? (rest (rest args))))
       (null? (rest (rest (rest args)))))
      (let ((condition (ueval (first args) env)))
        (cond 
          ((equal? condition #t) (ueval (second args) env))
          ((equal? condition #f) (ueval (third args) env))
          (else (ueval-error "condition did not evaluate to #t or #f" (first args)))))
      (ueval-error "if expression malformed" (cons if-symbol args))))


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


; evaluation of 2-argument operator with compatibility check

(define (eval-compatible operator L env)
  (if (length2? L)
      (let (
            (Q1 (ueval (first L) env))
            (Q2 (ueval (second L) env))
            )
        (if (compatible? Q1 Q2)
            (case operator
              ('< (< (multiplier Q1) (multiplier Q2)))
              ('> (> (multiplier Q1) (multiplier Q2)))
              ('= (= (multiplier Q1) (multiplier Q2)))
              (else (ueval-error "unrecognized operator" operator)))
            (ueval-error "arguments are not compatible for operator" operator)))
      (ueval-error "wrong number of arguments to operator" operator)))


; 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)
        (let (
              (found (assoc var global-environment))
              )
          (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)))))


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


;; Determine whether the argument is a list of exactly 3 elements
       
(define (has-exactly-3-elements? x)
  (and
   (not (or (null? x) (null? (rest x)) (null? (rest (rest x)))))
   (null? (rest (rest (rest x))))))


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


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Definitions below this line are not required in assignment 2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Add two unicalc quantities, returning a normalized quantity.
; If either argument is zero, use units of the other.
; If the quantities are not interconvertible, an error is returned.

(define (add x y)
  (cond ((zero? (multiplier x)) y)
        ((zero? (multiplier y)) x)
        (else
  (let (
        (ynx (in-units-of y x))
        )
  (if (same-units? x ynx)
      (make-raw-quantity 
       (+ (multiplier x) (multiplier ynx)) 
       (num x) 
       (den x))
      (error "illegal add" x y))))))


; Determine whether two normalized quantities have the same units.

(define (same-units? x y)
  (and
   (equal? (num x)(num y))
   (equal? (den x)(den y))))


; Subtract the second unicalc quantity from the first.
; If either argument is zero, use units of the other.
; If the quantities are not interconvertible, an error is returned.

(define (subtract x y)
  (let (
        (ynx (in-units-of y x))
        )
  (cond ((zero? (multiplier x)) (negate y))
        ((zero? (multiplier y)) x)
        (else
  (if (same-units? x ynx)
      (make-raw-quantity 
       (- (multiplier x) (multiplier ynx)) 
       (num x) 
       (den x))
      (error "illegal subtract" x y))))))


; Negate the argument quantity.

(define (negate x)
  (make-quantity (- (multiplier x)) (num x) (den x)))
  
  
; Convert quantity x to the units of y

(define (in-units-of x y)
  (if (zero? (multiplier y))
      (make-quantity 0 (num x) (den x))
      (multiply (convert x (single-unit-of y)) (single-unit-of y))))


; Return a single unit of whatver unicalc quantity x is.
           
(define (single-unit-of x)
  (make-raw-quantity 1 (num x) (den x)))


; Convert one quantity to another, giving the conversion factor.

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


; Convert one unit to another, giving the conversion factor.

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


(define (compatible? Q1 Q2)
  (let ((conversion (convert Q1 Q2)))
    (and
     (null? (num conversion))
     (null? (den conversion)))))

; (trace )

(repl)