(load "util.scm")
(load "misc/evaluator.scm")

(display "\nex-4.31 - explicit-laziness\n")

(define (parameter-qualifier parameter)
  (if (pair? parameter) (cadr parameter) 'none))

(define (parameter-symbol parameter)
  (if (pair? parameter) (car parameter) parameter))

(define (proecure-parameters p) (cadr p))

(define (procedure-parameters-only p)
  (map parameter-symbol (cadr p)))

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

(define (list? exp)
  (tagged-list? exp 'list))

(define (list-elements exp)
  (cdr exp))

(define (eval exp env)
  ;;(display "EVAL -- ") (display exp) (newline)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp env))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        ((if? exp) (eval-if exp env))
        ((list? exp) (eval (list->cons (list-elements exp)) env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp)
                         (lambda-body exp)
                         env))
        ((begin? exp)
         (eval-sequence (begin-actions exp) env))
        ((cond? exp) (eval (cond->if exp) env))
        ((application? exp)
         (apply (actual-value (operator exp) env)
                (operands exp)
                env))
        (else
         (error "Unknown expression type -- EVAL" exp))))

(define (delay-arguments parameters arguments env)
  (define (parameter->arg parameter arg)
    (let ((qualifier (parameter-qualifier parameter)))
      (cond
        ((eq? qualifier 'none) (actual-value arg env))
        ((eq? qualifier 'lazy) (delay-it arg env))
        ((eq? qualifier 'lazy-memo) (delay-it-memo arg env))
        (else (error "unsupported qualifier -- PARAMETER->ARG" qualifier)))))
  (map parameter->arg parameters arguments))

(define (apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          (list-of-arg-values arguments env)))
        ((compound-procedure? procedure)
         (eval-sequence
           (procedure-body procedure)
           (extend-environment
             (procedure-parameters-only procedure)
             (delay-arguments (procedure-parameters procedure) arguments env)
             (procedure-environment procedure))))
        (else
         (error
          "Unknown procedure type -- APPLY" procedure))))

(define (actual-value exp env)
  (force-it (eval exp env)))

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

(define (delay-it exp env)
  (list 'thunk exp env))

(define (delay-it-memo exp env)
  (list 'thunk-memo exp env))

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

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

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

(define (thunk-exp thunk) (cadr thunk))

(define (thunk-env thunk) (caddr thunk))

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

(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))

(define (force-it obj)
  (cond ((thunk-memo? obj)
         (let ((result (actual-value (thunk-exp obj) (thunk-env 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))
        ((thunk-regular? obj)
         (actual-value (thunk-exp obj) (thunk-env obj)))
        (else obj)))

(let ((the-global-environment (setup-environment)))
  (eval '(define count 0) the-global-environment)
  (eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
  (eval '(define (square (y lazy-memo)) (* y y)) the-global-environment)
  (assert (eval '(square (id 10)) the-global-environment) 100)
  (assert (eval 'count the-global-environment) 1))

(let ((the-global-environment (setup-environment)))
  (eval '(define count 0) the-global-environment)
  (eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
  (eval '(define (square (y lazy)) (* y y)) the-global-environment)
  (assert (eval '(square (id 10)) the-global-environment) 100)
  (assert (eval 'count the-global-environment) 2))

(let ((the-global-environment (setup-environment)))
  (eval '(define count 0) the-global-environment)
  (eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
  (eval '(define (square y) (* y y)) the-global-environment)
  (assert (eval '(square (id 10)) the-global-environment) 100)
  (assert (eval 'count the-global-environment) 1))

(display "\nex-4.32 - lazy-streams\n")

(eval
  '(begin
    (define (cons (x lazy-memo) (y lazy-memo))
      (lambda (lazy-list-m) (lazy-list-m x y)))
    (define (car z)
      (z (lambda (p q) p)))
    (define (cdr z)
      (z (lambda (p q) q)))
    (define (list-ref items n)
      (if (= n 0)
          (car items)
          (list-ref (cdr items) (- n 1))))
    (define (map proc items)
      (if (null? items)
          '()
          (cons (proc (car items))
                (map proc (cdr items)))))
    (define (scale-list items factor)
      (map (lambda (x) (* x factor))
           items))
    (define (add-lists list1 list2)
      (cons (+ (car list1) (car list2))
            (add-lists (cdr list1) (cdr list2))))
    (define ones (cons 1 ones))
    (define integers (cons 1 (add-lists ones integers)))
    (define fib (cons 1 (cons 1 (add-lists fib (cdr fib)))))
    )
  the-global-environment)

(assert (eval-force '(list-ref fib 10) the-global-environment) 89)
(assert (eval-force '(list-ref ones 100) the-global-environment) 1)

(display "\nex-4.33 - quoted-list\n")

(define (list->cons elements)
  (define (make-cons elements)
    (if (null? elements)
      'end
      (list 'cons (car elements)
            (make-cons (cdr elements)))))
  (make-cons elements))

(define (text-of-quotation exp env)
  (define (quote-it x)
    (list 'quote x))
  (let ((q (cadr exp)))
    (if (pair? q)
      (eval (list->cons (map quote-it q)) env)
      q)))

(assert (eval '(car '(a b c)) the-global-environment) 'a)

(display "\nex-4.34 - print-lazy-cons\n")

(define (user-print object)
  (cond
    ((and (compound-procedure? object)
          (= (length (procedure-parameters object)) 1)
          (eq? (car (procedure-parameters object)) 'lazy-list-m))
     (display "{...}"))
    ((compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>)))
    (else
      (display object))))

(user-print (eval 'ones the-global-environment))
(newline)

(display "[done]\n")