部分継続の利用例。

めも。
途中でreturn

(use gauche.partcont)
(use util.match)

(define (times xs) (fold * 1 xs))

(times '(1 2 3)) ; => 6
;; (times '(1 2 0 "foo")) ; => *** ERROR: operation * is not defined between "foo" and 0

(define (times/pc xs)
  (fold (lambda (x n) (if (= x 0) (shift _ 0) (* x n)))
        1 xs))

(reset (times/pc '(1 2 3))) ; => 6
(reset (times/pc '(1 2 0 "foo"))) ; => 0

よくあるcps?の例

(define (idlist/cps xs cont)
  (match xs
    [() (cont '())]
    [(x . xs) (cons x (idlist/cps xs cont))]))

(idlist/cps '(1 2 3) identity) ; => (1 2 3)
(idlist/cps '(1 2 3) (lambda (_) (list 1 3 4))) ; => (1 2 3 1 3 4)

(define (idlist xs)
  (match xs
    [() (shift k k)]
    [(x . xs) (cons x (idlist xs))]))

(define cont (reset (idlist '(1 2 3))))
(cont '()) ; => (1 2 3)
(cont '(1 3 4)) ; => (1 2 3 1 3 4)

失敗が分かったとき全て調べないtravarse

(define (yield x)
  (shift k (values x k)))

(define (traverse tree)
  (match tree
    [() (values #f #f)]
    [(left e right)
     (traverse left)
     (yield e)
     (traverse right)]))

(define (node l e r)
  (list l e r))
(define (leaf e)
  (list '() e '()))

(define (same-fringe tree0 tree1 fn)
  (receive (x k0)
      (reset (traverse tree0))
    (receive (y k1)
        (reset (traverse tree1))
      (let loop ((x x) (y y) (k0 k0) (k1 k1))
        (fn (cons x y))
        (cond [(and (not k0) (not k1)) #t]
              [(= x y)
               (receive (x* k0*) (k0)
                 (receive (y* k1*) (k1)
                   (loop x* y* k0* k1*)))]
              [else #f])))))

(same-fringe (node (leaf 1) 2 (leaf 3))
             (node (node (leaf 1) 2 '()) 3 '())
             identity) ; => #t

(same-fringe (node (leaf 1) 2 (leaf 3))
             (node (node (leaf 1) 3 '()) 3 '())
             identity) ; => #f

(same-fringe (node (leaf 1) 2 (leaf 3))
             (node (node (leaf 1) 3 '()) 3 '())
             print)
;;  ; => (1 . 1)
;; (2 . 3)
;; #f

iteratorもどき

(define (traverse-iter tree)
  (receive (x k)
      (reset (traverse (node '() '() tree))) ;;ここ嫌い
    (let ((x x) (k k))
      (lambda ()
        (when k 
          (receive (x* k*) (k)
            (set! k k*)
            (set! x x*)
            x))))))


(define cont (traverse-iter (node (node (leaf 1) 2 (leaf 3)) 4 (node (leaf 5) 6 (leaf 7)))))
;;(cont)

resetの中に触れる

(define f
  (reset 
    (string-append "hello " (shift k (lambda (x) (k x))) "!")))

(f "world") ; => "hello world!"
(f "all") ; => "hello all!"

printfっぽいかんじの変換

(define (g xs)
  (match xs 
    [() '()]
    [(x . xs*)
     (cons (shift k (lambda (f) (k (f x))))
           (g xs*))]))
  
(define (uncurry knil . fns)
  (fold (lambda (f k) (k f)) knil fns))

(let1 k (reset (g '("foo" 123)))
  ((k identity) number->string)) ; => ("foo" "123")

(let1 k (reset (g '("foo" 123)))
  (uncurry k identity number->string)) ; => ("foo" "123")

(define (dispatch x)
  (cond ((string=? x "%s") identity)
        ((string=? x "%d") number->string)
        ((string=? x "%b") (lambda (e) (if e "True" "False")))
        (else (shift _ 'fail))))

(define (printf-like fmt xs)
  (reset
   (let1 fns (map dispatch fmt)
     (let1 k (reset (g xs))
       (apply uncurry k fns)))))

(printf-like '("%s") '("foo")) ; => ("foo")
(printf-like  '("%d" "%s" "%b")  '(120  "foo" #t)) ; => ("120" "foo" "True")
(printf-like
 '("%d" "%s" "%b" "%s" "%b")
 '(120  "foo" #t "bar" #f)) ; => ("120" "foo" "True" "bar" "False")
(printf-like
 '("%d" "%s" "%c" "%s" "%b")
 '(120  "foo" #t '(1 2 3) "bar" #f)) ; => fail

(printf-like '("%d") '(120 #t)) ; => #<closure (g #f #f)>
((printf-like '("%d") '(120 (120))) x->string) ; => ("120" "(120)")

amb

(define (either x y)
  (shift k (k x) (k y)))

(reset (let1 x (either 1 2)
         (print x)))
;;  ; => 1
;; 2
;; #<undef>

(define (choice xs)
  (shift k (for-each k xs)))

(let1 src '(1 2 3 4 5 6 7 8 9)
  (reset
   (let* ((x (choice src))
          (y (choice src))
          (z (choice src)))
     (when (= (+ (* x x) (* y y)) (* z z))
       (print (list x y z))))))
; => (3 4 5)
;; (4 3 5)
;; #<undef>