;;;; Explicit demand evaluator

#|
Here's a fun interpreter that contains most of the content of
Pingali's MIT thesis (embedding demand flow in data flow).  It doesn't
have demand for sums, so null? isn't treated right, but the rest is
sound.

The demand objects are a kind of co-data.  They allow programs whose
output is infinite (there are examples at the end) without using
thunks.  Instead of forcing at the end, one specifies how much to
evaluate at the beginning.
|#

;; Eval : Exp -> Env -> (Dem -> Val)
;; Env = Id -> (Dem -> Val)
;; Dem = DEM | NO-DEM | Dem*Dem

;;; Environments

(define (env-lookup var env succeed fail)
  (let ((binding (assq var env)))
    (if binding
	(succeed (cdr binding))
	(fail))))

(define (env-extend var val env)
  (cons (cons var val) env))

(define (make-empty-env) '())

;;; Evaluator

(define (constant? exp)
  (or (number? exp) (boolean? exp) (null? exp)))

(define DEMAND 'DEMAND)
(define NO-DEMAND 'NO-DEMAND)

(define (no-demand? dem)
  (eq? dem NO-DEMAND))

(define (eval-exp exp env dem)
  ((cond ((no-demand? dem) eval-no-demand)
	 ((constant? exp) eval-constant)
	 ((symbol? exp) eval-variable)
	 ((assq (car exp) primitives) => cdr)
	 (else eval-combination))
   exp env dem))

(define (eval-combination exp env dem)
  (let ((proc (eval-exp (first exp) env DEMAND)))
    (if (and (pair? proc)
	     (eq? 'closure (first proc)))
	(eval-exp (third proc)
		  (env-extend (second proc) 
			      (lambda (dem) (eval-exp (second exp) env dem))
			      (fourth proc))
		  dem)
	(error "Not applicable: " proc))))

(define (eval-lambda exp env dem)
  (list 'closure (second exp) (third exp) env))

(define (eval-no-demand exp env dem) '?)

(define (eval-constant exp env dem) exp)

(define (eval-variable exp env dem)
  (env-lookup 
   exp env 
   (lambda (den) (den dem))
   (lambda () (error "Unbound variable: " exp))))

(define (eval-letrec exp env dem)
  (let ((v (second exp))
	(e1 (third exp))
	(e2 (fourth exp)))
    (letrec ((new-env 
	      (env-extend v (lambda (dem) (eval-exp e1 new-env dem)) env)))
      (eval-exp e2 new-env dem))))

(define (eval-if exp env dem)
  (let ((p (second exp))
	(c (third exp))
	(a (fourth exp)))
    (if (eval-exp p env DEMAND)
	(eval-exp c env dem)
	(eval-exp a env dem))))

(define (eval-cons exp env dem)
  (cons (eval-exp (second exp) env (car dem))
	(eval-exp (third exp) env (cdr dem))))

(define (eval-car exp env dem)
  (car (eval-exp (second exp) env (cons dem NO-DEMAND))))

(define (eval-cdr exp env dem)
  (cdr (eval-exp (second exp) env (cons NO-DEMAND dem))))

(define (eval-null? exp env dem)
  (null? (eval-exp (second exp) env (cons NO-DEMAND NO-DEMAND))))

;;; Primitives

(define (eval-operands exp env)
  (map (lambda (exp) (eval-exp exp env DEMAND))
       (cdr exp)))

(define (make-primitive operator)
  (lambda (exp env dem)
    (apply operator (eval-operands exp env))))

(define primitives
  (list (cons 'if eval-if)
	(cons 'letrec eval-letrec)
	(cons 'lambda eval-lambda)
	(cons 'cons eval-cons)
	(cons 'car eval-car)
	(cons 'cdr eval-cdr)
	(cons 'null? eval-null?)
	(cons '+ (make-primitive +))
	(cons '- (make-primitive -))
	(cons '* (make-primitive *))
	(cons '/ (make-primitive /))
	(cons '= (make-primitive =))
	(cons '< (make-primitive <))
	(cons '> (make-primitive >))
	(cons '<= (make-primitive <=))
	(cons '>= (make-primitive >=))))

;;; REP loop

(define (go)
  (define (loop env)
    (newline)
    (display "==> ")
    (let ((exp (read)))
      (if (and (pair? exp) (eq? 'define (first exp)))
	  (begin (newline)
		 (display "DONE")
		 (loop (env-extend 
			(second exp)
			(lambda (dem) (eval-exp (third exp) env dem))
			env)))
	  (begin (write-line (eval-exp exp env DEMAND))
		 (loop env)))))
  (loop (make-empty-env)))

#|

Example:

==> (letrec map
      (lambda f
	(lambda l
	  (if (null? l)
	      ()
	      (cons (f (car l))
		    ((map f) (cdr l))))))
      (letrec ints 
	(cons 1 ((map (lambda x (+ x 1))) ints))
	(car (cdr (cdr (cdr (cdr (cdr (cdr ints)))))))))
7
==>

(eval-exp
 '(letrec map
    (lambda f
      (lambda l
	(if (null? l)
	    ()
	    (cons (f (car l))
		  ((map f) (cdr l))))))
    (letrec ints 
      (cons 1 ((map (lambda x (+ x 1))) ints))
      ints))
 (make-empty-env)
 (cons NO-DEMAND (cons DEMAND (cons NO-DEMAND (cons DEMAND NO-DEMAND)))))
;Value 2: (? 2 ? 4 . ?)

|#