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

;;; amb
(define-values (amb-fail amb-choose amb-assert)
  (let ((amb-stack '()))
    (values
      (lambda ()
        (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")))
      (lambda 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)))))
      (lambda (xpr)
        (if (not xpr)
          (amb-fail)
          #t))
      )))

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

;;; cooperative threads
(define-values
  (threads-halt threads-spawn threads-yield threads-quit threads-start)
  (let ((threads-queue '()))
    (values
      #f
      (lambda (thunk)
        (let ((cc (continuation)))
          (if (continuation? cc)
            (set! threads-queue
                  (append threads-queue (list cc)))
            (begin (thunk) (threads-quit)))))
      (lambda ()
        (let ((cc (continuation)))
          (if (and (continuation? cc) (pair? threads-queue))
            (let ((next-thread (car threads-queue)))
              (set! threads-queue
                    (append (cdr threads-queue) (list cc)))
              (throw next-thread 'resume)))))
      (lambda ()
        (if (pair? threads-queue)
          (let ((next-thread (car threads-queue)))
            (set! threads-queue (cdr threads-queue))
            (throw next-thread 'resume))
          (threads-halt)))
      (lambda ()
        (let ((cc (continuation)))
          (when cc;(continuation? cc)
            (set! threads-halt (lambda () (throw cc #f)))
            (if (not (null? threads-queue))
              (let ((next-thread (car threads-queue)))
                (set! threads-queue (cdr threads-queue))
                (throw next-thread 'resume)))))))))

;;; iterators
(define-syntax iterate
  (syntax-rules ()
    ((_ var iterator xpr . xprs)
     (let ((it iterator) (it-cont #f))
       (let loop ()
         (let ((cc (continuation)))
           (if (continuation? cc)
             ;; first let-pass
             (if (continuation? it-cont)
               (throw it-cont (void))
               (it (lambda (val)
                   (catch next-cc
                     (throw cc (cons next-cc val))))))
             ;; second let-pass (cc is now pair)
             (let ((next-cont (car cc))
                   (next-val (cdr cc)))
               (set! it-cont next-cont)
               (let ((var next-val)) xpr . xprs)
               (loop)))))))))


(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"
  (equal? (pythagoras 1 2 3 4 5 6 7) '(4 3 5))
  "COOPERATIVE 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))
  )