Haskell
HaskellDay 7

Tree: 親子関係の付け替え

Tree: 親子関係の付け替え

この記事はHaskell Advent Calendar 2017に投稿したものです.

関数プログラミングでは,ツリー構造はさまざまなデータの集まりを表現するのに便利なデータ構造です.
単純でよいなら,Haskell(GHC)ではcontainersパッケージにある,Data.Treeモジュールを使ってTree型で表現するのが楽です.

import Data.Tree

data Lab = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
  deriving (Eq,Ord,Enum,Bounded,Show,Read)

sample :: Tree Lab
sample = Node A [Node B [Node C [Node D []
                                ,Node E []]
                        ,Node F [Node G []
                                ,Node H []]]
                ,Node I [Node J [Node K []
                                ,Node L []]
                        ,Node M [Node N []
                                ,Node O []]]]

有向木

この木を描くと以下の図のようになります。

fig1.png

Tree a型の構造は,このように根ノードから葉ノードへ向う根付き有向木を表現したものと考えられます.このような根付き有向木は,ルートノードからはすべてのノードが到達可能です.

しかし,各ノードは自分の親ノードについては何も知らないので,任意の2ノード間のパスを調べるたりするには工夫がいります.
ここでは,その工夫を考えてみましょう.

無向木

さきほどの木を描いたものを再掲します.

fig2.png

再掲とはいいましたが,ちょっとだけ変更してあり,無向木になっています.有向木のときにはすべてのノードへの到達経路があるのは唯一ルートノードだけでした.無向木にするとどのノードから出発しても任意のノードに到達できることがわかります.どのノードでもルートノードになれるということです.
たとえば,ノードFもルートになれるのです.

fig3.png

ルートノードを別のノードに変更する

試しにFのノードを摘んで引き上げてルートノードに見立てましょう.

fig4.png

無向木であれば、Aノードをルートノードとして描いたものと、Fノードをルートノードとして描いものも、同じグラフです。これを、Fノードをルートノードとする有向木にすると

fig5.png

となり,さらにこれをTreeにすると、

reparented :: Tree Lab
reparented = Node F [Node B [Node A [Node I [Node J [Node K []
                                                    ,Node L []]
                                            ,Node M [Node N []
                                                    ,Node O []]]]
                            ,Node C [Node D []
                                    ,Node E []]]
                    ,Node G []
                    ,Node H []]

となります.さて,ここから本題です.sample :: Tree Labと,ノードFを指定して,reparented :: Tree Labを生成するにはどうするかを考えましょう.

reparent :: a -> Tree a -> Tree aをどう構成するかを考えていきます.reparentの引数はどのノードをルートノードにするかの指定です.ここでは,TreerootLabelフィールドはノードIDとして機能するという仮定をしておきます.ノードIDで指定したノードがない場合も考えてreparentの型シグネチャは,

reparent :: Eq a => a -> Tree a -> Maybe (Tree a)

aがノードID)としましょう.reparentの構成は,

  • ノードIDで指定したノードを探して(search)
  • それをルートノードに昇格させる(promote)

でいいでしょう.

reparent x = maybe Nothing (Just . promote) . search x

ノードIDで指定した,ノードを見つけたとして,それをルートノードに昇格させる方法(promote)から考えましょう.最初の図で説明したようにTree構造は有向木になります.

ノードの昇格

それでは,たとえば,ノードFをルートノードにするにはどうすればいいでしょう.

fig6.png

そうですね,ルートノードAからノードFまでのパスにある辺,A → B と B → F の向きを逆転して,B → A と F → B のようにすればいいですよね.

fig7.png

これを

fig8.png

とすればよいだけです.これでノードFを最上位に描画すれば,

fig9.png

となって,目的の木が得られます.

簡単にいってしまいましたが,ルートノードAからノードFまでのパス情報が必要です.どうしましょう?
そうです,Arunekoさんもお勧めの(Zipperに挑む)のZipperです.

Zipper

Tree用のZipperは現在のノードとパン屑リストとの対です.

type Zipper a = (Tree a, [Crumb a])

current :: Zipper a -> Tree a
current (n,_)  = n

crumbs :: Zipper a -> [Crumb a]
crumbs (_,cs) = cs

としましょう.パン屑Crumb aは以下のように定義しましょう.

type Crumb a = ([Tree a], a, [Tree a])

elders :: Crumb a -> [Tree a]
elders (es,_,_) = es

parentLabel :: Crumb a -> a
parentLabel (_,a,_) = a

youngers :: Crumb a -> [Tree a]
youngers (_,_,ys) = ys

パン屑の1つめの要素は兄姉ノードのリスト,2つめは親のルートラベル,3つめは弟妹ノードのリストです.

TreeZipperの相互変換は以下のようにします.

toZipper :: Tree a -> Zipper a
toZipper = (,[])

fromZipper :: Zipper a -> Tree a
fromZipper = current . upMost

Zipperの上への移動upと最上位への移動upMostとを定義しましょう.

up :: Zipper a -> Maybe (Zipper a)
up z = case crumbs z of
  []     -> Nothing
  (b:bs) -> Just $ (Node (parentLabel b) (elders b++current z : youngers b), bs)

upMost :: Zipper a -> Zipper a
upMost z = maybe z upMost (up z)

promoteの実装

現在のノードを含むZipperがあれば,現在ノードからルートへ,パン屑リストを使って遡れるので,promoteは以下のように実装できそうです.

promote :: Zipper a -> Tree a
promote (t,bs) = fromZipper (foldl f (t,[]) bs)
  where
    f (Node lab cs, ds) (ps,r,qs) = (Node r (ps ++ qs), ([],lab,cs) : ds)

searchの実装

promoteはZipperを必要としますので,search xTree aに適用すると,ノードIDがxであるようなノードを現在のノードとして含み,パン屑リストはルートからそのノードまでのパスを示すものですようなZipperになるはずですね.

search :: Eq a => a -> Tree a -> Maybe (Zipper a)
search x t = listToMaybe (searchDown x (toZipper t))

これにはZipperを下へたどる仕組みsearchDownを利用することにしましょう.

searchDown :: Eq a => a -> Zipper a -> [Zipper a]
searchDown x z@(Node y ys, bs) =
  bool id (z:) (x == y) (concatMap (searchDown x) (downs z))

downsはZipperの下への移動です.複数ありうるのでZipperのリストで表しています.

downs :: Zipper a -> [Zipper a]
downs (Node r rs, bs) = map zipper (select rs)
  where
    zipper (ps,x,qs) = (x,(ps,r,qs):bs)

select :: [a] -> [([a],a,[b])]
select = para f []
  where
    f x (xs, yss)   = ([], x, xs) : map (add x) yss
    add y (ys,z,zs) = (y:ys,z,zs)

para :: (a -> ([a], b) -> b) -> b -> [a] -> b
para _ e []     = e
para f e (x:xs) = f x (xs, para f e xs)

selectはリスト上のある種のZipperのリストですが,ここでは,paramorphismのインスタンスとして定義してあります.

というわけで、今回は『「木」配りのススメ』でした。(嗚呼GGネタ)