;; using call/cc as a catch/throw mechanism
(define (contains item ls)
  (print "enter fn")
  (let ((result (call/cc
                 (lambda (exit)
                   (print "enter lambda")
                   (dolist (e ls)
                     (print "iteration: " e)
                     (when (eq? e item)
                       (print "found match, exit")
                       (exit #t)))
                   (print "leave lambda")
                   #f))))
    (print "leave fn")
    result))

(print (contains 'a '(b a h)))
(print (contains 'a '(b c d)))

;; rewritten version, based on product function below (from TSPL)
(define (contains item ls)
  (call/cc
   (lambda (break)
     (let loop ((ls ls))
       (cond ((null? ls) #f)
             ((eq? item (car ls)) (break #t))
             (else (loop (cdr ls))))))))

(print (contains 'a '(b a h)))
(print (contains 'a '(b c d)))

(define (product ls)
  (call/cc
   (lambda (break)
     (let f ((ls ls))
       (cond
        ((null? ls) 1)
        ((= (car ls) 0) (break 0))
        (else (* (car ls) (f (cdr ls)))))))))

(print (product '(1 2 3 4 5)))
(print (product '(7 3 8 0 1 9 5)))

;; -----------------------------------------------------------------
;; break points (see applications-of-continuations.pdf)
(define resume #f)

;; meta:
;; (define (break message)
;;   (call/cc
;;    (lambda (k)
;;      (set! resume k)
;;      ((lambda^ (x) x) message))))
;;
;; where (lambda^ (id ...) e ...) ==
;;       (lambda (id ...) (invoke/no-cont (lambda () e ...)))

(define invoke/no-cont #f)

(define (make-invoke/no-cont)
  ((call/cc
    (lambda (k)
      (set! invoke/no-cont (lambda (th) (k th)))
      (lambda () 'invoke/no-cont)))))

;; this must be done at toplevel
(make-invoke/no-cont)

(define (break message)
  (call/cc
   (lambda (k)
     (set! resume k)
     ((lambda (x) (invoke/no-cont (lambda () x))) message))))

(define (fact n)
  (cond ((= n 1) (break "break!") 1)
        (else (* n (fact (- n 1))))))

;; (fact 10)
;; -> break!
;; (resume)
;; -> 3628800

;; -----------------------------------------------------------------
;; call/cc with dynamic wind

;; from the dynamic-wind info:
(letrec ((paths '())
         (c #f)
         (add (lambda (s) (push! paths s))))
  (dynamic-wind
      (lambda () (add 'connect))
      (lambda ()
        (add (call/cc (lambda (c0) (set! c c0) 'talk1))))
      (lambda () (add 'disconnect)))
  (if (< (length paths) 4)
      (c 'talk2)
      (reverse paths)))
;; -> (connect talk1 disconnect connect talk2 disconnect)

;; example with explicit finalisation
(define (with-database-connection query)
  (dynamic-wind
      (lambda () (print "opening connection"))
      (lambda () (print "exec: " query))
      (lambda () (print "closing connection"))))

;; brainfart: let causes infinite loop
(define (make-transaction-context database-connection)
  (let ((continuation #f))
    (dynamic-wind
        (lambda () (format #t "(start-txn ~s)\n" database-connection))
        (lambda () (format #t "(exec ~s ~a)\n"
                           database-connection
                           (call/cc (lambda (c)
                                      (set! continuation c)
                                      "initialising"))))
        (lambda () (format #t "(commit-txn ~s)\n" database-connection)))
    continuation))

(define ctx (make-transaction-context 'pgsql))
(ctx "select foo from bar")

(let ((pgsql-ctx (make-transaction-context 'pgsql)))
  (pgsql-ctx "select foo from bar")) 

;; From: Shiro Kawai <shiro@la...>
;; Re: dynamic-wind with call/cc behaviour
;; 2002-12-20 05:45
;;  Well, calling a continuation from toplevel is somewhat tricky
;;  (I think the semantics of "toplevel" is not really well defined)
;;  but the behavior within let is exptected.
;;
;;  > gosh> (let ((pgsql-ctx (make-transaction-context 'pgsql)))
;;  >        (pgsql-ctx "select foo from bar"))
;;
;;  It is better understood without dynamic-wind, for it has
;;  nothing to do with the infinite loop.
;;
;;  The first time make-transaction-context is executed,
;;  call/cc captures the following continuation:
;;
;;    (1) With the return value, call (format #t "(exec ....
;;    (2) Return the value of "continuation"---which is
;;        bound to the captured continuation itself.
;;    (3) Binds pgsql-ctx with the captured continuation
;;    (4) Invokes the captured continuation with
;;        argument "select foo from bar".
;;
;;  Now, the return value of make-transaction-context
;;  encapsulates the above actions.  You bind it to pgsql-ctx,
;;  then invokes it with "select foo from bar".
;;
;;  The control resumes from (1), as if call/cc returns
;;  "select foo from bar".   As you see, you'll go through
;;  the same steps as the first time, and at (4) you invokes
;;  the same continuation----then restarts from (1), and so on.
;;
;;  The essence is that (1) the continuation captures not only
;;  the flow within make-transaction-context, but entire
;;  context of let, and (2) you're returning the same
;;  continuation repeatedly to be called.
;;
;;  --shiro

(define ctx #f)

(define (make-transaction-context database-connection)
  (dynamic-wind
      (lambda () (format #t "(start-txn ~s)\n" database-connection))
      (lambda () (format #t "(exec ~s ~a)\n"
                         database-connection
                         (call/cc (lambda (c)
                                    (set! ctx c)
                                    "initialising"))))
      (lambda () (format #t "(commit-txn ~s)\n" database-connection))))

(make-transaction-context 'pgsql)
(ctx "select foo from bar")

;; -----------------------------------------------------------------
;; continuation stuff from On Lisp, Chp 20.

(define frozen ())

(append '(the call/cc returned)
        (list (call/cc
               (lambda (cc)
                 (set! frozen cc)
                 'a))))
;; yields (the call/cc returned a)

;; now call the continuation repeatedly
(frozen 'again)                         ; (the call/cc returned again)
(frozen 'thrice)                        ; (the call/cc returned thrice)
;; the pending (+ 1 ...) is ignored. The continuation returns up the
;; stack that was pending at the time it was first created
(+ 1 (frozen 'safely))                  ; (the call/cc returned safely)

;; Continuations do not get unique copies of the stack. They may share
;; variables with other continuations, or with the computation
;; currently in progress. In this example, two continuations share the
;; same stack:
(define frozen1 ())
(define frozen2 ())
(let1 x 0
  (call/cc
   (lambda (cc)
     (set! frozen1 cc)
     (set! frozen2 cc)))
  (inc! x)
  x)                                    ; 1
(frozen1)                               ; 2
(frozen2)                               ; 3

;; traversing trees using continuations
(define t1 '(a (b (d h)) (c e (f i) g)))
(define t2 '(1 (2 (3 6 7) 4 5)))

;; first an ordinary depth-first traversal
(define (dft tree)
  (cond ((null? tree) ())
        ((not (pair? tree)) (display tree))
        (else (dft (car tree))
              (dft (cdr tree)))))

;; then traversal using continuations, dealing out nodes one at a time
(define *saved* ())

;; when dft-node reaches a node, it follows the car of the node and
;; pushes a continuation to explore the cdr onto *saved*.
(define (dft-node tree)
  (cond ((null? tree) (restart))
        ((not (pair? tree)) tree)
        (else (call/cc
               (lambda (cc)
                 (set! *saved*
                       (cons (lambda ()
                               (cc (dft-node (cdr tree))))
                             *saved*))
                 (dft-node (car tree)))))))

;; restart continues the traversal, popping the most recently saved
;; continuation and calling it
(define (restart)
  (if (null? *saved*)
      'done
      (let1 cont (car *saved*)
        (set! *saved* (cdr *saved*))
        (cont))))

;; no explicit recursion or iteration in dft2: successive nodes are
;; printed because the continuations invoked by restart always return
;; through the same cond clause in dft-node
(define (dft2 tree)
  (set! *saved* ())
  (let1 node (dft-node tree)
    (cond ((eq? node 'done) ())
          (else (display node)
                (restart)))))

(dft t1)                                ; abdhcefig()
(dft-node t1)                           ; a
(restart)                               ; b
(restart)                               ; d, will return done eventually
(dft2 t1)                               ; abdhcefig()

;; If we only want to traverse one tree at a time, as in dft2, then
;; there is no reason to bother using this technique. The advantage of
;; dft-node is that we can have several instances of it going at
;; once. Suppose we have two trees, and we want to generate, in
;; depth-first order, the cross-product of their elements.
(define (dft3 tree1 tree2)
  (set! *saved* ())
  (let1 node1 (dft-node t1)
    (if (eq? node1 'done)
        'done
        (begin
          (display (list node1 (dft-node t2)))
          (restart)))))

;; (a 1)(a 2)(a 3)(a 6)(a 7)(a 4)(a 5)(b 1)(b 2)(b 3)(b 6)(b 7)(b 4)(b
;; 5)(d 1)(d 2)(d 3)(d 6)(d 7)(d 4)(d 5)(h 1)(h 2)(h 3)(h 6)(h 7)(h
;; 4)(h 5)(c 1)(c 2)(c 3)(c 6)(c 7)(c 4)(c 5)(e 1)(e 2)(e 3)(e 6)(e
;; 7)(e 4)(e 5)(f 1)(f 2)(f 3)(f 6)(f 7)(f 4)(f 5)(i 1)(i 2)(i 3)(i
;; 6)(i 7)(i 4)(i 5)(g 1)(g 2)(g 3)(g 6)(g 7)(g 4)(g 5)done