;;;; Monadic Interpreter

;;; Environments

(define (make-env) '())

(define (env-extend name value env)
  (cons (cons name value) env))

(define (env-lookup name env)
  (cdr (assq name env)))

(define (env-extend-bindings names values env)
  (append (map cons names values) env))

;;; Primitives

(define (make-cbv-env unit mapply)
  (define (make-primitive op)
    (lambda args
      (unit (apply op args))))
  (list (cons '+ (make-primitive +))
	(cons '* (make-primitive *))
	(cons '- (make-primitive -))
	(cons '/ (make-primitive /))
	(cons '= (make-primitive =))))

(define (make-cbn-env unit mapply)
  (define (make-primitive op)
    (unit
     (lambda comps
       (mapply (lambda args
		 (unit (apply op args)))
	       comps))))
  (list (cons '+ (make-primitive +))
	(cons '* (make-primitive *))
	(cons '- (make-primitive -))
	(cons '/ (make-primitive /))
	(cons '= (make-primitive =))))

;;; Monads

;; Unit : A -> MA
;; Bind : MA -> (A -> MB) -> MB

(define make-monad list)
(define monad-unit car)
(define monad-bind cadr)

(define make-extension list)
(define extension-forms car)
(define extension-eval cadr)

;;; Evaluator parts

(define (constant? exp)
  (or (number? exp)
      (procedure? exp)))

(define (make-rep-loop initial-env eval answer)
  (define (loop env)
    (newline)
    (display "--> ")
    (let ((exp (read)))
      (write-line (answer (eval exp env))))
    (loop env))
  (lambda ()
    (loop initial-env)))

;; MApply : (Vals -> Comp) -> List Comp -> Comp

(define (make-mapply bind)
  (lambda (f lc)
    (define (bind-list lc k)
      (if (null? lc)
	  (k '())
	  (bind (car lc)
		(lambda (val)
		  (bind-list (cdr lc)
			     (lambda (lv)
			       (k (cons val lv))))))))
    (bind-list lc (lambda (l) (apply f l)))))

(define (make-eval-list eval)
  (lambda (exps env)
    (map (lambda (exp) (eval exp env)) exps)))

(define (make-cbv-eval monad ext answer)

  ;; Eval  : Exp -> Env -> Comp
  ;; Apply : Val -> Val -> Comp
  ;; Env   = Id -> Val
  ;; Proc  = Val -> Comp
  ;; Val   = Num + Proc

  (define unit (monad-unit monad))
  (define bind (monad-bind monad))

  (define ext-forms (extension-forms ext))
  (define ext-eval  (extension-eval ext))

  (define mapply    (make-mapply    (lambda (x y) (bind x y))))
  (define eval-list (make-eval-list (lambda (x y) (eval x y))))

  (define (eval exp env)
    (cond ((constant? exp) (unit exp))
	  ((symbol? exp) (unit (env-lookup exp env)))
	  ((eq? 'lambda (first exp))
	   (unit (lambda vals
		   (eval (third exp)
			 (env-extend-bindings
			  (second exp) vals env)))))
	  ((memq (first exp) ext-forms)
	   (ext-eval exp env eval unit bind))
	  (else
	   (mapply (lambda (proc . args) (apply proc args))
		   (eval-list exp env)))))

  (make-rep-loop (make-cbv-env unit mapply) eval answer))

(define (make-cbn-eval monad ext answer)

  ;; Eval  : Exp -> Env -> Comp
  ;; Apply : Val -> Comp -> Comp
  ;; Env   = Id -> Comp
  ;; Proc  = Comp -> Comp
  ;; Val   = Num + Proc

  (define unit (monad-unit monad))
  (define bind (monad-bind monad))

  (define ext-forms (extension-forms ext))
  (define ext-eval  (extension-eval ext))

  (define mapply    (make-mapply    (lambda (x y) (bind x y))))
  (define eval-list (make-eval-list (lambda (x y) (eval x y))))

  (define (eval exp env)
    (cond ((constant? exp) (unit exp))
	  ((symbol? exp) (env-lookup exp env))
	  ((eq? 'lambda (first exp))
	   (unit (lambda comps
		   (eval (third exp)
			 (env-extend-bindings
			  (second exp) comps env)))))
	  ((memq (first exp) ext-forms)
	   (ext-eval exp env eval unit bind))
	  (else
	   (mapply (lambda (proc)
		     (apply proc (eval-list (cdr exp) env)))
		   (list (eval (car exp) env))))))

  (make-rep-loop (make-cbn-env unit mapply) eval answer))

;;; Standard Interpreter

;; M A = A

(define std-monad
  (make-monad 
   (lambda (a) a)
   (lambda (m k) (k m))))

(define std-ext
  (make-extension
   '() 
   (lambda (exp env eval unit bind)
     'done)))

(define std-answer
  (lambda (m) m))

(define std-cbv (make-cbv-eval std-monad std-ext std-answer))
(define std-cbn (make-cbn-eval std-monad std-ext std-answer))

;;; Errors

;; M A = (SUCCESS x A) + (ERROR x Msg)

(define error-monad
  (make-monad
   (lambda (a) (cons 'success a))
   (lambda (m k)
     (if (eq? (car m) 'success)
	 (k (cdr m))
	 m))))

(define error-ext
  (make-extension
   '(error)
   (lambda (exp env eval unit bind)
     (cons 'error (cadr exp)))))

(define error-answer
  (lambda (m) m))

(define error-cbv (make-cbv-eval error-monad error-ext error-answer))
(define error-cbn (make-cbn-eval error-monad error-ext error-answer))

;;; Ticks

;; M A = State -> A x State

(define tick-monad
  (make-monad
   (lambda (a) (lambda (s) (cons a s)))
   (lambda (m k)
     (lambda (s)
       (let ((as (m s)))
	 ((k (car as)) (cdr as)))))))

(define tick-ext
  (make-extension
   '(tick)
   (lambda (exp env eval unit bind)
     (bind (eval (cadr exp) env)
	   (lambda (a)
	     (lambda (s)
	       (cons a (1+ s))))))))

(define tick-answer
  (lambda (m) (m 0)))

(define tick-cbv (make-cbv-eval tick-monad tick-ext tick-answer))
(define tick-cbn (make-cbn-eval tick-monad tick-ext tick-answer))

;;; Output

;; M A = Output x A

(define output-monad
  (make-monad
   (lambda (a) (cons '() a))
   (lambda (ma k)
     (let ((mb (k (cdr ma))))
       (cons (append (car ma) (car mb))
	     (cdr mb))))))

(define output-ext
  (make-extension
   '(output)
   (lambda (exp env eval unit bind)
     (bind (eval (cadr exp) env)
	   (lambda (a)
	     (cons (list a) a))))))

(define output-answer
  (lambda (m) m))

(define output-cbv (make-cbv-eval output-monad output-ext output-answer))
(define output-cbn (make-cbn-eval output-monad output-ext output-answer))

;;; Amb

;; M A = List A

(define amb-monad
  (make-monad
   (lambda (a) (list a))
   (lambda (ma k) (append-map k ma))))

(define amb-ext
  (make-extension
   '(amb fail)
   (lambda (exp env eval unit bind)
     (if (eq? 'fail (car exp))
	 '()
	 (append (eval (second exp) env)
		 (eval (third exp) env))))))

(define amb-answer
  (lambda (m) m))

(define amb-cbv (make-cbv-eval amb-monad amb-ext amb-answer))
(define amb-cbn (make-cbn-eval amb-monad amb-ext amb-answer))

;;; Continuations

;; M A = (A -> Answer) -> Answer

(define cont-monad
  (make-monad
   (lambda (a) (lambda (c) (c a)))
   (lambda (m k)
     (lambda (c) (m (lambda (a) ((k a) c)))))))

(define (catch-throw-ext exp env eval unit bind)
  (case (car exp)
    ((catch)
     (bind (eval (second exp) env)
	   (lambda (f)
	     (lambda (k)
	       ((eval (list f k) env) k)))))
    ((throw)
     (bind (eval (second exp) env)
	   (lambda (k)
	     (lambda (k2)
	       ((eval (third exp) env) k)))))))

(define cont-ext
  (make-extension '(catch throw) catch-throw-ext))

(define cont-answer
  (lambda (c) (c (lambda (v) v))))

(define cont-cbv (make-cbv-eval cont-monad cont-ext cont-answer))
(define cont-cbn (make-cbn-eval cont-monad cont-ext cont-answer))

;;; Dynamic binding

;; M A = Env -> A

(define env-monad
  (make-monad
   (lambda (a) (lambda (env) a))
   (lambda (m k)
     (lambda (env) ((k (m env)) env)))))

(define env-answer
  (lambda (m) (m (make-env))))

(define dyn-ext
  (make-extension
   '(dlet dref)
   (lambda (exp env eval unit bind)
     (if (eq? 'dlet (first exp))
	 (bind (eval (third exp) env)
	       (lambda (val)
		 (lambda (denv)
		   ((eval (fourth exp) env)
		    (env-extend (second exp) val denv)))))
	 (lambda (denv) (env-lookup (second exp) denv))))))

(define dyn-cbv (make-cbv-eval env-monad dyn-ext env-answer))
(define dyn-cbn (make-cbn-eval env-monad dyn-ext env-answer))

;;; CBV static binding (assume env wasn't there)

;; Comp = Env -> Val
;; Env  = Id -> Val
;; Proc = Val -> Comp

(define scbv-ext
  (make-extension
   '(svar slambda sapply)
   (lambda (exp env eval unit bind)
     (case (first exp)
       ((svar)
	(lambda (senv) (env-lookup (second exp) senv)))
       ((slambda)
	(lambda (senv) (cons senv exp)))
       ((sapply)
	(bind (eval (second exp) env)
	      (lambda (proc)
		(bind (eval (third exp) env)
		      (lambda (arg)
			(lambda (senv)
			  ((eval (third (cdr proc)) env)
			   (env-extend (second (cdr proc)) 
				       arg 
				       (car proc)))))))))))))

(define scbv-cbv (make-cbv-eval env-monad scbv-ext env-answer))
(define scbv-cbn (make-cbn-eval env-monad scbv-ext env-answer))

;;; CBN static binding (assume env wasn't there)

;; Comp = Env -> Val
;; Env  = Id -> Comp
;; Proc = Comp -> Comp

(define scbn-ext
  (make-extension
   '(svar slambda sapply)
   (lambda (exp env eval unit bind)
     (case (first exp)
       ((svar)
	(lambda (senv) ((env-lookup (second exp) senv) senv)))
       ((slambda)
	(lambda (senv) (cons senv exp)))
       ((sapply)
	(bind (eval (second exp) env)
	      (lambda (proc)
		(lambda (senv)
		  ((eval (third (cdr proc)) env)
		   (env-extend (second (cdr proc)) 
			       (eval (third exp) env)
			       (car proc)))))))))))

(define scbn-cbv (make-cbv-eval env-monad scbn-ext env-answer))
(define scbn-cbn (make-cbn-eval env-monad scbn-ext env-answer))


;;; BF amb monad

;; Comp   = Cont -> Task
;; Cont   = Val -> Task
;; Task   = Queue -> Answer
;; Answer = (Fail + Val) * Queue
;; Queue  = List Task

(define (basic-cont val)
  (lambda (q)
    (cons (in-right val) q)))

(define (bfamb-answer comp)
  (define (loop q)
    (if (empty-queue? q)
	the-empty-stream
	(let ((answer (next q)))
	  (sum-case 
	   (car answer)
	   (lambda (unit) (loop (cdr answer)))
	   (lambda (val) (cons-stream val (loop (cdr answer))))))))
  (head-stream 
   20 (loop (enqueue (comp basic-cont) (make-empty-queue)))))

;; next, fail : Task

(define (next q)
  (dequeue q (lambda (task q) (task q))))

(define (fail q)
  (cons (in-left unit) q))

(define bfamb-ext
  (make-extension
   '(amb fail)
   (lambda (exp env eval unit bind)
     (case (car exp)
       ((amb)
	(lambda (k)
	  (lambda (q)
	    (let ((t1 ((eval (second exp) env) k))
		  (t2 ((eval (third exp) env) k)))
	      (next (enqueue t2 (enqueue t1 q)))))))
       ((fail) (lambda (k) fail))))))

(define bfamb-cbv (make-cbv-eval cont-monad bfamb-ext bfamb-answer))
(define bfamb-cbn (make-cbn-eval cont-monad bfamb-ext bfamb-answer))

;; Extras

(define (dequeue q k)
  (k (car q) (cdr q)))

(define (enqueue item q)
  (append q (list item)))

(define empty-queue? null?)
(define (make-empty-queue) '())

(define unit '())

(define (in-left x)
  (cons 'left x))

(define (in-right x)
  (cons 'right x))

(define (sum-case x f g)
  (case (car x)
    ((left) (f (cdr x)))
    ((right) (g (cdr x)))))     

(define (head-stream n s)
  (cond ((empty-stream? s) '())
	((zero? n) '(...))
	(else 
	 (cons (head s)
	       (head-stream (-1+ n) (tail s))))))


;;; List / Continuation interpreters

;; Ans = List Val

; Try (amb 1 (amb 2 3))
; Try (catch (lambda (k) (amb 3 (throw k 2))))
; Try (catch (lambda (k) (amb (throw k 2) 3)))

;; CBV continuations
;; Comp = (Val -> Ans) -> Ans

(define lcv-answer
  (lambda (c) (c list)))

;; Parallel Amb

(define lcvp-ext
  (make-extension
   '(amb fail catch throw)
   (lambda (exp env eval unit bind)
     (case (first exp)
       ((amb)
	(lambda (k)
	  (append ((eval (second exp) env) k)
		  ((eval (third exp) env) k))))
       ((fail)
	(lambda (k) '()))
       (else
	(catch-throw-ext exp env eval unit bind))))))

(define lcvp-cbv (make-cbv-eval cont-monad lcvp-ext lcv-answer))
(define lcvp-cbn (make-cbn-eval cont-monad lcvp-ext lcv-answer))

;; Serial Amb

(define lcvs-ext
  (make-extension
   '(amb fail catch throw)
   (lambda (exp env eval unit bind)
     (case (first exp)
       ((amb)
	(lambda (k)
	  ((eval (second exp) env)
	   (lambda (v1)
	     ((eval (third exp) env)
	      (lambda (v2)
		(append (k v1) (k v2))))))))
       ((fail)
	(lambda (k) '()))
       (else
	(catch-throw-ext exp env eval unit bind))))))

(define lcvs-cbv (make-cbv-eval cont-monad lcvs-ext lcv-answer))
(define lcvs-cbn (make-cbn-eval cont-monad lcvs-ext lcv-answer))


;; CBN Continuations
;; Comp = (List Val -> Ans) -> Ans

;; Uses serial combination and appends BEFORE invoking the
;; continuation (the only choice that makes this interesting).
;; Check equivalence of this with fancy List Cont.

(define lcn-monad
  (make-monad
   (lambda (v)
     (lambda (k) (k (list v))))
   (lambda (c f)
     (lambda (k)
       (c (lambda (lv) (cps-append-map f lv k)))))))

(define lcn-ext
  (make-extension
   '(amb fail catch throw)
   (lambda (exp env eval unit bind)
     (case (first exp)
       ((amb)
	(lambda (k)
	  ((eval (second exp) env)
	   (lambda (lv1)
	     ((eval (third exp) env)
	      (lambda (lv2)
		(k (append lv1 lv2))))))))
       ((fail)
	(lambda (k) '()))
       (else
	(catch-throw-ext exp env eval unit bind))))))

(define lcn-answer
  (lambda (c) (c (lambda (lv) lv))))

(define lcn-cbv (make-cbv-eval lcn-monad lcn-ext lcn-answer))
(define lcn-cbn (make-cbn-eval lcn-monad lcn-ext lcn-answer))

;; Extra

(define (cps-append-map f l k)
  (if (null? l)
      (k '())
      ((f (car l))
       (lambda (first)
	 (cps-append-map
	  f (cdr l)
	  (lambda (rest)
	    (k (append first rest))))))))


;; CPS lists
;; Comp = ((Nil + Val*Comp) -> Ans) -> Ans

(define lccps-monad
  (make-monad
   (lambda (v) (cps-cons v cps-nil))
   (lambda (c f)
     (let loop ((c c))
       (lambda (k)
	 (c (lambda (l)
	      (if (null? l)
		  (cps-nil k)
		  ((cps-append (f (car l)) (loop (cdr l)))
		   k)))))))))

(define lccps-ext
  (make-extension
   '(amb fail catch throw)
   (lambda (exp env eval unit bind)
     (case (first exp)
       ((amb)
	(cps-append (eval (second exp) env) 
		    (eval (third exp) env)))
       ((fail)
	cps-nil)
       (else
	(catch-throw-ext exp env eval unit bind))))))

(define (lccps-answer c)
  (c (lambda (l)
       (if (null? l)
	   '()
	   (cons (car l) (lccps-answer (cdr l)))))))

(define cps-nil
  (lambda (k) (k '())))

(define (cps-cons v l)
  (lambda (k) (k (cons v l))))

(define (cps-append l1 l2)
  (lambda (k)
    (l1 (lambda (l)
	  (if (null? l)
	      (l2 k)
	      ((cps-cons (car l)
			 (cps-append (cdr l) l2))
	       k))))))

(define lccps-cbv (make-cbv-eval lccps-monad lccps-ext lccps-answer))
(define lccps-cbn (make-cbn-eval lccps-monad lccps-ext lccps-answer))


;; Composable continuations (F)

;; Comp = Cont -> Val
;; Cont = List F
;; F    = Val * Cont -> Val

;; Proc = Val -> TVal
;; Val  = Num + Proc

(define f-monad
  (make-monad
   (lambda (v) (lambda (k) (send v k)))
   (lambda (c f)
     (lambda (k)
       (c (push 
	   (lambda (v k1)
	     ((f v) k1))
	   k))))))

(define f-ext
  (make-extension
   '(f reset)
   (lambda (exp env eval unit bind)
     (case (first exp)
       ((f)
	(lambda (k)
	  ((eval (third exp)
		 (env-extend 
		  (second exp)
		  (lambda (v1)
		    (lambda (k1)
		      (send v1 (append k k1))))
		  env))
	   initial-f-cont)))
       ((prompt)
	(lambda (k)
	  ((eval (second exp) env) initial-f-cont)))))))

(define (f-answer c)
  (c '()))

(define initial-f-cont '())

(define (send v k)
  (if (null? k)
      v
      ((car k) v (cdr k))))

(define (push f k)
  (cons f k))

(define f-cbv (make-cbv-eval f-monad f-ext f-answer))
(define f-cbn (make-cbn-eval f-monad f-ext f-answer))