(load "datatype.ss")

;;;;;;;; mem ;;;;;;;;

(define mem
  (lambda (a ls)
    (mem-cps a ls (make-init-k-mem))))

(define mem-cps
  (lambda (a ls k)
    (cond
      ((null? ls) (apply-cont-mem k #f))
      ((eq? a (car ls)) (apply-cont-mem k #t))
      (else (mem-cps a (cdr ls) k)))))

(define apply-cont-mem
  (lambda (k x)
    (k x)))

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

;;;;;;;; remove-all ;;;;;;;;

(define-datatype cont-type-rem
  (init-k-rem))

(define remove-all
  (lambda (ls1 ls2)
    (remove-all-cps ls1 ls2 (make-init-k-rem))))

(define remove-all-cps
  (lambda (ls1 ls2 k)
    (cond
      ((null? ls1) (apply-cont-rem k ls2))
      (else (remove-all-cps (cdr ls1) (remq (car ls1) ls2) k)))))

(define apply-cont-rem
  (lambda (k v)
    (type-case cont-type-rem  k
      ((init-k-rem) v))))

;;;;;;;; append-all ;;;;;;;;

(define append-all
  (lambda (lss)
    (append-all-cps lss (make-init-k-append))))

(define append-all-cps
  (lambda (lss k)
    (cond
      ((null? lss) (apply-cont-append k '()))
      (else 
         (append-all-cps (cdr lss) (make-k1-append k lss))))))

(define apply-cont-append
  (lambda (k x)
    (k x)))

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

(define make-k1-append
  (lambda (k lss)
    (lambda (v)
      (k (append (car lss) v)))))

;;;;;;;; numlist? ;;;;;;;;

(define-datatype cont-type-num
  (init-k-num)
  (k1-num (k cont-type-num?)
          (v boolean?))
  (k2-num (k cont-type-num?)
          (ls pair-or-number?)))

(define pair-or-number?
  (lambda (x)
    (if (or (pair? x) (number? x))
        #t
        #f)))

(define numlist?
  (lambda (ls)
    (numlist?-cps ls (make-init-k-num))))

(define numlist?-cps
  (lambda (ls k)
    (cond
      ((null? ls) (apply-cont-numlist? k #t))
      ((number? ls) (apply-cont-numlist? k #t))
      ((atom? ls) (apply-cont-numlist? k #f))
      (else (numlist?-cps (car ls) (make-k2-num k ls))))))

(define apply-cont-numlist?
  (lambda (k p)
    (type-case cont-type-num k
      ((init-k-num) p) 
      ((k1-num k v) (apply-cont-numlist? k (and v p)))
      ((k2-num k ls) (numlist?-cps (cdr ls) (make-k1-num k p))))))

;;;;;;;; eval-ae ;;;;;;;;

(define-datatype cont-type-eval
  (init-k-eval)
  (k1cont (k cont-type-eval?)
          (v number?))
  (k2cont (k cont-type-eval?)
          (v number?))
  (k3cont (k cont-type-eval?)
          (v number?))
  (k4cont (k cont-type-eval?)
          (v number?))
  (k1 (k cont-type-eval?) exp)
  (k2 (k cont-type-eval?) exp)
  (k3 (k cont-type-eval?) exp)
  (k4 (k cont-type-eval?) exp))

(define eval-ae
  (lambda (exp)
    (eval-ae-cps exp (make-init-k-eval))))

(define eval-ae-cps
  (lambda (exp k)
    (cond
      ((number? exp) (apply-cont-eval k exp))
      ((atom? exp) 
         (error 'eval-ae "invalid expression ~s" exp))
      ((not (= (length exp) 3)) 
         (error 'eval-ae "invalid expression ~s" exp))
      (else
        (case (car exp)
          ((+) (eval-ae-cps (cadr exp) (make-k1 k exp)))
          ((-) (eval-ae-cps (cadr exp) (make-k2 k exp)))
          ((*) (eval-ae-cps (cadr exp) (make-k3 k exp)))
          ((/) (eval-ae-cps (cadr exp) (make-k4 k exp)))
          (else (error 'eval-ae "invalid expression ~s" exp)))))))

(define apply-cont-eval
  (lambda (kprime p)
    (type-case cont-type-eval kprime
      ((init-k-eval) p) 
      ((k1cont k v) (apply-cont-eval k (+ v p)))
      ((k2cont k v) (apply-cont-eval k (- v p)))
      ((k3cont k v) (apply-cont-eval k (* v p)))
      ((k4cont k v) (apply-cont-eval k (/ v p)))
      ((k1 k exp) (eval-ae-cps (caddr exp) (make-k1cont k p)))
      ((k2 k exp) (eval-ae-cps (caddr exp) (make-k2cont k p)))
      ((k3 k exp) (eval-ae-cps (caddr exp) (make-k3cont k p)))
      ((k4 k exp) (eval-ae-cps (caddr exp) (make-k4cont k p))))))

;;;;;;;; map-tree ;;;;;;;;

(define map-tree
  (lambda (f-cps nls)
    (map-tree-cps f-cps nls (lambda (v) v))))

(define map-tree-cps
  (lambda (f-cps nls k)
    (cond
      ((null? nls) (k '()))
      ((list? (car nls))
         (map-tree-cps f-cps (car nls)
           (lambda (v)
             (map-tree-cps f-cps (cdr nls)
                (lambda (w)
                  (k (cons v w)))))))
      (else
         (f-cps (car nls)
           (lambda (v)
             (map-tree-cps f-cps (cdr nls)
               (lambda (w)
                  (k (cons v w))))))))))

;;;;;;;; addfunc ;;;;;;;;

(define addfunc
  (lambda (f-cps g-cps x)
    (addfunc-cps f-cps g-cps x (lambda (v) v))))

(define addfunc-cps
  (lambda (f-cps g-cps x k)
    (f-cps x
      (lambda (v)
        (g-cps x
           (lambda (w)
             (+ v w)))))))

;;;;;;;; operate ;;;;;;;;

(define operate
  (lambda (f-cps)
    (operate-cps f-cps (lambda (v) v))))

(define operate-cps
  (lambda (f-cps k1)
    (k1 (lambda (x k2)
          (f-cps x x k2)))))