; We write code in CPS using a continuation ADT.

; As we did in our first representation of
; environments we represent each continuation by a
; Scheme procedure.
; Then we can see that make-k and apply-k are very simple.

(define apply-k
  (lambda (k v)
    (k v)))

(define make-k
  (lambda (v) v))

;; Some procedures to transform to CPS

(define fact-acc
  (lambda (n acc)
    (if (zero? n)
	acc
	(fact-acc (- n 1) (* acc n)))))

(fact-acc 5 1)

(define fact-cps
  (lambda (n k)
    (if (zero? n)
	(apply-k k 1)
	(fact-cps (- n 1)
		  (make-k (lambda (v)
			    (apply-k k (* n v)))))
	)))

(fact-cps 5 (make-k list))
(fact-cps 6 (make-k (lambda (v) (* 10 v))))

(define list-copy-cps
  (lambda (L k)
    (if (null? L)
	(apply-k k '())
	(list-copy-cps
	 (cdr L)
	 (make-k (lambda (copied-cdr)
		   (apply-k k (cons (car L)
				    copied-cdr)))))
	)))

(list-copy-cps '(1 2 3) (make-k reverse))

(define memq-cps
  (lambda (sym ls k)
    (cond [(null? ls)          
	   (apply-k k #f)]
	  [(eq? (car ls) sym)
	   (apply-k k #t)]
	  [else (memq-cps sym (cdr ls) k)]
	 )))

(memq-cps 'a '(b c a d) (make-k list))
(memq-cps 'a '( b c d) (make-k not))
		     

(define intersection  ; convert this to CPS
  (lambda (los1 los2)
    (cond
     [(null? los1) '()]
     [(memq (car los1) los2)
      (cons (car los1)
            (intersection (cdr los1) los2))]
     [else (intersection (cdr los1) los2)])))


(define intersection-cps
  (lambda (los1 los2 k)
    (if (null? los1) 
	(apply-k k '())
	(memq-cps
	 (car los1)
	 los2
	 (make-k
	  (lambda (car-in?)
	    (intersection-cps
	     (cdr los1)
	     los2
	     (make-k
	      (lambda (intersection-with-cdr)
		(apply-k
		 k
		 (if car-in?
		     (cons (car los1)
			   intersection-with-cdr)
		     intersection-with-cdr)))))))))))
				   
	)))
	
(intersection-cps
 '(a d e g h) '(s f c h b r a) (make-k list))
    



(define free-vars ; convert to CPS.  Will also need to convert union and remove
  (lambda (exp)
    (cond [(symbol? exp) (list exp)]
	  [(eq? (1st exp) 'lambda)       
	   (remove (car (2nd exp)) 
		   (free-vars (3rd exp)))]      
	  [else (union (free-vars (1st exp))
		       (free-vars (2nd exp)))])))

(define 1st car)
(define 2nd cadr)
(define 3rd caddr)

(define free-vars-cps ; convert to CPS
  (lambda (exp k)
    (cond [(symbol? exp) ;fill it in
	   (apply-k k (list exp))]
	  [(eq? (1st exp) 'lambda) 
	   (free-vars-cps
	    (3rd exp)
	    (make-k
	     (lambda (body-free-vars)
	       (apply-k k (remove (2nd exp)
				  body-free-vars)))))]
	  [else ; fill it in
	   (free-vars-cps
	    (2nd exp)
	    (make-k
	     (lambda (rands-free-vars)
	       (free-vars-cps
		(1st exp)
		(make-k
		 (lambda (rator-free-vars)
		   (union-cps rands-free-vars
			      rator-free-vars
			      k)))))))]
	    )))
					     

(free-vars-cps '(a (b ((lambda (x) (c (d (lambda (y) ((x y) e))))) f)))
	       (make-k (lambda (v) v)))

(define union-cps
  (lambda (s1 s2 k)
    (if (null? s1)
	; fill it in 
)))

(union-cps '(3 1 11 6 8 4) '(5 1 8 9 2) (make-k list))

(define remove-cps
  (lambda (element ls k)
    (if (null? ls) 
	; fill it in
	)))

(remove-cps 'a '(b c e a d a a ) (make-k list))
			 
(define apply-k  ; allows for continuations with any number of args
  (lambda (k . args) ; is equivalent to previous apply-k if k takes one argument
    (apply k args)))

(define substitute-leftmost
  (lambda (new old slist)
    (subst-left-cps
      new
      old
      slist
      (make-k (lambda (v) v))     ; succeed continuation (called "changed" in cps code)
      (make-k (lambda () slist))  ; fail continuation (called "unchanged" in cps code)
     )))

(define subst-left-cps  ; changed and unchanged are continuations
  (lambda (new old slist changed unchanged)
    (let loop ([slist slist] [changed changed] [unchanged unchanged])
      (cond
       [(null? slist) (apply-k unchanged)]
       [(symbol? (car slist)) 
	; fill it in
	]
       [else ; car is an s-list
	; fill it in
	]))))

(substitute-leftmost 'b 'a '((a c a) (((a (((b a))))))))
(substitute-leftmost 'b 'a '((d c a) (((a (((b a))))))))
(substitute-leftmost 'b 'a '((d c d) (((a (((b a))))))))