(require-library continuations simple-tests)

(import continuations 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)))))

;;; coroutines with 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-pong")
;(print (ping (capture pong)))

(define amb-stack '())
(define (amb-fail)
  (if (pair? amb-stack)
    (let ((back-track-point (car amb-stack)))
      (set! amb-stack (cdr amb-stack))
      (goto back-track-point))
    (error 'amb-fail "amb-stack exhausted")))
(define (amb . choices)
  (let ((cc (continuation)))
    (cond
      ((null? choices)
       (amb-fail))
      ((pair? choices)
       (let ((choice (car choices)))
         (set! choices (cdr choices))
         (set! amb-stack (cons cc amb-stack))
         choice)))))
(define (amb-assert xpr)
  (if (not xpr)
    (amb-fail)
    #t))
(define (pythagoras . lst)
  (let ((a (apply amb lst))
        (b (apply amb lst))
        (c (apply amb lst)))
    (amb-assert (= (* c c) (+ (* a a) (* b b))))
    (amb-assert (< b a))
    (list a b c)))

;;; (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! ####")))))

(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)
;  (not 1+)
;  (= (init) 1)
;  (= (1+ 5) 6)
;  (= (init-again) 1)
;  (= (1+ 25) 26)
  (equal? (pythagoras 1 2 3 4 5 6 7) '(4 3 5))
  )