(require-extension continuations)

(import continuations)

;;; von " A short introduction to call-with-current-continuation"
;;; http://community.scheme-wiki.org

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

;; 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))

;; escaping from procedure
(define 1+ #f)

(define (init)
  (+ 1 (catch cont
              ;(set! 1+ cont)
              (set! 1+ (continuation->procedure cont))
              0)))

;;; coroutines with continuation-capture
(define (ping other)
  (let loop ((n 5))
    (print "compute ... " n 0)
    (set! other (capture (continuation->procedure other)))
    (print "compute ... " n 1)
    (set! other (capture (continuation->procedure other)))
    (print "compute ... " n 2)
    (set! other (capture (continuation->procedure other)))
    (if (> n 0)
      (loop (- n 1)))))

(define (pong other)
  (let loop ()
    (for-each (lambda (graphic)
                (print graphic)
                (set! other (capture (continuation->procedure other))))
              '(up right down left))
    (loop)))
;(print (ping (capture pong)))

;; coroutines with call/cc
(define (ying other)
  (let loop ((n 5))
    (print "compute ... " n 0)
    (set! other (call/cc other))
    (print "compute ... " n 1)
    (set! other (call/cc other))
    (print "compute ... " n 2)
    (set! other (call/cc other))
    (if (> n 0)
      (loop (- n 1)))))

(define (yang other)
  (let loop ()
    (for-each (lambda (graphic)
                (print graphic)
                (set! other (call/cc other)))
              '(up right down left))
    (loop)))
;(print (ying yang))

;;; (run xpr0 xpr1 ...)
;;; -------------------
(define (run . xprs)
  (let loop ((xprs xprs))
    (if (null? xprs)
      (print "All tests passed!")
      (if (car xprs)
        (loop (cdr xprs))
        (error 'run "#### Some test failed! ####")))))

;; call as (ping (capture pong))

;; Note that after (init) 1+ does not return!
;; Calling 1+ outside of run will jump into the run loop again
;; making it fail!
(run
  (= (search even? '(1 2 3)) 2)
  (not (search even? '(1 3)))
  (= (handled-search (treat even?) '(1 2 3)) 2)
  (= (init) 1)
  ;(= (1+ 5) 6)
  )