;; Vikram Subramaniam
;;; EOPL: 8.5.4 (p. 281)


;;; (a) MAP-CPS

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

(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)))))))))




;;;; (b) FNLR>N

(define fnlr>n
  (lambda (ls n)
    (cond
      ((number? ls) (if (< n ls) ls #f))
      ((pair? ls) (or
		    (fnlr>n (car ls) n)
		    (fnlr>n (cdr ls) n)))
      (else #f))))


(define fnlr>n-cps
  (lambda (ls n k)
    (cond ((number? ls)
           (if (< n ls)
               (k ls)
               (k #f)))
          ((pair? ls)
           (or (fnlr>n-cps (car ls) n k)
               (fnlr>n-cps (cdr ls) n k)))
          (else (k #f)))))






;;; (c) add>n

(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)))))


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




;;; (d) andmap

(define andmap
  (lambda (f ls)
    (if (null? ls)
      #t
      (and (f (car ls)) (andmap f (cdr ls))))))


(define andmap-cps
  (lambda (f ls k)
    (if (null? ls)
      (k #t)
      (f (car ls)
	(lambda (v)
	  (if v
	    (andmap-cps f (cdr ls) k)
	    (k #f)))))))



;;; Problems selected from SATAOP.

;;; (a) HARMONIC-SUM

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

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




		       
;;; (b) F

(define f
  (lambda (l)
    (cond
      ((null? l) 0)
      ((g l) (+ 1 (f (car l))))
      (else (+ (f (car l)) (f (cdr l)))))))


(define f-cps
  (lambda (l k)
    (if (null? l)
      (k 0)
      (g l
	(lambda (v)
	  (if v
	    (f-cps (car l)
	      (lambda (w)
		(k (+ 1 w))))
	    (f-cps (car l)
	      (lambda (x)
		(f-cps (cdr l)
		  (lambda (y)
		    (k (+ x y))))))))))))

			    
;;; Now you'd have to CPS the procedure G.



;;; (c) MYSTERY

(define mystery
  (lambda (n)
    (letrec
      ((mystery-helper
	 (lambda (n s)
	   (cond
	     ((zero? n) (list s))
	     (else
	       (append
		 (mystery-helper (sub1 n) (cons 0 s))
		 (mystery-helper (sub1 n) (cons 1 s))))))))
      (mystery-helper n '()))))



(define mystery-cps
  (lambda (n k)
    (letrec
      ((mystery-helper-cps
	 (lambda (n s k)
	   (cond
	     ((zero? n) (k (list s)))
	     (else
	       (mystery-helper-cps (sub1 n) (cons 0 s)
		 (lambda (v)
		   (mystery-helper-cps (sub1 n) (cons 1 s)
		     (lambda (w)
		       (k (append v w)))))))))))
      (mystery-helper-cps n '() k))))


;;; Assuming that LIST and APPEND are primitives. Perhaps a little too
;;; unreasonable ??  To get rid of LIST, replace (LIST S) with:
;;; (CONS S '()).  To CPS APPEND, replace (K (APPEND V W)) with:
;;; (APPEND V W K) and modify APPEND to take a continuation.



;;; (d) DEEP-RECUR

(define deep-recur
  (lambda (seed item-proc list-proc)
    (letrec
      ((helper
	 (lambda (ls)
	   (if (null? ls)
	     seed
	     (let ((a (car ls)))
	       (if (or (pair? a) (null? a))
		 (list-proc (helper a) (helper (cdr ls)))
		 (item-proc a (helper (cdr ls)))))))))
      helper)))



(define deep-recur-cps
  (lambda (seed item-proc list-proc k)
    (letrec
      ((helper-cps
	 (lambda (ls k)
	   (if (null? ls)
	     seed
	     (let ((a (car ls)))
	       (if (or (pair? a) (null? a))
		 (helper-cps a
		   (lambda (v)
		     (helper-cps (cdr ls)
		       (lambda (w)
			 (list-proc v w k)))))
		 (helper-cps (cdr ls)
		   (lambda (v)
		     (item-proc a v)))))))))
      helper-cps)))



;;; Note that DEEP-RECUR-CPS returns a procedure, HELPER-CPS, that
;;; takes a continuation.  It is fair to assume that SEED is not a
;;; procedure.