Sigmax.purs 9.32 KB
Newer Older
James Laver's avatar
James Laver committed
1 2 3
module Gargantext.Hooks.Sigmax
  where

arturo's avatar
arturo committed
4
import DOM.Simple.Types (Element)
James Laver's avatar
James Laver committed
5
import Data.Array as A
6
import Data.Either (either)
7
import Data.Foldable (sequence_, foldl)
8
import Data.Map as Map
9 10
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable)
James Laver's avatar
James Laver committed
11
import Data.Sequence (Seq)
12
import Data.Sequence as Seq
13
import Data.Set as Set
14
import Data.Traversable (traverse_)
15
import Data.Tuple (Tuple(..))
arturo's avatar
arturo committed
16
import Data.Tuple.Nested ((/\))
James Laver's avatar
James Laver committed
17
import Effect (Effect)
18
import Effect.Class.Console (error)
19
import Effect.Timer (TimeoutId, clearTimeout)
20
import FFI.Simple ((.=))
James Laver's avatar
James Laver committed
21
import Gargantext.Hooks.Sigmax.Sigma as Sigma
22
import Gargantext.Hooks.Sigmax.Types as ST
arturo's avatar
arturo committed
23
import Gargantext.Utils.Console as C
24
import Gargantext.Utils.Reactix as R2
arturo's avatar
arturo committed
25 26 27
import Prelude (Unit, bind, discard, flip, map, not, pure, unit, ($), (&&), (*>), (<<<), (<>), (>>=))
import Reactix as R
import Toestand as T
James Laver's avatar
James Laver committed
28 29 30

type Sigma =
  { sigma :: R.Ref (Maybe Sigma.Sigma)
31
    -- TODO is Seq in cleanup really necessary?
James Laver's avatar
James Laver committed
32 33 34
  , cleanup :: R.Ref (Seq (Effect Unit))
  }

35
type Data n e = { graph :: R.Ref (ST.Graph n e) }
James Laver's avatar
James Laver committed
36

arturo's avatar
arturo committed
37 38 39 40 41 42
moduleName :: R2.Module
moduleName = "Gargantext.Hooks.Sigmax"

console :: C.Console
console = C.encloseContext C.Main moduleName

43 44 45 46 47 48
initSigma :: R.Hooks Sigma
initSigma = do
    s <- R2.nothingRef
    c <- R.useRef Seq.empty
    pure { sigma: s, cleanup: c }

James Laver's avatar
James Laver committed
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
readSigma :: Sigma -> Maybe Sigma.Sigma
readSigma sigma = R.readRef sigma.sigma

writeSigma :: Sigma -> Maybe Sigma.Sigma -> Effect Unit
writeSigma sigma = R.setRef sigma.sigma

-- | Pushes to the back of the cleanup sequence. Cleanup happens
-- | *before* sigma is destroyed
cleanupLast :: Sigma -> Effect Unit -> Effect Unit
cleanupLast sigma = R.setRef sigma.cleanup <<< Seq.snoc existing
  where existing = R.readRef sigma.cleanup

-- | Pushes to the front of the cleanup sequence. Cleanup happens
-- | *before* sigma is destroyed
cleanupFirst :: Sigma -> Effect Unit -> Effect Unit
cleanupFirst sigma =
  R.setRef sigma.cleanup <<< (flip Seq.cons) (R.readRef sigma.cleanup)

cleanupSigma :: Sigma -> String -> Effect Unit
cleanupSigma sigma context = traverse_ kill (readSigma sigma)
  where
    kill sig = runCleanups *> killSigma *> emptyOut
      where -- close over sig
        killSigma = Sigma.killSigma sig >>= report
    runCleanups = sequence_ (R.readRef sigma.cleanup)
    emptyOut = writeSigma sigma Nothing *> R.setRef sigma.cleanup Seq.empty
arturo's avatar
arturo committed
75
    report = either (console.log2 errorMsg) (\_ -> console.log successMsg)
James Laver's avatar
James Laver committed
76 77 78 79 80 81
    prefix = "[" <> context <> "] "
    errorMsg = prefix <> "Error killing sigma:"
    successMsg = prefix <> "Killed sigma"

refreshData :: forall n e. Sigma.Sigma -> Sigma.Graph n e -> Effect Unit
refreshData sigma graph
arturo's avatar
arturo committed
82
  =   console.log clearingMsg
83
  *>  Sigma.clear sigmaGraph
arturo's avatar
arturo committed
84
  *>  console.log readingMsg
85
  *>  Sigma.graphRead sigmaGraph graph
arturo's avatar
arturo committed
86
  >>= either (console.log2 errorMsg) refresh
James Laver's avatar
James Laver committed
87
  where
88
    sigmaGraph = Sigma.graph sigma
