Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
191
Issues
191
List
Board
Labels
Milestones
Merge Requests
8
Merge Requests
8
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
ea615b2e
Commit
ea615b2e
authored
Sep 29, 2025
by
Alfredo Di Napoli
Committed by
Alfredo Di Napoli
Sep 29, 2025
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Slight tweak of the algorithm
parent
63608dd9
Pipeline
#7942
canceled with stages
Changes
1
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
16 additions
and
11 deletions
+16
-11
NodeStory.hs
src/Gargantext/Core/NodeStory.hs
+16
-11
No files found.
src/Gargantext/Core/NodeStory.hs
View file @
ea615b2e
...
...
@@ -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
$
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment