;;;; Representation independent Interpreter for simple Forth subset
;;;;

(add-to-load-path ".")

(library (interpreter)
  (export eval-program make-primitive-environment)
  (import (rnrs)
          (environment)
          (stack)
          (program))

  (define primitive-bindings
    (lambda ()
      "return a list of bindings for the primitive environment"
      (list (cons '+ (lambda (program) (eval-arithmetic-op + program)))
            (cons '* (lambda (program) (eval-arithmetic-op * program)))
            (cons '- (lambda (program) (eval-arithmetic-op - program)))
            (cons '/ (lambda (program) (eval-arithmetic-op / program)))
            (cons 'dup duplicate)
            (cons 'swap swap)
            (cons 'over over)
            (cons 'drop drop)
            (cons ': bind))))

  (define make-primitive-environment
    (lambda ()
      "return the environment of primitive bindings"
      (let ((env (make-empty-environment)))
        (let ((extend-env (lambda (id-value-pair)
                            (let ((id (car id-value-pair))
                                  (value (cdr id-value-pair)))
                              (extend-environment id value env)))))
          (map extend-env (primitive-bindings))))))

  (define eval-program
    (lambda (program)
      "return a program P where P's stack cannot be simplified further given
P's environment"
      (let ((stack (get-stack program))
            (env (get-environment program)))
        (if (empty? stack)
            program
            (let ((first-element (first stack))
                  (new-stack (tail stack)))
              (let ((operator (environment-lookup first-element env))
                    (new-program (make-program new-stack env)))
                (if operator
                    (eval-program (apply-operator operator new-program))
                    program)))))))

  (define apply-operator
    (lambda (operator program)
      "return a program P which results from applying operator to program"
      (if (procedure? operator)
          (eval-program (operator program))
          (eval-program (push-on-program-stack operator program)))))

  (define drop
    (lambda (program)
      "return a new program P whose stack S is the tail of program's stack"
      (let ((stack (get-stack program)))
        (if (empty? stack)
            (error "Cannot call drop on an empty stack")
            (make-program stack (get-environment program))))))

  (define duplicate
    (lambda (program)
      "return a new program P where P's stack is the stack of the input program
with the element at the head duplicated.
Precondition: program's stack is not empty"
      (let ((stack (get-stack program)))
        (if (empty? stack)
            "Not enough arguments in stack for duplicate"
            (let ((element (first stack)))
              (push-on-program-stack element program))))))

  (define swap
    (lambda (program)
      "return a new program P where the first two values of P's stack is
the first two of program's but swapped.
Precondition: program's stack has at least two elements"
      (let ((stack (get-stack program)))
        (if (not (contains-at-least-two? stack))
            (error "stack must have at least 2 elements for swap to work")
            (let ((a (first stack))
                  (b (second stack))
                  (tail-tail (tail (tail stack))))
              (make-program (push a (push b tail-tail))
                            (get-environment program)))))))
  (define over
    (lambda (program)
      "return a new program P such that the P's stack S is the second element
of program's stack, and P's tail is program's stack"
      (let ((stack (get-stack program)))
        (if (not (contains-at-least-two? stack))
            (error "Over expects a stack with at least 2 elements")
            (push-on-program-stack (second stack) program)))))

  ;;; Evaluating arithmetic operations
  ;;; let us reperesent programs as follows <stack, environment>
  ;;; op program -> program
  ;;; let
  ;;;   R = program, and
  ;;;   <(a b rest), env> = R
  ;;;   in
  ;;; if a is a number then,
  ;;;   if b is a number then,
  ;;;     let
  ;;;       c = b `op` a
  ;;;     in
  ;;;      return <(c rest),env>
  ;;;     end-let
  ;;;   else if b is a symbol then,
  ;;;     let
  ;;;       <(e gs), env2> = evaluate <(b rest), env>
  ;;;     in
  ;;;       eval-arithmetic-op op <(a e gs), env2>
  ;;;     end-let
  ;;; else if a is a symbol,
  ;;;     let
  ;;;       Pa = evaluate R
  ;;;       in
  ;;;     eval-aritmetic-op op Pa

  (define eval-arithmetic-op
    (lambda (op program)
      "return a program P which results from applying op to program.
Precondition: the stack S in program must have at least two elements."
      (let ((stack (get-stack program)))
        (if (not (contains-at-least-two? stack))
            (error "Arithmetic operations require at least 2 operands")
            (let ((a (first stack)))
              (if (number? a)
                  (let ((b (second stack)))
                    (if (number? b)
                        (push-on-program-stack (op b a) (drop (drop program)))
                        (let ((program-2 (eval-program (drop program))))
                          (eval-arithmetic-op  op (push-on-program-stack a program-2)))))
                  (eval-arithmetic-op op (eval-program program))))))))

  (define bind
    (lambda (program)
      "let the binding be of the following format: id value.
return a new program P such that id is bound to value in P's environment,
and P's stack is the resulting stack after the bining statement is removed from
program's stack"
      (let ((stack (get-stack program)))
        (if (not (and (eq? ': (first stack))
                      (eq? '! (third (tail stack)))))
            (error "Syntax error, binding syntax is `: id value !`")
            (let ((id (second stack))
                  (value (third stack))
                  (new-stack (tail (tail (tail (tail stack)))))
                  (env (get-environment program)))
              (make-program new-stack env)))))))