(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

(compound-test (continuations)

  (define-test (test-continuation)
    (check
      ;; 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)))))
      (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))
      (= (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)
  ))
  (test-continuation)
  
  (define-test (test-amb)
    (check
      (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))
  ))
  (test-amb)

  (define-test (cooperative-threads)
    (check
      (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)))
  ))
  (cooperative-threads)

  (define-test (iterators)
    (check
      (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))
  ))
  (iterators)
  )