Scheme中的call/cc

理解中断

本部分是把 Continuation 在 JS 中的应用 这篇文章的例子用scheme重写了一遍，不用call/cc，只用church encoding实现中断。

;; Functions of calculation: in a Church encoding manner
;; for addF, the result of x+y is collected by F. The rest is the same.

(define addF
  (lambda (x y F) 
    (F (+ x y))))

(define subF
  (lambda (x y F) 
    (F (- x y))))

(define doubleF
  (lambda (x F)
    (F (* x 2))))

;; callback: original version

;; example: calculating a = ((1+2)-5)*2
;; the intermediate result 1+2 is collected as addResult 
;; in the continuation of addF 1 2. (The rest is the same.)
(define a
  (addF 1 2 
    (lambda (addResult) (subF addResult 5 
      (lambda (subResult) (doubleF subResult
        (lambda (doubleResult) doubleResult)))))))

;; callback: ensure conditional abort, by defining a evaluation sequence

;; evalSeq: the evaluation sequence
(define evalSeq 
  (list
    (lambda (x F) (addF 1 2 F)) ;; note the input x in the first func is never used
    (lambda (x F) (subF x 5 F))
    (lambda (x F) (doubleF x F))))

;; evaluate: sequentially operates evalSeq
;; in the evaluation, if the result of some step meets `condition`
;; then returns `abortF` of this intermediate result;
;; otherwise, the whole evaluation could be successfully done, 
;; returns `successF` of the final result.
(define evaluate
  (lambda (condition abortF successF x fs)
    (cond 
      ((null? fs) (successF x))
      (else 
        ((car fs) x
          (lambda (x)
            (cond 
              ((condition x) (abortF x))
              (else 
                (evaluate condition abortF successF x (cdr fs))))))))))

;; a1: never abort and returns the final result itself ((1+2)-5)*2 = -4.
;; note that we take `void` as a beginning, 
;; and this `void` is not used in the first func of the seq.
(define a1
  (let 
    ((id (lambda (x) x)))
    (evaluate (lambda (x) #f) id id void evalSeq)))


;; a2: in the evaluation, if the result of some step < 0, 
;; then returns this intermediate result itself.
;; the evaluation aborts at (1+2)-5 = -2.
(define a2
  (let 
    ((id (lambda (x) x)))
    (evaluate (lambda (x) (< x 0)) id id void evalSeq)))

理解call/cc

;; Now let's continue: try to implement this kind of abort by call/cc

;; use call/cc to return value abruptly and promptly

;; func1: the local computation 
(define func1 (lambda (x) (* x 2)))
;; func2: the continuation after the computation of `func1 5`
(define func2 (lambda (x) (* x 3))) 

(define comp1
  (lambda (cont)
    (func1 (cont 5))))

(define comp2
  (lambda (cont)
    (func1 5)))

(define comp-callcc-1 (func2 (call/cc comp1))) ;; 15
(define comp-callcc-2 (call/cc comp1)) ;; 5
(define comp-callcc-3 (func2 (call/cc comp2))) ;; 30
(define comp-callcc (list comp-callcc-1 comp-callcc-2 comp-callcc-3))

let/cc的部分与call/cc对应着看，两者原理是一样的

;; let/cc version

(define comp-letcc-1 (func2 (let/cc cont (comp1 cont))))
(define comp-letcc-2 (let/cc cont (comp1 cont)))
(define comp-letcc-3 (func2 (let/cc cont (comp2 cont))))
(define comp-letcc (list comp-letcc-1 comp-letcc-2 comp-letcc-3))

haskell版本如下

import Control.Monad.Cont
import Data.Char (chr, ord)
import Data.Function ((&))

comp1 :: MonadCont m => (Int -> m Char) -> m Int
comp1 k = fmap succ (fmap ord (k 97))

comp2 :: MonadCont m => (Int -> m Char) -> m Int
comp2 k = fmap succ (pure 97)

test1 = [runCont (comp (pure . chr)) id | comp <- [comp1, comp2]] -- [98, 98]
test2 = [runCont (callCC comp) id | comp <- [comp1, comp2]] -- [97, 98]

应用call/cc

直接用上面那个中断的例子展示call/cc的作用，有点苍白。这里采用了Scheme call/cc 研究这篇文章举的例子，用letrec重写了一下，踩了一遍坑，来展示call/cc的威力和正确使用方式。

;; use call/cc to conditional abort the multiplication of elements in a list

;; multiplication with param information shown
(define mul
  (lambda (x y)
    (letrec ((product (* x y)))
      (printf "Doing ~a * ~a = ~a \n" x y product)
      product)))

;; normal version
(define product
  (lambda (ls)
    (printf "Checking ~s \n" ls)
    (cond
      ((null? ls) 1)
      ((= (car ls) 0) 0)
      (else (mul (car ls) (product (cdr ls)))))))

;; call/cc should go with letrec, but the implement below is incorrect
;; calling product-c in letrec leads to new call stack
;; making the abortion non-effective
(define product-c
  (lambda (ls)
    (call/cc
      (lambda (cont)
        (printf "Checking ~s \n" ls)
        (cond
          ((null? ls) 1)
          ((= (car ls) 0) (cont 0))
          (else (mul (car ls) (product-c (cdr ls)))))))))

;; call/cc with letrec: correct version
;; all things should be done in the letrec
(define product-c1
  (call/cc
    (lambda (cont)
      (letrec 
        ((f
            (lambda (ls)
              (printf "Checking ~s \n" ls)
              (cond
                ((null? ls) 1)
                ((= (car ls) 0) (cont 0))
                (else (mul (car ls) (f (cdr ls))))))))
        f))))

(define test1
  (letrec ((test-ls '(1 2 3 0 5)))
    (printf "Normal version of product \n")
    (product test-ls)
    (printf "Incorrect version of using call/cc in product-c \n")
    (printf "Will not be aborted when it should be \n")
    (product-c test-ls)
    (printf "Correct version of using call/cc in product-c1 \n")
    (printf "Will not do any multiplication \n")
    (product-c1 test-ls)))

另一个例子，是the seasoned schemer书上给出的，暂时还没有测试，而且只把intersectall改了call/cc，其实辅助函数也可以改的

(define member?
  (lambda (a ls)
    (cond
      ((null? ls) #f)
      ((eq? a (car ls)) #t)
      (else (member? a (cdr ls))))))

(define intersect
  (lambda (set1 set2)
    (printf "Intersecting ~s ~s \n" set1 set2)
    (cond
      ((null? set1) '())
      ((member? (car set1) set2) 
        (cons (car set1) (intersect (cdr set1) set2)))
      (else (intersect (cdr set1) set2)))))

(define intersectall
  (lambda (lset)
    (call/cc
      (lambda (cont)
        (letrec
          ((A
              (lambda (lset)
                (printf "Doing ~s \n" lset)
                (cond 
                  ((null? lset) '())
                  ((null? (car lset)) (cont '()))
                  ((null? (cdr lset)) (car lset))
                  (else (intersect (car lset) (A (cdr lset))))))))
          (A lset))))))

(define test
  (intersectall '((1 2 3) (3 5 6) () (2 3 4))))