親と子の関係を表現するLookAtパターン

続編：LookAtパターン・改

Haskellにおけるデザインパターンを紹介します。
前回は Autonomieパターン を紹介しました。今回はこれと合わせて(自分が)よく使う親と子の関係を表すパターンです。

簡単なゲームを考えましょう。普通、フィールドオブジェクトはプレイヤーを管理するため、プレイヤーオブジェクトを保持しているはずです。このときフィールド=>親、プレイヤー=>子ということになります。
プレイヤーは例えば自身を破棄したり、フィールドに影響を与える操作をする場合、親にそのことを伝えなくてはいけないので親への参照を持ちます。この関係をHaskellで実装します。

ただし今回はFRPのようなことはしません。純粋な函数を組み合わせて表現します。

{-# LANGUAGE GADTs, TemplateHaskell, FlexibleContexts #-}
import Control.Arrow
import Data.List
import Control.Monad.Operational.Mini
import Control.Monad.Operational.TH (makeSingletons)
import Control.Monad.State

data Pattern p q x where
  GetLocal :: Pattern p q p
  PutLocal :: p -> Pattern p q ()
  GetQ :: Pattern p q q
  PutQ :: q -> Pattern p q ()

makeSingletons ''Pattern

type LookAt p q = Program (Pattern p (q, [State q ()]))

runLookAt :: LookAt p q () -> State (p, (q, [State q ()])) ()
runLookAt = interpret step
  where
    step :: Pattern p (q, [State q ()]) a -> State (p, (q, [State q ()])) a
    step GetLocal = fst `fmap` get
    step (PutLocal p) = modify $ first $ const p
    step GetQ = snd `fmap` get
    step (PutQ q) = modify $ second $ const q

getGlobal :: LookAt p q q
getGlobal = do
  (q, ks) <- getQ
  return $ (foldr (.) id $ fmap execState ks) q

liftGlobal :: State q () -> LookAt p q ()
liftGlobal f = do
  (q, ks) <- getQ
  putQ $ (q, f:ks)

putGlobal :: q -> LookAt p q ()
putGlobal q = liftGlobal (modify $ const q)

liftLocal :: (p -> p) -> LookAt p q ()
liftLocal f = getLocal >>= putLocal . f

data Item a = Item { name :: String, content :: a } deriving (Eq, Show)
data ItemHolder a = ItemHolder { items :: [Item a] } deriving (Eq, Show)

updateAll :: [LookAt (Item a) (ItemHolder a) ()] -> State (ItemHolder a) ()
updateAll fs = do
  h@(ItemHolder s) <- get
  let (s',h') = scan (fmap runLookAt fs) s h ([],return ())
  put $ h { items = reverse $ s' }
  modify $ execState h'
  where
    scan :: [State (p, (q, [State q ()])) ()] -> [p] -> q -> ([p], State q ()) -> ([p], State q ())
    scan [] [] h (xs,g) = (xs,g)
    scan (k:ks) (x:xs) h (xs',g) = scan ks xs h (x':xs', g') where
      (x', (_, fs)) = execState k (x, (h, []))
      g' = foldr (>>) g fs
    scan _ _ _ _ = error "error while scanning"

----------------------------------------
-- examples
----------------------------------------
duplicate :: LookAt (Item a) (ItemHolder a) ()
duplicate = do
  i <- getLocal
  liftGlobal $ do
    ItemHolder s <- get
    put $ ItemHolder $ i:s

nameReverse :: LookAt (Item a) (ItemHolder a) ()
nameReverse = liftLocal $ execState $ do
  i@(Item n _) <- get
  put $ i { name = reverse n }

rename :: LookAt (Item a) (ItemHolder a) ()
rename = do
  Item n _ <- getLocal
  liftGlobal $ do
    ItemHolder s <- get
    put $ ItemHolder $ reverse $ label 0 n s []
  where
    label :: Int -> String -> [Item a] -> [Item a] -> [Item a]
    label _ _ [] bs = bs
    label i n (a@(Item m _):as) bs
      | n == m = label (i+1) n as (a { name = m ++ "(" ++ show i ++ ")" }:bs)
      | otherwise = label i n as (a:bs)

main = do
  f <- return $ ItemHolder [Item "normal bag" ("bag", 100)]
  print $ execState (updateAll [duplicate] >> updateAll [nameReverse, duplicate]) f
  {-
  ItemHolder {items =
    [Item {name = "normal bag", content = ("bag",100)},
     Item {name = "normal bag", content = ("bag",100)},
     Item {name = "gab lamron", content = ("bag",100)}]}
  -}


  f2 <- return $ ItemHolder
    [Item "normal bag" ("bag", 95),
     Item "large desk" ("desk", 400),
     Item "small cellphone" ("phone", 10),
     Item "normal bag" ("bag", 120),
     Item "favorite book" ("book", 30)]
  print $ execState (updateAll [rename, return (), return (), return (), return ()]) f2
  {-
  ItemHolder {items = 
    [Item {name = "normal bag(0)", content = ("bag",95)},
     Item {name = "large desk", content = ("desk",400)},
     Item {name = "small cellphone", content = ("phone",10)},
     Item {name = "normal bag(1)", content = ("bag",120)},
     Item {name = "favorite book", content = ("book",30)}]}
  -}

LookAt p qという型は、pが子、qが親を表します。
例えば例の一つを見てみます。

duplicate :: LookAt (Item a) (ItemHolder a) ()
duplicate = do
  i <- getLocal
  liftGlobal $ do
    ItemHolder s <- get
    put $ ItemHolder $ i:s

これはあるItem aをコピーする函数です。このときItem aを操作するにはgetLocal, liftLocal, putLocalを使いますが、Item aの親であるItemHolder aを操作するにはgetGlobal, liftGlobal, putGlobalを使えばよいわけです。
LookAt p q ()はStateのようなモナドになっていて、それぞれ子と親の操作を同じ場所でできます。

ただし上の実装ではliftLocalを全て実行した後にliftGlobalをまとめて実行するので、各操作が実行されるタイミングをよく考えないとこのラグによって意図したとおりに実行されない可能性があります。

またgetGlobalしてputGlobalする操作とliftGlobalする操作ではかかるコストが異なります(後者のほうが効率が良い)。実用上差が出るほどではないと思いますが。(たぶん)

実装が大変だった割にあんまり素敵なものにはなりませんでした。もしかしたら意図通りの実装ができてないかもしれません。
また親と子の関係を表現したいなら素直にFRPなどを使うのが良いと思います。少なくともこんな面倒なことをする必要はなくなるはずです。