次のような枝番号を持つ文字列のリストがあったとして、 それを木構造に変換する関数を書く。
この手の変換はたとえば EPUB の目次をつくるときに使う。
これを:
["1", "1-1", "1-1-1", "1-1-2", "1-1-3", "2", "2-1", "2-2"]
こんな感じに構造化したい。
root
- 1
-- 1-1
--- 1-1-1
--- 1-1-2
--- 1-1-3
- 2
-- 2-1
-- 2-2
$ stack ghc -- --version
The Glorious Glasgow Haskell Compilation System, version 9.6.4
type Name = String
data Tree
= Leaf Name
| Node Name [Tree]
deriving (Show)
ルートの木を Leaf として生成して標準出力してみる。
root :: Tree
root = Leaf "root"
main :: IO ()
main = do
putStrLn $ show root
実行して確認する。
$ stack ghc main.hs
$ ./main
Leaf "root"
それでは、こてだめしで、自分で Tree を構築して標準出力してみます。
node1 = Node "1" [Node "1-1" [Leaf "1-1-1", Leaf "1-1-2", Leaf "1-1-3"]]
node2 = Node "2" [Leaf "2-1", Leaf "2-2"]
root = Node "root" [node1, node2]
これを実行すると次のようになります。
Node "root" [Node "1" [Node "1-1" [Leaf "1-1-1",Leaf "1-1-2",Leaf "1-1-3"]],Node "2" [Leaf "2-1",Leaf "2-2"]]
一行で出力されるとうまくできたか不明なので、いい感じに show できるように、 自分で show を定義することにします。
Tree で deriving (Show) を削除して自分で show を定義します。
instance Show Tree where
show tree = toTreeString tree
toTreeString 関数が再帰的に木構造をたどって いい感じの文字列 を生成します。
toTreeString の定義:
toTreeString :: Tree -> String
toTreeString (Leaf n) = "- " ++ (show n)
toTreeString (Node n tx) =
"- " ++ (show n) ++ joinToString (map (\t -> toTreeString t) tx) "\n"
joinToString は 文字列のリストを連結する自前定義の補助関数です。
kotlin だったらこのように書くやつです。
listOf("a", "b", "c").joinToString(" ")
joinToString :: [String] -> String -> String
joinToString sx sep = foldl (\acc b -> acc ++ sep ++ b) "" sx
たぶん、自前定義しなくてもこの手の関数は用意されている気がするが、とりあえずこれで。
さらに、 toTreeString を別関数として定義するのではなく、Tree に対する Show 型クラスの定義に含めてしまいましょう。
instance Show Tree where
show (Leaf n) = "- " ++ (show n)
show (Node n tx) =
"- " ++ (show n) ++ joinToString (map (\t -> show t) tx) "\n"
これで実行してみます。
$ stack ghc main.hs
$ ./main
- "root"
- "1"
- "1-1"
- "1-1-1"
- "1-1-2"
- "1-1-3"
- "2"
- "2-1"
- "2-2"
インデントがないと木構造の階層がわからない。
"- " している部分を Name に応じて適切な長さの - を出すようにする toPrefix を定義。
toPrefix :: String -> String
toPrefix n
| n == "root" = ""
| otherwise = take (length n) (repeat '-')
root の場合は特別対処して、それ以外は Tree の Name の文字列の長さ分だけ - を出すようにして、深さを表現する。
この toPrefix を使って Tree に対する定義を書きかえます。
instance Show Tree where
show (Leaf n) = (toPrefix n) ++ (show n)
show (Node n tx) =
(toPrefix n) ++ (show n) ++ joinToString (map (\t -> show t) tx) "\n"
これで実行してみる。
"root"
-"1"
---"1-1"
-----"1-1-1"
-----"1-1-2"
-----"1-1-3"
-"2"
---"2-1"
---"2-2"
本当は Name のハイフンは数えないで計算したかったけど、深さを把握したい、という目的は達したので、これでよいことにします。
ここまでできたら、あとは、フラットな文字列リストから木構造を構築する関数 buildTree をかけば完成です。
toChildNames :: Name -> [Name] -> [Name]
toChildNames name allNames = filter (\n -> elem n (candidates name)) allNames
where
candidates :: Name -> [Name]
candidates name
| name == "root" = sx
| otherwise = map (\suffix -> name ++ "-" ++ suffix) sx
where
sx = ["1", "2", "3"]
toTrees :: [Name] -> [Name] -> [Tree]
toTrees childNames allNames =
map (\n -> toTree n (toChildNames n allNames)) childNames
where
toTree n [] = Leaf n
toTree n childNames = Node n (toTrees childNames allNames)
buildTree :: [Name] -> Tree
buildTree allNames
| allNames == [] = Leaf "root"
| otherwise = Node "root" (toTrees childNames allNames)
where
childNames = toChildNames "root" allNames
sx = ["1", "2", "3"] の部分は今このサンプルでは Name に出現する番号が 1,2,3 の いずれかしかないからですが、もし 1,2,3...9 まで使いたいのであれば、 次のように記述すればよいでしょう。
sx = map (\n -> show n) [1,2 .. 9]
これで root = buildTree ["1", "1-1", "2", "3"] を実行すれば、 次のような標準出力を得ることができます。
"root"
-"1"
---"1-1"
-"2"
-"3"
それでは、冒頭のリストを木構造に変換してみます。
root = buildTree ["1", "1-1", "1-1-1", "1-1-2", "1-1-3", "2", "2-1", "2-2"]
main :: IO ()
main = do
putStrLn $ show root
実行します。
$ stack ghc main.hs
$ ./main.hs
"root"
-"1"
---"1-1"
-----"1-1-1"
-----"1-1-2"
-----"1-1-3"
-"2"
---"2-1"
---"2-2"
意図通り変換できました。
完成したコードを掲載します。
main.hs
type Name = String
data Tree
= Leaf Name
| Node Name [Tree]
joinToString :: [String] -> String -> String
joinToString sx sep = foldl (\acc b -> acc ++ sep ++ b) "" sx
toPrefix :: String -> String
toPrefix n
| n == "root" = ""
| otherwise = take (length n) (repeat '-')
{-
toTreeString :: Tree -> String
toTreeString (Leaf n) = (toPrefix n) ++ (show n)
toTreeString (Node n tx) =
(toPrefix n) ++ (show n) ++ joinToString (map (\t -> toTreeString t) tx) "\n"
instance Show Tree where
show tree = toTreeString tree
-}
instance Show Tree where
show (Leaf n) = (toPrefix n) ++ (show n)
show (Node n tx) =
(toPrefix n) ++ (show n) ++ joinToString (map (\t -> show t) tx) "\n"
toChildNames :: Name -> [Name] -> [Name]
toChildNames name allNames = filter (\n -> elem n (candidates name)) allNames
where
candidates :: Name -> [Name]
candidates name
| name == "root" = sx
| otherwise = map (\suffix -> name ++ "-" ++ suffix) sx
where
sx = map (\n -> show n) [1,2 .. 9]
toTrees :: [Name] -> [Name] -> [Tree]
toTrees childNames allNames =
map (\n -> toTree n (toChildNames n allNames)) childNames
where
toTree n [] = Leaf n
toTree n childNames = Node n (toTrees childNames allNames)
buildTree :: [Name] -> Tree
buildTree allNames
| allNames == [] = Leaf "root"
| otherwise = Node "root" (toTrees childNames allNames)
where
childNames = toChildNames "root" allNames
root = buildTree ["1", "1-1", "1-1-1", "1-1-2", "1-1-3", "2", "2-1", "2-2"]
main :: IO ()
main = do
putStrLn $ show root
以上です。
Liked some of this entry? Buy me a coffee, please.