#lang racket
(require "du-environment.scm")
(require "du-utility.scm")
(provide actual-value apply0 eval0)
;
; eval & apply
;
(define (actual-value expr xenv)
  (force-it (eval0 expr xenv)))

(define (list-of-arg-values exps xenv)
  (if (no-operands? exps)
      '()
      (cons (actual-value (first-operand exps) xenv)
            (list-of-arg-values (rest-operands exps)
                                xenv))))

(define (list-of-delayed-args exps xenv)
;  (display ">>>list-of-delayed-args exps ")(display exps)(newline)
  (if (no-operands? exps)
      '()
      (cons (delay-it (first-operand exps) xenv)
            (list-of-delayed-args (rest-operands exps)
                                  xenv))))

;;; Representing thunks 

;; non-memoizing version of force-it

(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))

;; thunks

(define (delay-it expr xenv)
  (list 'thunk expr xenv))

(define (thunk? obj)
  (tagged-list? obj 'thunk))

(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (list-ref thunk 2))
(define (thunk-extened-env thunk) (caaddr thunk))
(define (thunk-base-env thunk) (cdaddr thunk))

;; "thunk" that has been forced and is storing its (memoized) value
;(define (evaluated-thunk? obj)
;  (tagged-list? obj 'evaluated-thunk))
;
;(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
;
;
;;; memoizing version of force-it
;
;(define (force-it-memo obj)
;  (cond ((thunk? obj)
;         (let ((result (actual-value
;                        (thunk-exp obj)
;                        (thunk-env obj)
;                        (thunk-cntr obj)))) 
;           (set-car! obj 'evaluated-thunk)
;           (set-car! (cdr obj) result)  ; replace exp with its value
;           (set-cdr! (cdr obj) '())     ; forget unneeded env
;           result))
;        ((evaluated-thunk? obj)
;         (thunk-value obj))
;        (else obj)))

(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

(define (procedure-parameters p)
  (map un-syntax (list-ref p 1)))
(define (procedure-body p) (list-ref p 2))
(define (procedure-environment p) (list-ref p 3))

(define (primitive-implementation proc) (cadr proc))

(define (apply-primitive-procedure proc args)
  (apply 
   (primitive-implementation proc) args))

(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (eval-sequence exps xenv)
  (cond ((last-exp? exps) (eval0 (first-exp exps) xenv))
        (else (eval0 (first-exp exps) xenv)
              (eval-sequence (rest-exps exps) xenv))))


(define (apply0 procedure arguments xenv)
  (define (new-xe)
    (list 
     (if (get-p-key procedure) 
         (xcons  (get-current-keys xenv) (get-p-key procedure))
         (get-current-keys xenv))
     (if (get-p-lock procedure) 
         (xcons (get-current-locks xenv) (get-p-lock procedure)) 
         (get-current-locks xenv))))
  (define (change-guard envir)
    (cons (new-xe) (get-basic-env envir)))
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          (list-of-arg-values arguments xenv)))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (change-guard
           (extend-environment
            (procedure-parameters procedure)
            (list-of-delayed-args arguments xenv)
            (procedure-environment procedure)))
          ; add a key or lock to current-keys or current-locks
          ))
        (else
         (error "Unknown procedure type -- APPLY" procedure))))

(define (variable? apple) (symbol? apple))
(define (application? pear) (pair? pear))
(define (operator orange) (car orange))
(define (operands cherry) (cdr cherry))

(define (self-evaluating? plum)
  (cond ((number? plum) #t)
        ((string? plum) #t)
        ((boolean? plum) #t)
        ((tagged-list? plum 'freeze) #t)
        (else #f)))


(define (eval0 expr xenv)
  (define (extra-check squril)
    ; this function just removes the warning message
    ; we know that eval0 has to be able to work when meta info has been removed
    (if (syntax? squril)
        (un-syntax squril)
        squril))
   (define (get-locks box)
    (list-ref box 1))
  (define (get-value box)
    (list-ref box 2))
  (define (lock box locks) 
    (if (null? locks)
        box
        (list 'box-symbol locks box)))
  (define (op? expr)
    (if (pair? expr)
        (get 'op (extra-check (car expr)))
        #f))
 
  (define (unlock box xenv) 
    (if (tagged-list? box 'box-symbol)
        (cond ((null? (get-locks box))
               (get-value box))
              ((member (car (get-locks box)) (get-current-keys xenv))
               (unlock (list (car box) (cdr (get-locks box)) 
                             (get-value box)) xenv)) 
              (else (error " Boundary violation " box)))
        box))
  
  (define (old-evaluate expresion xenv)
    (let ((expr (extra-check expresion)))
      (cond ((self-evaluating? expr)
             expr)
            ((variable? expr)
             (lookup-variable-value expr xenv))
            ((op? expr) => 
                        (lambda (ladybug) (ladybug (cdr expr) xenv)))
            ((application? expr)
;             (begin (display ">>>EVAL operator ")(display (operator expr))(newline)
;                    (display ">>>EVAL operands ")(display (operands expr))(newline)
             (apply0 (actual-value (operator expr) xenv)
                     (operands expr)
                     xenv))
;             )
            (else
             (error "Unknown expression type -- EVAL" expr)))))

;  (display ">>>EVAL expr ")(display expr)(newline)
  (lock (old-evaluate
         (unlock expr xenv) xenv)
        (get-current-locks xenv)))


(define (eval-freeze expr xenv)
  ; a 'frozen list' that is self evaluating, so don't do anything
;  (display ">>>FREEZE expr ")(display expr)(newline)
  (if (eq? 1 (length expr))
      (list 'freeze xenv expr)
      (list 'freeze expr)))
(put 'op 'freeze eval-freeze)

;(define (eval-freeze-name expr xenv)
;  ; a 'frozen list' that is self evaluating, so don't do anything
;  (display ">>>FREEZE-NAME expr ")(display expr)(newline)
;  (cond ((and (list? expr)
;              (not (eq? 1 (length expr))))
;         (error "Should have one argument. -- FREEZE-NAME"))
;        ((syntax? (car expr))
;         (eval-freeze-name (un-syntax (car expr)) xenv))
;        ((not (symbol? (car expr)))
;         (error "First argument should be a name. -- FREEZE-NAME"))
;        (else
;         (list 'freeze xenv expr))))
;(put 'op 'freeze-name eval-freeze-name)


(define (eval-thaw expr xenv)
  ; 'thaw' a 'frozen list'
  ; need practical experience to see if it works better then using eval
  ;TODO freeze-name
  (define (a b)
    (if (syntax? b)
        (un-syntax b)
        b))
  (define (slimemold muck)
;    (display ">>>THAW:slime stuff ")(display muck)(newline)(newline)
    (cond ((not (list? muck))
           (actual-value muck xenv))
          ((eq? 1 (length muck))
           (actual-value (car muck) xenv))
          ((eq? 2 (length muck))
           (actual-value (caadr muck) (car muck)))
          (else
           (error "Should have one argument. -- THAW" expr))))
  (define (init bee)
;    (display ">>>THAW:init bee ")(display bee)(newline)(newline)
    (cond ((syntax? bee)
           (init (un-syntax bee)))
          ((symbol? bee)
           (init (lookup-variable-value bee xenv)))
          ((not (list? bee))
           (error "Not a frozen list. -- THAW" bee))
          ((syntax? (car bee))
           (init (map un-syntax bee)))
          ((tagged-list? bee 'list)
           (init (un-parse-list bee)))
          ((not (tagged-list? bee 'freeze))
           (error "Not a frozen list. -- THAW" bee))
          ((not (pair? (cdr bee))) ;? self-evaluating works differently ?
           (cdr bee))
          (else
           (cdr bee))))
  (slimemold (a (init (car expr)))))
(put 'op 'thaw   eval-thaw)