Continuation Monad (4)
一応最後まで書いておく。でも随分前に書いたのでどう考えたのかは忘れてしまった。
13.4 Coroutines
まずcoroutine macroを定義する。
(define-macro coroutine
(lambda (x . body)
`(letrec ((+local-control-state
(lambda (,x) ,@body))
(resume
(lambda (c v)
(call/cc
(lambda (k)
(set! +local-control-state k)
(c v))))))
(lambda (v)
(+local-control-state v)))))
Haskellはlazyなので、strictなSchemeではマクロでないとできないことが関数でできる。
condやifは簡単だ。しかしこのマクロの場合はそれほど簡単ではない。継続を呼び出すときに使うためのresumeが"+local-control-state"を参照しているためだ。
(define make-matcher-coroutine
(lambda (tree-cor-1 tree-cor-2)
(coroutine dont-need-an-init-arg
(let loop ()
(let ((leaf1 (resume tree-cor-1 'get-a-leaf))
(leaf2 (resume tree-cor-2 'get-a-leaf)))
(if (eqv? leaf1 leaf2)
(if (null? leaf1) #t (loop))
#f))))))
上の二つのresumeは、このcontine macroの呼び出しに固有の"+local-control-state"を呼び出す必要がある。
隠れて"+local-control-state"をresumeに渡すためにReaderモナドを使うと、以下のようになる*1。
coroutine :: (t -> ReaderT (STRef s (t -> ContT r (ST s) a)) (ContT r (ST s)) a)
-> ContT r2 (ST s) (t -> ContT r (ST s) a)
coroutine lambody
= do local_control_state <- lift $ fixST (\local_control_state ->
newSTRef $ \init_arg ->
do runReaderT (lambody init_arg) local_control_state)
return $ \init_arg ->
do lcs <- lift $ readSTRef local_control_state
lcs init_argresume :: (a -> ContT r (ST s) c) -> a
-> ReaderT (STRef s (c -> ContT r (ST s) b)) (ContT r (ST s)) c
resume c v =
do local_control_state <- ask
lift $ callCC (\k ->
do lift $ writeSTRef local_control_state k
c v)このように、resumeに引数を渡すこととを避けられた。
make_matcher_coroutine tree_cor_1 tree_cor_2
= do coroutine $ \_ ->
fix (\loop ->
do leaf1 <- resume tree_cor_1 (error "get_a_leaf")
leaf2 <- resume tree_cor_2 (error "get_a_leaf")
if leaf1 == leaf2 then
if isNull leaf1 then return True else loop
else return False)
(define make-leaf-gen-coroutine
(lambda (tree matcher-cor)
(coroutine dont-need-an-init-arg
(let loop ((tree tree))
(cond ((null? tree) 'skip)
((pair? tree)
(loop (car tree))
(loop (cdr tree)))
(else
(resume matcher-cor tree))))
(resume matcher-cor '()))))
make_leaf_gen_coroutine tree matcher_cor
= do coroutine $ \_ ->
do fix (\loop tree ->
do cond [(isNull tree, return (error "skip"))
, (isPair tree, loop (car tree) >> loop (cdr tree))
, (otherwise , resume matcher_cor tree >> return (error "next"))]) tree
resume matcher_cor (Tree [])
fail "impossible"次はsame-fringe?だ。
ここでletrecをこう定義してみる。この定義は、中でrunContTを実行しているので、継続を保存しない。つまり、letrecの中でcall/ccを呼んだりする使いかたに対しては正常に(schemeで期待されるように)動作しない。しかし、一般的な使用では問題がない。
letrec f = lift $ mfix $ \x -> runContT (f x) return
Unfortunately, Scheme's letrec can resolve mutually recursive references amongst the lexical variables it introduces only if such variable references are wrapped inside a lambda. And so we write:
とあって、Schemeでも matcher-cor を lambda (v) (matcher-cor v) と書いて名前解決を遅らせなければならないように、ここでreferenceを挟むか、runContTしておかないと、無限ループになる。ここではletrecの中でrunContTを走らせてしまうことにした。
(define same-fringe?
(lambda (tree1 tree2)
(letrec ((tree-cor-1
(make-leaf-gen-coroutine
tree1
(lambda (v) (matcher-cor v))))
(tree-cor-2
(make-leaf-gen-coroutine
tree2
(lambda (v) (matcher-cor v))))
(matcher-cor
(make-matcher-coroutine
(lambda (v) (tree-cor-1 v))
(lambda (v) (tree-cor-2 v)))))
(matcher-cor 'start-ball-rolling))))
same_fringe' tree1 tree2
= do (_, _, matcher_cor) <- letrec (\ ~(tree_cor_1, tree_cor_2, matcher_cor) ->
do t1 <- make_leaf_gen_coroutine tree1 matcher_cor
t2 <- make_leaf_gen_coroutine tree2 matcher_cor
mc <- make_matcher_coroutine tree_cor_1 tree_cor_2
return (t1, t2, mc ))
matcher_cor (error "start-ball-rolling")テスト
d01 = Tree [Leaf 1, Leaf 2, Leaf 3] d02 = Tree [Leaf 1, Tree [Leaf 3, Leaf 2]] f10 = runST (flip runContT return $ same_fringe' d01 d02) f11 = runST (flip runContT return $ same_fringe' d01 d01)
>
*1:implicit paramterでも良い
