Slight tweak of the algorithm

src/Gargantext/Core/NodeStory.hs

@@ -73,13 +73,15 @@ module Gargantext.Core.NodeStory
   ) where
 
 import Control.Lens ((%~), non, _Just, at, over, Lens', (#), to)
+import Control.Monad.State.Strict (modify')
+import Database.PostgreSQL.Simple qualified as PGS
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.ToField qualified as PGS
+import Data.List qualified as L
 import Data.ListZipper
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Tree
-import Database.PostgreSQL.Simple qualified as PGS
-import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Database.PostgreSQL.Simple.ToField qualified as PGS
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory.DB
 import Gargantext.Core.NodeStory.Types
@@ -88,7 +90,6 @@ import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
 import Gargantext.Database.Prelude
 import Gargantext.Prelude hiding (to)
-import qualified Data.List as L
 
 class HasNgramChildren e where
   ngramsElementChildren :: Lens' e (MSet NgramsTerm)
@@ -141,20 +142,24 @@ destroyArchiveStateForest :: Map Ngrams.NgramsType (Forest (TreeNode NgramsRepoE
 destroyArchiveStateForest = Map.map destroyForest
 
 -- | Builds an ngrams forest from the input ngrams table map.
-buildForest :: forall e. HasNgramChildren e
+buildForest :: forall e. (HasNgramParent e, HasNgramChildren e)
             => OnLoopDetectedStrategy
             -- ^ A strategy to apply when a loop is found.
             -> Map NgramsTerm e
             -> Either BuildForestError (Forest (TreeNode e))
-buildForest onLoopStrategy mp = unfoldForestM unfoldNode $ Map.toList mp
+buildForest onLoopStrategy mp = flip evalState (BuildForestState 1 mempty []) . runExceptT $
+  unfoldForestM buildTree $ Map.toList mp
   where
-    unfoldNode :: TreeNode e -> Either BuildForestError (TreeNode e, [TreeNode e])
-    unfoldNode (n, el) = flip evalState (BuildForestState 1 mempty []) . runExceptT $ do
+    buildTree :: TreeNode e
+              -> ExceptT BuildForestError (State (BuildForestState e)) (TreeNode e, [TreeNode e])
+    buildTree (n, el) = do
+      lift $ modify' (\st -> st { _bfs_visited = mempty, _bfs_children = [] })
       let initialChildren = getChildren mp (mSetToList $ el ^. ngramsElementChildren)
       children <- unfold_node onLoopStrategy mp initialChildren
       -- Create the final ngram by setting the children in the root node to be
       -- the children computed by unfold_node.
-      pure ((n, el & ngramsElementChildren .~ (mSetFromList $ map fst children)), children)
+      let root = el & ngramsElementChildren .~ (mSetFromList $ map fst children)
+      pure ((n, root), children)
 
 getChildren :: Map NgramsTerm e -> [NgramsTerm] -> [TreeNode e]
 getChildren mp = mapMaybe (\t -> (t,) <$> Map.lookup t mp)
@@ -185,7 +190,7 @@ unfold_node onLoopStrategy mp (x:xs) = do
       BreakLoop algo -> breakLoopByAlgo mp x xs algo
     False -> do
       put (BuildForestState (pos + 1) (Set.insert (VN (pos + 1) nt) visited) (x : children_so_far))
-      unfold_node onLoopStrategy mp (getChildren mp (mSetToList $ snd x ^. ngramsElementChildren) <> xs)
+      unfold_node onLoopStrategy mp xs
 
 
 breakLoopByAlgo :: HasNgramChildren e
@@ -213,7 +218,7 @@ justDoItLoopBreaker mp (nt, el) xs = do
   let x' = (nt, el')
 
   put (BuildForestState pos visited (x' : children_so_far))
-  unfold_node (BreakLoop LBA_just_do_it) mp (getChildren mp (mSetToList $ snd x' ^. ngramsElementChildren) <> xs)
+  unfold_node (BreakLoop LBA_just_do_it) mp xs
 
 findLoopyEdges :: HasNgramChildren e => e -> Set VisitedNode -> MSet NgramsTerm
 findLoopyEdges e vns = mSetFromSet $