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

4
import Prelude (Unit, bind, discard, flip, pure, unit, ($), (*>), (<<<), (<>), (>>=), (&&), not, const, map)
5

James Laver's avatar
James Laver committed
6
import Data.Array as A
7
import Data.Either (either)
8
import Data.Foldable (sequence_, foldl)
9
import Data.Map as Map
10 11
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable)
James Laver's avatar
James Laver committed
12
import Data.Sequence (Seq)
13
import Data.Sequence as Seq
14
import Data.Set as Set
15
import Data.Traversable (traverse_)
16
import Data.Tuple (Tuple(..))
17
import Data.Tuple.Nested((/\))
18 19
import DOM.Simple.Console (log, log2)
import DOM.Simple.Types (Element)
James Laver's avatar
James Laver committed
20
import Effect (Effect)
21
import Effect.Class.Console (error)
22
import Effect.Timer (TimeoutId, clearTimeout)
23
import FFI.Simple ((.=))
James Laver's avatar
James Laver committed
24
import Gargantext.Hooks.Sigmax.Sigma as Sigma
25
import Gargantext.Hooks.Sigmax.Types as ST
26 27
import Gargantext.Utils.Reactix as R2
import Reactix as R
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

37 38 39 40 41 42
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
43 44 45 46 47 48 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 75 76
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
    report = either (log2 errorMsg) (\_ -> log successMsg)
    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
  =   log clearingMsg
77
  *>  Sigma.clear sigmaGraph
James Laver's avatar
James Laver committed
78
  *>  log readingMsg
79
  *>  Sigma.graphRead sigmaGraph graph
James Laver's avatar
James Laver committed
80 81
  >>= either (log2 errorMsg) refresh
  where
82
    sigmaGraph = Sigma.graph sigma
James Laver's avatar
James Laver committed
83
    refresh _ = log refreshingMsg *> Sigma.refresh sigma
84 85 86 87
    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
88

89 90
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
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
  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
    Nothing -> log notFoundMsg
    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
    Nothing -> log notFoundMsg
    Just c -> f c

107 108 109

-- Effectful versions of the above code

110 111 112
-- | 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.
113
--handleForceAtlasPause sigmaRef (toggled /\ setToggled) mFAPauseRef = do
114 115
handleForceAtlas2Pause :: R.Ref Sigma -> R.State ST.ForceAtlasState -> R.Ref (Maybe TimeoutId) -> Effect Unit
handleForceAtlas2Pause sigmaRef (toggled /\ setToggled) mFAPauseRef = do
116 117
  let sigma = R.readRef sigmaRef
  dependOnSigma sigma "[handleForceAtlas2Pause] sigma: Nothing" $ \s -> do
118 119
    --log2 "[handleForceAtlas2Pause] mSigma: Just " s
    --log2 "[handleForceAtlas2Pause] toggled: " toggled
120
    let isFARunning = Sigma.isForceAtlas2Running s
121
    --log2 "[handleForceAtlas2Pause] isFARunning: " isFARunning
122
    case Tuple toggled isFARunning of
123 124 125 126
      Tuple ST.InitialRunning false -> do
        -- hide edges during forceAtlas rendering, this prevents flickering
        Sigma.restartForceAtlas2 s
      Tuple ST.Running false -> do
127 128
        -- hide edges during forceAtlas rendering, this prevents flickering
        Sigma.restartForceAtlas2 s
129 130 131
        case R.readRef mFAPauseRef of
          Nothing -> pure unit
          Just timeoutId -> clearTimeout timeoutId
132
      Tuple ST.Paused true -> do
133 134
        -- restore edges state
        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


191 192
bindSelectedNodesClick :: Sigma.Sigma -> R.State ST.NodeIds -> R.Ref Boolean -> Effect Unit
bindSelectedNodesClick sigma (_ /\ setNodeIds) multiSelectEnabledRef =
193 194 195 196
  Sigma.bindClickNodes sigma $ \nodes -> do
    let multiSelectEnabled = R.readRef multiSelectEnabledRef
    let nodeIds = Set.fromFoldable $ map _.id nodes
    if multiSelectEnabled then
197
      setNodeIds $ multiSelectUpdate nodeIds
198
    else
199
      setNodeIds $ const nodeIds
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 212 213 214

selectorWithSize :: Sigma.Sigma -> Int -> Effect Unit
selectorWithSize sigma size = do
  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