;;; Vikram Subramaniam
;;; C311

;;; This file contains solutions to selected exercises from
;;; homework 11.  My motivation for picking these were that the
;;; last two could begin easily tested.

;;; Thanks to Rich Kendall's observations.


;;; Here are some procedures we will use often

(define make-final
  (lambda ()
    (list 'final)))

(define writeln
  (lambda unres-args
    (for-each display unres-args)
    (newline)))


;;; Also you'll need to implement your favourite stack ADT.

(define stk '())

(define push!
  (lambda (x)
    (set! stk (cons x stk))))

(define pop!
  (lambda ()
    (if (null? stk)
      (begin
        (display "The stack is empty")
        (newline))
    (let ([stktop (car stk)])
      (set! stk (cdr stk))
      stktop))))

(define top
  (lambda ()
    (if (null? stk)
      (begin
        (display "The stack is empty")
        (newline))
      (car stk))))



;;; --------------------------------------------------------------

;;; MAP

;;; Original procedure.

(define map
  (lambda (proc ls)
    (if (null? ls)
      '()
      (cons
	(proc (car ls))
	(map proc (cdr ls))))))

;;; > (map zero? '(1 2 3 0)) ==> (#f #f #f #t)



;;; CPS transformation.

;;; Assume that proc is also CPS trandformed into proc-cps

(define map-cps
  (lambda (proc-cps ls k)
    (if (null? ls)
      (k '())
      (map-cps
	proc-cps
	(cdr ls)
	(lambda (v)
	  (proc-cps
	    (car ls)
	    (lambda (w)
	      (k (cons w v)))))))))

(define z-cps
  (lambda (n k)
    (k (zero? n))))

(map-cps z-cps '(1 2 3 0) (lambda (x) x))
(#f #f #f #t)


;;; Lambda lifting transformation

(define map-cps
  (lambda (proc-cps ls k)
    (if (null? ls)
      (apply-continuation k '())
      (map-cps
	proc-cps
	(cdr ls)
	(make-map-cont1 proc-cps ls k)))))

(define make-map-cont1
  (lambda (proc-cps ls k)
    (list 'map-cont1 proc-cps ls k)))

(define make-map-cont2
  (lambda (k v)
    (list 'map-cont2 k v)))

(define apply-continuation
  (lambda (k v)
    (form-case k
      (final () (writeln "The answer is: " v))
      (map-cont1 (proc-cps ls k)
	(proc-cps
	  (car ls)
	  (make-map-cont2 k v)))
      (map-cont2 (k w)
	(apply-continuation k (cons (w v)))))))


;;; Register transformation

(define ls-reg '*)
(define k-reg '*)
(define v-reg '*)
(define proc-reg '*)

(define map
  (lambda (proc ls)
    (set! ls-reg ls)
    (set! proc-reg proc)
    (set! k-reg (make-final))
    (map/reg)))

(define map/reg
  (lambda ()
    (if (null? ls-reg)
      (begin
	(set! v-reg '())
	(apply-continuation/reg))
      (begin
	(set! k-reg (make-map-cont1 proc-reg ls-reg k-reg))
	(set! ls-reg (cdr ls-reg))
	(map/reg)))))

(define apply-continuation/reg
  (lambda ()
    (form-case k-reg
      (final () (writeln "The answer is: " v-reg))
      (map-cont1 (proc/reg ls k)
	(begin
	  (set! ls-reg (car ls-reg))
	  (set! k-reg (make-map-cont2 k v-reg))
	  (proc/reg)))
      (map-cont-2 (k w)
	(set! v-reg (cons (w v-reg)))
	(apply-continuation/reg)))))
	


(define ls-reg '*)
(define v-reg '*)
(define proc-reg '*)

(define map
  (lambda (proc ls)
    (set! ls-reg ls)
    (set! proc-reg proc)
    (push 'final)
    (map/stack)))

(define map/stack
  (lambda ()
    (if (null? ls-reg)
      (begin
	(set! v-reg '())
	(apply-cont/stack))
      (begin
	(let ((old-ls ls-reg))
	  (set! ls-reg (cdr ls-reg))
	  (push! proc-reg)
	  (push! old-ls)
	  (push 'map-cont-1)
	  (map/stack))))))

(define apply-cont/stack
  (lambda ()
    (case (pop!)
      ((final) (writeln "The answer is: " v-reg))
      ((map-cont-1) (begin
		      (let ((ls (pop!)))
			(let ((proc/reg ((pop!))))
			  (set! ls-reg (car ls-reg))
			  (push! v-reg)
			  (push! 'map-cont-2)
			  (proc/reg)))))
      ((map-cont-2) (begin
		      (let ((w (pop!)))
			(set! v-reg (cons (w v-reg)))
			(apply-cont/stack)))))))



;;;----------------------------------------------------------------------

;;; ADD>N

;;; Original procedure

(define add>n
  (lambda (ls n)
    (cond
      ((null? ls) 0)
      ((< n (car ls)) (+ (car ls) (add>n (cdr ls) n)))
      (else (add>n (cdr ls) n)))))


;;; CPS transformation.

(define add>n-cps
  (lambda (ls n k)
    (if (null? ls)
      (k 0)
      (if (< n (car ls))
	(add>n-cps
	  (cdr ls)
	  n
	  (lambda (v)
	    (k (+ (car ls) v))))
	(add>n-cps (cdr ls) n k)))))


;;; Lambda lifting transformation

(define add>n-cps
  (lambda (ls n k)
    (if (null? ls)
      (apply-continuation k 0)
      (if (< n (car ls))
	(add>n-cps
	  (cdr ls)
	  n
	  (make-add>n-cont k ls))
	(add>n-cps (cdr ls) n k)))))

(define make-add>n-cont
  (lambda (k ls)
    (list 'add>n-cont k ls)))

(define apply-continuation
  (lambda (k v)
    (form-case k
      (final () (writeln "The answer is: " v))
      (add>n-cont (k ls)
	(apply-continuation k (+ (car ls) v))))))



;;; Register transformation.

(define ls-reg '*)
(define n-reg '*)
(define v-reg '*)
(define k-reg '*)

(define add>n
  (lambda (ls n)
    (set! ls-reg ls)
    (set! n-reg n)
    (set! k-reg (make-final))
    (add>n/reg)))

(define add>n/reg
  (lambda ()
    (if (null? ls-reg)
      (begin
	(set! v-reg 0)
	(apply-continuation/reg))
      (if (< n-reg (car ls-reg))
	(begin
	  (set! k-reg (make-add>n-cont k-reg ls-reg))
	  (set! ls-reg (cdr ls-reg))
	  (add>n/reg))
	(begin
	  (set! ls-reg (cdr ls-reg))
	  (add>n/reg))))))

(define apply-continuation/reg
  (lambda ()
    (form-case k-reg
      (final () (writeln "The answer is : " v-reg))
      (add>n-cont (k ls)
	(begin
	  (set! k-reg k)
	  (set! v-reg (+ (car ls) v-reg))
	  (apply-continuation/reg))))))



;;; Stack transformation

(define ls-reg '*)
(define n-reg '*)
(define v-reg '*)

(define add>n
  (lambda (ls n)
    (set! ls-reg ls)
    (set! n-reg n)
    (push! 'final)
    (add>n/stack)))

(define add>n/stack
  (lambda ()
    (if (null? ls-reg)
      (begin
	(set! v-reg 0)
	(apply-cont/stack))
      (if (< n-reg (car ls-reg))
	(begin
	  (push! ls-reg)
	  (push! 'add>n-cont)
	  (set! ls-reg  (cdr ls-reg))
	  (add>n/stack))
	(begin
	  (set! ls-reg (cdr ls-reg))
	  (add>n/stack))))))

(define apply-cont/stack
  (lambda ()
    (case (pop!)
      ((final) (writeln "The answer is: " v-reg))
      ((add>n-cont)
       (let ((ls (pop!)))
	 (set! v-reg (+ (car ls) v-reg))
	 (apply-cont/stack))))))






;;;
;;;------------------------------------------------------------------------

;;; HARMONIC SUM

;;; Original procedure
(define harmonic-sum
  (lambda (n)
    (cond
      ((zero? n) 0)
      (else (+ (/ 1 n) (harmonic-sum (- n 1)))))))


;;; CPS transformation
(define harmonic-sum-cps
  (lambda (n k)
    (cond
      ((zero? n) (k 0))
      (else (harmonic-sum-cps (- n 1)
              (lambda (v)
                (k (+ (/ 1 n) v))))))))


;;; Lambda lifting transformation

(define harmonic-sum-cps
  (lambda (n k)
    (if (zero? n)
      (apply-continuation k 0)
      (harmonic-sum-cps
	(- n 1)
	(make-harmonic-sum-cont k n)))))

(define make-harmonic-sum-cont
  (lambda (k n)
    (list 'harmonic-sum-cont k n)))

(define apply-continuation
  (lambda (k v)
    (form-case k
      (final () (writeln "The answer is: " v))
      (harmonic-sum-cont (k n)
	(apply-continuation
	  k
	  (+ (/ 1 n) v))))))


;;; Register transformation

(define n-reg '*)
(define k-reg '*)
(define v-reg '*)

(define harmonic-sum
  (lambda (n)
    (set! n-reg n)
    (set! k-reg (make-final))
    (harmonic-sum/reg)))

(define harmonic-sum/reg
  (lambda ()
    (if (zero? n-reg)
      (begin
	(set! v-reg 0)
	(apply-continuation))
      (begin 
	(set! k-reg (make-harmonic-sum-cont k-reg n-reg))
	(set! n-reg (- n-reg 1))
	(harmonic-sum/reg)))))

(define apply-continuation
  (lambda ()
    (form-case k-reg
      (final () (writeln "The answer is: " v-reg))
      (harmonic-sum-cont (k n)
	(begin
	  (set! k-reg k)
	  (set! v-reg (+ (/ 1 n) v-reg))
	  (apply-continuation))))))

;;; Stack transformation

(define n-reg '*)
(define k-reg '*)
(define v-reg '*)

(define harmonic-sum
  (lambda (n)
    (set! n-reg n)
    (push! 'final)
    (harmonic-sum/stack)))

(define harmonic-sum/stack
  (lambda ()
    (if (zero? n-reg)
      (begin
	(set! v-reg 0)
	(apply-cont/stack))
      (begin 
	(push! n-reg)
	(push! 'harmonic-sum-cont)
	(set! n-reg (- n-reg 1))
	(harmonic-sum/stack)))))

(define apply-cont/stack
  (lambda ()
    (case (pop!)
      ((final) (writeln "The answer is : " v-reg))
      ((harmonic-sum-cont)
       (begin
	 (let ((n (pop!)))
	   (set! v-reg (+ (/ 1 n) v-reg))
	   (apply-cont/stack)))))))