;;; $Id: ch3-5-reducer.scm,v 1.3 2006/01/05 22:24:09 leavens Exp $
;;; Reducing (little step) interpreter with procedures (closures)

(module ch3-5-reducer (lib "typedscm.ss" "typedscm")
  
(provide read-eval-print eval-program run
         scan&parse just-scan
         run-all run-one equal-external-reps?)
  
(require (lib "separate.scm" "lib342")
         (lib "all-mod.scm" "lib342")
         (lib "list-index-find.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)))

;;; Domains for this interpreter:
;;;
;;; Expressed-Value = Number + ProcVal + List(Expressed-Value)
;;; Denoted-Value = Expressed-Value

;;; ADTs used

;;;;;;;;;;;;;;;; ProcVal ;;;;;;;;;;;;;;;;

(deftype procval? (type-predicate-for procval))
(deftype closure (-> ((list-of symbol) expression environment) procval))
(deftype apply-procval
  (-> (procval (list-of Expressed-Value)
       environment (-> (expression environment) expression))
      expression))
(deftype unparse-procval (-> (procval) string))

(define-datatype procval procval?
  (closure 
    (ids (list-of symbol?)) 
    (body expression?)
    (env environment?)))

(define apply-procval
  (lambda (proc args old-env cont)
    (cases procval proc
      (closure (ids body env)
         (let ((new-env (new-env-if-needed! (extend-env ids args env))))
           (output-reason-with-env-def "app-exp" new-env)
           (cont (go-back-to-exp body old-env) new-env))))))

(define unparse-procval
  (lambda (proc)
    (cases procval proc
      (closure (ids body env)
        (string-append "(closure '("
                       (blank-separate (map symbol->string ids))
                       ") <<"
                       (unparse-expression body)
                       ">> "
                       (unparse-env env)
                       ")"
                       )))))

;;;;;;;;;;;;;;;; environment ;;;;;;;;;;;;;;;;

;; Note: we can't use the module for environments,
;; because unparse-env is recursive with unparse for expressions.

;; type predicate
(deftype environment? (type-predicate-for environment))

;; constructors
(deftype empty-env (-> () environment))
(deftype extend-env
  (-> ((list-of symbol) (list-of Expressed-Value) environment) environment))

;; observers
(deftype apply-env
  (-> (environment symbol) Expressed-Value))
(deftype defined-in-env?                   ; added
  (-> (environment symbol) boolean))
(deftype unparse-env                       ; added
  (-> (environment) string))

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vec vector?)              ; can use this for anything.
    (env environment?))
  (named-env-record
    (name symbol?)
    (env-ref environment?))
  )

(define empty-env
  (lambda ()
    (empty-env-record)))

(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

(define apply-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env "No binding for ~s" sym))
      (named-env-record (name env)
        (apply-env env sym))
      (extended-env-record (syms vals env)
        (let ((position (list-index sym syms)))
          (if (<= 0 position)
              (vector-ref vals position)
              (apply-env env sym)))))))

