X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=topics%2Fcps_hint_3.mdwn;h=fa8b3736d0a6eaa96edddeba6217862eced75f75;hp=0000000000000000000000000000000000000000;hb=fac1570c5e308143c929a1a0c686d4a45ccaae61;hpb=3a2824d682c7c6860c6487b7dfcbb3b0ce0a5c56 diff --git a/topics/cps_hint_3.mdwn b/topics/cps_hint_3.mdwn new file mode 100644 index 00000000..fa8b3736 --- /dev/null +++ b/topics/cps_hint_3.mdwn @@ -0,0 +1,40 @@ +This function is developed in *The Seasoned Schemer* pp. 84-89. It accepts an atom `a` and a list `lst` and returns `lst` with the leftmost occurrence of `a`, if any, removed. Occurrences of `a` will be found no matter how deeply embedded. + + #lang racket + + (define (atom? x) + (and (not (pair? x)) (not (null? x)))) + + (define gamma + (lambda (a lst) + (letrec ([aux (lambda (l k) + (cond + [(null? l) (k 'notfound)] + [(eq? (car l) a) (cdr l)] + [(atom? (car l)) (cons (car l) (aux (cdr l) k))] + [else + ; when (car l) exists but isn't an atom, we try to remove a from (car l) + ; if we succeed we prepend the result to (cdr l) and stop + (let ([car2 (let/cc k2 + ; calling k2 with val will bind car2 to val and continue with the (cond ...) block below + (aux (car l) k2))]) + (cond + ; if a wasn't found in (car l) then prepend (car l) to the result of removing a from (cdr l) + [(eq? car2 'notfound) (cons (car l) (aux (cdr l) k))] + ; else a was found in (car l) + [else (cons car2 (cdr l))]))]))] + [lst2 (let/cc k1 + ; calling k1 with val will bind lst2 to val and continue with the (cond ...) block below + (aux lst k1))]) + (cond + ; was no atom found in lst? + [(eq? lst2 'notfound) lst] + [else lst2])))) + + (gamma 'a '(((a b) ()) (c (d ())))) ; ~~> '(((b) ()) (c (d ()))) + (gamma 'a '((() (a b) ()) (c (d ())))) ; ~~> '((() (b) ()) (c (d ()))) + (gamma 'a '(() (() (a b) ()) (c (d ())))) ; ~~> '(() (() (b) ()) (c (d ()))) + (gamma 'c '((() (a b) ()) (c (d ())))) ; ~~> '((() (a b) ()) ((d ()))) + (gamma 'c '(() (() (a b) ()) (c (d ())))) ; ~~> '(() (() (a b) ()) ((d ()))) + (gamma 'x '((() (a b) ()) (c (d ())))) ; ~~> '((() (a b) ()) (c (d ()))) +