; Solution to Assignment #4

(cs441-load "sets.scm")
(cs441-load "parser.scm")

(define dupla-cps
  (lambda (a ls k)
    (if (null? ls)
        (k '()) 
	(dupla-cps a (cdr ls)
          (lambda (x) (k (cons a x)))))))

(define tree-mult-cps
  (lambda (ls k)
    (if (null? ls)
        (k 1)
        (if (not (pair? (car ls)))
            (tree-mult-cps (cdr ls) 
              (lambda (x)
                (k (* (car ls) x))))
	    (tree-mult-cps (car ls)
              (lambda (x)
                (tree-mult-cps (cdr ls) 
                  (lambda (y) (k (* x y))))))))))

(define double*-cps
  (lambda (a ls k)
    (if (null? ls)
        (k '())
        (if (not (pair? (car ls)))
            (if (eq? (car ls) a)
                (double*-cps a (cdr ls)
                  (lambda (x) (k (cons a (cons a x)))))
                (double*-cps a (cdr ls)
                  (lambda (x) (k (cons (car ls) x)))))
	    (double*-cps a (car ls)
              (lambda (x)
                (double*-cps a (cdr ls)
                  (lambda (y) (k (cons x y))))))))))

(define snoc-cps
  (lambda (x ls k)
    (if (null? ls)
        (k (cons x '()))
        (snoc-cps x (cdr ls)
          (lambda (y) (k (cons (car ls) y)))))))
    
(define map-cps
  (lambda (f ls k)
    (if (null? ls)
        (k '())
        (f (car ls)
           (lambda (x)
             (map-cps f (cdr ls) 
               (lambda (y) (k (cons x y)))))))))

(define dbl-cps (lambda (a k) (k (list a a))))

(define filter-cps
  (lambda (pred ls k)
    (if (null? ls)
        (k '()) 
        (pred (car ls)
              (lambda (x) 
                (if (not x)
                    (filter-cps pred (cdr ls) k)
                    (filter-cps pred (cdr ls) 
                      (lambda (y) 
                        (k (cons (car ls) y))))))))))

; (filter-cps (lambda(x k) (k (not (zero? x)))) '(1 2 0 3) (lambda(x) x))

(define compose-cps
  (lambda (f g k)    
    (k (lambda (x k2) (g x (lambda (y) (f y k2)))))))

;(compose-cps (lambda (x k) (k (+ x 1))) (lambda (y k) (k (- y 1)))
;	      (lambda (v) (v 0 (lambda (w) w))))

(define depth-cps
  (lambda (ls k)
    (if (null? ls)
        (k 1)
	(if (not (pair? (car ls)))
            (depth-cps (cdr ls) k)
	    (depth-cps (car ls) 
              (lambda (x)
                (depth-cps (cdr ls) 
                  (lambda (y)
                    (let ((h (+ 1 x))
                          (t y))
                      (if (< h t) (k t) (k h)))))))))))

(define make-empty
  (lambda ()
    (lambda (x) #f)))

(define extend
  (lambda (f d r)
    (lambda (x)
      (if (eq? x d)
          r
          (f x)))))

(define lookup
  (lambda (f x)
    (f x)))

(define eval-cps
  (lambda (e env k)
    (variant-case e
      (Const (value) (k value))
      (Var (name) (k (lookup env name)))
      (Lam (formals body)
        (k (lambda (arg c) (eval-cps body (extend env (car formals) arg) c))))
      (Ap (fun args)
        (eval-cps fun env 
	  (lambda (x) (eval-cps (car args) env (lambda (y) (x y k)))))))))

; (eval-cps (parse '((lambda (x) x) 1)) (make-empty) (lambda (x) x))