;;
;; Lecture 18 Interpreter (alternative implementation of primitive procedures)
;;

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

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

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

(define the-lexical-spec
  '((whitespace (whitespace)                                                                            skip)
    (comment    ("%" (arbno (not #\newline)))                                                           skip)
    (identifier ((or 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 ("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)
    ))

(sllgen:make-define-datatypes the-lexical-spec the-grammar)

(define show-the-datatypes
  (lambda ()
    (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

(define just-scan
  (sllgen:make-string-scanner the-lexical-spec the-grammar))

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

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

(define eval-program
  (lambda (pgm)
    (cases program pgm
           (a-program (body) (eval-expression body (init-env))))))

(define eval-expression
  (lambda (exp env)
    (cases expression exp
           (lit-exp  (datum)                       datum)
           (var-exp  (id)                          (apply-env env id))
           (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)))
           (let-exp  (ids rands body)              (let ((args (eval-rands rands env)))
                                                     (eval-expression body (extend-env ids args env))))
           (proc-exp (ids body)                    (closure ids body env))
           (app-exp  (rator rands)                 (let ((proc (eval-expression rator env))
                                                         (args (eval-rands rands env)))
                                                     (if (procval? proc)
                                                         (apply-procval proc args)
                                                         (eopl:error 'eval-expression "Attempt to apply non-procedure ~s" proc))))
           (else                                   (eopl:error 'eval-expression "Not here:~s" exp))
           )))


(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

;;;;;;;;;;;;;;;; booleans ;;;;;;;;;;;;;;;;

(define true-value?
  (lambda (x)
    (not (zero? x))))

;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;

(define primitives '(+ - * add1 sub1))

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

(define apply-procval
  (lambda (proc args)
    (cases procval proc
           (closure (ids body env) (apply-closure ids body env))
           (primitive (prim)       (apply-primitive prim args)))))

(define apply-closure
  (lambda (ids args env)
    (eval-expression body (extend-env ids args env))))

(define apply-primitive
  (lambda (prim args)
    (case prim
      ('+     () (+ (car args) (cadr args)))
      ('-     () (- (car args) (cadr args)))
      ('*     () (* (car args) (cadr args)))
      ('add1  () (+ (car args) 1))
      ('sub1  () (- (car args) 1))
      )))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

(define init-env
  (lambda ()
    (extend-env '(i v x)
                '(1 5 10)
                (extend-env primitives
                            (map primitive primitives)
                            (empty-env)))))

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record (syms (list-of symbol?))
                       (vals vector?)              ;; You can put any type of expressed value in here
                       (env 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))
           (extended-env-record (syms vals env) (let ((position (rib-find-position sym syms)))
                                                  (if (number? position)
                                                      (vector-ref vals position)
                                                      (apply-env env sym)))))))

(define rib-find-position
  (lambda (sym los)
    (list-find-position sym los)))

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond ((null? ls)      #f)
          ((pred (car ls)) 0)
          (else            (let ((list-index-r (list-index pred (cdr ls))))
                             (if (number? list-index-r)
                                 (+ list-index-r 1)
                                 #f))))))