String 通过在Haskell中插入每个后缀来构建后缀树

我正在使用以下数据类型：

data SuffixTree = Leaf Int | Node [(String, SuffixTree)] 
                deriving (Eq, Show)

每个子树都有相应的标签（字符串）。 其思想是通过将每个后缀及其索引添加到累加树中来构建相应的后缀树（开始时是

节点[]

）

这已经定义好了

buildTree s
    = foldl (flip insert) (Node []) (zip (suffixes s) [0..length s-1]) 

其中

后缀

定义正确

我尝试实现

insert

函数已有一段时间了，但似乎没有成功

这就是我现在拥有的（名称和样式不是最好的，因为这仍在进行中）：

partition

函数接受两个字符串并返回一个元组，元组包括：

公共前缀（如果存在）

不带前缀的第一个字符串

不带前缀的第二个字符串

我想我理解建造这棵树所需要的规则

我们首先比较第一个子树的标签和要插入的字符串（比如，

str

）。如果它们没有共同的前缀，我们将尝试在下一子树中插入

如果标签是

str

的前缀，我们将继续查看该子树，但不是使用

str

，而是尝试插入不带前缀的

str

如果

str

是label的前缀，那么我们用一个新的

节点

替换现有子树，该节点有一个

叶

和旧子树。我们还调整标签

如果

str

和任何标签之间不匹配，那么我们将在子树列表中添加一个新的

叶

但是，我遇到的最大问题是，我需要返回一个包含更改的新树，因此我必须跟踪树中的所有其他内容（不确定如何执行此操作，或者我是否正确地考虑了此操作）

代码似乎在此字符串上正常工作：
“banana”
：

然而，在这个字符串
“mississippi”
上，我得到了一个
异常：函数insert'
中的非穷举模式

非常感谢任何帮助或想法
 问题是如何发生的

假设您正在处理
buildTree“保姆”
。插入后缀“nanny”、“anny”和“nny”后，您的树看起来像是
t1
给出的：

let t1 = Node t1_content
    t1_content = [("n",t2),("anny",Leaf 1)]
    t2 = Node [("ny",Leaf 2),("anny",Leaf 0)]

接下来，尝试插入前缀“ny”：

接下来要做的是将
（“y”，3）
插入
t2
中，以生成：

Node [("y", Leaf 3), ("ny",Leaf 2),("anny",Leaf 0)])

相反，发生的是：

insert' ("y", 3) t2 t1_content
-- have s="y", a="ny", so p="", r="y", r'="ny"
-- which matches guard: null p
= insert' ("y", 3) (Node [("anny", Leaf 0)]) t1_content
-- have s="y", a="anny", so p="", r="y", r'="anny"
-- which matches guard: null p
= insert' ("y", 3) (Node []) t1_content
= Node [("y", Leaf 3), ("n",t2), ("anny",Leaf 1)]

后缀“y”已添加到
t1
而不是
t2

当您下次尝试插入后缀“y”时，保护
p==a
案例尝试将
（“y”，3）
插入
叶3
中，您会得到一个模式错误

它在香蕉树上工作的原因是您只在树的顶层插入一个新节点，所以“添加到t2”和“添加到t1”是一样的

我怀疑您需要重新考虑递归的结构才能使其工作。
您使用的是二次算法；而最理想的情况是，后缀树可以在线性时间内构造。也就是说，使用相同的算法，可能更好的方法是首先构建（未压缩的）后缀trie（而不是树），然后压缩生成的trie

优点是后缀trie可以使用
Data.Map
：

data SuffixTrie
  = Leaf' Int
  | Node' (Map (Maybe Char) SuffixTrie)

这使得操作比成对列表更高效、更容易。这样做，您也可以完全绕过公共前缀计算，因为它本身就是：

import Data.List (tails)
import Data.Maybe (maybeToList)
import Control.Arrow (first, second)
import Data.Map.Strict (Map, empty, insert, insertWith, assocs)

data SuffixTree
  = Leaf Int
  | Node [(String, SuffixTree)]
  deriving Show

data SuffixTrie
  = Leaf' Int
  | Node' (Map (Maybe Char) SuffixTrie)

