C311 Fall96. Assignment 8 (solution)

;;
;; C311 Assignment 8
;; CPS Transformation (Registers and Stacks)
;; Due F 11/08/96 @ 5:00pm
;;

(define k-reg  'ignored)
(define a-reg  'ignored)
(define v-reg  'ignored)
(define n-reg  'ignored)
(define ls-reg 'ignored)
(define s0-reg 'ignored)
(define s1-reg 'ignored)

; 1. list index

(define list-index
  (lambda (a ls)
    (set! a-reg a)
    (set! ls-reg ls)
    (set! k-reg (make-final-k))
    (list-index-cps/reg)))

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

(define make-listindex-k
  (lambda (k)
    (list 'listindex-k k)))


; 2. intersection

(define intersection
  (lambda (s0 s1)
    (set! s0-reg s0)
    (set! s1-reg s1)
    (set! k-reg (make-final-k))
    (intersection-cps/reg)))

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

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

; 3 count-parens

(define count-parens
  (lambda (ls)
    (set! ls-reg ls)
    (set! k-reg (make-final-k))
    (count-parens-cps/reg)))

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

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

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

; 4 depth

(define depth
  (lambda (ls)
    (set! ls-reg ls)
    (set! k-reg (make-final-k))
    (depth-cps/reg)))

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

(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)
    (set! a-reg a)
    (set! v-reg v)
    (set! k-reg (make-final-k))
    (vector-index-cps/reg)))

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

;;
;;
;; apply-k

(define apply-k/reg
  (lambda ()
    (record-case k-reg
      (listindex-k (k)
	(let ([answ v-reg])
	  (if (= answ -1)
	      (begin
		(set! k-reg k)
		(set! v-reg -1)
		(apply-k/reg))
	      (begin
		(set! k-reg k)
		(set! v-reg (add1 answ))
		(apply-k/reg)))))
      (intersection-k (s0 k)
	(let ([v v-reg])
	  (set! k-reg k)
	  (set! v-reg (cons (car s0) v))
	  (apply-k/reg)))
      (countparens-k (ls k)
	(let ([v-car v-reg])
	  (set! k-reg (make-countparens2-k v-car k))
	  (set! ls-reg (cdr ls))
	  (count-parens-cps/reg)))
      (countparens2-k (v-car k)
	(let ([v-cdr v-reg])
	  (set! k-reg k)
	  (set! v-reg  (+ v-car v-cdr))
	  (apply-k/reg)))
      (depth-k (ls k)
	(let ([v-car v-reg])
	  (set! k-reg (make-depth2-k v-car k))
	  (set! ls-reg (cdr ls))
	  (depth-cps/reg)))
      (depth2-k (v-car k)
	(let ([v-cdr v-reg])
	  (set! k-reg k)
	  (set! v-reg (max (add1 v-car) v-cdr))
	  (apply-k/reg)))
      (final-k ()
	v-reg)
      (else (error 'apply-k "invalid continuation ~s" k-reg)))))

(define make-final-k
  (lambda ()
    (list 'final-k)))