arturo's avatar
arturo committed
89
    refresh _ = console.log refreshingMsg *> Sigma.refresh sigma
90 91 92 93
    clearingMsg = "[refreshData] Clearing existing graph data"
    readingMsg = "[refreshData] Reading graph data"
    refreshingMsg = "[refreshData] Refreshing graph"
    errorMsg = "[refreshData] Error reading graph data:"
James Laver's avatar
James Laver committed
94

95 96
sigmafy :: forall n e. ST.Graph n e -> Sigma.Graph n e
sigmafy (ST.Graph g) = {nodes,edges}
James Laver's avatar
James Laver committed
97 98 99 100 101 102 103
  where
    nodes = A.fromFoldable g.nodes
    edges = A.fromFoldable g.edges

dependOnSigma :: Sigma -> String -> (Sigma.Sigma -> Effect Unit) -> Effect Unit
dependOnSigma sigma notFoundMsg f = do
  case readSigma sigma of
arturo's avatar
arturo committed
104
    Nothing -> console.warn notFoundMsg
James Laver's avatar
James Laver committed
105 106 107 108 109
    Just sig -> f sig

dependOnContainer :: R.Ref (Nullable Element) -> String -> (Element -> Effect Unit) -> Effect Unit
dependOnContainer container notFoundMsg f = do
  case R.readNullableRef container of
arturo's avatar
arturo committed
110
    Nothing -> console.warn notFoundMsg
James Laver's avatar
James Laver committed
111 112
    Just c -> f c

113 114 115

-- Effectful versions of the above code

116 117 118
-- | Effect for handling pausing FA via state changes.  We need this because
-- | pausing can be done not only via buttons but also from the initial
-- | setTimer.
119 120
handleForceAtlas2Pause :: forall settings. R.Ref Sigma -> T.Box ST.ForceAtlasState -> R.Ref (Maybe TimeoutId) -> settings -> Effect Unit
handleForceAtlas2Pause sigmaRef forceAtlasState mFAPauseRef settings = do
121
  let sigma = R.readRef sigmaRef
122
  toggled <- T.read forceAtlasState
123
  dependOnSigma sigma "[handleForceAtlas2Pause] sigma: Nothing" $ \s -> do
124
    let isFARunning = Sigma.isForceAtlas2Running s
125
    case Tuple toggled isFARunning of
126
      Tuple ST.InitialRunning false -> do
127
        Sigma.restartForceAtlas2 s settings
128
      Tuple ST.Running false -> do
129
        Sigma.restartForceAtlas2 s settings
130 131 132
        case R.readRef mFAPauseRef of
          Nothing -> pure unit
          Just timeoutId -> clearTimeout timeoutId
133
      Tuple ST.Paused true -> do
134
        Sigma.stopForceAtlas2 s
135
      _ -> pure unit
136 137 138 139 140 141 142 143

setEdges :: Sigma.Sigma -> Boolean -> Effect Unit
setEdges sigma val = do
  let settings = {
        drawEdges: val
      , drawEdgeLabels: val
      , hideEdgesOnMove: not val
    }
144 145
  Sigma.setSettings sigma settings

146

147
updateEdges :: Sigma.Sigma -> ST.EdgesMap -> Effect Unit
148
updateEdges sigma edgesMap = do
149
  Sigma.forEachEdge (Sigma.graph sigma) \e -> do
150 151 152
    let mTEdge = Map.lookup e.id edgesMap
    case mTEdge of
      Nothing -> error $ "Edge id " <> e.id <> " not found in edgesMap"
153
      (Just {color: tColor, hidden: tHidden}) -> do
154
        _ <- pure $ (e .= "color") tColor
155
        _ <- pure $ (e .= "hidden") tHidden
156
        pure unit
157
  --Sigma.refresh sigma
158 159


160
updateNodes :: Sigma.Sigma -> ST.NodesMap -> Effect Unit
161
updateNodes sigma nodesMap = do
162
  Sigma.forEachNode (Sigma.graph sigma) \n -> do
163 164 165
    let mTNode = Map.lookup n.id nodesMap
    case mTNode of
      Nothing -> error $ "Node id " <> n.id <> " not found in nodesMap"
166 167
      (Just { borderColor: tBorderColor
             , color: tColor
168
             , equilateral: tEquilateral
169
             , hidden: tHidden
170
             , type: tType }) -> do
171
        _ <- pure $ (n .= "borderColor") tBorderColor
172
        _ <- pure $ (n .= "color") tColor
173
        _ <- pure $ (n .= "equilateral") tEquilateral
174
        _ <- pure $ (n .= "hidden") tHidden
175
        _ <- pure $ (n .= "type") tType
176
        pure unit
177
  --Sigma.refresh sigma
178 179


