#lang plai

; a simple dynamically typed OO-language

; a few helper functions to define precise contracts and to manage lists of symbol/value pairs

(define (list-of p)
  (lambda (l)
    (or
     (empty? l)
     (foldl (lambda (a b) (and a b)) true (map p l)))))

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

(define (zip l1 l2)
  (if (or (empty? l1) (empty? l2))
      empty
      (cons (cons (first l1) (first l2))
            (zip (rest l1) (rest l2)))))

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

; actual interpreter code starts here:

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

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

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

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

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

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

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

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

(define emptyenv (anEnv (object 'Object '()) '()))

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

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

(define prog (list 
              (classdecl 'Food 'Object '() (list (method 'getCalories '() (num 1))
                                                 (method 'getJoule '() (add (call (self) 'getCalories '()) (num 555)))))
              (classdecl 'Pizza 'Food '() (list (method 'getCalories '() (num 5000))))
              (classdecl 'Soup 'Food '() (list (method 'getCalories '() (num 1000))))
              (classdecl 'Water 'Food '() '())
              (classdecl 'Calculator 'Object '() (list (method 'addthree '(a b c) (add (add (id 'a) (id 'b)) (id 'c)))))
              (classdecl 'Menu 'Food '(appetizer entree drink) 
                         (list (method 'getCalories '() 
                                       (call (newobj 'Calculator '()) 'addthree
                                             (list (call (fieldaccess (self) 'appetizer) 'getCalories '())
                                                   (call (fieldaccess (self)'entree) 'getCalories '())
                                                   (call (fieldaccess (self) 'drink) 'getCalories '()))))))
              (classdecl 'SuperMenu 'Menu '(desert)
                         (list (method 'getCalories '() 
                                       (add
                                            (add (call (fieldaccess (self) 'appetizer) 'getCalories '())
                                                 (call (fieldaccess (self)'entree) 'getCalories '()))
                                            (add (call (fieldaccess (self) 'drink) 'getCalories '())
                                                 (call (fieldaccess (self) 'desert) 'getCalories '()))))))))
                         


(define (test) (interp (call (newobj 'Menu (list 
                                            (newobj 'Pizza '()) 
                                            (newobj 'Soup '()) 
                                            (newobj 'Water '() ))) 
                             'getJoule '()) prog emptyenv))

(define (test2) (interp (newobj 'SuperMenu (list 
                                            (newobj 'Soup '()) 
                                            (newobj 'Soup '() )
                                            (newobj 'Pizza '())
                                            (newobj 'Water '()) 
)) 
                       prog emptyenv))

(define (test3) (interp (call (newobj 'SuperMenu (list 
                                            (newobj 'Soup '()) 
                                            (newobj 'Soup '()) 
                                            (newobj 'Pizza '() )
                                            (newobj 'Water '())))
                              'getCalories
                              '())
                               prog emptyenv))

(test)
(test2)
(test3)