Continuation Monad (3)

[Haskell] Continuation Monad (2) [id:yts:20050103#p1] の続き。

13.3 Tree matching

まずTree型の定義をしておく。

data Tree a = Tree [Tree a] | Leaf a deriving (Eq, Show)
car (Tree (x:xs)) = x
cdr (Tree (x:xs)) = Tree xs
isNull (Tree []) = True
isNull _ = False
isPair (Tree (x:xs)) = True
isPair _ = False

ついでにSchemeのcondを真似してみる。

cond ((True, w):xs) = w
cond ((_, w):xs) = cond xs

Example 1

(define tree->generator
  (lambda (tree)
    (let ((caller '*))
      (letrec
          ((generate-leaves
            (lambda ()
              (let loop ((tree tree))
                (cond ((null? tree) 'skip)
                      ((pair? tree)
                       (loop (car tree))
                       (loop (cdr tree)))
                      (else
                       (call/cc
                        (lambda (rest-of-tree)
                          (set! generate-leaves
                            (lambda ()
                              (rest-of-tree 'resume)))
                          (caller tree))))))
              (caller '()))))
        (lambda ()
          (call/cc
           (lambda (k)
             (set! caller k)
             (generate-leaves))))))))

generate_leaves は (set! generate-leavesa ...) で書き換えられているので、STRefにする。関数として呼び出すときはあらかじめreadSTRefすることになる。
問題は、generate_leavesの定義で自分自身を参照しているが、モナドの束縛なので

generate_leaves <- ... generate_leaves ...

とは書けないことだ。ContT(Contも)はMonadFixのinstanceではないので、mfixというわけにもいかない。

generate_leavesは(lambda () ...)なので、STRef s (ContT r (ST s) (Tree a))という型になるだろう。ContT r (ST s)に関する副作用はreadSTRefしたあと手動で走らせることで生じさせることになる。つまりgenerate_leavesをバインドするときにはContT r (ST s)に関する副作用は発生しない。STモナドのmfix(fixST)で十分だ。

tree_generator :: Tree a -> ContT r (ST s) (ContT r (ST s) (Tree a))
tree_generator tree = 
    do  caller <- lift $ newSTRef undefined
        generate_leaves <- lift $ fixST (\generate_leaves ->
            do  newSTRef (
                  do  fix (\loop tree ->
                        cond [(isNull tree, return (error "skip"))
                            , (isPair tree, loop (car tree) >> loop (cdr tree))
                            , (otherwise, callCC (\rest_of_tree ->
                                  do  lift $ writeSTRef generate_leaves (rest_of_tree (error "resume"))
                                      c <- lift $ readSTRef caller
                                      c tree))]) tree
                      c <- lift $ readSTRef caller
                      c (Tree [])
                  ))
        return (
          do  callCC (\k ->
                do  lift $ writeSTRef caller k
                    g <- lift $ readSTRef generate_leaves
                    g) )

Example 2

(define same-fringe?
  (lambda (tree1 tree2)
    (let ((gen1 (tree->generator tree1))
          (gen2 (tree->generator tree2)))
      (let loop ()
        (let ((leaf1 (gen1))
              (leaf2 (gen2)))
          (if (eqv? leaf1 leaf2)
              (if (null? leaf1) #t (loop))
              #f))))))

same_fringe :: Eq a => Tree a -> Tree a -> ContT r (ST s) Bool
same_fringe tree1 tree2 = 
    do  gen1 <- tree_generator tree1
        gen2 <- tree_generator tree2
        fix (\loop -> do
            leaf1 <- gen1
            leaf2 <- gen2
            if leaf1 == leaf2 then
                if isNull leaf1 then return True else loop
              else return False)

f07 = runST (flip runContT return $ 
      same_fringe (Tree [Leaf 1, Tree [Leaf 2, Leaf 3]])
        (Tree [Tree [Leaf 1, Leaf 2], Leaf 3]))
f08 = runST (flip runContT return $
      same_fringe (Tree [Leaf 1, Leaf 2, Leaf 3]) (Tree [Leaf 1, Tree [Leaf 3, Leaf 2]]))

Schemeのletrecをどう扱うかが難しい点だ。奥が深い。

><

結局STモナドの上で動いているのだから、strictであっても、継続を使うよりもイテレーターを保持しているgeneratorを作った方がわかりやすいような。Schemerはイテレータよりも継続を選ぶのだろうか。