{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IGraph.Mutable
( MGraph(..)
, new
, nNodes
, nEdges
, addNodes
, delNodes
, addEdges
, delEdges
, setEdgeAttr
, setNodeAttr
)where
import Control.Monad (forM)
import Control.Monad.Primitive
import Data.Either (fromRight)
import Data.Serialize (decode)
import qualified Data.Map.Strict as M
import Data.List (foldl', delete)
import Data.Primitive.MutVar
import Data.Serialize (Serialize, encode)
import Data.Singletons.Prelude (Sing, SingI, fromSing, sing)
import Foreign hiding (new)
import IGraph.Internal
import IGraph.Internal.Initialization
import IGraph.Types
data MGraph m (d :: EdgeType) v e = MGraph
{ _mgraph :: IGraph
, _mlabelToNode :: MutVar m (M.Map v [Node])
}
new :: forall m d v e. (SingI d, Ord v, Serialize v, PrimMonad m)
=> [v] -> m (MGraph (PrimState m) d v e)
new nds = do
gr <- unsafePrimToPrim $ do
gr <- igraphInit >>= igraphNew n directed
withAttr vertexAttr nds $ \attr ->
withPtrs [attr] (igraphAddVertices gr n . castPtr)
return gr
m <- newMutVar $ M.fromListWith (++) $ zip nds $ map return [0 .. n - 1]
return $ MGraph gr m
where
n = length nds
directed = case fromSing (sing :: Sing d) of
D -> True
U -> False
nNodes :: PrimMonad m => MGraph (PrimState m) d v e -> m Int
nNodes gr = unsafePrimToPrim $ igraphVcount $ _mgraph gr
{-# INLINE nNodes #-}
nEdges :: PrimMonad m => MGraph (PrimState m) d v e -> m Int
nEdges gr = unsafePrimToPrim $ igraphEcount $ _mgraph gr
{-# INLINE nEdges #-}
addNodes :: (Ord v, Serialize v, PrimMonad m)
=> [v]
-> MGraph (PrimState m) d v e -> m ()
addNodes labels gr = do
m <- nNodes gr
unsafePrimToPrim $ withAttr vertexAttr labels $ \attr ->
withPtrs [attr] (igraphAddVertices (_mgraph gr) n . castPtr)
modifyMutVar' (_mlabelToNode gr) $ \x ->
foldl' (\acc (k,v) -> M.insertWith (++) k v acc) x $
zip labels $ map return [m .. m + n - 1]
where
n = length labels
{-# INLINE addNodes #-}
nodeLab :: (PrimMonad m, Serialize v) => MGraph (PrimState m) d v e -> Node -> m v
nodeLab gr i = unsafePrimToPrim $
igraphHaskellAttributeVAS (_mgraph gr) vertexAttr i >>= toByteString >>=
return . fromRight (error "decode failed") . decode
{-# INLINE nodeLab #-}
delNodes :: (PrimMonad m, Ord v, Serialize v)
=> [Node] -> MGraph (PrimState m) d v e -> m ()
delNodes ns gr = do
unsafePrimToPrim $ withVerticesList ns $ igraphDeleteVertices (_mgraph gr)
writeMutVar (_mlabelToNode gr) $ mkLabelToId $ _mgraph gr
{-# INLINE delNodes #-}
addEdges :: (PrimMonad m, Serialize e)
=> [LEdge e] -> MGraph (PrimState m) d v e -> m ()
addEdges es gr = unsafePrimToPrim $
withAttr edgeAttr vs $ \attr -> withList (concat xs) $ \vec ->
withPtrs [attr] (igraphAddEdges (_mgraph gr) vec . castPtr)
where
(xs, vs) = unzip $ map ( \((a,b),v) -> ([a, b], v) ) es
{-# INLINE addEdges #-}
delEdges :: forall m d v e. (SingI d, PrimMonad m)
=> [Edge] -> MGraph (PrimState m) d v e -> m ()
delEdges es gr = unsafePrimToPrim $ do
eids <- forM es $ \(fr, to) -> igraphGetEid (_mgraph gr) fr to directed True
withEdgeIdsList eids (igraphDeleteEdges (_mgraph gr))
where
directed = case fromSing (sing :: Sing d) of
D -> True
U -> False
setNodeAttr :: (PrimMonad m, Serialize v, Ord v)
=> Int
-> v
-> MGraph (PrimState m) d v e
-> m ()
setNodeAttr nodeId x gr = do
x' <- nodeLab gr nodeId
unsafePrimToPrim $ withByteString (encode x) $
igraphHaskellAttributeVASSet (_mgraph gr) vertexAttr nodeId
modifyMutVar' (_mlabelToNode gr) $
M.insertWith (++) x [nodeId] . M.adjust (delete nodeId) x'
setEdgeAttr :: (PrimMonad m, Serialize e)
=> Int
-> e
-> MGraph (PrimState m) d v e
-> m ()
setEdgeAttr edgeId x gr = unsafePrimToPrim $
withByteString (encode x) $ igraphHaskellAttributeEASSet (_mgraph gr) edgeAttr edgeId