diff options
Diffstat (limited to 'ps07_amb/funco.scm')
| -rw-r--r-- | ps07_amb/funco.scm | 223 |
1 files changed, 223 insertions, 0 deletions
diff --git a/ps07_amb/funco.scm b/ps07_amb/funco.scm new file mode 100644 index 0000000..73fb947 --- /dev/null +++ b/ps07_amb/funco.scm @@ -0,0 +1,223 @@ +;;;; Fun with Continuations + +#| Adapted from MIT/GNU Scheme Reference Manual [Section 12.4]: + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 -19)) ; ** + #t)) +;Value: -3 + +|# + +;;; Continuations as Non-Local Exits + +(define (funco:first-negative list-of-numbers) + (call-with-current-continuation + (lambda (k_exit) + (or (call-with-current-continuation + (lambda (k_shortcut) + (for-each (lambda (n) + (cond ((not (number? n)) + (pp `(not-a-number: ,n)) + (k_exit #f)) + ((negative? n) + (k_shortcut n)) + (else + ':keep-looking))) + list-of-numbers) + #f ;; Fall-through sentinel: no negatives found. + )) + ':no-negatives-found)))) + +#| +(funco:first-negative '(54 0 37 -3 245 -19)) +;Value: -3 + +(funco:first-negative '(54 0 37 3 245 19)) +;Value: :no-negatives-found + +(funco:first-negative '(54 0 37 no 245 boo)) +(not-a-number: no) +;Value: #f +|# + +;;; Continuations for Proceeding (Suspend/Resume Backtracking) + +(define (funco:first-negative-n-proceed list-of-numbers) ;;; ** + (call-with-current-continuation + (lambda (k_exit) + (or (call-with-current-continuation + (lambda (k_shortcut) + (for-each (lambda (n) + (pp ;;; ** + (call-with-current-continuation ;;; ** + (lambda (k_proceed) ;;; ** + (cond ((not (number? n)) + (pp `(not-a-number: ,n)) + (k_exit + (cons n k_proceed))) ;;; ** + ((negative? n) + (k_shortcut + (cons n k_proceed))) ;;; ** + (else + ':keep-looking))) + ))) ;;; ** + list-of-numbers) + #f ;; Fall-through sentinel: no negatives found. + )) + ':no-negatives-found)))) + +(define (funco:first-negative-n-proceed-more? smore) (pair? smore)) +(define (funco:first-negative-n-proceed-more/found smore) (car smore)) +(define (funco:first-negative-n-proceed-more/k smore) (cdr smore)) +(define (funco:first-negative-n-proceed-more/next smore) + ((funco:first-negative-n-proceed-more/k smore) + (funco:first-negative-n-proceed-more/found smore))) + +#| +;;; ------------ +(define funco:first-of-two + (funco:first-negative-n-proceed '(54 0 37 -3 245 -19))) +:keep-looking +:keep-looking +:keep-looking +;Value: funco:first-of-two + +(funco:first-negative-n-proceed-more? funco:first-of-two) +;Value: #t + +(funco:first-negative-n-proceed-more/found funco:first-of-two) +;Value: -3 + +(funco:first-negative-n-proceed-more/next funco:first-of-two) +-3 +:keep-looking +;Value: funco:first-of-two + +(funco:first-negative-n-proceed-more? funco:first-of-two) +;Value: #t + +(funco:first-negative-n-proceed-more/found funco:first-of-two) +;Value: -19 + +(funco:first-negative-n-proceed-more/next funco:first-of-two) +-19 +;Value: funco:first-of-two + +(funco:first-negative-n-proceed-more? funco:first-of-two) +;Value: #f + +funco:first-of-two +;Value: :no-negatives-found +|# + +#| +;;; ---- +(define funco:nada + (funco:first-negative-n-proceed '(54 0 37 3 245 19))) +:keep-looking +:keep-looking +:keep-looking +:keep-looking +:keep-looking +:keep-looking +;Value: funco:nada + +(funco:first-negative-n-proceed-more? funco:nada) +;Value: #f + +funco:nada +;Value: :no-negatives-found +|# + +#| +;;; ---- +(define funco:nans + (funco:first-negative-n-proceed '(54 0 37 no 245 boo))) +:keep-looking +:keep-looking +:keep-looking +(not-a-number: no) +;Value: funco:nans + +(funco:first-negative-n-proceed-more? funco:nans) +;Value: #t + +(funco:first-negative-n-proceed-more/found funco:nans) +;Value: no + +(funco:first-negative-n-proceed-more/next funco:nans) +no +:keep-looking +(not-a-number: boo) +;Value: funco:nans + +(funco:first-negative-n-proceed-more? funco:nans) +;Value: #t + +(funco:first-negative-n-proceed-more/next funco:nans) +boo +;Value: funco:nans + +(funco:first-negative-n-proceed-more? funco:nans) +;Value: #f + +funco:nans +;Value: :no-negatives-found +|# + +;;; Continuations for Backtracking (Re-entrant 1st-Class Continuations) + +(define *k_re-funco*) +(define funco) + +#| +(begin + (set! funco (+ 2 (call-with-current-continuation + (lambda (k_re-funco) + (set! *k_re-funco* k_re-funco) + 3)))) + ':ok) +;Value: :ok + +funco +;Value: 5 + +(*k_re-funco* 4) +;Value: :ok + +funco +;Value: 6 + +(*k_re-funco* 5) +;Value: :ok + +funco +;Value: 7 +|# + +;;; Dynamic Contexts and Within-Continuation + +(define (funco:test-k-thunk k-thunk) + (let ((*foo* 2)) ;----------------------. + (define (foo-thunk) *foo*) ; *foo* is 2 out here. : + (call-with-current-continuation ; : + (lambda (k) ; : + (fluid-let ((*foo* 3)) ;---------------------. : + (k-thunk k foo-thunk) ; *foo* is 3 in here. : : + ) ;---------------------' : + )) ; *foo* is 2 out here. : + )) ;----------------------' +#| +(funco:test-k-thunk (lambda (k thunk) + (k (thunk)))) +;Value: 3 + +(funco:test-k-thunk (lambda (k thunk) + (within-continuation k thunk))) +;Value: 2 +|# |