;;; $Id: my-3-5-dynamic.scm,v 1.3 2006/04/25 22:17:37 leavens Exp leavens $
;;; Interpreter with dynamically-scoped procedures.

;;; Name: <your name here>

(require (lib "environment-as-ribcage.scm" "lib342")
         (lib "test-suite.scm" "lib342"))

;;;;;;;;;;;;;;;; top level and tests ;;;;;;;;;;;;;;;;

(deftype run (-> (string) datum))
(define run
  (lambda (string)
    (eval-program (scan&parse string))))

(deftype run-all (-> () void))
(define run-all
  (lambda ()
    (run-experiment run use-execution-outcome
      '(lang3-1 lang3-5) (all-tests))))

(deftype run-one (-> (symbol) datum))
(define run-one
  (lambda (test-name)
    (run-test run test-name)))

;; needed for testing
(deftype equal-external-reps? (-> (datum datum) boolean))
(define equal-external-reps?
  (lambda (x y)
    (equal? x y)))

;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "_" "-" "?")))
      symbol)
    (number (digit (arbno digit)) number)))

(define the-grammar
  '((program (expression) a-program)

    (expression (number) lit-exp)
    (expression (identifier) var-exp)   
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
    (expression
      ("let" (arbno  identifier "=" expression) "in" expression)
      let-exp)
    (expression
      ("proc" "(" (separated-list identifier ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (expression
      ("begin" expression (arbno ";" expression) "end")
      begin-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("zero?") zero-test-prim)
    ))

(deftype show-the-datatypes (-> () (list-of datum)))
(define show-the-datatypes
  (lambda ()
    (sllgen:make-define-datatypes the-lexical-spec the-grammar)
    (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

;; The following is generated by calling show-the-datatypes
;; (and then removing the outer lists, indenting, and renaming fields).
(define-datatype
  program
  program?
  (a-program (exp expression?)))

(define-datatype
  expression
  expression?
  (lit-exp (datum number?))
  (var-exp (id symbol?))
  (primapp-exp
   (prim primitive?)
   (rands (list-of expression?)))
  (if-exp
   (test-exp expression?)
   (true-exp expression?)
   (false-exp expression?))
  (let-exp
   (ids (list-of symbol?))
   (rands (list-of expression?))
   (body expression?))
  (proc-exp
   (ids (list-of symbol?))
   (body expression?))
  (app-exp
   (rator expression?)
   (rands (list-of expression?)))
  (begin-exp
   (first expression?)
   (rest (list-of expression?)))
  )

(define-datatype
  primitive
  primitive?
  (add-prim)
  (subtract-prim)
  (mult-prim)
  (incr-prim)
  (decr-prim)
  (zero-test-prim)
  )

(deftype scan&parse (-> (string) program))
(define scan&parse
  (lambda (ptext)
    ((sllgen:make-string-parser the-lexical-spec the-grammar)
     ptext)))

(deftype just-scan (forall (TOK) (-> (string) (list-of TOK))))
(define just-scan
  (lambda (ptext)
    ((sllgen:make-string-scanner the-lexical-spec the-grammar)
     ptext)))

(deftype read-eval-print (-> () poof))
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop
      "--> "
      (lambda (pgm) (eval-program pgm))
      (sllgen:make-stream-parser 
       the-lexical-spec
       the-grammar)))))

;;; Domains for this interpreter:
;;;
;;; Expressed-Value = Number + ProcText + List(Expressed-Value)
;;; ProcText = (-> ((list-of Expressed-Value) environment) Expressed-Value)
;;; Denoted-Value = Expressed-Value

;;; ADTs used

;;;;;;;;;;;;;;;; procedure texts ;;;;;;;;;;;;;;;;

(deftype proctext?
  (type-predicate-for
   (-> ((list-of Expressed-Value) environment) Expressed-Value)))
(deftype text
  (-> ((list-of symbol) expression)
      (-> ((list-of Expressed-Value) environment) Expressed-Value)))
(deftype apply-proctext
  (-> ((-> ((list-of Expressed-Value) environment) Expressed-Value)
       (list-of Expressed-Value)
       environment)
      Expressed-Value))

(define proctext? procedure?)

(define text
  (lambda (ids body)
    (lambda (args env)
        ;; exercise 3.30
        ;; <put your code here>
      )))

(define apply-proctext
  (lambda (proc args env)
    ;; exercise 3.30
    ;; <put your code here>
    ))

;;; Anonymous figure : page 80

(deftype true-value? (-> (Expressed-Value) boolean))
(define true-value?
  (lambda (x)
    (not (zero? (expressed->number x)))))

;;;;;;;;; Expressed-Value ;;;;;;;;;;;;;;;;;;;;;;;;;

;; upcasts
(deftype number->expressed (-> (number) Expressed-Value))
(deftype proctext->expressed
  (-> ((-> ((list-of Expressed-Value) environment) Expressed-Value))
      Expressed-Value))
(deftype list->expressed (-> ((list-of Expressed-Value)) Expressed-Value))

;; downcasts
(deftype expressed->number (-> (Expressed-Value) number))
(deftype expressed->proctext
  (-> (Expressed-Value)
      (-> ((List-Of Expressed-Value) Environment) Expressed-Value)))
(deftype expressed->list (-> (Expressed-Value) (list-of Expressed-Value)))

;; debugging
(deftype expressed->printable (-> (Expressed-Value) datum))

;; tests
(deftype number->expressed? (-> (Expressed-Value) boolean))
(deftype proctext->expressed? (-> (Expressed-Value) boolean))
(deftype list->expressed? (-> (Expressed-Value) boolean))

(define-datatype Expressed-Value expval?
  (number->expressed (num number?))
  (proctext->expressed (pt proctext?))
  (list->expressed (lst (list-of expval?))))

(define expressed->number
  (lambda (ev)
    (cases Expressed-Value ev
      (number->expressed (num) num)
      (else (error "expressed->number passed non-number argument: " ev)))))

(define expressed->proctext
  (lambda (ev)
    (cases Expressed-Value ev
      (proctext->expressed (pt) pt)
      (else (error "expressed->proctext passed non-proctext argument: " ev)))))

(define expressed->list
  (lambda (ev)
    (cases Expressed-Value ev
      (list->expressed (lst) lst)
      (else (error "expressed->list passed non-list argument: " ev)))))

(define expressed->printable
  (lambda (ev)
    (cases Expressed-Value ev
      (number->expressed (num) (has-type datum num))
      (proctext->expressed (pt)
        (has-type datum pt))
      (list->expressed (lst)
         (has-type datum (map expressed->printable lst))))))

(define number->expressed?
  (lambda (ev)
    (cases Expressed-Value ev
      (number->expressed (num) #t)
      (else #f))))

(define proctext->expressed?
  (lambda (ev)
    (cases Expressed-Value ev
      (proctext->expressed (pt) #t)
      (else #f))))

(define list->expressed?
  (lambda (ev)
    (cases Expressed-Value ev
      (list->expressed (lst) #t)
      (else #f))))

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

(deftype eval-program (-> (program) datum))
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (expressed->printable (eval-expression body (init-env)))))))

(deftype eval-expression (-> (expression environment) Expressed-Value))
(define eval-expression 
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum)
        (number->expressed datum))
      (var-exp (id)
        (apply-env env id))
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-primitive prim args)))
      (if-exp (test-exp true-exp false-exp)
        (if (true-value? (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (begin-exp (exp1 exps)
        (let loop ((acc (eval-expression exp1 env))
                   (exps exps))
          (if (null? exps) acc
            (loop (eval-expression (car exps) env) (cdr exps)))))
      (let-exp (ids rands body)
        (let ((args (eval-rands rands env)))
          (eval-expression
           body
           (extend-env ids args env))))
      (proc-exp (ids body)
         ;; exercise 3.30
         ;; <put your code here>
                )
      (app-exp (rator rands)
         ;; exercise 3.30
         ;; <put your code here>
               )
      (else (eopl:error 'eval-expression "Missing case:~s" exp))
      )))

(deftype eval-rands
  (-> ((list-of expression) environment) (list-of Expressed-Value)))
(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(deftype eval-rand (-> (expression environment) Expressed-Value))
(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

(deftype apply-primitive
  (-> (primitive (list-of Expressed-Value)) Expressed-Value))
(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  () (number->expressed
                     (+ (expressed->number (car args))
                        (expressed->number (cadr args)))))
      (subtract-prim () (number->expressed
                         (- (expressed->number (car args))
                            (expressed->number (cadr args)))))
      (mult-prim  () (number->expressed
                      (* (expressed->number (car args))
                         (expressed->number (cadr args)))))
      (incr-prim  () (number->expressed
                      (+ (expressed->number (car args)) 1)))
      (decr-prim  () (number->expressed
                      (- (expressed->number (car args)) 1)))
      (zero-test-prim () (number->expressed
                          (if (zero? (expressed->number (car args))) 1 0)))
      )))

(deftype init-env (-> () environment))
(define init-env 
  (lambda ()
    (extend-env
      '(i v x)
      (map number->expressed '(1 5 10))
      (empty-env))))