C311 Fall96. Assignment 7 (solution)

;;
;; C311 Assignment 7
;; CPS transformation
;; Due F 11/01/96 @ 5:00pm
;;


; 1. list index

(define list-index
  (lambda (a ls)
    (list-index-cps a ls (make-final-valcont))))

(define list-index-cps
  (lambda (a ls k)
    (cond
      [(null? ls) (apply-k k -1)]
      [(eq? (car ls) a) (apply-k k 0)]
      [else (list-index-cps a (cdr ls) (make-listindex-k k))])))

(define make-listindex-k
  (lambda (k)
    (lambda (v)
      (let ([answ v])
	(if (= answ -1)
	    (apply-k k -1)
	    (apply-k k (add1 answ)))))))


; 2. intersection

(define intersection
  (lambda (s0 s1)
    (intersection-cps s0 s1 (make-final-valcont))))

(define intersection-cps
  (lambda (s0 s1 k)
    (cond
      [(null? s0) (apply-k k '())]
      [(memq (car s0) s1)
       (intersection-cps (cdr s0) s1
	 (make-intersection-k s0 k))]
      [else
	(intersection-cps (cdr s0) s1 k)])))

(define make-intersection-k
  (lambda (s0 k)
    (list 'intersection-k s0 k)))

; 3 count-parens

(define count-parens
  (lambda (ls)
    (count-parens-cps ls (make-final-valcont))))

(define count-parens-cps
  (lambda (ls k)
    (cond
      [(null? ls) (apply-k k 2)]
      [(list? (car ls))
       (count-parens-cps (car ls) (make-countparens-k ls k))]
      [else
	(count-parens-cps (cdr ls) k)])))

(define make-countparens-k
  (lambda (ls k)
    (lambda (v-car)
      (count-parens-cps (cdr ls) (make-countparens2-k v-car k)))))

(define make-countparens2-k
  (lambda (v-car k)
    (lambda (v-cdr)
      (apply-k k (+ v-car v-cdr)))))

; 4 depth

(define depth
  (lambda (ls)
    (depth-cps ls (make-final-valcont))))

(define depth-cps
  (lambda (ls k)
    (cond
      [(null? ls) (apply-k k 1)]
      [(pair? ls) (depth-cps (car ls) (make-depth-k ls k))]
      [else (apply-k k 0)])))

(define make-depth-k
  (lambda (ls k)
    (list 'depth-k ls k)))

(define make-depth2-k
  (lambda (v-car k)
    (list 'depth2-k v-car k)))

; vector-index

(define vector-index
  (lambda (a v)
    (vector-index-cps a v (make-final-valcont))))

(define vector-index-cps
  (lambda (a v k)
    (let ([vlen (vector-length v)])
      (letrec ([vindex-hlp-cps
		 (lambda (n k)
		   (cond
		     [(= vlen n)	(apply-k k -1)]
		     [(eq? (vector-ref v n) a) (apply-k k n)]
		     [else (vindex-hlp-cps (add1 n) k)]))])
	(vindex-hlp-cps 0 k)))))

;;
;;
;; apply-k

(define apply-k
  (lambda (k v)
    (if (procedure? k)
	(k v)
	(record-case k
	  (intersection-k (s0 k)
	    (let ([v v])
	      (apply-k k (cons (car s0) v))))
	  (depth-k (ls k)
	    (let ([v-car v])
	      (depth-cps (cdr ls) (make-depth2-k v-car k))))
	  (depth2-k (v-car k)
	    (let ([v-cdr v])
	      (apply-k k (max (add1 v-car) v-cdr))))
	  (else (error 'apply-k "invalid continuation ~s" k))))))

(define make-final-valcont
  (lambda ()
    (lambda (v)
      v)))