source: project/release/4/continuations/tags/1.2.1/tests/run.scm @ 29413

(require-library continuations simple-tests)

(import continuations continuations-used simple-tests)

;;; from " A short introduction to call-with-current-continuation"
;;; http://community.scheme-wiki.org
;;; and "Continuations by example ..."
;;; http://matt.might.net/articles

(define (search ok? lst)
  (catch return
         (for-each (lambda (item)
                     (if (ok? item)
                       (throw return item)))
                   lst)
         #f))

(define (search-with-goto ok? lst)
  (let ((start (continuation)))
    (cond
      ((null? lst) #f)
      ((ok? (car lst)) (car lst))
      (else
        (set! lst (cdr lst))
        (goto start)))))

;; nonlocal return: throw and catch in different procedures
(define (treat ok?)
  (lambda (item cont)
    (if (ok? item)
      (throw cont item))))

(define (handled-search handle lst)
  (catch return
         (for-each (lambda (item)
                     (handle item return))
                   lst)
         #f))

;; export continuation ...
(define 1+ #f)
;; ... with catch
(define (init)
  (+ 1 (catch cont
              (set! 1+ (continuation->procedure cont))
              (throw cont 0))))
;; ... with continuation
(define (init-again)
  (+ 1 (let ((cc (continuation)))
         (cond
           ((continuation? cc)
            (set! 1+ (continuation->procedure cc))
            (throw cc 0))
           (else cc)))))

(run-tests
  (= (search even? '(1 2 3)) 2)
  (not (search even? '(1 3)))
  (= (search-with-goto odd? '(0 1 2 3)) 1)
  (not (search-with-goto odd? '(0 2)))
  (= (handled-search (treat even?) '(1 2 3)) 2)
  "AMB"
  (define amb (make-amb))
  (define (pythagoras . choices)
    (let ((a (apply (amb 'choose) choices))
          (b (apply (amb 'choose) choices))
          (c (apply (amb 'choose) choices)))
      ((amb 'assert) (= (* c c) (+ (* a a) (* b b))))
      ((amb 'assert) (< b a))
      (list a b c)))
  (equal? (pythagoras 1 2 3 4 5 6 7) '(4 3 5))
  "COOPERATIVE THREADS"
  (define threads (make-threads))
  (equal?
    (let ((result '()))
      (define make-thunk
        (let ((counter 10))
          (lambda (name)
            (rec (loop)
              (if (< counter 0)
                ((threads 'quit)))
              (set! result (cons (cons name counter) result))
              (set! counter (- counter 1))
              ((threads 'yield))
              (loop)))))
      ((threads 'spawn) (make-thunk 'a))
      ((threads 'spawn) (make-thunk 'aa))
      ((threads 'spawn) (make-thunk 'aaa))
      ((threads 'start))
      (reverse result))
    '((a . 10) (aa . 9) (aaa . 8) (a . 7) (aa . 6) (aaa . 5)
      (a . 4) (aa .  3) (aaa . 2) (a . 1) (aa . 0)))
  "ITERATORS" 
  (equal?
    (let ((tree-iterator (lambda (tree)
                           (lambda (yield)
                             (let walk ((tree tree))
                               (if (pair? tree)
                                 (begin (walk (car tree))
                                        (walk (cdr tree)))
                                 (yield tree))))))
          (result '()))
      (iterate var (tree-iterator '(3 . ((4 . 5) . 6)))
        (set! result (cons var result)))
      (reverse result))
    '(3 4 5 6))
  )