(module cae-t (lib "lang.ss" "plai-typed")
  
  (define-type CAE
    [num (n : number)]
    [str (s : string)]
    [add (lhs : CAE)
         (rhs : CAE)]
    [sub (lhs : CAE)
         (rhs : CAE)]
    [if0 (test-expr : CAE)
         (then-expr : CAE)
         (else-expr : CAE)]
    [arg]
    [this]
    [new (class : symbol)
         (args : (listof CAE))]
    [get (obj-expr : CAE)
         (field-name : symbol)]
    [dsend (obj-expr : CAE)
           (method-name : symbol)
           (arg-expr : CAE)]
    [ssend (obj-expr : CAE)
           (class-name : symbol)
           (method-name : symbol)
           (arg-expr : CAE)])

  (define-type CDecl
    [class (name : symbol)
      (fields : (listof Field))
      (methods : (listof Method))])

  (define-type Field
    [field (name : symbol)])

  (define-type Method
    [method (name : symbol)
            (body-expr : CAE)])
  
  (define-type CAE-Value
    [numV (n : number)]
    [strV (s : string)]
    [objV (class : CDecl)
          (field-values : (listof CAE-Value))])
  
  ;; ----------------------------------------

  (define (find what name-of)
    (lambda (name vals)
      (cond
       [(empty? vals)
        (error 'find (string-append
                      (string-append
                       "cannot find "
                       what)
                      (string-append
                       " "
                       (to-string name))))]
       [else (if (equal? name (name-of (first vals)))
                 (first vals)
                 ((find what name-of) name (rest vals)))])))

  (define find-class
    (find "class" (lambda (c)
                    (type-case CDecl c
                      [class (name fields methods) name]))))

  (define find-method
    (find "method" (lambda (m)
                     (type-case Method m
                       [method (name body-expr) name]))))

  (define (get-field name fields vals)
    (local [(define-values (n v)
              ((find "field"
                     (lambda (n+v)
                       (local [(define-values (n v) n+v)]
                         n)))
               name
               (map2 (lambda (f v)
                       (type-case Field f
                         [field (name) (values name v)]))
                     fields
                     vals)))]
      v))

  ;; ----------------------------------------
  
  (define interp : (CAE (listof CDecl) CAE-Value CAE-Value -> CAE-Value)
    (lambda (a-cae cdecls this-val arg-val)
      (local [(define (recur expr)
                (interp expr cdecls this-val arg-val))]
        (type-case CAE a-cae
          [num (n) (numV n)]
          [str (s) (strV s)]
          [add (l r) (num+ (recur l) (recur r))]
          [sub (l r) (num- (recur l) (recur r))]
          [if0 (test-expr then-expr else-expr)
               (if (numzero? (recur test-expr))
                   (recur then-expr)
                   (recur else-expr))]
          [this () this-val]
          [arg () arg-val]
          [new (class-name field-exprs)
               (local [(define cdecl (find-class class-name cdecls))
                       (define vals (map recur field-exprs))]
                 (objV cdecl vals))]
          [get (obj-expr field-name)
               (type-case CAE-Value (recur obj-expr)
                 [objV (cdecl field-vals)
                       (type-case CDecl cdecl
                         [class (name fields methods)
                           (get-field field-name fields field-vals)])]
                 [else (error 'interp "not an object")])]
          [dsend (obj-expr method-name arg-expr)
                 (local [(define obj (recur obj-expr))
                         (define arg-val (recur arg-expr))]
                   (type-case CAE-Value obj
                     [objV (cdecl field-vals)
                           (type-case CDecl cdecl
                             [class (name fields methods)
                               (type-case Method (find-method method-name methods)
                                 [method (name body-expr)
                                         (interp body-expr
                                                 cdecls
                                                 obj
                                                 arg-val)])])]
                     [else (error 'interp "not an object")]))]
          [ssend (obj-expr class-name method-name arg-expr)
                 (local [(define obj (recur obj-expr))
                         (define arg-val (recur arg-expr))]
                   (type-case CDecl (find-class class-name cdecls)
                     [class (name fields methods)
                       (type-case Method (find-method method-name methods)
                         [method (name body-expr)
                                 (interp body-expr
                                         cdecls
                                         obj
                                         arg-val)])]))]))))

  ;; num-op : (number number -> number) -> (CAE-Value CAE-Value -> CAE-Value)
  (define (num-op op op-name x y)
    (numV (op (numV-n x) (numV-n y))))
  
  (define (num+ x y) (num-op + '+ x y))
  (define (num- x y) (num-op - '- x y))
  (define (numzero? x) (= 0 (numV-n x)))
  
  ;; Examples

  (define posnClass
    (class 'posn
      (list (field 'x) (field 'y))
      (list (method 'mdist
                    (add (get (this) 'x) (get (this) 'y)))
            (method 'addDist
                    (add (dsend (this) 'mdist (num 0))
                         (dsend (arg) 'mdist (num 0))))
            (method 'addX
                    (add (get (this) 'x) (arg)))
            (method 'subY (sub (arg) (get (this) 'y)))
            (method 'factory01 (new 'posn (list (num 0) (num 1)))))))
    
  (define posn3DClass
    (class 'posn3D
      (list (field 'x) (field 'y) (field 'z))
      (list (method 'mdist (add (get (this) 'z)
                                (ssend (this) 'posn 'mdist (arg))))
            (method 'addDist (ssend (this) 'posn 'addDist (arg))))))
    
  (define mkPosn27 (new 'posn (list (num 2) (num 7))))
  (define mkPosn531 (new 'posn3D (list (num 5) (num 3) (num 1))))

  (define (mdist o)
    (dsend o 'mdist (num 0)))
  (define (addDist o p)
    (dsend o 'addDist p))
  (define (addX o y)
    (dsend o 'addX y))
  (define (subY o y)
    (dsend o 'subY y))

  (define (interp-posn x)
    (interp x (list posnClass posn3DClass) (numV 0) (numV 0)))

  ;; ----------------------------------------
  
  (test (interp (num 10) 
                empty (numV -1) (numV -1))
        (numV 10))
  (test (interp (add (num 10) (num 17))
                empty (numV -1) (numV -1))
        (numV 27))
  (test (interp (sub (num 10) (num 7))
                empty (numV -1) (numV -1))
        (numV 3))
  
  (test (interp-posn (mdist mkPosn27))
        (numV 9))

  (test (interp-posn (addX mkPosn27 (num 10)))
        (numV 12))

  (test (interp-posn (subY (ssend mkPosn27 'posn 'factory01 (num 0)) (num 15)))
        (numV 14))
  
  (test (interp-posn (addDist mkPosn531 mkPosn27))
        (numV 18))

  )