buildTrie :: String -> SuffixTrie
buildTrie s = foldl go (flip const) (init $ tails s) (length s) $ Node' empty
  where
  go run xs i (Node' ns) = run (i - 1) $ Node' tr
    where tr = foldr loop (insert Nothing $ Leaf' (i - 1)) xs ns
  loop x run = insertWith (+:) (Just x) . Node' $ run empty
    where _ +: Node' ns = Node' $ run ns

buildTree :: String -> SuffixTree
buildTree = loop . buildTrie
  where
  loop (Leaf' i) = Leaf i
  loop (Node' m) = Node $ con . second loop <$> assocs m
  con (Just x, Node [(xs, tr)]) = (x:xs, tr) -- compress single-child nodes
  con n = maybeToList `first` n

同样地：

\> buildTree "mississippi"
Node [("i",Node [("",Leaf 10),
                 ("ppi",Leaf 7),
                 ("ssi",Node [("ppi",Leaf 4),
                              ("ssippi",Leaf 1)])]),
      ("mississippi",Leaf 0),
      ("p",Node [("i",Leaf 9),
                 ("pi",Leaf 8)]),
      ("s",Node [("i",Node [("ppi",Leaf 6),
                            ("ssippi",Leaf 3)]),
                 ("si",Node [("ppi",Leaf 5),
                             ("ssippi",Leaf 2)])])]

看起来这段代码完成了这项工作，尽管可能还有改进。我希望它足够通用，可以处理任何字符串。我还试图避免使用
++
，但这总比不使用要好

getContent (Node listOfPairs)
  = listOfPairs

insert :: (String, Int) -> SuffixTree -> SuffixTree
insert (s, n) (Node [])
  = Node [(s, Leaf n)]
insert (s, n) (Node (pair@(a, tree) : pairs))
  | p == a   = Node ((a, insert (r, n) tree) : pairs)
  | null p   = Node (pair : (getContent (insert (r, n) (Node pairs))))
  | p /= a   = Node ([(p, Node [(r, Leaf n), (r', tree)])] ++ pairs)
  where
    (p, r, r') = partition s a

你的基本情况就是问题所在-我打赌
insert'
在某个时候会被
Leaf
调用（仅基于错误消息和你的数据类型）。我也一直在考虑这个问题。但是，在尝试了一些变体之后，我仍然没有找到它。您可能希望使用
Node[（Char，后缀树）]
来代替，我有一种预感，它将大大简化逻辑。感谢您的实现。这个问题背后的想法是以一种暴力、直接的方式实现后缀树构造，这就是为什么它使用非最优算法的原因。不过，有一个更有效的替代方案真是太好了@大卫，这也是一种幼稚的方法，类似于你现在所做的；不是最佳线性算法对，抱歉搞混了。我的意思是，在现实世界中，有一个更快的算法供您使用是很好的。
import Data.List (tails)
import Data.Maybe (maybeToList)
import Control.Arrow (first, second)
import Data.Map.Strict (Map, empty, insert, insertWith, assocs)

data SuffixTree
  = Leaf Int
  | Node [(String, SuffixTree)]
  deriving Show

data SuffixTrie
  = Leaf' Int
  | Node' (Map (Maybe Char) SuffixTrie)

buildTrie :: String -> SuffixTrie
buildTrie s = foldl go (flip const) (init $ tails s) (length s) $ Node' empty
  where
  go run xs i (Node' ns) = run (i - 1) $ Node' tr
    where tr = foldr loop (insert Nothing $ Leaf' (i - 1)) xs ns
  loop x run = insertWith (+:) (Just x) . Node' $ run empty
    where _ +: Node' ns = Node' $ run ns

buildTree :: String -> SuffixTree
buildTree = loop . buildTrie
  where
  loop (Leaf' i) = Leaf i
  loop (Node' m) = Node $ con . second loop <$> assocs m
  con (Just x, Node [(xs, tr)]) = (x:xs, tr) -- compress single-child nodes
  con n = maybeToList `first` n

\> buildTree "banana"
Node [("a",Node [("",Leaf 5),
                 ("na",Node [("",Leaf 3),
                             ("na",Leaf 1)])]),
      ("banana",Leaf 0),
      ("na",Node [("",Leaf 4),
                  ("na",Leaf 2)])]

\> buildTree "mississippi"
Node [("i",Node [("",Leaf 10),
                 ("ppi",Leaf 7),
                 ("ssi",Node [("ppi",Leaf 4),
                              ("ssippi",Leaf 1)])]),
      ("mississippi",Leaf 0),
      ("p",Node [("i",Leaf 9),
                 ("pi",Leaf 8)]),
      ("s",Node [("i",Node [("ppi",Leaf 6),
                            ("ssippi",Leaf 3)]),
                 ("si",Node [("ppi",Leaf 5),
                             ("ssippi",Leaf 2)])])]

getContent (Node listOfPairs)
  = listOfPairs

insert :: (String, Int) -> SuffixTree -> SuffixTree
insert (s, n) (Node [])
  = Node [(s, Leaf n)]
insert (s, n) (Node (pair@(a, tree) : pairs))
  | p == a   = Node ((a, insert (r, n) tree) : pairs)
  | null p   = Node (pair : (getContent (insert (r, n) (Node pairs))))
  | p /= a   = Node ([(p, Node [(r, Leaf n), (r', tree)])] ++ pairs)
  where
    (p, r, r') = partition s a