; lazymicro - a microscopic version of scheme with lazy evaluation

; The following scheme-like functions and key words are defined,
; though they may not have identical behavior:

; #t,(),#f,quote,cond,set!,begin,lambda,car cdr,cons,pair?,not,exit,trace,
; untrace,null?,eq?,*,+,primitive,procedure,define,else.

; To run this interpreter, execute this file in DrScheme (or load it
; into Mzscheme) and execute the command

; (micro-r-e-p)

; To leave lazymicro, use the (exit) command.

(define (micro-eval s environment)
  (if *trace-on*
      (begin
	 (upcounter)
	 (micro-print s)
	 (newline)))
(let ((result
  (cond ((not (pair? s))
           (cond ((eq? s '#t) '#t)
                 ((eq? s '()) '())
                 ((eq? s '#f) '#f)
                 ((number? s) s)
		 ((string? s) s)
                 (else (micro-value s environment))))
        ((eq? (car s) 'quote) (cadr s))
        ((eq? (car s) 'cond)
           (micro-evalcond (cdr s) environment))
        ((eq? (car s) 'set!)
           (micro-set! (cadr s) (caddr s) environment))
        ((eq? (car s) 'begin)
            (micro-evalbegin (cdr s) environment))
	((eq? (car s) 'define)
	   (micro-define-var (definition-var s)
			     (micro-eval (definition-val s) environment)
			     environment))
	((eq? (car s) 'unknown) 'unknown)
	((eq? (car s) 'trace) (set! *trace-on* #t))
	((eq? (car s) 'untrace) (set! *trace-on* #f))
        ((eq? (car s) 'lambda)
           (list 'procedure (cadr s) (cons 'begin (cddr s)) environment))
        (else 
           (micro-apply (actual-value (car s) environment)
                        (cdr s)
                        environment)))))
  (if *trace-on*
      (begin
	(downcounter)
	(display "-->")
	(micro-print result)
	(newline)))
  result))

(define (actual-value expr env) (micro-force (micro-eval expr env)))

;  A delayed evaluation is represented by a "thunk."

(define (micro-delay expr env) (list 'thunk expr env))

(define (thunk? x) (and (pair? x) (eq? (car x) 'thunk)))

(define (thunk-expr x) (cadr x))

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

; Let's memoize:

(define (evaluated-thunk? x) (and (pair? x) (eq? (car x) 'evaluated-thunk)))

(define (thunk-value x) (cadr x)) ; should only be applied to evaluated thunks

(define (micro-force obj)
  (cond ((thunk? obj)
         (let ((result (actual-value (thunk-expr obj) (thunk-env obj))))
	      (set-car! obj 'evaluated-thunk)
	      (set-car! (cdr obj) result) ; save result
	      (set-cdr! (cdr obj) ())  ; save space
               result))
        ((evaluated-thunk? obj) (thunk-value obj))
	(else obj)))

(define (micro-apply function args environment)
  (cond ((not (pair? function))
	 (display "ERROR: ")
	 (display function)
	 (display " is not a function")
	 (newline)
	 'unknown)
	((eq? (car function) 'primitive)
	  (apply (cadr function)
	         (map (lambda (x) (actual-value x environment))
	              args)))
        ((eq? (car function) 'procedure)
           (micro-eval (caddr function)
                       (micro-bind (cadr function)
                                   (map (lambda (x)
				            (micro-delay x environment))
				        args)
                                   (cadddr function))))))

(define global-frame
  (map (lambda (x) (list x 'primitive (eval x)))
       '(car cdr cons pair? not exit null? eq? * +)))

(define (micro-r-e-p)
   (let ((s '())
         (environment (list global-frame)))
       (define (main-loop)
          (newline)
          (display "lazymicro> ")
          (set! s (read))
          (cond ((not (equal? s '(exit)))
                 (micro-print (actual-value s environment))
                 (main-loop))
                (else "Leaving lazymicro")))
       (main-loop)))

(define (micro-evalcond clauses environment)
  (cond ((null? clauses) #f)
	((eq? (caar clauses) 'else)
	 (micro-evalbegin (cdar clauses) environment))
        ((actual-value (caar clauses) environment)
         (micro-evalbegin (cdar clauses) environment))
        (else (micro-evalcond (cdr clauses) environment))))

; An environment is a list of frames.  A frame is a list of var-value
; pairs (an assoc list).

(define (micro-bind key-list value-list environment)
  (define (micro-binder key-list value-list)  ; returns a new frame
    (cond ((or (null? key-list) (null? value-list))
            '())
          (else (cons (cons (car key-list) (car value-list))
                      (micro-binder (cdr key-list)
                                    (cdr value-list))))))
  (cons (micro-binder key-list value-list) environment))

(define (micro-get-var-val var environment)
  (if (null? environment)
      #f
      (let ((vv (assoc var (car environment))))
	   (if vv
	       vv
	       (micro-get-var-val var (cdr environment))))))

(define (micro-value var environment)
  (let ((vv (micro-get-var-val var environment)))
       (if vv
           (cdr vv)
           (begin
	     (display "ERROR: No value for ")
	     (display var)
	     (display " found")
	     (newline)
	     'unknown))))

(define (micro-set! var val env)
  (let ((entry (micro-get-var-val var env)))
       (if entry
           (set-cdr! entry (micro-eval val env))
           (begin
	     (display "ERROR: variable ")
	     (display var)
	     (display " not previously defined")
	     (newline)
	     'unknown))))

(define (micro-evalbegin exprs env)
  (if (null? (cdr exprs))
      (micro-eval (car exprs) env)
      (begin (micro-eval (car exprs) env)
             (micro-evalbegin (cdr exprs) env))))

(define (definition-var s)
  (if (symbol? (cadr s))
      (cadr s)
      (caadr s)))

(define (definition-val s)
  (if (symbol? (cadr s))
      (caddr s)
      (cons 'lambda (cons (cdadr s) (cddr s)))))

(define (micro-define-var var val env)
  (let ((vv (assoc var (car env))))  ; search only first frame
       (if vv
	   (set-cdr! vv val)
	   (set-car! env (cons (cons var val) (car env))))))

; here is a print command you can use to debug micro.  Use it in place
; of display in any debugging statements you want to insert.

(define (micro-print x)
  (cond ((not (pair? x)) (display x))

    ; we don't want to print out environments in procedures because they may
    ; be circular lists.

        ((eq? (car x) 'procedure)
         (display "(procedure ")
         (micro-print-help (list (cadr x) (caddr x)))
         (display " <an environment>)"))

    ; thunks and evaluated thunks must be forced.

        ((or (eq? (car x) 'thunk) (eq? (car x) 'evaluated-thunk))
         (micro-print (micro-force x)))

    ; otherwise, print out the list.

        (else (display "(")
              (micro-print-help x)
              (display ")"))))

; micro-print-help prints the elements of a list with a space between them

(define (micro-print-help x)
  (if (and (pair? x)
           (not (eq? (car x) 'thunk))
           (not (eq? (car x) 'evaluated-thunk)))
      (begin (micro-print (car x))
             (if (and (pair? (cdr x))
                      (not (eq? (cadr x) 'thunk))
                      (not (eq? (cadr x) 'evaluated-thunk)))
                 (display " ")
                 (if (not (null? (cdr x))) (display " . ")))
             (micro-print-help (cdr x)))
      (if (not (null? x)) (micro-print x))))

(define counter 0)

(define (upcounter)
  (set! counter (+ counter 1))
  (indent-bars counter)
  (display counter)
  (display " "))

(define (downcounter)
  (indent-bars counter)
  (display counter)
  (display " ")
  (set! counter (- counter 1)))

(define (indent-bars n)
  (if (> n 0)
      (begin
	(display "|")
	(indent-bars (- n 1)))))

(define *trace-on* #f)