Commit ea615b2e authored by Alfredo Di Napoli's avatar Alfredo Di Napoli Committed by Alfredo Di Napoli

Slight tweak of the algorithm

parent 63608dd9
Pipeline #7942 canceled with stages
......@@ -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 $
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment