C311 Spring 1997. Assignment 7. Representation Independent Continuations

;;
;; C311 Assignment 7
;; CPS transformation.  Representation Independent Procedures
;; Due R 3/13 @ 11:59pm
;;

; 1. assq

(define assq
  (lambda (a als)
    (assq-cps a als (make-final-val-k))))

(define assq-cps
  (lambda (a als k)
    (cond
      [(null? als) (apply-k k #f)]
      [(eq? (caar als) a) (apply-k k (car als))]
      [else (assq-cps a (cdr als) k)])))


; 2. duplicate

(define duplicate
  (lambda (n a)
    (duplicate-cps n a (make-final-val-k))))

(define duplicate-cps
  (lambda (n a k)
    (if (zero? n)
      (apply-k k '())
      (duplicate-cps (sub1 n) a (make-duplicate-k a k)))))

(define make-duplicate-k
  (lambda (a k)
    (list 'duplicate-k a k)))


; 3. union

(define union
  (lambda (s0 s1)
    (union-cps s0 s1 (make-final-val-k))))

(define union-cps
  (lambda (s0 s1 k)
    (if (null? s0)
      (apply-k k s1)
      (memq-cps (car s0) s1 (make-union-car-k s0 s1 k)))))

(define make-union-car-k
  (lambda (s0 s1 k)
    (lambda (v)
      (if v
	(union-cps (cdr s0) s1 k)
	(union-cps (cdr s0) s1 (make-union-cdr-k s0 k))))))

(define make-union-cdr-k
  (lambda (s0 k)
    (lambda (v)
      (apply-k k (cons (car s0) v)))))


; 4. snoc

(define snoc
  (lambda (ls i)
    (snoc-cps ls i (make-final-val-k))))

(define snoc-cps
  (lambda (ls i k)
    (if (null? ls)
      (apply-k k (list i))
      (snoc-cps (cdr ls) i (make-snoc-k ls k)))))

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


; 5. prefixes

(define prefixes
  (lambda (ls)
    (prefixes-cps ls (make-final-val-k))))

(define prefixes-cps
  (letrec ([prefix-hlp
	     (lambda (ls current-prefix answ k)
	       (if (null? ls)
		 (apply-k k answ)
		 (snoc-cps current-prefix (car ls) (make-prefixes-k prefix-hlp ls answ k))))])
    (lambda (ls k)
      (prefix-hlp ls '() '(()) k))))

(define make-prefixes-k
  (lambda (prefix-hlp ls answ k)
    (list 'prefixes-k prefix-hlp ls answ k)))


;;
;;
;; apply-k

(define apply-k
  (lambda (k v)
    (if (procedure? k)
      (k v)
      (record-case k
	(duplicate-k (a k)
	  (apply-k k (cons a v)))
	(snoc-k (ls k)
	  (apply-k k (cons (car ls) v)))
	(prefixes-k (prefix-hlp ls answ k)
	  (let ([new-prefix v])
	    (prefix-hlp
	      (cdr ls)
	      new-prefix
	      (cons new-prefix answ)
	      k)))
	(else (error 'apply-k "invalid continuation ~s" k))))))

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