;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(planet plai/plai:1:6/lang/reader)
; a few helper functions to define precise contracts and to manage lists of symbol/value pairs

(define (list-of? p)
  (lambda (x) 
    (or (empty? x)
    	(pair-of? p (list-of? p)))))

(define (pair-of? p1 p2)
  (lambda (x)
    (and (pair? x)
         (p1 (car x))
         (p2 (cdr x)))))

(define (zip k l)
  (if (or (empty? k) (empty? l))
      empty
      (cons (cons (first k) (first l))
            (zip (rest k) (rest l)))))

(define (lookup namedvals id)
  (local ([define entry (assoc id namedvals)])
    (if (false? entry)
        (error 'lookup "unknown identifier")
        (cdr entry))))

;
; an object-oriented language
;

(define-type OOE
  [OOE-num (n number?)]
  [OOE-add (lhs OOE?) (rhs OOE?)]
  [OOE-id (name symbol?)]
  [OOE-call (receiver OOE?) (method symbol?) (args (list-of? OOE?))]
  [OOE-fieldaccess (receiver OOE?) (fieldname symbol?)]
  [OOE-newobj (classname symbol?) (args (list-of? OOE?))]
  [OOE-self])

(define-type OOE-Value
  [OOE-numV (n number?)]
  [OOE-object (class symbol?) (fieldvals (list-of? (pair-of? symbol? OOE-Value?)))])

(define-type OOE-Method
  [OOE-method (name symbol?) (args (list-of? symbol?)) (body OOE?)])

(define-type OOE-Class
  [OOE-classdecl (name symbol?) (superclass symbol?) (fields (list-of? symbol?)) (methods (list-of? OOE-Method?))])

(define (OOE-lookup-method class methodname classenv)
  (local 
    ([define the-method 
       (memf (lambda (m) (symbol=? (OOE-method-name m) methodname)) (OOE-classdecl-methods class))])
    (if (false? the-method)
        (local ([define superclass-name (OOE-classdecl-superclass class)])
          (if (symbol=? superclass-name 'Object)
              (error 'lookup-method "Unknown method")
              (OOE-lookup-method (OOE-lookup-class classenv superclass-name) methodname classenv)))
        (first the-method))))

(define (OOE-lookup-all-fields classname classenv)
  (if (symbol=? classname 'Object) 
      '()
      (local ([define the-class (OOE-lookup-class classenv classname)])
        (append (OOE-classdecl-fields the-class) (OOE-lookup-all-fields (OOE-classdecl-superclass the-class) classenv)))))

(define (OOE-lookup-class classes classname)
  (first (memf (lambda (cd) (symbol=? (OOE-classdecl-name cd) classname)) classes)))

(define-type OOE-Env
  [OOE-anEnv (self OOE-Value?) (args (list-of? (pair-of? symbol? OOE-Value?)))])

(define (OOE-emptyEnv) 
  (OOE-anEnv (OOE-object 'Object '()) '()))

(define (OOE-lookupenv env id)
  (type-case OOE-Env env
             [OOE-anEnv (s args) (lookup args id)]))

(define (OOE-interp expr classenv env)
  (type-case OOE expr
    [OOE-num (n) 
      (OOE-numV n)]
    [OOE-add (l r) 
      (OOE-numV (+ (OOE-numV-n (OOE-interp l classenv env)) 
                   (OOE-numV-n (OOE-interp r classenv env))))]
    [OOE-id (n) 
      (OOE-lookupenv env n)]
    [OOE-self () 
      (OOE-anEnv-self env)]
    [OOE-fieldaccess (receiver fieldname)
      (type-case OOE-Value (OOE-interp receiver classenv env)
        [OOE-numV (n) (error 'OOE-interp "object expected, number found")]
        [OOE-object (cl fieldvals) (lookup fieldvals fieldname)])]
    [OOE-newobj (cn args) 
      (OOE-object cn (zip (OOE-lookup-all-fields cn classenv) 
                          (map (lambda (e) (OOE-interp e classenv env)) args)))]
    [OOE-call (receiver method args) 
      (local ([define the-rec (OOE-interp receiver classenv env)]
              [define the-args (map (lambda (e) (OOE-interp e classenv env)) args)]
              [define the-class (OOE-lookup-class classenv (OOE-object-class the-rec))]
              [define the-method (OOE-lookup-method the-class method classenv)])
        (OOE-interp (OOE-method-body the-method)
                classenv
                (OOE-anEnv the-rec (zip (OOE-method-args the-method) the-args))))]))

;
; a functional language
;

(define-type FAE
  [FAE-num (n number?)]
  [FAE-add (lhs FAE?) (rhs FAE?)]
  [FAE-with (name symbol?) (named-expr FAE?) (body FAE?)]
  [FAE-id (name symbol?)]
  [FAE-fun (param symbol?) (body FAE?)]
  [FAE-app (fun-expr FAE?) (arg-expr FAE?)])

(define (desugar expr)
  (type-case FAE expr
    [FAE-num (n) expr]
    [FAE-add (l r)  (FAE-add (desugar l) (desugar r))]
    [FAE-id (v) expr]
    [FAE-fun (bound-FAE-id bound-body) 
         (FAE-fun bound-FAE-id (desugar bound-body))]
    [FAE-app (the-fun the-arg) 
         (FAE-app (desugar the-fun) (desugar the-arg))]
    [FAE-with (FAE-id ne body)
          (FAE-app (FAE-fun FAE-id (desugar body)) (desugar ne))]))


(define-type FAE-Value
   [FAE-numV (n number?)]
   [FAE-closureV (param symbol?) (body FAE?) (env FAE-Env?)])

(define-type FAE-Env
  [FAE-emptyEnv]
  [FAE-anEnv (name symbol?) (val FAE-Value?) (rest FAE-Env?)])

(define (FAE-lookup name env)
  (type-case FAE-Env env
    [FAE-emptyEnv () 
      (error 'FAE-lookup "name not found")]
      
    [FAE-anEnv (n value rest)
      (if (symbol=? n name)
          value
          (FAE-lookup name rest))]))

; FAE-interp: FAE * FAE-Env -> FAE-Value
(define (FAE-interp expr env)
  (type-case FAE expr
    [FAE-num (n) 
      (FAE-numV n)]
    [FAE-add (l r) 
      (FAE-numV (+ (FAE-numV-n (FAE-interp l env)) 
      		   (FAE-numV-n (FAE-interp r env))))]
    [FAE-id (v) 
      (FAE-lookup v env)]
    [FAE-fun (bound-FAE-id bound-body) 
      (FAE-closureV bound-FAE-id bound-body env)]
    [FAE-app (fun-expr arg-expr)
      (let* ((closure-val (FAE-interp fun-expr env))
            (arg-val (FAE-interp arg-expr env))
            (the-env (FAE-anEnv (FAE-closureV-param closure-val) 
                    	       arg-val 
                    	       (FAE-closureV-env closure-val))))
        (FAE-interp (FAE-closureV-body closure-val) the-env))]
      
    [else (error 'FAE-interp "please desugar first")]))

; H5.1 Free Variables

(define (FAE-free-variables expr)
  (error 'FAE-free-variables "please implement me!"))

(define free-vars (FAE-free-variables (FAE-fun 'x (FAE-app (FAE-id 'f) (FAE-add (FAE-id 'y) (FAE-id 'x))))))

(test free-vars (list 'f 'y))

; H5.3 FAE to OOE translation

(define-type Exp*Classenv
  [e*c (exp OOE?) (classenv (list-of? OOE-Class?))])

;; FAE->OOE : FAE -> Exp*Classenv
(define (FAE->OOE exp)
  (error 'FAE->OOE "please implement me!"))

(define original
  (FAE-with 'x (FAE-num 3)
         (FAE-with 'f (FAE-fun 'y (FAE-add (FAE-id 'x) (FAE-id 'y)))
               (FAE-with 'x (FAE-num 5)
                     (FAE-app (FAE-id 'f) (FAE-num 4))))))

(define transformed
  (FAE->OOE (desugar original)))

(test (FAE-numV-n (FAE-interp (desugar original) 
                              (FAE-emptyEnv)))
      (OOE-numV-n (OOE-interp (e*c-exp transformed) 
                              (e*c-classenv transformed) 
                              (OOE-emptyEnv))))