From: Jim Date: Thu, 30 Apr 2015 16:39:36 +0000 (-0400) Subject: add cps_hint_* X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=commitdiff_plain;h=fac1570c5e308143c929a1a0c686d4a45ccaae61;hp=3a2824d682c7c6860c6487b7dfcbb3b0ce0a5c56 add cps_hint_* --- diff --git a/topics/cps_hint_1.mdwn b/topics/cps_hint_1.mdwn new file mode 100644 index 00000000..985ba183 --- /dev/null +++ b/topics/cps_hint_1.mdwn @@ -0,0 +1,27 @@ +This function is developed in *The Seasoned Schemer* pp. 55-60. It accepts an atom `a` and a list of atoms `lst`, and returns the part of `lst` following the last occurrence of `a`. If `a` is not in `lst`, it returns `lst` unaltered. + + #lang racket + + (define (atom? x) + (and (not (pair? x)) (not (null? x)))) + + (define alpha + (lambda (a lst) + (let/cc k ; calling k with val will immediately return val from the call to alpha + (letrec ([aux (lambda (l) + (cond + [(null? l) '()] + [(eq? (car l) a) + ; we abandon any waiting recursive (aux ...) calls, and instead immediately return (aux (cdr l)) + ; ...since Scheme is call-by-value, (aux (cdr l)) will be evaluated first, and + ; any calls to k therein will come first (and the pending (k ...) here will be abandoned) + (k (aux (cdr l)))] + [else (cons (car l) (aux (cdr l)))]))]) + (aux lst))))) + + + (alpha 'a '(a b c a d e f)) ; ~~> '(d e f) + (alpha 'x '(a b c a d e f)) ; ~~> '(a b c a d e f) + (alpha 'f '(a b c a d e f)) ; ~~> '() + (alpha 'a '(a b c x d e f)) ; ~~> '(b c x d e f) + diff --git a/topics/cps_hint_2.mdwn b/topics/cps_hint_2.mdwn new file mode 100644 index 00000000..d948a280 --- /dev/null +++ b/topics/cps_hint_2.mdwn @@ -0,0 +1,43 @@ +This function is developed in *The Seasoned Schemer* pp. 76-83. It accepts a list `lst` and returns the leftmost atom in it, even if that atom is embedded several levels deep. Any empty lists preceding the leftmost atom are ignored. + + + #lang racket + + (define (atom? x) + (and (not (pair? x)) (not (null? x)))) + + (define beta + (lambda (lst) + (let/cc k ; calling k with val will immediately return val from the call to beta + (letrec ([aux (lambda (l) + (cond + [(null? l) '()] + [(atom? (car l)) (k (car l))] + [else (begin + ; each of the following lines will evaluate to '() iff no atom was found in the specified part of l + (aux (car l)) + (aux (cdr l)))]))]) + (aux lst))))) + + (beta '(((a b) ()) (c (d ())))) ; ~~> 'a + (beta '((() (a b) ()) (c (d ())))) ; ~~> 'a + (beta '(() (() (a b) ()) (c (d ())))) ; ~~> 'a + (beta '(() (() ()))) ; no leftmost atom, returns '() + +This function could also be written like this: + + (define leftmost + (lambda (l) + (cond + [(null? l) '()] + [(atom? (car l)) (car l)] + [else (let ([found (leftmost (car l))]) + (cond + ; here we check whether the recursive call found an atom in (car l) + [(atom? found) found] + ; if not, we search for an atom in (cdr l) + [else (leftmost (cdr l))]))]))) + +But in this version, when an atom is found, it is returned back the chain of recursive calls, one by one. The previous version, on the other hand, uses a captured continuation `k` to return the atom immediately upon finding it. + + 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 ()))) + diff --git a/topics/cps_hint_4.mdwn b/topics/cps_hint_4.mdwn new file mode 100644 index 00000000..028504cd --- /dev/null +++ b/topics/cps_hint_4.mdwn @@ -0,0 +1,56 @@ +This function is developed in *The Seasoned Schemer* pp. 165-177. It accepts a list `lst` and returns `#t` or `#f` depending on whether any atom appears in `lst` twice in a row. The list is interpreted as though it were flattened: all embedded lists are collapsed into the topmost level, and empty list elements are ignored. However, no flattened copy of the list is ever constructed. + + #lang racket + + (define (atom? x) + (and (not (pair? x)) (not (null? x)))) + + (define delta + (letrec ([yield (lambda (x) x)] + [resume (lambda (x) x)] + [walk (lambda (l) + (cond + ; this is the only case where walk terminates naturally + [(null? l) '()] + [(atom? (car l)) (begin + (let/cc k2 (begin + (set! resume k2) ; now calling resume with val will ignore val + ; and continue with the final line of (begin ... (walk (cdr l))) + ; when the next line is executed, yield will be bound to k1 or k3 + (yield (car l)))) + ; the previous yield line will never return, but the following line will be executed when resume is called + (walk (cdr l)))] + [else (begin + ; walk will only ever return when a '() is reached, and will in that case return a '() + (walk (car l)) + (walk (cdr l)))]))] + [next (lambda () ; next is a thunk + (let/cc k3 (begin + (set! yield k3) ; now calling yield with val will return val from the call to next + ; when the next line is executed, resume will be bound to k2 + (resume 'blah))))] + [check (lambda (prev) + (let ([n (next)]) + (cond + [(eq? n prev) #t] + [(atom? n) (check n)] + ; n will fail to be an atom iff we've walked to the end of the list, and (resume 'blah) returned naturally + [else #f])))]) + (lambda (lst) + (let ([fst (let/cc k1 (begin + (set! yield k1) ; now calling yield with val will bind fst to val and continue with the (cond ...) block below + (walk lst) + ; the next line will be executed when we've walked to the end of lst + (yield '())))]) + (cond + [(atom? fst) (check fst)] + [else #f]) + )))) + + (delta '(((a b) ()) (c (d ())))) ; ~~> #f + (delta '(((a b) ()) (b (d ())))) ; ~~> #t + (delta '(((a b) ()) (c (d (d))))) ; ~~> #t + (delta '(((a b c) ()) (c (d ())))) ; ~~> #t + (delta '(((a b) ()) (c (d ()) c))) ; ~~> #f + (delta '((() ()) ())) ; ~~> #f +