;;-------------------------------------------------------------------------- ;; Solution for hw5 ;; ;; This solution is suggested by Valerio Pascucci ;;-------------------------------------------------------------------------- ;; The rules applied are: ;; - if at top leven there is a if or cond the continuation k ;; is applied to all the braches of the condition; ;; ;; - if the continuation is applied to a simple call if the f ;; than such continuation is passed as continuation of the f-cps ;; itself ;; (k (f ....)) ;; becomes ;; (f-cps ...... k) ;; ;; - if the function f is used inside an expression in non-tail ;; form its call is replace with a name of variable and the expression ;; is enclosed into a lambda that gets in input such variable and used ;; as continuation of the f-cps: ;; (....... (f ...) ......) ;; becomes ;; (f-cps ...... ;; (lambda (v) ;; (........ v ....))) ;; ;; - if in a COND if one of the tests involes the computation of the ;; function f than we have not only ro replace the call to f with ;; a variable v as in the prvious case but also move the remaining ;; branches of the COND insinde the (lambda (v) ...) for example using ;; some (if ...) expressions. ;; ;********************************************************* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;; Exercise 8.5.3 : page 279 ;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;********************************************************* ;--------------------------------------------------- ; auxiliary function used as top level continuation (define final-valcont (lambda (v) (display "The answer is: ") (write v) (newline))) ;********************************************************* ;****************** remove ****************************** ;********************************************************* ;---------------------------------------------- ; regular version of the remove function (define remove* (lambda (a alst) (cond ((null? alst) '()) ((pair? (car alst)) (cons (remove* a (car alst)) (remove* a (cdr alst)))) ((eq? (car alst) a) (remove* a (cdr alst))) (else (cons (car alst) (remove* a (cdr alst))))))) ;---------------------------------------------- ; CPS version of the remove function (define remove*-cps (lambda (a alst k) (cond ((null? alst) (k '())) ((pair? (car alst)) (remove*-cps a (car alst) (lambda (v) (remove*-cps a (cdr alst) (lambda (w) (k (cons v w))))))) ((eq? (car alst) a) (remove*-cps a (cdr alst) k)) (else (remove*-cps a (cdr alst) (lambda (v) (k (cons (car alst) v)))))))) ;********************************************************* ;****************** member ****************************** ;********************************************************* ;--------------------------------------------------------- ;regular version of the function (define member* (lambda (a alst) (cond ((null? alst) #f) ((pair? (car alst)) (or (member* a (car alst)) (member* a (cdr alst)))) ((eq? (car alst) a) alst) (else (member* a (cdr alst)))))) ;---------------------------------------------- ; CPS version of the function (define member*-cps (lambda (a alst k) (cond ; simply apply the continuation to the result ((null? alst) (k #f)) ((pair? (car alst)) ; two recursive calls are prformed requiring to ; construct two nested continuations (member*-cps a (car alst) (lambda (v) (member*-cps a (cdr alst) (lambda (w) (k (or v w ))))))) ; simply apply the continuation to the result ((eq? (car alst) a) (k alst)) ; simply apply the continuation to the result (else (member*-cps a (cdr alst) k))))) ;********************************************************* ;****************** remfirst **************************** ;********************************************************* ;----------------------------------------------------------- ; regular version of the function (define remfirst* (lambda (a alst) (letrec ((loop (lambda (alst) (cond ((null? alst) '()) ((not (pair? (car alst))) (if (eq? (car alst) a) (cdr alst) (cons (car alst) (loop (cdr alst))))) ((equal? (loop (car alst)) (car alst)) (cons (car alst) (loop (cdr alst)))) (else (cons (loop (car alst)) (cdr alst))))))) (loop alst)))) ;---------------------------------------------- ; CPS version of the function (define remfirst*-cps (lambda (a alst k) (letrec ((loop-cps (lambda (alst k) (cond ((null? alst) (k '())) ((not (pair? (car alst))) (if (eq? (car alst) a) (k (cdr alst) ) (loop-cps (cdr alst) (lambda (v) (k (cons (car alst) v)))))) (else (loop-cps (car alst) (lambda (v) (if (equal? v (car alst)) (loop-cps (cdr alst) (lambda (v) (k (cons (car alst) v)))) (loop-cps (car alst) (lambda (v) (k (cons v (cdr alst))))))))))))) (loop-cps alst k)))) ;********************************************************* ;****************** depth ******************************* ;********************************************************* ;----------------------------------------------------------- ; regular version of the function (define depth (lambda (alst) (cond ((null? alst) 1) ((not (pair? (car alst))) (depth (cdr alst))) ((< (+ (depth (car alst)) 1) (depth (cdr alst))) (depth (cdr alst))) (else (+ (depth (car alst)) 1))))) ;---------------------------------------------- ; CPS version of the function (define depth-cps (lambda (alst k) (cond ((null? alst) (k 1)) ((not (pair? (car alst))) (depth-cps (cdr alst) k)) (else (depth-cps (cdr alst) (lambda (v) (depth-cps (car alst) (lambda (w) (if (< (+ w 1) v) (depth-cps (cdr alst) k) (depth-cps (car alst) (lambda (v) (k (+ v 1))))))))))))) ;********************************************************* ;****************** depth-with-let ********************** ;********************************************************* ;----------------------------------------------------------- ; regular version of the function (define depth-with-let (lambda (alst) (if (null? alst) 1 (let ((drest (depth-with-let (cdr alst)))) (if (pair? (car alst)) (let ((dfirst (+ (depth-with-let (car alst)) 1))) (if (< dfirst drest) drest dfirst)) drest))))) ;---------------------------------------------- ; CPS version of the function (define depth-with-let-cps (lambda (alst k) (if (null? alst) (k 1) (depth-with-let-cps (cdr alst) (lambda (v) (let ((drest v)) (if (pair? (car alst)) (depth-with-let-cps (car alst) (lambda (v) (let ((dfirst (+ v 1))) (if (< dfirst drest) (k drest) (k dfirst))))) (k drest)))))))) ;********************************************************* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;; Exercise 8.5.4 : page 281 ;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;********************************************************* ;********************************************************* ;****************** map ******************************** ;********************************************************* ;----------------------------------------------------------- ; regular version of the function (define map* (lambda (f ls) (if (null? ls) '() (cons (f (car ls)) (map* f (cdr ls)))))) ;---------------------------------------------- ; CPS version of the function (define map-cps (lambda (f ls k) (if (null? ls) (k '()) (map-cps f (cdr ls) (lambda (v) (f (car ls) (lambda (w) (k (cons w v))))))))) ;********************************************************* ;****************** fnlr>n ***************************** ;********************************************************* ;----------------------------------------------------------- ; regular version of the function (define fnlr>n* (lambda (alist n) (if (null? alist) '() (if (number? alist) (if (> alist n) alist '()) (let ((result-car (fnlr>n* (car alist) n))) (if (null? result-car) (fnlr>n* (cdr alist) n) result-car)))))) ;---------------------------------------------------------- ; CPS version of the function (define fnlr>n (lambda (alist n k) (if (null? alist) (k '()) (if (number? alist) (if (> alist n) (k alist) (k '())) (fnlr>n (car alist) n (lambda (v) (let ((result-car v)) (if (null? result-car) (fnlr>n (cdr alist) n k) (k result-car))))))))) ;********************************************************* ;****************** add>n ****************************** ;********************************************************* ;----------------------------------------------------------- ; regular version of the function (define add>n* (lambda (alist n) (cond ((number? alist) (if (> alist n) alist 0)) ((pair? alist) (+ (add>n* (cdr alist) n) (add>n* (car alist) n))) (else 0)))) ;---------------------------------------------------------- ; CPS version of the function (define add>n (lambda (alist n k) (cond ((number? alist) (if (> alist n) (k alist) (k 0))) ((pair? alist) (add>n (car alist) n (lambda (v) (add>n (cdr alist) n (lambda (w) (k (+ w v))))))) (else (k 0))))) ;********************************************************* ;****************** andmap ***************************** ;********************************************************* ;----------------------------------------------------------- ; regular version of the function (define andmap* (lambda (f ls) (if (null? ls) #t (and (f (car ls)) (andmap* f (cdr ls)))))) ;---------------------------------------------------------- ; CPS version of the function (define andmap (lambda (f ls k) (if (null? ls) (k #t) (f (car ls) (lambda (v) (andmap f (cdr ls) (lambda (w) (k (and v w))))))))) ;---------------------------------------------------------- ; cps version of the test NULL? (define null?-cps (lambda (x k) (k (null? x))))