Friday, February 16, 2024

Haskell / リストから木構造をつくる

次のような枝番号を持つ文字列のリストがあったとして、それを木構造に変換する関数を書く。

この手の変換はたとえば 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.

Haskell / リストから 木構造をつくる

環境

木構造を定義

まとめ

Haskell / リストから木構造をつくる