(define defined-in-env?
  (lambda (env sym)
    (cases environment env
      (empty-env-record () #f)
      (named-env-record (name env)
        (defined-in-env? env sym))
      (extended-env-record (syms vals env)
        (let ((position (list-index sym syms)))
          (or (<= 0 position)
              (defined-in-env? env sym)))))))

(define unparse-env
  (lambda (env)
    (cases environment env
      (empty-env-record () "(empty-env)")
      (named-env-record (name env) (symbol->string name))
      (extended-env-record (syms vals env)
        (string-append "(extend-env '("
                       (blank-separate (map symbol->string syms))
                       ") (list "
                       (blank-separate
                        (map unparse-expression
                         (map expressed->expression (vector->list vals))))
                       ") "
                       (unparse-env env)
                       ")")))))

(deftype env-equal? (-> (environment environment) boolean))
(define env-equal?
  (lambda (env1 env2)
    (cases environment env1
      (empty-env-record ()
         (cases environment env2
            (empty-env-record () #t)
            (named-env-record (name2 env2-val)
               (env-equal? env1 env2-val))
            (else #f)))
      (named-env-record (name1 env1-val)
         (cases environment env2
           (named-env-record (name2 env2-val)
              (or (eq? name1 name2) (env-equal? env1-val env2-val)))
           (else (env-equal? env1-val env2))))
      (extended-env-record (syms1 vals1 old-env1)
         (cases environment env2
           (named-env-record (name2 env2-val)
              (env-equal? env1 env2-val))
           (extended-env-record (syms2 vals2 old-env2)
              (and (equal? syms1 syms2)
                   (equal? vals1 vals2)
                   (env-equal? old-env1 old-env2)))
           (else #f))))))

(define-datatype env-name-pair env-name-pair?
  (en-pair (name symbol?)
           (env environment?)))

(deftype env-name-pair->name (-> (env-name-pair) symbol))
(define env-name-pair->name
  (lambda (enp)
    (cases env-name-pair enp
      (en-pair (name env) name))))

(deftype env-name-pair->env (-> (env-name-pair) environment))
(define env-name-pair->env
  (lambda (enp)
    (cases env-name-pair enp
      (en-pair (name env) env))))

(deftype *env-registry* (list-of env-name-pair))
(define *env-registry* '())
(deftype *env-number* number)
(define *env-number* 0)

(deftype new-env-name! (-> () symbol))
(define new-env-name!
  (lambda ()
    (begin
      (set! *env-number* (+ 1 *env-number*))
      (string->symbol (string-append "env" (number->string *env-number*))))))

(deftype init-env-registry! (-> () void))
(define init-env-registry!
  (lambda ()
    (set! *env-number* 0)
    (set! *env-registry* '())
    (cons-to-env-registry! 'init-env (init-env))))

(deftype cons-to-env-registry! (-> (symbol environment) void))
(define cons-to-env-registry!
  (lambda (name env)
    (set! *env-registry* (cons (en-pair name env) *env-registry*))))

(deftype find-in-env-registry?
  (forall (T) (-> ((-> (env-name-pair) boolean)) boolean)))
(define find-in-env-registry?
  (lambda (pred)
    (letrec ((loop (lambda (reg-list)
                     (and (not (null? reg-list))
                          (or (pred (car reg-list))
                              (loop (cdr reg-list)))))))
      (loop *env-registry*))))

(deftype env-in-env-registry? (-> (environment) boolean))
(define env-in-env-registry?
  (lambda (env)
    (find-in-env-registry?
     (lambda (evp) (env-equal? env (env-name-pair->env evp))))))

(deftype name-in-env-registry? (-> (symbol) boolean))
(define name-in-env-registry?
  (lambda (name)
    (find-in-env-registry?
     (lambda (evp) (eq? name (env-name-pair->name evp))))))

(deftype add-to-env-registry! (-> (environment) symbol))
(define add-to-env-registry!
  (lambda (env)
    (letrec ((loop (lambda (reg-list)
                     (if (null? reg-list)
                         (let ((new-name (new-env-name!)))
                           (cons-to-env-registry! new-name env)
                           new-name)
                         (if (env-equal? env
                                         (env-name-pair->env (car reg-list)))
                             (env-name-pair->name (car reg-list))
                             (loop (cdr reg-list)))))))
    (loop *env-registry*))))

(deftype new-env-if-needed!
  (-> (environment) environment))
(define new-env-if-needed!
  (lambda (env)
    (let ((name (add-to-env-registry! env)))
      (named-env-record name env))))

;;; 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 procval->expressed (-> (Procval) Expressed-Value))
(deftype list->expressed (-> ((list-of Expressed-Value)) Expressed-Value))

;; downcasts
(deftype expressed->number (-> (Expressed-Value) number))
(deftype expressed->procval (-> (Expressed-Value) Procval))
(deftype expressed->list (-> (Expressed-Value) (list-of Expressed-Value)))

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

(define-datatype Expressed-Value expval?
  (number->expressed (num number?))
  (procval->expressed (pv procval?))
  (list->expressed (lst list?)))

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

(define expressed->procval
  (lambda (ev)
    (cases Expressed-Value ev
      (procval->expressed (pv) pv)
      (else (error "expressed->procval passed non-procval 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))
      (procval->expressed (pv)
        (cases procval pv
          (closure (ids body env)
           (has-type datum (list 'closure ids body "<env>")))))
      (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 procval->expressed?
  (lambda (ev)
    (cases Expressed-Value ev
      (procval->expressed (pv) #t)
      (else #f))))

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

;;;;;;;;;;;;;;;; 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?)))
  ;; added for the interpretation process, not user visible
  (closure-exp
   (closure procval?))
  (go-back-to-exp
   (expr expression?)
   (old-env environment?))
  )

(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
  (let ((rep (sllgen:make-rep-loop
              "--> "
              (lambda (pgm) (eval-program pgm))
              (sllgen:make-stream-parser 
               the-lexical-spec
               the-grammar))))
    (lambda ()
      (displayln
"There are several conventions used in the calculation:

  - Abstract syntax trees are shown in double angle brackets,
     <<like this>>, as on pp. 87-88 of EOPL2e.
  - Closures are shown as if they were expressions with 3 parts, a
    list of identifiers, an AST for the body, and an environment.
    For example, 
       (closure '(x) <<proc(y) +(x, y)>> init-env)
    is a closure with list of formal parameters (x), AST <<proc(y) +(x, y)>>,
    and environment init-env
  - Environments are named as soon as they are introduced.  The initial
    environment is named init-env, and other environments are named env1, etc.,
    with the names introduced by a reason of the following form.
       = { by ...,
           letting env3 = ... }
    Such names are global to the calculation.
  - Go-back-to expressions, which are expressions that are being evaluated
    in an extended environment are shown as if they were expressions with
    two parts, an expression AST and an environment.
    When their evaluation is finished, the interpreter continues with
    the envronment environment in the second part
    For example,
        (go-back-to <<+(x, y)>> env2)
    is a go-back-to expression, representing the computation of
    <<+(x, y)>>, in the current environment, *not* env2.
    The computation will go back to using the env2 when +(x,y)
    has been fully evaluatied.  These are necessary for proper scoping.
")
      (rep))))
 

;; the unparser

(deftype unparse-program (-> (program) string))
(define unparse-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (unparse-expression body)))))

(deftype unparse-expression (-> (expression) string))
(define unparse-expression 
  (lambda (exp)
    (cases expression exp
      (lit-exp (datum) (number->string datum))
      (var-exp (id) (symbol->string id))
      (primapp-exp (prim rands)
        (let ((args (unparse-rands rands)))
          (string-append (unparse-primitive prim)
                         "("
                         (comma-separate args)
                         ")")))
      (if-exp (test-exp true-exp false-exp)
        (string-append
         "if " (unparse-expression test-exp)
         " then " (unparse-expression true-exp)
         " else " (unparse-expression false-exp)))
      (begin-exp (exp1 exps)
        (let ((s1 (unparse-expression exp1))
              (ss (map unparse-expression exps)))
          (semicolon-separate (cons s1 ss))))
      (let-exp (ids rands body)
        (let* ((args (unparse-rands rands))
               (bindings (map (lambda (id arg)
                                (string-append (symbol->string id) " = " arg))
                              ids args)))
          (string-append
           "let " (binding-separate bindings)
           " in " (unparse-expression body))))
      (proc-exp (ids body)
        (string-append "proc(" (comma-separate (map symbol->string ids)) ")"
                       " " (unparse-expression body)))
      (app-exp (rator rands)
        (let ((proc (unparse-expression rator))
              (args (unparse-rands rands)))
        (string-append "(" (blank-separate (cons proc args)) ")")))
      (closure-exp (closure) (unparse-procval closure))
      (go-back-to-exp (exp old-env)
           (string-append "(go-back-to <<"
                          (unparse-expression exp)
                          ">> "
                          (unparse-env old-env)
                          ")"))
      (else (eopl:error 'unparse-expression "missing case for ~s" exp))
      )))

(deftype unparse-rands
  (-> ((list-of expression)) (list-of string)))
(define unparse-rands
  (lambda (rands)
    (map unparse-expression rands)))

(deftype unparse-primitive
  (-> (primitive) string))
(define unparse-primitive
  (lambda (prim)
    (cases primitive prim
      (add-prim  () "+")
      (subtract-prim () "-")
      (mult-prim  () "*")
      (incr-prim () "add1")
      (decr-prim () "sub1")
      (zero-test-prim () "zero?")
      )))


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

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

(deftype reduce-program (-> (program) program))
(define reduce-program 
  (lambda (pgm)
    (init-env-registry!)
    (cases program pgm
      (a-program (body)
        (a-program
         (letrec ((loop (lambda (exp env)
                          (cases expression exp
                            (go-back-to-exp (inner-exp old-env)
                               ;; can drop an outermost go-back-to-exp
                               (loop inner-exp env))
                            (else (if (self-evaluating? exp)
                                      exp
                                      (begin (output-exp exp env)
                                             (reduce-expression
                                              exp env loop))))))))
           (let ((env (new-env-if-needed! (init-env))))
             (output-exp body env)
             (reduce-expression body env loop))))))))

(deftype output-exp (-> (expression environment) void))
(define output-exp
  (lambda (exp env)
    (displayln " (eval-expression")
    (displayln "   <<" (unparse-expression exp) ">>")
    (displayln "   " (unparse-env env) ")")))


(deftype self-evaluating? (-> (expression) boolean))
(define self-evaluating?
  (lambda (exp)
    (cases expression exp
      (lit-exp (datum) #t)
      (closure-exp (closure) #t)
      (else #f))))

(deftype expression->expressed (-> (expression) Expressed-Value))
(define expression->expressed
  (lambda (exp)
    ;; REQUIRES: exp is self-evaluating
    (cases expression exp
      (lit-exp (datum) (number->expressed datum))
      (closure-exp (closure) (procval->expressed closure))
      (else (eopl:error 'expression->expressed
                        "~s is not self-evaluating" exp)))))

(deftype expressed->expression (-> (Expressed-Value) expression))
(define expressed->expression
  (lambda (ev)
    (cond
     ((number->expressed? ev) (lit-exp (expressed->number ev)))
     ((procval->expressed? ev) (closure-exp (expressed->procval ev)))
     (else (eopl:error 'expressed->expression
                        "missing case for ~s" ev)))))

(deftype output-reason-line (-> (string) void))
(define output-reason-line
  (lambda (reason)
    (displayln "= { by " reason " }")))

(deftype output-reason-c (-> (string) (-> (string) void)))
(define output-reason-c
  (lambda (context)
    (lambda (case-name)
      (output-reason-line (string-append case-name " case of " context)))))

(deftype output-reason (-> (string) void))
(define output-reason (output-reason-c "eval-expression"))

(deftype output-reason-with-env-def (-> (string environment) void))
(define output-reason-with-env-def
  (lambda (case-name env)
    (cases environment env
       (named-env-record (env-name env-val)
         (displayln "= { by " case-name " case of eval-expression,")
         (displayln "    letting " env-name
                    " = " (unparse-env env-val) " }"))
       (else (eopl:error 'output-reason-with-env-def
                 "Expected a named-env-record, got ~s" env)))))

(deftype reduce-expression
  (-> (expression environment (-> (expression environment) expression))
      expression))
(define reduce-expression 
  (lambda (exp env cont)
    (cases expression exp
      (lit-exp (datum)
        (output-reason "lit-exp")
        (cont exp env))
      (closure-exp (closure)
        (output-reason-line "closures reduce to themselves")
        (cont exp env))
      (go-back-to-exp (exp old-env)
        (if (self-evaluating? exp)
            (begin (output-reason-line
                    "resuming the computation using the old environment")
                   (cont exp old-env))
            (reduce-expression exp env
              (lambda (exp2 env2)
                (cont (go-back-to-exp exp2 old-env) env2)))))
      (var-exp (id)
        (output-reason "var-exp")
        (cont (expressed->expression (apply-env env id)) env))
      (primapp-exp (prim rands)
        (if (all self-evaluating? rands)
            (begin (output-reason "primapp-exp")
                   (cont
                    (lit-exp
                     (expressed->number
                      (apply-primitive prim
                                       (map expression->expressed rands))))
                    env))
            (reduce-rands rands env
             (lambda (rands2 env2)
               (cont (primapp-exp prim rands2) env2)))))
      (if-exp (test-exp true-exp false-exp)
        (if (self-evaluating? test-exp)
            (begin (output-reason "if-exp")
                   (if (true-value? (expression->expressed test-exp))
                       (cont true-exp env)
                       (cont false-exp env)))
            (reduce-expression test-exp env
              (lambda (test-exp2 env2)
                (cont (if-exp test-exp2 true-exp false-exp) env2)))))
      (begin-exp (exp1 exps)
        (if (self-evaluating? exp1)
            (begin (output-reason "begin-exp")
                   (if (null? exps)
                       (cont exp1 env)
                       (cont (begin-exp (car exps) (cdr exps)) env)))
            (reduce-expression exp1 env
              (lambda (exp1-reduced env2)
                (cont (begin-exp exp1-reduced exps) env2)))))
      (let-exp (ids rands body)
        (if (all self-evaluating? rands)
            (let ((new-env
                   (new-env-if-needed!
                    (extend-env ids
                                (map expression->expressed rands)
                                env))))
              (output-reason-with-env-def "let-exp" new-env)
              (cont (go-back-to-exp body env) new-env))
            (reduce-rands rands env
              (lambda (rands2 env2)
                (cont (let-exp ids rands2 body) env2)))))
      (proc-exp (ids body)
        (output-reason "proc-exp")
        (cont (closure-exp (closure ids body env)) env))
      (app-exp (rator rands)
        (if (and (self-evaluating? rator)
                 (all self-evaluating? rands))
            (let ((proc (expression->expressed rator))
                  (args (map expression->expressed rands)))
              (if (procval->expressed? proc)
                  (apply-procval
                   (expressed->procval proc) args env cont)
                  (eopl:error 'reduce-expression
                              "Attempt to apply non-procedure ~s"
                              proc)))
            (if (not (self-evaluating? rator))
                (reduce-expression rator env
                  (lambda (rator2 env2)
                    (cont (app-exp rator2 rands) env2)))
                (reduce-rands rands env
                  (lambda (rands2 env2)
                    (cont (app-exp rator rands2) env2))))))
      (else (eopl:error 'reduce-expression "Missing case:~s" exp))
      )))

(deftype reduce-rands
  (-> ((list-of expression) environment
       (-> ((list-of expression) environment) expression))
      expression))
(define reduce-rands
  (lambda (rands env cont)
    (if (null? rands)
        (cont rands env)
        (if (not (self-evaluating? (car rands)))
            (reduce-expression (car rands) env
               (lambda (exp env2)
                 (cont (cons exp (cdr rands)) env2)))
            (reduce-rands (cdr rands) env
               (lambda (rands2 env2)
                 (cont (cons (car rands) rands2) env2)))))))

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

) ;; end module