180
-- | Toggles item visibility in the selected set
181
multiSelectUpdate :: ST.NodeIds -> ST.NodeIds -> ST.NodeIds
182 183 184 185 186 187 188 189 190
multiSelectUpdate new selected = foldl fld selected new
  where
    fld selectedAcc item =
      if Set.member item selectedAcc then
        Set.delete item selectedAcc
      else
        Set.insert item selectedAcc


arturo's avatar
arturo committed
191 192
bindSelectedNodesClick :: Sigma.Sigma -> T.Box ST.NodeIds -> T.Box Boolean -> Effect Unit
bindSelectedNodesClick sigma selectedNodeIds multiSelectEnabled =
193 194
  Sigma.bindClickNodes sigma $ \nodes -> do
    let nodeIds = Set.fromFoldable $ map _.id nodes
arturo's avatar
arturo committed
195 196
    multiSelectEnabled' <- T.read multiSelectEnabled
    if multiSelectEnabled' then
197
      T.modify_ (multiSelectUpdate nodeIds) selectedNodeIds
198
    else
199
      T.write_ nodeIds selectedNodeIds
200

201 202
bindSelectedEdgesClick :: R.Ref Sigma -> R.State ST.EdgeIds -> Effect Unit
bindSelectedEdgesClick sigmaRef (_ /\ setEdgeIds) =
203 204
  dependOnSigma (R.readRef sigmaRef) "[graphCpt] no sigma" $ \sigma -> do
    Sigma.bindClickEdge sigma $ \edge -> do
205
      setEdgeIds \eids ->
206 207 208 209
        if Set.member edge.id eids then
          Set.delete edge.id eids
        else
          Set.insert edge.id eids
210 211

selectorWithSize :: Sigma.Sigma -> Int -> Effect Unit
arturo's avatar
arturo committed
212
selectorWithSize _ _ = do
213 214
  pure unit

215 216 217 218 219
performDiff :: Sigma.Sigma -> ST.SGraph -> Effect Unit
performDiff sigma g = do
  if (Seq.null addEdges) && (Seq.null addNodes) && (Set.isEmpty removeEdges) && (Set.isEmpty removeNodes) then
    pure unit
  else do
220 221 222 223
    traverse_ (Sigma.addNode sigmaGraph) addNodes
    traverse_ (Sigma.addEdge sigmaGraph) addEdges
    traverse_ (Sigma.removeEdge sigmaGraph) removeEdges
    traverse_ (Sigma.removeNode sigmaGraph) removeNodes
224 225
    Sigma.refresh sigma
    Sigma.killForceAtlas2 sigma
226 227 228 229 230
  where
    sigmaGraph = Sigma.graph sigma
    sigmaEdgeIds = Sigma.sigmaEdgeIds sigmaGraph
    sigmaNodeIds = Sigma.sigmaNodeIds sigmaGraph
    {add: Tuple addEdges addNodes, remove: Tuple removeEdges removeNodes} = ST.sigmaDiff sigmaEdgeIds sigmaNodeIds g
231 232
-- DEPRECATED

233
markSelectedEdges :: Sigma.Sigma -> ST.EdgeIds -> ST.EdgesMap -> Effect Unit
234
markSelectedEdges sigma selectedEdgeIds graphEdges = do
235
  Sigma.forEachEdge (Sigma.graph sigma) \e -> do
236 237 238 239 240 241 242 243 244 245 246 247
    case Map.lookup e.id graphEdges of
      Nothing -> error $ "Edge id " <> e.id <> " not found in graphEdges map"
      Just {color} -> do
        let newColor =
              if Set.member e.id selectedEdgeIds then
                "#ff0000"
              else
                color
        _ <- pure $ (e .= "color") newColor
        pure unit
  Sigma.refresh sigma

248
markSelectedNodes :: Sigma.Sigma -> ST.NodeIds -> ST.NodesMap -> Effect Unit
249
markSelectedNodes sigma selectedNodeIds graphNodes = do
250
  Sigma.forEachNode (Sigma.graph sigma) \n -> do
251 252 253 254 255 256 257 258 259 260 261
    case Map.lookup n.id graphNodes of
      Nothing -> error $ "Node id " <> n.id <> " not found in graphNodes map"
      Just {color} -> do
        let newColor =
              if Set.member n.id selectedNodeIds then
                "#ff0000"
              else
                color
        _ <- pure $ (n .= "color") newColor
        pure unit
  Sigma.refresh sigma
262 263 264 265 266 267

getEdges :: Sigma.Sigma -> Effect (Array (Record ST.Edge))
getEdges sigma = Sigma.getEdges sigma

getNodes :: Sigma.Sigma -> Effect (Array (Record ST.Node))
getNodes sigma = Sigma.getNodes sigma