diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,14 @@ Revision history for haskell-igraph =================================== +v0.6.0 -- 2018-05-10 +-------------------- + +* Breaking change: Drop `Graph` type class. Change `LGraph` and `MLGraph` to +`Graph` and `MGraph`. The new `Graph` and `MGraph` types are now dependently typed. + v0.5.0 -- 2018-04-25 -------------------- +-------------------- * Fix memory leaks. * Interface change: `mapNodes`, `mapEdges`, `filterNodes`, `filterEdges` become @@ -10,6 +16,6 @@ v0.4.0 -- 2018-04-20 -------------------- +-------------------- * A new attribute interface written in C. The graph attributes are now directly serialized into bytestring using "cereal" (before we used the `Show` instance). diff --git a/haskell-igraph.cabal b/haskell-igraph.cabal --- a/haskell-igraph.cabal +++ b/haskell-igraph.cabal @@ -1,5 +1,5 @@ name: haskell-igraph -version: 0.5.0 +version: 0.6.0 synopsis: Haskell interface of the igraph library. description: igraph<"http://igraph.org/c/"> is a library for creating and manipulating large graphs. This package provides the Haskell @@ -27,7 +27,6 @@ exposed-modules: IGraph.Internal.Initialization IGraph.Internal.Constants - IGraph.Internal.Types IGraph.Internal IGraph IGraph.Types @@ -56,15 +55,15 @@ , bytestring >= 0.9 , bytestring-lexing >= 0.5 , cereal - , cereal-conduit , colour , conduit >= 1.3.0 + , data-ordlist , primitive , unordered-containers , hashable , hxt , split - , data-default-class + , singletons extra-libraries: igraph hs-source-dirs: src @@ -87,6 +86,7 @@ Test.Structure Test.Isomorphism Test.Motif + Test.Clique Test.Utils default-language: Haskell2010 diff --git a/src/IGraph.hs b/src/IGraph.hs --- a/src/IGraph.hs +++ b/src/IGraph.hs @@ -1,11 +1,24 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + module IGraph ( Graph(..) - , LGraph(..) - , U - , D - , decodeC + , EdgeType(..) + , isDirected + , nNodes + , nodeLab + , nodes + , labNodes + , nEdges + , edgeLab + , edges + , labEdges + , hasEdge + , getNodes + , getEdgeByEid + , getEdgeLabByEid , empty , mkGraph , fromLabeledEdges @@ -29,11 +42,9 @@ import Conduit import Control.Arrow ((&&&)) -import Control.Monad (forM, forM_, liftM, replicateM) +import Control.Monad (forM, forM_, liftM, replicateM, when) import Control.Monad.Primitive import Control.Monad.ST (runST) -import qualified Data.ByteString as B -import Data.Conduit.Cereal import Data.Either (fromRight) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as M @@ -41,103 +52,26 @@ import Data.List (sortBy) import Data.Ord (comparing) import Data.Serialize -import Foreign (castPtr) +import Data.Singletons (Sing, SingI (..), fromSing) +import Foreign (Ptr, castPtr) import System.IO.Unsafe (unsafePerformIO) import IGraph.Internal import IGraph.Internal.Constants -import IGraph.Mutable +import IGraph.Mutable (MGraph(..)) +import qualified IGraph.Mutable as GM import IGraph.Types -class MGraph d => Graph d where - -- | Graph is directed or not. - isDirected :: LGraph d v e -> Bool - isD :: d -> Bool - - -- | Return the number of nodes in a graph. - nNodes :: LGraph d v e -> Int - nNodes (LGraph g _) = unsafePerformIO $ igraphVcount g - {-# INLINE nNodes #-} - - -- | Return all nodes. @nodes gr == [0 .. nNodes gr - 1]@. - nodes :: LGraph d v e -> [Node] - nodes gr = [0 .. nNodes gr - 1] - {-# INLINE nodes #-} - - labNodes :: Serialize v => LGraph d v e -> [LNode v] - labNodes gr = map (\i -> (i, nodeLab gr i)) $ nodes gr - {-# INLINE labNodes #-} - - -- | Return the number of edges in a graph. - nEdges :: LGraph d v e -> Int - nEdges (LGraph g _) = unsafePerformIO $ igraphEcount g - {-# INLINE nEdges #-} - - -- | Return all edges. - edges :: LGraph d v e -> [Edge] - edges gr = map (getEdgeByEid gr) [0 .. nEdges gr - 1] - {-# INLINE edges #-} - - labEdges :: Serialize e => LGraph d v e -> [LEdge e] - labEdges gr = map (getEdgeByEid gr &&& getEdgeLabByEid gr) [0 .. nEdges gr - 1] - {-# INLINE labEdges #-} - - -- | Whether a edge exists in the graph. - hasEdge :: LGraph d v e -> Edge -> Bool - hasEdge (LGraph g _) (fr, to) = unsafePerformIO $ do - i <- igraphGetEid g fr to True False - return $ i >= 0 - {-# INLINE hasEdge #-} - - -- | Return the label of given node. - nodeLab :: Serialize v => LGraph d v e -> Node -> v - nodeLab (LGraph g _) i = unsafePerformIO $ - igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>= - return . fromRight (error "decode failed") . decode - {-# INLINE nodeLab #-} - - -- | Return all nodes that are associated with given label. - getNodes :: (Hashable v, Eq v) => LGraph d v e -> v -> [Node] - getNodes gr x = M.lookupDefault [] x $ _labelToNode gr - {-# INLINE getNodes #-} - - -- | Return the label of given edge. - edgeLab :: Serialize e => LGraph d v e -> Edge -> e - edgeLab (LGraph g _) (fr,to) = unsafePerformIO $ - igraphGetEid g fr to True True >>= - igraphHaskellAttributeEAS g edgeAttr >>= bsToByteString >>= - return . fromRight (error "decode failed") . decode - {-# INLINE edgeLab #-} - - -- | Find the edge by edge ID. - getEdgeByEid :: LGraph d v e -> Int -> Edge - getEdgeByEid (LGraph g _) i = unsafePerformIO $ igraphEdge g i - {-# INLINE getEdgeByEid #-} - - -- | Find the edge label by edge ID. - getEdgeLabByEid :: Serialize e => LGraph d v e -> Int -> e - getEdgeLabByEid (LGraph g _) i = unsafePerformIO $ - igraphHaskellAttributeEAS g edgeAttr i >>= bsToByteString >>= - return . fromRight (error "decode failed") . decode - {-# INLINE getEdgeLabByEid #-} - -instance Graph U where - isDirected = const False - isD = const False - -instance Graph D where - isDirected = const True - isD = const True - -- | Graph with labeled nodes and edges. -data LGraph d v e = LGraph +data Graph (d :: EdgeType) v e = Graph { _graph :: IGraph , _labelToNode :: M.HashMap v [Node] } -instance (Graph d, Serialize v, Serialize e, Hashable v, Eq v) - => Serialize (LGraph d v e) where +instance (SingI d, Serialize v, Serialize e, Hashable v, Eq v) + => Serialize (Graph d v e) where put gr = do + put $ fromSing (sing :: Sing d) put $ nNodes gr go (nodeLab gr) (nNodes gr) 0 put $ nEdges gr @@ -146,42 +80,108 @@ go f n i | i >= n = return () | otherwise = put (f i) >> go f n (i+1) get = do + directed <- get + when (fromSing (sing :: Sing d) /= directed) $ + error "Incorrect graph type" nn <- get nds <- replicateM nn get ne <- get es <- replicateM ne get return $ mkGraph nds es --- | Decode a graph from a stream of inputs. This may be more memory efficient --- than standard @decode@ function. -decodeC :: ( PrimMonad m, MonadThrow m, Graph d - , Serialize v, Serialize e, Hashable v, Eq v ) - => ConduitT B.ByteString o m (LGraph d v e) -decodeC = do - nn <- sinkGet get - nds <- replicateM nn $ sinkGet get - ne <- sinkGet get - conduitGet2 get .| deserializeGraph nds ne +-- | Is the graph directed or not. +isDirected :: forall d v e. SingI d => Graph d v e -> Bool +isDirected _ = case fromSing (sing :: Sing d) of + D -> True + U -> False +{-# INLINE isDirected #-} +-- | Return the number of nodes in a graph. +nNodes :: Graph d v e -> Int +nNodes = unsafePerformIO . igraphVcount . _graph +{-# INLINE nNodes #-} + +-- | Return all nodes. @nodes gr == [0 .. nNodes gr - 1]@. +nodes :: Graph d v e -> [Node] +nodes gr = [0 .. nNodes gr - 1] +{-# INLINE nodes #-} + +labNodes :: Serialize v => Graph d v e -> [LNode v] +labNodes gr = map (\i -> (i, nodeLab gr i)) $ nodes gr +{-# INLINE labNodes #-} + +-- | Return the number of edges in a graph. +nEdges :: Graph d v e -> Int +nEdges = unsafePerformIO . igraphEcount . _graph +{-# INLINE nEdges #-} + + -- | Return all edges. +edges :: Graph d v e -> [Edge] +edges gr = map (getEdgeByEid gr) [0 .. nEdges gr - 1] +{-# INLINE edges #-} + +labEdges :: Serialize e => Graph d v e -> [LEdge e] +labEdges gr = map (getEdgeByEid gr &&& getEdgeLabByEid gr) [0 .. nEdges gr - 1] +{-# INLINE labEdges #-} + +-- | Whether a edge exists in the graph. +hasEdge :: Graph d v e -> Edge -> Bool +hasEdge gr (fr, to) = unsafePerformIO $ do + i <- igraphGetEid (_graph gr) fr to True False + return $ i >= 0 +{-# INLINE hasEdge #-} + +-- | Return the label of given node. +nodeLab :: Serialize v => Graph d v e -> Node -> v +nodeLab gr i = unsafePerformIO $ + igraphHaskellAttributeVAS (_graph gr) vertexAttr i >>= toByteString >>= + return . fromRight (error "decode failed") . decode +{-# INLINE nodeLab #-} + +-- | Return all nodes that are associated with given label. +getNodes :: (Hashable v, Eq v) => Graph d v e -> v -> [Node] +getNodes gr x = M.lookupDefault [] x $ _labelToNode gr +{-# INLINE getNodes #-} + +-- | Return the label of given edge. +edgeLab :: Serialize e => Graph d v e -> Edge -> e +edgeLab (Graph g _) (fr,to) = unsafePerformIO $ + igraphGetEid g fr to True True >>= + igraphHaskellAttributeEAS g edgeAttr >>= toByteString >>= + return . fromRight (error "decode failed") . decode +{-# INLINE edgeLab #-} + +-- | Find the edge by edge ID. +getEdgeByEid :: Graph d v e -> Int -> Edge +getEdgeByEid (Graph g _) i = unsafePerformIO $ igraphEdge g i +{-# INLINE getEdgeByEid #-} + +-- | Find the edge label by edge ID. +getEdgeLabByEid :: Serialize e => Graph d v e -> Int -> e +getEdgeLabByEid (Graph g _) i = unsafePerformIO $ + igraphHaskellAttributeEAS g edgeAttr i >>= toByteString >>= + return . fromRight (error "decode failed") . decode +{-# INLINE getEdgeLabByEid #-} + -- | Create a empty graph. -empty :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e) - => LGraph d v e -empty = runST $ new 0 >>= unsafeFreeze +empty :: (SingI d, Hashable v, Serialize v, Eq v, Serialize e) + => Graph d v e +empty = runST $ GM.new 0 >>= unsafeFreeze -- | Create a graph. -mkGraph :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e) +mkGraph :: (SingI d, Hashable v, Serialize v, Eq v, Serialize e) => [v] -- ^ Nodes. Each will be assigned a ID from 0 to N. -> [LEdge e] -- ^ Labeled edges. - -> LGraph d v e + -> Graph d v e mkGraph vattr es = runST $ do - g <- new 0 - addLNodes vattr g - addLEdges es g + g <- GM.new 0 + GM.addLNodes vattr g + GM.addLEdges es g unsafeFreeze g -- | Create a graph from labeled edges. -fromLabeledEdges :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e) - => [((v, v), e)] -> LGraph d v e +fromLabeledEdges :: (SingI d, Hashable v, Serialize v, Eq v, Serialize e) + => [((v, v), e)] -> Graph d v e fromLabeledEdges es = mkGraph labels es' where es' = flip map es $ \((fr, to), x) -> ((f fr, f to), x) @@ -190,17 +190,20 @@ labelToId = M.fromList $ zip labels [0..] -- | Create a graph from a stream of labeled edges. -fromLabeledEdges' :: (PrimMonad m, Graph d, Hashable v, Serialize v, Eq v, Serialize e) +fromLabeledEdges' :: (MonadUnliftIO m, SingI d, Hashable v, Serialize v, Eq v, Serialize e) => a -- ^ Input, usually a file -> (a -> ConduitT () ((v, v), e) m ()) -- ^ deserialize the input into a stream of edges - -> m (LGraph d v e) + -> m (Graph d v e) fromLabeledEdges' input mkConduit = do (labelToId, _, ne) <- runConduit $ mkConduit input .| foldlC f (M.empty, 0::Int, 0::Int) - let getId x = M.lookupDefault undefined x labelToId - runConduit $ mkConduit input .| - mapC (\((v1, v2), e) -> ((getId v1, getId v2), e)) .| - deserializeGraph (fst $ unzip $ sortBy (comparing snd) $ M.toList labelToId) ne + let action evec bsvec = do + let getId x = M.lookupDefault undefined x labelToId + runConduit $ mkConduit input .| + mapC (\((v1, v2), e) -> ((getId v1, getId v2), e)) .| + deserializeGraph (fst $ unzip $ sortBy (comparing snd) $ M.toList labelToId) evec bsvec + withRunInIO $ \runInIO -> allocaVectorN (2*ne) $ \evec -> + allocaBSVectorN ne $ \bsvec -> (runInIO $ action evec bsvec) where f (vs, nn, ne) ((v1, v2), _) = let (vs', nn') = add v1 $ add v2 (vs, nn) @@ -210,110 +213,102 @@ then (m, i) else (M.insert v i m, i + 1) -deserializeGraph :: ( PrimMonad m, Graph d, Hashable v, Serialize v - , Eq v, Serialize e ) +deserializeGraph :: (MonadIO m, SingI d, Hashable v, Serialize v, Eq v, Serialize e) => [v] - -> Int -- ^ The number of edges - -> ConduitT (LEdge e) o m (LGraph d v e) -deserializeGraph nds ne = do - evec <- unsafePrimToPrim $ igraphVectorNew $ 2 * ne - bsvec <- unsafePrimToPrim $ bsvectorNew ne - let f i ((fr, to), attr) = unsafePrimToPrim $ do + -> Ptr Vector -- ^ a vector that is sufficient to hold all edges + -> Ptr BSVector + -> ConduitT (LEdge e) o m (Graph d v e) +deserializeGraph nds evec bsvec = do + let f i ((fr, to), attr) = liftIO $ do igraphVectorSet evec (i*2) $ fromIntegral fr igraphVectorSet evec (i*2+1) $ fromIntegral to bsvectorSet bsvec i $ encode attr return $ i + 1 _ <- foldMC f 0 - gr@(MLGraph g) <- new 0 - addLNodes nds gr - unsafePrimToPrim $ withAttr edgeAttr bsvec $ \ptr -> do - vptr <- fromPtrs [castPtr ptr] - withVectorPtr vptr (igraphAddEdges g evec . castPtr) - unsafeFreeze gr + liftIO $ do + gr@(MGraph g) <- GM.new 0 + GM.addLNodes nds gr + withBSAttr edgeAttr bsvec $ \ptr -> + withPtrs [ptr] (igraphAddEdges g evec . castPtr) + unsafeFreeze gr {-# INLINE deserializeGraph #-} -- | Convert a mutable graph to immutable graph. freeze :: (Hashable v, Eq v, Serialize v, PrimMonad m) - => MLGraph (PrimState m) d v e -> m (LGraph d v e) -freeze (MLGraph g) = do + => MGraph (PrimState m) d v e -> m (Graph d v e) +freeze (MGraph g) = do g' <- unsafePrimToPrim $ igraphCopy g - unsafeFreeze (MLGraph g') + unsafeFreeze (MGraph g') -- | Convert a mutable graph to immutable graph. The original graph may not be -- used afterwards. unsafeFreeze :: (Hashable v, Eq v, Serialize v, PrimMonad m) - => MLGraph (PrimState m) d v e -> m (LGraph d v e) -unsafeFreeze (MLGraph g) = unsafePrimToPrim $ do + => MGraph (PrimState m) d v e -> m (Graph d v e) +unsafeFreeze (MGraph g) = unsafePrimToPrim $ do nV <- igraphVcount g labels <- forM [0 .. nV - 1] $ \i -> - igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>= + igraphHaskellAttributeVAS g vertexAttr i >>= toByteString >>= return . fromRight (error "decode failed") . decode - return $ LGraph g $ M.fromListWith (++) $ zip labels $ map return [0..nV-1] + return $ Graph g $ M.fromListWith (++) $ zip labels $ map return [0..nV-1] where -- | Create a mutable graph. -thaw :: (PrimMonad m, Graph d) => LGraph d v e -> m (MLGraph (PrimState m) d v e) -thaw (LGraph g _) = unsafePrimToPrim . liftM MLGraph . igraphCopy $ g +thaw :: PrimMonad m => Graph d v e -> m (MGraph (PrimState m) d v e) +thaw (Graph g _) = unsafePrimToPrim . liftM MGraph . igraphCopy $ g -- | Create a mutable graph. The original graph may not be used afterwards. -unsafeThaw :: PrimMonad m => LGraph d v e -> m (MLGraph (PrimState m) d v e) -unsafeThaw (LGraph g _) = return $ MLGraph g +unsafeThaw :: PrimMonad m => Graph d v e -> m (MGraph (PrimState m) d v e) +unsafeThaw (Graph g _) = return $ MGraph g -- | Find all neighbors of the given node. -neighbors :: LGraph d v e -> Node -> [Node] -neighbors gr i = unsafePerformIO $ do - vs <- igraphVsAdj i IgraphAll - vit <- igraphVitNew (_graph gr) vs - vitToList vit +neighbors :: Graph d v e -> Node -> [Node] +neighbors gr i = unsafePerformIO $ withVerticesAdj i IgraphAll $ \vs -> + iterateVerticesC (_graph gr) vs $ \source -> runConduit $ source .| sinkList -- | Find all nodes that have a link from the given node. -suc :: LGraph D v e -> Node -> [Node] -suc gr i = unsafePerformIO $ do - vs <- igraphVsAdj i IgraphOut - vit <- igraphVitNew (_graph gr) vs - vitToList vit +suc :: Graph 'D v e -> Node -> [Node] +suc gr i = unsafePerformIO $ withVerticesAdj i IgraphOut $ \vs -> + iterateVerticesC (_graph gr) vs $ \source -> runConduit $ source .| sinkList -- | Find all nodes that link to to the given node. -pre :: LGraph D v e -> Node -> [Node] -pre gr i = unsafePerformIO $ do - vs <- igraphVsAdj i IgraphIn - vit <- igraphVitNew (_graph gr) vs - vitToList vit +pre :: Graph 'D v e -> Node -> [Node] +pre gr i = unsafePerformIO $ withVerticesAdj i IgraphIn $ \vs -> + iterateVerticesC (_graph gr) vs $ \source -> runConduit $ source .| sinkList -- | Apply a function to change nodes' labels. -nmap :: (Graph d, Serialize v1, Serialize v2, Hashable v2, Eq v2) - => (LNode v1 -> v2) -> LGraph d v1 e -> LGraph d v2 e +nmap :: (Serialize v1, Serialize v2, Hashable v2, Eq v2) + => (LNode v1 -> v2) -> Graph d v1 e -> Graph d v2 e nmap f gr = runST $ do - (MLGraph gptr) <- thaw gr - let gr' = MLGraph gptr - forM_ (nodes gr) $ \x -> setNodeAttr x (f (x, nodeLab gr x)) gr' + (MGraph gptr) <- thaw gr + let gr' = MGraph gptr + forM_ (nodes gr) $ \x -> GM.setNodeAttr x (f (x, nodeLab gr x)) gr' unsafeFreeze gr' -- | Apply a function to change edges' labels. -emap :: (Graph d, Serialize e1, Serialize e2, Hashable v, Eq v, Serialize v) - => (LEdge e1 -> e2) -> LGraph d v e1 -> LGraph d v e2 +emap :: (Serialize e1, Serialize e2, Hashable v, Eq v, Serialize v) + => (LEdge e1 -> e2) -> Graph d v e1 -> Graph d v e2 emap f gr = runST $ do - (MLGraph gptr) <- thaw gr - let gr' = MLGraph gptr + (MGraph gptr) <- thaw gr + let gr' = MGraph gptr forM_ [0 .. nEdges gr - 1] $ \i -> do let lab = f (getEdgeByEid gr i, getEdgeLabByEid gr i) - setEdgeAttr i lab gr' + GM.setEdgeAttr i lab gr' unsafeFreeze gr' -- | Keep nodes that satisfy the constraint. -nfilter :: (Hashable v, Eq v, Serialize v, Graph d) - => (LNode v -> Bool) -> LGraph d v e -> LGraph d v e +nfilter :: (Hashable v, Eq v, Serialize v) + => (LNode v -> Bool) -> Graph d v e -> Graph d v e nfilter f gr = runST $ do let deleted = fst $ unzip $ filter (not . f) $ labNodes gr gr' <- thaw gr - delNodes deleted gr' + GM.delNodes deleted gr' unsafeFreeze gr' -- | Keep edges that satisfy the constraint. -efilter :: (Hashable v, Eq v, Serialize v, Serialize e, Graph d) - => (LEdge e -> Bool) -> LGraph d v e -> LGraph d v e +efilter :: (SingI d, Hashable v, Eq v, Serialize v, Serialize e) + => (LEdge e -> Bool) -> Graph d v e -> Graph d v e efilter f gr = runST $ do let deleted = fst $ unzip $ filter (not . f) $ labEdges gr gr' <- thaw gr - delEdges deleted gr' + GM.delEdges deleted gr' unsafeFreeze gr' diff --git a/src/IGraph/Clique.chs b/src/IGraph/Clique.chs --- a/src/IGraph/Clique.chs +++ b/src/IGraph/Clique.chs @@ -1,35 +1,50 @@ {-# LANGUAGE ForeignFunctionInterface #-} module IGraph.Clique ( cliques + , largestCliques , maximalCliques + , cliqueNumber ) where import Control.Applicative ((<$>)) import System.IO.Unsafe (unsafePerformIO) import qualified Foreign.Ptr as C2HSImp +import Foreign import IGraph +import IGraph.Internal.C2HS {#import IGraph.Internal #} #include "haskell_igraph.h" -cliques :: LGraph d v e +cliques :: Graph d v e -> (Int, Int) -- ^ Minimum and maximum size of the cliques to be returned. -- No bound will be used if negative or zero -> [[Int]] -- ^ cliques represented by node ids -cliques gr (lo, hi) = unsafePerformIO $ do - vpptr <- igraphVectorPtrNew 0 - _ <- igraphCliques (_graph gr) vpptr lo hi - (map.map) truncate <$> toLists vpptr -{#fun igraph_cliques as ^ { `IGraph', `VectorPtr', `Int', `Int' } -> `Int' #} +cliques gr (lo, hi) = unsafePerformIO $ allocaVectorPtr $ \vptr -> do + igraphCliques (_graph gr) vptr lo hi + (map.map) truncate <$> toLists vptr +{#fun igraph_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #} -maximalCliques :: LGraph d v e +largestCliques :: Graph d v e -> [[Int]] +largestCliques gr = unsafePerformIO $ allocaVectorPtr $ \vptr -> do + igraphLargestCliques (_graph gr) vptr + (map.map) truncate <$> toLists vptr +{#fun igraph_largest_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr' } -> `CInt' void- #} + +maximalCliques :: Graph d v e -> (Int, Int) -- ^ Minimum and maximum size of the cliques to be returned. -- No bound will be used if negative or zero -> [[Int]] -- ^ cliques represented by node ids -maximalCliques gr (lo, hi) = unsafePerformIO $ do - vpptr <- igraphVectorPtrNew 0 - _ <- igraphMaximalCliques (_graph gr) vpptr lo hi +maximalCliques gr (lo, hi) = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do + igraphMaximalCliques (_graph gr) vpptr lo hi (map.map) truncate <$> toLists vpptr -{#fun igraph_maximal_cliques as ^ { `IGraph', `VectorPtr', `Int', `Int' } -> `Int' #} +{#fun igraph_maximal_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #} + +cliqueNumber :: Graph d v e -> Int +cliqueNumber gr = unsafePerformIO $ igraphCliqueNumber $ _graph gr +{#fun igraph_clique_number as ^ + { `IGraph' + , alloca- `Int' peekIntConv* + } -> `CInt' void- #} diff --git a/src/IGraph/Community.chs b/src/IGraph/Community.chs --- a/src/IGraph/Community.chs +++ b/src/IGraph/Community.chs @@ -1,13 +1,17 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} module IGraph.Community - ( CommunityOpt(..) - , CommunityMethod(..) + ( modularity , findCommunity + , CommunityMethod(..) + , defaultLeadingEigenvector + , defaultSpinglass ) where -import Data.Default.Class import Data.Function (on) import Data.List (sortBy, groupBy) +import Data.List.Ordered (nubSortBy) import Data.Ord (comparing) import System.IO.Unsafe (unsafePerformIO) @@ -15,99 +19,115 @@ import Foreign.C.Types import IGraph +import IGraph.Internal.C2HS {#import IGraph.Internal #} {#import IGraph.Internal.Constants #} #include "haskell_igraph.h" -data CommunityOpt = CommunityOpt - { _method :: CommunityMethod - , _weights :: Maybe [Double] - , _nIter :: Int -- ^ [LeadingEigenvector] number of iterations, default is 10000 - , _nSpins :: Int -- ^ [Spinglass] number of spins, default is 25 - , _startTemp :: Double -- ^ [Spinglass] the temperature at the start - , _stopTemp :: Double -- ^ [Spinglass] the algorithm stops at this temperature - , _coolFact :: Double -- ^ [Spinglass] the cooling factor for the simulated annealing - , _gamma :: Double -- ^ [Spinglass] the gamma parameter of the algorithm. - } - -data CommunityMethod = LeadingEigenvector - | Spinglass +modularity :: Graph d v e + -> [[Int]] -- ^ Communities. + -> Maybe [Double] -- ^ Weights + -> Double +modularity gr clusters ws + | length nds /= length (concat clusters) = error "Duplicated nodes" + | nds /= nodes gr = error "Some nodes were not given community assignments" + | otherwise = unsafePerformIO $ withList membership $ \membership' -> + withListMaybe ws (igraphModularity (_graph gr) membership') + where + (membership, nds) = unzip $ nubSortBy (comparing snd) $ concat $ + zipWith f [0 :: Int ..] clusters + where + f i xs = zip (repeat i) xs +{#fun igraph_modularity as ^ + { `IGraph' + , castPtr `Ptr Vector' + , alloca- `Double' peekFloatConv* + , castPtr `Ptr Vector' + } -> `CInt' void- #} -instance Default CommunityOpt where - def = CommunityOpt - { _method = LeadingEigenvector - , _weights = Nothing - , _nIter = 10000 - , _nSpins = 25 - , _startTemp = 1.0 - , _stopTemp = 0.01 - , _coolFact = 0.99 - , _gamma = 1.0 +data CommunityMethod = + LeadingEigenvector + { _nIter :: Int -- ^ number of iterations, default is 10000 } + | Spinglass + { _nSpins :: Int -- ^ number of spins, default is 25 + , _startTemp :: Double -- ^ the temperature at the start + , _stopTemp :: Double -- ^ the algorithm stops at this temperature + , _coolFact :: Double -- ^ the cooling factor for the simulated annealing + , _gamma :: Double -- ^ the gamma parameter of the algorithm. + } -findCommunity :: LGraph U v e -> CommunityOpt -> [[Int]] -findCommunity gr opt = unsafePerformIO $ do - result <- igraphVectorNew 0 - ws <- case _weights opt of - Just w -> fromList w - _ -> fmap Vector $ newForeignPtr_ $ castPtr nullPtr +defaultLeadingEigenvector :: CommunityMethod +defaultLeadingEigenvector = LeadingEigenvector 10000 - _ <- case _method opt of - LeadingEigenvector -> do - ap <- igraphArpackNew - igraphCommunityLeadingEigenvector (_graph gr) ws nullPtr result - (_nIter opt) ap nullPtr False - nullPtr nullPtr nullPtr - nullFunPtr nullPtr - Spinglass -> - igraphCommunitySpinglass (_graph gr) ws nullPtr nullPtr result - nullPtr (_nSpins opt) False (_startTemp opt) - (_stopTemp opt) (_coolFact opt) - IgraphSpincommUpdateConfig (_gamma opt) +defaultSpinglass :: CommunityMethod +defaultSpinglass = Spinglass + { _nSpins = 25 + , _startTemp = 1.0 + , _stopTemp = 0.01 + , _coolFact = 0.99 + , _gamma = 1.0 } + +findCommunity :: Graph 'U v e + -> Maybe [Double] -- ^ node weights + -> CommunityMethod -- ^ Community finding algorithms + -> [[Int]] +findCommunity gr ws method = unsafePerformIO $ allocaVector $ \result -> + withListMaybe ws $ \ws' -> do + case method of + LeadingEigenvector n -> allocaArpackOpt $ \arpack -> + igraphCommunityLeadingEigenvector (_graph gr) ws' nullPtr result + n arpack nullPtr False + nullPtr nullPtr nullPtr + nullFunPtr nullPtr + Spinglass{..} -> igraphCommunitySpinglass (_graph gr) ws' nullPtr nullPtr result + nullPtr _nSpins False _startTemp + _stopTemp _coolFact + IgraphSpincommUpdateConfig _gamma IgraphSpincommImpOrig 1.0 - fmap ( map (fst . unzip) . groupBy ((==) `on` snd) - . sortBy (comparing snd) . zip [0..] ) $ toList result + fmap ( map (fst . unzip) . groupBy ((==) `on` snd) + . sortBy (comparing snd) . zip [0..] ) $ toList result {#fun igraph_community_spinglass as ^ -{ `IGraph' -, `Vector' -, id `Ptr CDouble' -, id `Ptr CDouble' -, `Vector' -, id `Ptr Vector' -, `Int' -, `Bool' -, `Double' -, `Double' -, `Double' -, `SpincommUpdate' -, `Double' -, `SpinglassImplementation' -, `Double' -} -> `Int' #} + { `IGraph' + , castPtr `Ptr Vector' + , id `Ptr CDouble' + , id `Ptr CDouble' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , `Int' + , `Bool' + , `Double' + , `Double' + , `Double' + , `SpincommUpdate' + , `Double' + , `SpinglassImplementation' + , `Double' + } -> `CInt' void- #} {#fun igraph_community_leading_eigenvector as ^ -{ `IGraph' -, `Vector' -, id `Ptr Matrix' -, `Vector' -, `Int' -, `ArpackOpt' -, id `Ptr CDouble' -, `Bool' -, id `Ptr Vector' -, id `Ptr VectorPtr' -, id `Ptr Vector' -, id `T' -, id `Ptr ()' -} -> `Int' #} + { `IGraph' + , castPtr `Ptr Vector' + , castPtr `Ptr Matrix' + , castPtr `Ptr Vector' + , `Int' + , castPtr `Ptr ArpackOpt' + , id `Ptr CDouble' + , `Bool' + , castPtr `Ptr Vector' + , castPtr `Ptr VectorPtr' + , castPtr `Ptr Vector' + , id `T' + , id `Ptr ()' + } -> `CInt' void- #} -type T = FunPtr ( Ptr Vector +type T = FunPtr ( Ptr () -> CLong -> CDouble - -> Ptr Vector + -> Ptr () -> FunPtr (Ptr CDouble -> Ptr CDouble -> CInt -> Ptr () -> IO CInt) -> Ptr () -> Ptr () diff --git a/src/IGraph/Exporter/GEXF.hs b/src/IGraph/Exporter/GEXF.hs --- a/src/IGraph/Exporter/GEXF.hs +++ b/src/IGraph/Exporter/GEXF.hs @@ -9,12 +9,13 @@ , writeGEXF ) where -import Data.Colour (AlphaColour, alphaChannel, black, - opaque, over) -import Data.Colour.SRGB (channelBlue, channelGreen, - channelRed, toSRGB24) +import Data.Colour (AlphaColour, alphaChannel, black, opaque, + over) +import Data.Colour.SRGB (channelBlue, channelGreen, channelRed, + toSRGB24) import Data.Hashable import Data.Serialize +import Data.Singletons (SingI) import GHC.Generics import IGraph import Text.XML.HXT.Core @@ -71,7 +72,7 @@ , _edgeZindex = 2 } -genXMLTree :: (ArrowXml a, Graph d) => LGraph d NodeAttr EdgeAttr -> a XmlTree XmlTree +genXMLTree :: (SingI d, ArrowXml a) => Graph d NodeAttr EdgeAttr -> a XmlTree XmlTree genXMLTree gr = root [] [gexf] where gexf = mkelem "gexf" [ attr "version" $ txt "1.2" @@ -124,7 +125,7 @@ a = show $ alphaChannel $ _edgeColour at {-# INLINE genXMLTree #-} -writeGEXF :: Graph d => FilePath -> LGraph d NodeAttr EdgeAttr -> IO () +writeGEXF :: SingI d => FilePath -> Graph d NodeAttr EdgeAttr -> IO () writeGEXF fl gr = runX (genXMLTree gr >>> writeDocument config fl) >> return () where config = [withIndent yes] diff --git a/src/IGraph/Generators.chs b/src/IGraph/Generators.chs --- a/src/IGraph/Generators.chs +++ b/src/IGraph/Generators.chs @@ -1,46 +1,83 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} module IGraph.Generators ( full + , star , ErdosRenyiModel(..) , erdosRenyiGame , degreeSequenceGame , rewire ) where -import Control.Monad (when) +import Control.Monad (when, forM_) import Data.Hashable (Hashable) import Data.Serialize (Serialize) +import Data.Singletons (SingI, Sing, sing, fromSing) +import System.IO.Unsafe (unsafePerformIO) import qualified Foreign.Ptr as C2HSImp +import Foreign import IGraph -import IGraph.Mutable +import IGraph.Mutable (MGraph(..)) +import qualified IGraph.Mutable as M {#import IGraph.Internal #} {#import IGraph.Internal.Constants #} {# import IGraph.Internal.Initialization #} #include "haskell_igraph.h" -{#fun igraph_full as full +full :: forall d. SingI d + => Int -- ^ The number of vertices in the graph. + -> Bool -- ^ Whether to include self-edges (loops) + -> Graph d () () +full n hasLoop = unsafePerformIO $ do + gr <- MGraph <$> igraphFull n directed hasLoop + M.initializeNullAttribute gr + unsafeFreeze gr + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False +{#fun igraph_full as ^ { allocaIGraph- `IGraph' addIGraphFinalizer* , `Int', `Bool', `Bool' } -> `CInt' void- #} +-- | Return the Star graph. The center node is always associated with id 0. +star :: Int -- ^ The number of nodes + -> Graph 'U () () +star n = unsafePerformIO $ do + gr <- MGraph <$> igraphStar n IgraphStarUndirected 0 + M.initializeNullAttribute gr + unsafeFreeze gr +{# fun igraph_star as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Int' + , `StarMode' + , `Int' + } -> `CInt' void- #} + data ErdosRenyiModel = GNP Int Double | GNM Int Int -erdosRenyiGame :: Graph d +erdosRenyiGame :: forall d. SingI d => ErdosRenyiModel - -> d -- ^ directed -> Bool -- ^ self-loop - -> IO (LGraph d () ()) -erdosRenyiGame (GNP n p) d self = do - gp <- igraphInit >> igraphErdosRenyiGame IgraphErdosRenyiGnp n p (isD d) self - unsafeFreeze $ MLGraph gp -erdosRenyiGame (GNM n m) d self = do - gp <- igraphInit >> igraphErdosRenyiGame IgraphErdosRenyiGnm n - (fromIntegral m) (isD d) self - unsafeFreeze $ MLGraph gp + -> IO (Graph d () ()) +erdosRenyiGame model self = do + igraphInit + gr <- fmap MGraph $ case model of + GNP n p -> igraphErdosRenyiGame IgraphErdosRenyiGnp n p directed self + GNM n m -> igraphErdosRenyiGame IgraphErdosRenyiGnm n (fromIntegral m) + directed self + M.initializeNullAttribute gr + unsafeFreeze gr + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False {#fun igraph_erdos_renyi_game as ^ { allocaIGraph- `IGraph' addIGraphFinalizer* , `ErdosRenyi', `Int', `Double', `Bool', `Bool' @@ -49,25 +86,24 @@ -- | Generates a random graph with a given degree sequence. degreeSequenceGame :: [Int] -- ^ Out degree -> [Int] -- ^ In degree - -> IO (LGraph D () ()) -degreeSequenceGame out_deg in_deg = do - out_deg' <- fromList $ map fromIntegral out_deg - in_deg' <- fromList $ map fromIntegral in_deg - gp <- igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple - unsafeFreeze $ MLGraph gp + -> IO (Graph 'D () ()) +degreeSequenceGame out_deg in_deg = withList out_deg $ \out_deg' -> + withList in_deg $ \in_deg' -> do + gr <- MGraph <$> igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple + M.initializeNullAttribute gr + unsafeFreeze gr {#fun igraph_degree_sequence_game as ^ { allocaIGraph- `IGraph' addIGraphFinalizer* - , `Vector', `Vector', `Degseq' + , castPtr `Ptr Vector', castPtr `Ptr Vector', `Degseq' } -> `CInt' void- #} -- | Randomly rewires a graph while preserving the degree distribution. -rewire :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e) +rewire :: (Hashable v, Serialize v, Eq v, Serialize e) => Int -- ^ Number of rewiring trials to perform. - -> LGraph d v e - -> IO (LGraph d v e) + -> Graph d v e + -> IO (Graph d v e) rewire n gr = do - (MLGraph gptr) <- thaw gr - err <- igraphRewire gptr n IgraphRewiringSimple - when (err /= 0) $ error "failed to rewire graph!" - unsafeFreeze $ MLGraph gptr -{#fun igraph_rewire as ^ { `IGraph', `Int', `Rewiring' } -> `Int' #} + (MGraph gptr) <- thaw gr + igraphRewire gptr n IgraphRewiringSimple + unsafeFreeze $ MGraph gptr +{#fun igraph_rewire as ^ { `IGraph', `Int', `Rewiring' } -> `CInt' void-#} diff --git a/src/IGraph/Internal.chs b/src/IGraph/Internal.chs --- a/src/IGraph/Internal.chs +++ b/src/IGraph/Internal.chs @@ -1,9 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface #-} module IGraph.Internal - ( module IGraph.Internal.Types - -- * Vector type and basic operations - , igraphVectorNew - , fromList + ( -- * Data structure library: vector, matrix, other data types + -- ** Igraph vector type and basic operations + Vector + , allocaVector + , allocaVectorN + , withList + , withListMaybe , toList , igraphVectorNull , igraphVectorFill @@ -13,27 +16,31 @@ , igraphVectorSize , igraphVectorCopyTo - -- * Pointer vector - , igraphVectorPtrNew - , fromPtrs + -- ** Igraph pointer vector + , VectorPtr + , allocaVectorPtr + , allocaVectorPtrN + , withPtrs , toLists - -- * String vector - , igraphStrvectorNew - , igraphStrvectorGet - , toStrVector - - -- * Bytestring - , asBS - , bsToByteString + -- ** Customized bytestring for storing attributes + , BSLen + , withByteString + , toByteString - -- * Bytestring vector - , bsvectorNew + -- ** Customized bytestring vector + , BSVector + , allocaBSVectorN + , withByteStrings , bsvectorSet - , toBSVector - -- * Igraph matrix type - , igraphMatrixNew + -- ** Igraph matrix type + , Matrix + , allocaMatrix + , allocaMatrixN + , withRowLists + , toRowLists + , toColumnLists , igraphMatrixNull , igraphMatrixFill , igraphMatrixE @@ -41,29 +48,40 @@ , igraphMatrixCopyTo , igraphMatrixNrow , igraphMatrixNcol - , fromRowLists - , toRowLists - , toColumnLists - -- * Igraph vertex selector - , igraphVsAll - , igraphVsAdj - , igraphVsVector + -- * Igraph type and constructors + , IGraph + , withIGraph + , allocaIGraph + , addIGraphFinalizer + , igraphNew + , igraphCreate - -- * Igraph vertex iterator - , igraphVitNew - , vitToList + -- * Selector and iterator for edge and vertex + -- ** Igraph vertex selector + , VertexSelector + , withVerticesAll + , withVerticesAdj + , withVerticesVector + , withVerticesList - -- * Igraph edge Selector - , igraphEsAll - , igraphEsVector + -- ** Igraph vertex iterator + , VertexIterator + , iterateVertices + , iterateVerticesC - -- * Igraph edge iterator - , igraphEitNew - , eitToList + -- ** Igraph edge Selector + , EdgeSelector + , withEdgesAll + , withEdgeIdsVector + , withEdgeIdsList - -- * IGraph type and basic operations - , igraphNew + -- ** Igraph edge iterator + , EdgeIterator + , iterateEdges + , iterateEdgesC + + -- * Basic graph operations , igraphCopy , igraphVcount , igraphEcount @@ -75,17 +93,21 @@ , igraphDeleteVertices , igraphDeleteEdges - -- * Igraph attribute record + -- * Igraph attribute record + , AttributeRecord , withAttr + , withBSAttr , igraphHaskellAttributeHasAttr - , igraphHaskellAttributeGANSet - , igraphHaskellAttributeGAN , igraphHaskellAttributeVAS - , igraphHaskellAttributeEAN , igraphHaskellAttributeEAS - , igraphHaskellAttributeEASSetv , igraphHaskellAttributeVASSet + , igraphHaskellAttributeVASSetv , igraphHaskellAttributeEASSet + , igraphHaskellAttributeEASSetv + + -- * Igraph arpack options type + , ArpackOpt + , allocaArpackOpt ) where import Control.Monad @@ -94,6 +116,9 @@ import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.List (transpose) import Data.List.Split (chunksOf) +import Data.Serialize (Serialize, encode) +import Control.Exception (bracket_) +import Conduit (ConduitT, yield, liftIO) import Foreign import Foreign.C.Types @@ -101,7 +126,6 @@ import IGraph.Internal.C2HS {#import IGraph.Internal.Initialization #} -{#import IGraph.Internal.Types #} {#import IGraph.Internal.Constants #} #include "haskell_attributes.h" @@ -111,20 +135,39 @@ -- Igraph vector -------------------------------------------------------------------------------- -{#fun igraph_vector_init as igraphVectorNew - { allocaVector- `Vector' addVectorFinalizer* - , `Int' } -> `CInt' void- #} +data Vector +-- | Allocate and initialize a vector. +allocaVector :: (Ptr Vector -> IO a) -> IO a +allocaVector fun = allocaBytes {# sizeof igraph_vector_t #} $ \vec -> + bracket_ (igraphVectorInit vec 0) (igraphVectorDestroy vec) (fun vec) +{-# INLINE allocaVector #-} + +allocaVectorN :: Int -> (Ptr Vector -> IO a) -> IO a +allocaVectorN n fun = allocaBytes {# sizeof igraph_vector_t #} $ \vec -> + bracket_ (igraphVectorInit vec n) (igraphVectorDestroy vec) (fun vec) +{-# INLINE allocaVectorN #-} + +{#fun igraph_vector_init as ^ { castPtr `Ptr Vector', `Int' } -> `CInt' void- #} +{#fun igraph_vector_destroy as ^ { castPtr `Ptr Vector' } -> `CInt' void- #} + +withList :: Real a => [a] -> (Ptr Vector -> IO b) -> IO b +withList xs fun = withArrayLen (map realToFrac xs) $ \n ptr -> + allocaBytes {# sizeof igraph_vector_t #} $ \vec -> + bracket_ (igraphVectorInitCopy vec ptr n) (igraphVectorDestroy vec) (fun vec) +{-# INLINE withList #-} {#fun igraph_vector_init_copy as ^ - { allocaVector- `Vector' addVectorFinalizer* + { castPtr `Ptr Vector' , id `Ptr CDouble', `Int' } -> `CInt' void- #} -fromList :: [Double] -> IO Vector -fromList xs = withArrayLen (map realToFrac xs) $ \n ptr -> - igraphVectorInitCopy ptr n -{-# INLINE fromList #-} +-- | Allocate a nullPtr if Nothing +withListMaybe :: Real a => Maybe [a] -> (Ptr Vector -> IO b) -> IO b +withListMaybe (Just xs) fun = withList xs fun +withListMaybe Nothing fun = fun $ castPtr nullPtr +{-# INLINE withListMaybe #-} -toList :: Vector -> IO [Double] + +toList :: Ptr Vector -> IO [Double] toList vec = do n <- igraphVectorSize vec allocaArray n $ \ptr -> do @@ -132,165 +175,153 @@ liftM (map realToFrac) $ peekArray n ptr {-# INLINE toList #-} +{#fun igraph_vector_copy_to as ^ { castPtr `Ptr Vector', id `Ptr CDouble' } -> `()' #} + -- Initializing elements -{#fun igraph_vector_null as ^ { `Vector' } -> `()' #} +{#fun igraph_vector_null as ^ { castPtr `Ptr Vector' } -> `()' #} -{#fun igraph_vector_fill as ^ { `Vector', `Double' } -> `()' #} +{#fun igraph_vector_fill as ^ { castPtr `Ptr Vector', `Double' } -> `()' #} -- Accessing elements -{#fun pure igraph_vector_e as ^ { `Vector', `Int' } -> `Double' #} +{#fun igraph_vector_e as ^ { castPtr `Ptr Vector', `Int' } -> `Double' #} -{#fun igraph_vector_set as ^ { `Vector', `Int', `Double' } -> `()' #} +{#fun igraph_vector_set as ^ { castPtr `Ptr Vector', `Int', `Double' } -> `()' #} -{#fun pure igraph_vector_tail as ^ { `Vector' } -> `Double' #} +{#fun igraph_vector_tail as ^ { castPtr `Ptr Vector' } -> `Double' #} --- Copying vectors - -{#fun igraph_vector_copy_to as ^ { `Vector', id `Ptr CDouble' } -> `()' #} - -- Vector properties -{#fun igraph_vector_size as ^ { `Vector' } -> `Int' #} +{#fun igraph_vector_size as ^ { castPtr `Ptr Vector' } -> `Int' #} -{#fun igraph_vector_ptr_init as igraphVectorPtrNew - { allocaVectorPtr- `VectorPtr' addVectorPtrFinalizer* - , `Int' } -> `CInt' void- #} - -{#fun igraph_vector_ptr_e as ^ { `VectorPtr', `Int' } -> `Ptr ()' #} -{#fun igraph_vector_ptr_set as ^ { `VectorPtr', `Int', id `Ptr ()' } -> `()' #} -{#fun igraph_vector_ptr_size as ^ { `VectorPtr' } -> `Int' #} - -fromPtrs :: [Ptr ()] -> IO VectorPtr -fromPtrs xs = do - vptr <- igraphVectorPtrNew n - forM_ (zip [0..] xs) $ \(i,x) -> igraphVectorPtrSet vptr i x - return vptr - where - n = length xs -{-# INLINE fromPtrs #-} - -toLists :: VectorPtr -> IO [[Double]] -toLists vpptr = do - n <- igraphVectorPtrSize vpptr - forM [0..n-1] $ \i -> do - vptr <- igraphVectorPtrE vpptr i - vec <- newForeignPtr_ $ castPtr vptr - toList $ Vector vec -{-# INLINE toLists #-} - -------------------------------------------------------------------------------- --- Igraph string vector +-- Pointer Vector -------------------------------------------------------------------------------- -{#fun igraph_strvector_init as igraphStrvectorNew - { allocaStrVector- `StrVector' addStrVectorFinalizer* - , `Int' - } -> `CInt' void-#} +data VectorPtr -{#fun igraph_strvector_get as ^ - { `StrVector' - , `Int' - , alloca- `String' peekString* - } -> `CInt' void-#} +-- | Allocate and initialize a pointer vector. +allocaVectorPtr :: (Ptr VectorPtr -> IO a) -> IO a +allocaVectorPtr fun = allocaBytes {# sizeof igraph_vector_ptr_t #} $ \ptr -> + bracket_ (igraphVectorPtrInit ptr 0) (igraphVectorPtrDestroy ptr) (fun ptr) +{-# INLINE allocaVectorPtr #-} -peekString :: Ptr CString -> IO String -peekString ptr = peek ptr >>= peekCString -{-# INLINE peekString #-} +allocaVectorPtrN :: Int -> (Ptr VectorPtr -> IO a) -> IO a +allocaVectorPtrN n fun = allocaBytes {# sizeof igraph_vector_ptr_t #} $ \ptr -> + bracket_ (igraphVectorPtrInit ptr n) (igraphVectorPtrDestroy ptr) (fun ptr) +{-# INLINE allocaVectorPtrN #-} -{#fun igraph_strvector_set as ^ { `StrVector', `Int', id `CString'} -> `()' #} -{#fun igraph_strvector_set2 as ^ { `StrVector', `Int', id `CString', `Int'} -> `()' #} +{#fun igraph_vector_ptr_init as ^ { castPtr `Ptr VectorPtr', `Int' } -> `CInt' void- #} +{#fun igraph_vector_ptr_destroy as ^ { castPtr `Ptr VectorPtr' } -> `()' #} -toStrVector :: [B.ByteString] -> IO StrVector -toStrVector xs = do - vec <- igraphStrvectorNew n - forM_ (zip [0..] xs) $ \(i,x) -> B.useAsCString x (igraphStrvectorSet vec i) - return vec +withPtrs :: [Ptr a] -> (Ptr VectorPtr -> IO b) -> IO b +withPtrs xs fun = allocaVectorPtrN n $ \vptr -> do + sequence_ $ zipWith (igraphVectorPtrSet vptr) [0..] $ map castPtr xs + fun vptr where n = length xs +{-# INLINE withPtrs #-} +toLists :: Ptr VectorPtr -> IO [[Double]] +toLists vptr = do + n <- igraphVectorPtrSize vptr + forM [0..n-1] $ \i -> igraphVectorPtrE vptr i >>= toList . castPtr +{-# INLINE toLists #-} +{#fun igraph_vector_ptr_e as ^ { castPtr `Ptr VectorPtr', `Int' } -> `Ptr ()' #} +{#fun igraph_vector_ptr_set as ^ { castPtr `Ptr VectorPtr', `Int', id `Ptr ()' } -> `()' #} +{#fun igraph_vector_ptr_size as ^ { castPtr `Ptr VectorPtr' } -> `Int' #} + + -------------------------------------------------------------------------------- -- Customized string vector -------------------------------------------------------------------------------- -bsToByteString :: Ptr BSLen -> IO B.ByteString -bsToByteString ptr = do +data BSLen + +toByteString :: Ptr BSLen -> IO B.ByteString +toByteString ptr = do n <- {#get bytestring_t->len #} ptr str <- {#get bytestring_t->value #} ptr packCStringLen (str, fromIntegral n) -{-# INLINE bsToByteString #-} +{-# INLINE toByteString #-} -asBS :: B.ByteString -> (Ptr BSLen -> IO a) -> IO a -asBS x f = unsafeUseAsCStringLen x $ \(str, n) -> do - fptr <- mallocForeignPtrBytes {#sizeof bytestring_t #} - withForeignPtr fptr $ \ptr -> do +withByteString :: B.ByteString -> (Ptr BSLen -> IO a) -> IO a +withByteString x f = unsafeUseAsCStringLen x $ \(str, n) -> + allocaBytes {#sizeof bytestring_t #} $ \ptr -> do {#set bytestring_t.len #} ptr (fromIntegral n) {#set bytestring_t.value #} ptr str f ptr -{-# INLINE asBS #-} +{-# INLINE withByteString #-} -{#fun bsvector_init as bsvectorNew - { allocaBSVector- `BSVector' addBSVectorFinalizer* - , `Int' - } -> `CInt' void- #} +data BSVector -{#fun bsvector_set as bsvectorSet' { `BSVector', `Int', castPtr `Ptr BSLen' } -> `()' #} +allocaBSVectorN :: Int -> (Ptr BSVector -> IO a) -> IO a +allocaBSVectorN n fun = allocaBytes {# sizeof bsvector_t #} $ \ptr -> + bracket_ (bsvectorInit ptr n) (bsvectorDestroy ptr) (fun ptr) +{-# INLINE allocaBSVectorN #-} -bsvectorSet :: BSVector -> Int -> B.ByteString -> IO () -bsvectorSet vec i bs = asBS bs (bsvectorSet' vec i) -{-# INLINE bsvectorSet #-} +{#fun bsvector_init as ^ { castPtr `Ptr BSVector', `Int' } -> `CInt' void- #} +{#fun bsvector_destroy as ^ { castPtr `Ptr BSVector' } -> `()' #} -toBSVector :: [B.ByteString] -> IO BSVector -toBSVector xs = do - vec <- bsvectorNew n - foldM_ (\i x -> bsvectorSet vec i x >> return (i+1)) 0 xs - return vec +withByteStrings :: [B.ByteString] -> (Ptr BSVector -> IO a) -> IO a +withByteStrings xs fun = allocaBSVectorN n $ \bsvec -> do + foldM_ (\i x -> bsvectorSet bsvec i x >> return (i+1)) 0 xs + fun bsvec where n = length xs +{-# INLINE withByteStrings #-} +bsvectorSet :: Ptr BSVector -> Int -> B.ByteString -> IO () +bsvectorSet vec i bs = withByteString bs (bsvectorSet' vec i) +{-# INLINE bsvectorSet #-} +{#fun bsvector_set as bsvectorSet' + { castPtr `Ptr BSVector', `Int', castPtr `Ptr BSLen' } -> `()' #} -{#fun igraph_matrix_init as igraphMatrixNew - { allocaMatrix- `Matrix' addMatrixFinalizer* - , `Int', `Int' - } -> `CInt' void- #} -{#fun igraph_matrix_null as ^ { `Matrix' } -> `()' #} - -{#fun igraph_matrix_fill as ^ { `Matrix', `Double' } -> `()' #} - -{#fun igraph_matrix_e as ^ { `Matrix', `Int', `Int' } -> `Double' #} +-------------------------------------------------------------------------------- +-- Matrix +-------------------------------------------------------------------------------- -{#fun igraph_matrix_set as ^ { `Matrix', `Int', `Int', `Double' } -> `()' #} +data Matrix -{#fun igraph_matrix_copy_to as ^ { `Matrix', id `Ptr CDouble' } -> `()' #} +allocaMatrix :: (Ptr Matrix -> IO a) -> IO a +allocaMatrix fun = allocaBytes {# sizeof igraph_matrix_t #} $ \mat -> + bracket_ (igraphMatrixInit mat 0 0) (igraphMatrixDestroy mat) (fun mat) +{-# INLINE allocaMatrix #-} -{#fun igraph_matrix_nrow as ^ { `Matrix' } -> `Int' #} +allocaMatrixN :: Int -- ^ Number of rows + -> Int -- ^ Number of columns + -> (Ptr Matrix -> IO a) -> IO a +allocaMatrixN r c fun = allocaBytes {# sizeof igraph_matrix_t #} $ \mat -> + bracket_ (igraphMatrixInit mat r c) (igraphMatrixDestroy mat) (fun mat) +{-# INLINE allocaMatrixN #-} -{#fun igraph_matrix_ncol as ^ { `Matrix' } -> `Int' #} +{#fun igraph_matrix_init as ^ { castPtr `Ptr Matrix', `Int', `Int' } -> `CInt' void- #} +{#fun igraph_matrix_destroy as ^ { castPtr `Ptr Matrix' } -> `()' #} -- row lists to matrix -fromRowLists :: [[Double]] -> IO Matrix -fromRowLists xs - | all (==c) $ map length xs = do - mptr <- igraphMatrixNew r c +withRowLists :: Real a => [[a]] -> (Ptr Matrix -> IO b) -> IO b +withRowLists xs fun + | all (==c) $ map length xs = allocaMatrixN r c $ \mat -> do forM_ (zip [0..] xs) $ \(i, row) -> forM_ (zip [0..] row) $ \(j,v) -> - igraphMatrixSet mptr i j v - return mptr + igraphMatrixSet mat i j $ realToFrac v + fun mat | otherwise = error "Not a matrix." where r = length xs c = length $ head xs +{-# INLINE withRowLists #-} -- to row lists -toRowLists :: Matrix -> IO [[Double]] -toRowLists = liftM transpose . toColumnLists +toRowLists :: Ptr Matrix -> IO [[Double]] +toRowLists = fmap transpose . toColumnLists -toColumnLists :: Matrix -> IO [[Double]] +toColumnLists :: Ptr Matrix -> IO [[Double]] toColumnLists mptr = do r <- igraphMatrixNrow mptr c <- igraphMatrixNcol mptr @@ -299,132 +330,245 @@ peekArray (r*c) ptr return $ chunksOf r $ map realToFrac xs +{#fun igraph_matrix_null as ^ { castPtr `Ptr Matrix' } -> `()' #} -{#fun igraph_vs_all as ^ - { allocaVs- `IGraphVs' addVsFinalizer* +{#fun igraph_matrix_fill as ^ { castPtr `Ptr Matrix', `Double' } -> `()' #} + +{#fun igraph_matrix_e as ^ { castPtr `Ptr Matrix', `Int', `Int' } -> `Double' #} + +{#fun igraph_matrix_set as ^ { castPtr `Ptr Matrix', `Int', `Int', `Double' } -> `()' #} + +{#fun igraph_matrix_copy_to as ^ { castPtr `Ptr Matrix', id `Ptr CDouble' } -> `()' #} + +{#fun igraph_matrix_nrow as ^ { castPtr `Ptr Matrix' } -> `Int' #} + +{#fun igraph_matrix_ncol as ^ { castPtr `Ptr Matrix' } -> `Int' #} + + +-------------------------------------------------------------------------------- +-- Graph Constructors and Destructors +-------------------------------------------------------------------------------- + +{#pointer *igraph_t as IGraph foreign finalizer igraph_destroy newtype#} + +allocaIGraph :: (Ptr IGraph -> IO a) -> IO a +allocaIGraph f = mallocBytes {# sizeof igraph_t #} >>= f +{-# INLINE allocaIGraph #-} + +addIGraphFinalizer :: Ptr IGraph -> IO IGraph +addIGraphFinalizer ptr = do + vec <- newForeignPtr igraph_destroy ptr + return $ IGraph vec +{-# INLINE addIGraphFinalizer #-} + +-- | Create a igraph object and attach a finalizer +igraphNew :: Int -> Bool -> HasInit -> IO IGraph +igraphNew n directed _ = igraphNew' n directed +{#fun igraph_empty as igraphNew' + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Int', `Bool' } -> `CInt' void- #} -{#fun igraph_vs_adj as ^ - { allocaVs- `IGraphVs' addVsFinalizer* - , `Int', `Neimode' +{#fun igraph_copy as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `IGraph' } -> `CInt' void- #} -{#fun igraph_vs_vector as ^ - { allocaVs- `IGraphVs' addVsFinalizer* - , `Vector' +{#fun igraph_create as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , castPtr `Ptr Vector' -- ^ The edges to add, the first two elements are + -- the first edge, etc. + , `Int' -- ^ The number of vertices in the graph, if smaller or equal to + -- the highest vertex id in the edges vector it will be + -- increased automatically. So it is safe to give 0 here. + , `Bool' -- ^ Whether to create a directed graph or not. If yes, + -- then the first edge points from the first vertex id in edges + -- to the second, etc. } -> `CInt' void- #} +{#fun igraph_to_directed as ^ + { `IGraph' -- ^ The graph object to convert. + , `ToDirected' -- ^ Specifies the details of how exactly the conversion is + -- done. Possible values: IGRAPH_TO_DIRECTED_ARBITRARY: + -- the number of edges in the graph stays the same, + -- an arbitrarily directed edge is created for each + -- undirected edge; IGRAPH_TO_DIRECTED_MUTUAL: two directed + -- edges are created for each undirected edge, one in each direction. + } -> `CInt' void- #} + + +-------------------------------------------------------------------------------- +-- Vertex selector +-------------------------------------------------------------------------------- + +data VertexSelector + +allocaVertexSelector :: (Ptr VertexSelector -> IO a) -> IO a +allocaVertexSelector fun = allocaBytes {# sizeof igraph_vs_t #} $ \vs -> do + r <- fun vs + igraphVsDestroy vs + return r +{-# INLINE allocaVertexSelector #-} + +{#fun igraph_vs_destroy as ^ { castPtr `Ptr VertexSelector' } -> `()' #} + +withVerticesAll :: (Ptr VertexSelector -> IO a) -> IO a +withVerticesAll fun = allocaVertexSelector $ \vs -> igraphVsAll vs >> fun vs +{-# INLINE withVerticesAll #-} +{#fun igraph_vs_all as ^ { castPtr `Ptr VertexSelector' } -> `CInt' void- #} + +withVerticesAdj :: Int -> Neimode -> (Ptr VertexSelector -> IO a) -> IO a +withVerticesAdj i mode fun = allocaVertexSelector $ \vs -> igraphVsAdj vs i mode >> fun vs +{-# INLINE withVerticesAdj #-} +{#fun igraph_vs_adj as ^ + { castPtr `Ptr VertexSelector', `Int', `Neimode' } -> `CInt' void- #} + +withVerticesVector :: Ptr Vector -> (Ptr VertexSelector -> IO a) -> IO a +withVerticesVector vec fun = allocaVertexSelector $ \vs -> igraphVsVector vs vec >> fun vs +{-# INLINE withVerticesVector #-} +{#fun igraph_vs_vector as ^ + { castPtr `Ptr VertexSelector', castPtr `Ptr Vector' } -> `CInt' void- #} + +withVerticesList :: Real a => [a] -> (Ptr VertexSelector -> IO b) -> IO b +withVerticesList xs fun = withList xs $ \vec -> withVerticesVector vec fun +{-# INLINE withVerticesList #-} + + +-------------------------------------------------------------------------------- -- Vertex iterator +-------------------------------------------------------------------------------- +data VertexIterator + +iterateVertices :: IGraph -> Ptr VertexSelector -> (Ptr VertexIterator -> IO a) -> IO a +iterateVertices gr vs fun = allocaBytes {# sizeof igraph_vit_t #} $ \vit -> + bracket_ (igraphVitCreate gr vs vit) (igraphVitDestroy vit) (fun vit) +{-# INLINE iterateVertices #-} + +iterateVerticesC :: IGraph + -> Ptr VertexSelector + -> (ConduitT i Int IO () -> IO a) + -> IO a +iterateVerticesC gr vs fun = allocaBytes {# sizeof igraph_vit_t #} $ \vit -> + bracket_ (igraphVitCreate gr vs vit) (igraphVitDestroy vit) (fun $ sourceVertexIterator vit) +{-# INLINE iterateVerticesC #-} + +{#fun igraph_vit_create as ^ + { `IGraph' + , castPtr %`Ptr VertexSelector' + , castPtr `Ptr VertexIterator' + } -> `CInt' void- #} +{#fun igraph_vit_destroy as ^ { castPtr `Ptr VertexIterator' } -> `()' #} + + +sourceVertexIterator :: Ptr VertexIterator -> ConduitT i Int IO () +sourceVertexIterator vit = do + isEnd <- liftIO $ igraphVitEnd vit + if isEnd + then return () + else do + liftIO (igraphVitGet vit) >>= yield + liftIO $ igraphVitNext vit + sourceVertexIterator vit +{-# INLINE sourceVertexIterator #-} + #c igraph_bool_t igraph_vit_end(igraph_vit_t *vit) { return IGRAPH_VIT_END(*vit); } - void igraph_vit_next(igraph_vit_t *vit) { IGRAPH_VIT_NEXT(*vit); } - igraph_integer_t igraph_vit_get(igraph_vit_t *vit) { return IGRAPH_VIT_GET(*vit); } #endc -{#fun igraph_vit_create as igraphVitNew - { `IGraph' - , %`IGraphVs' - , allocaVit- `IGraphVit' addVitFinalizer* - } -> `CInt' void- #} +{#fun igraph_vit_end as ^ { castPtr `Ptr VertexIterator' } -> `Bool' #} +{#fun igraph_vit_next as ^ { castPtr `Ptr VertexIterator' } -> `()' #} +{#fun igraph_vit_get as ^ { castPtr `Ptr VertexIterator' } -> `Int' #} -{#fun igraph_vit_end as ^ { `IGraphVit' } -> `Bool' #} -{#fun igraph_vit_next as ^ { `IGraphVit' } -> `()' #} +-------------------------------------------------------------------------------- +-- Edge Selector +-------------------------------------------------------------------------------- -{#fun igraph_vit_get as ^ { `IGraphVit' } -> `Int' #} +data EdgeSelector -vitToList :: IGraphVit -> IO [Int] -vitToList vit = do - isEnd <- igraphVitEnd vit - if isEnd - then return [] - else do - cur <- igraphVitGet vit - igraphVitNext vit - acc <- vitToList vit - return $ cur : acc +allocaEdgeSelector :: (Ptr EdgeSelector -> IO a) -> IO a +allocaEdgeSelector fun = allocaBytes {# sizeof igraph_es_t #} $ \es -> do + r <- fun es + igraphEsDestroy es + return r +{-# INLINE allocaEdgeSelector #-} +{#fun igraph_es_destroy as ^ { castPtr `Ptr EdgeSelector' } -> `()' #} +withEdgesAll :: EdgeOrderType -> (Ptr EdgeSelector -> IO a) -> IO a +withEdgesAll ord fun = allocaEdgeSelector $ \es -> igraphEsAll es ord >> fun es +{-# INLINE withEdgesAll #-} +{#fun igraph_es_all as ^ { castPtr `Ptr EdgeSelector', `EdgeOrderType'} -> `CInt' void- #} --- Edge Selector +withEdgeIdsVector :: Ptr Vector -> (Ptr EdgeSelector -> IO a) -> IO a +withEdgeIdsVector vec fun = allocaEdgeSelector $ \es -> + igraphEsVector es vec >> fun es +{-# INLINE withEdgeIdsVector #-} +{# fun igraph_es_vector as ^ + { castPtr `Ptr EdgeSelector', castPtr `Ptr Vector' } -> `CInt' void- #} -{#fun igraph_es_all as ^ - { allocaEs- `IGraphEs' addEsFinalizer* - , `EdgeOrderType' - } -> `CInt' void- #} +withEdgeIdsList :: [Int] -> (Ptr EdgeSelector -> IO b) -> IO b +withEdgeIdsList xs fun = withList xs $ \vec -> withEdgeIdsVector vec fun +{-# INLINE withEdgeIdsList #-} -{# fun igraph_es_vector as ^ - { allocaEs- `IGraphEs' addEsFinalizer* - , `Vector' - } -> `CInt' void- #} +-------------------------------------------------------------------------------- -- Edge iterator +-------------------------------------------------------------------------------- +data EdgeIterator + +iterateEdges :: IGraph -> Ptr EdgeSelector -> (Ptr EdgeIterator -> IO a) -> IO a +iterateEdges gr es fun = allocaBytes {# sizeof igraph_eit_t #} $ \eit -> + bracket_ (igraphEitCreate gr es eit) (igraphEitDestroy eit) (fun eit) +{-# INLINE iterateEdges #-} +{#fun igraph_eit_create as ^ { `IGraph', castPtr %`Ptr EdgeSelector', castPtr `Ptr EdgeIterator' } -> `CInt' void- #} +{#fun igraph_eit_destroy as ^ { castPtr `Ptr EdgeIterator' } -> `()' #} + +iterateEdgesC :: IGraph + -> Ptr EdgeSelector + -> (ConduitT i Int IO () -> IO a) + -> IO a +iterateEdgesC gr es fun = allocaBytes {# sizeof igraph_eit_t #} $ \eit -> + bracket_ (igraphEitCreate gr es eit) (igraphEitDestroy eit) (fun $ sourceEdgeIterator eit) +{-# INLINE iterateEdgesC #-} + +sourceEdgeIterator :: Ptr EdgeIterator -> ConduitT i Int IO () +sourceEdgeIterator eit = do + isEnd <- liftIO $ igraphEitEnd eit + if isEnd + then return () + else do + liftIO (igraphEitGet eit) >>= yield + liftIO $ igraphEitNext eit + sourceEdgeIterator eit +{-# INLINE sourceEdgeIterator #-} + #c igraph_bool_t igraph_eit_end(igraph_eit_t *eit) { return IGRAPH_EIT_END(*eit); } - void igraph_eit_next(igraph_eit_t *eit) { IGRAPH_EIT_NEXT(*eit); } - igraph_integer_t igraph_eit_get(igraph_eit_t *eit) { return IGRAPH_EIT_GET(*eit); } #endc - -{#fun igraph_eit_create as igraphEitNew - { `IGraph' - , %`IGraphEs' - , allocaEit- `IGraphEit' addEitFinalizer* - } -> `CInt' void- #} - -{#fun igraph_eit_end as ^ { `IGraphEit' } -> `Bool' #} - -{#fun igraph_eit_next as ^ { `IGraphEit' } -> `()' #} - -{#fun igraph_eit_get as ^ { `IGraphEit' } -> `Int' #} - -eitToList :: IGraphEit -> IO [Int] -eitToList eit = do - isEnd <- igraphEitEnd eit - if isEnd - then return [] - else do - cur <- igraphEitGet eit - igraphEitNext eit - acc <- eitToList eit - return $ cur : acc +{#fun igraph_eit_end as ^ { castPtr `Ptr EdgeIterator' } -> `Bool' #} +{#fun igraph_eit_next as ^ { castPtr `Ptr EdgeIterator' } -> `()' #} +{#fun igraph_eit_get as ^ { castPtr `Ptr EdgeIterator' } -> `Int' #} -------------------------------------------------------------------------------- --- Graph Constructors and Destructors --------------------------------------------------------------------------------- - -{#fun igraph_empty as igraphNew' - { allocaIGraph- `IGraph' addIGraphFinalizer* - , `Int', `Bool' - } -> `CInt' void- #} - -{#fun igraph_copy as ^ - { allocaIGraph- `IGraph' addIGraphFinalizer* - , `IGraph' - } -> `CInt' void- #} - --- | Create a igraph object and attach a finalizer -igraphNew :: Int -> Bool -> HasInit -> IO IGraph -igraphNew n directed _ = igraphNew' n directed - --------------------------------------------------------------------------------- -- Basic Query Operations -------------------------------------------------------------------------------- @@ -461,43 +605,103 @@ -- new vertices, call igraph_add_vertices() first. {# fun igraph_add_edges as ^ { `IGraph' -- ^ The graph to which the edges will be added. - , `Vector' -- ^ The edges themselves. + , castPtr `Ptr Vector' -- ^ The edges themselves. , id `Ptr ()' -- ^ The attributes of the new edges. } -> `()' #} -- | delete vertices -{# fun igraph_delete_vertices as ^ { `IGraph', %`IGraphVs' } -> `Int' #} +{# fun igraph_delete_vertices as ^ + { `IGraph', castPtr %`Ptr VertexSelector' } -> `CInt' void- #} -- | delete edges -{# fun igraph_delete_edges as ^ { `IGraph', %`IGraphEs' } -> `Int' #} +{# fun igraph_delete_edges as ^ + { `IGraph', castPtr %`Ptr EdgeSelector' } -> `CInt' void- #} +data AttributeRecord +withAttr :: Serialize a + => String -- ^ Attribute name + -> [a] -- ^ Attributes + -> (Ptr AttributeRecord -> IO b) -> IO b +withAttr name xs fun = withByteStrings (map encode xs) $ \bsvec -> + withBSAttr name bsvec fun +{-# INLINE withAttr #-} -withAttr :: String - -> BSVector -> (Ptr AttributeRecord -> IO a) -> IO a -withAttr name bs f = withBSVector bs $ \ptr -> do - fptr <- mallocForeignPtrBytes {#sizeof igraph_attribute_record_t #} - withForeignPtr fptr $ \attr -> withCString name $ \name' -> do - {#set igraph_attribute_record_t.name #} attr name' +withBSAttr :: String -- ^ Attribute name + -> Ptr BSVector -- ^ Attributes + -> (Ptr AttributeRecord -> IO b) -> IO b +withBSAttr name bsvec fun = withCString name $ \name' -> + allocaBytes {#sizeof igraph_attribute_record_t #} $ \attr -> + setAttribute attr name' (castPtr bsvec) >> fun attr + where + setAttribute attr x y = do + {#set igraph_attribute_record_t.name #} attr x {#set igraph_attribute_record_t.type #} attr 2 - {#set igraph_attribute_record_t.value #} attr $ castPtr ptr - f attr -{-# INLINE withAttr #-} + {#set igraph_attribute_record_t.value #} attr y +{-# INLINE withBSAttr #-} -{#fun igraph_haskell_attribute_has_attr as ^ { `IGraph', `AttributeElemtype', `String' } -> `Bool' #} +-- | Checks whether a (graph, vertex or edge) attribute exists +{#fun igraph_haskell_attribute_has_attr as ^ + { `IGraph' + , `AttributeElemtype' -- ^ The type of the attribute + , `String' -- ^ The name of the attribute + } -> `Bool' #} -{#fun igraph_haskell_attribute_GAN_set as ^ { `IGraph', `String', `Double' } -> `Int' #} +-- | Query a string vertex attribute +{#fun igraph_haskell_attribute_VAS as ^ + { `IGraph' + , `String' -- ^ The name of the attribute + , `Int' -- ^ The id of the queried vertex + } -> `Ptr BSLen' castPtr #} -{#fun igraph_haskell_attribute_GAN as ^ { `IGraph', `String' } -> `Double' #} +-- | Query a string edge attribute. +{#fun igraph_haskell_attribute_EAS as ^ + { `IGraph' + , `String' -- ^ The name of the attribute + , `Int' -- ^ The id of the queried edge + } -> `Ptr BSLen' castPtr #} -{#fun igraph_haskell_attribute_VAS as ^ { `IGraph', `String', `Int' } -> `Ptr BSLen' castPtr #} +{#fun igraph_haskell_attribute_VAS_set as ^ + { `IGraph' + , `String' + , `Int' + , castPtr `Ptr BSLen' + } -> `CInt' void-#} -{#fun igraph_haskell_attribute_EAN as ^ { `IGraph', `String', `Int' } -> `Double' #} +{#fun igraph_haskell_attribute_VAS_setv as ^ + { `IGraph' + , `String' -- ^ Name of the attribute + , castPtr `Ptr BSVector' -- ^ String vector, the new attribute values. + -- The length of this vector must match the + -- number of vertices. + } -> `CInt' void-#} -{#fun igraph_haskell_attribute_EAS as ^ { `IGraph', `String', `Int' } -> `Ptr BSLen' castPtr #} +-- | Set a string edge attribute. +{#fun igraph_haskell_attribute_EAS_set as ^ + { `IGraph' + , `String' -- ^ The name of the attribute + , `Int' -- ^ The id of the queried vertex + , castPtr `Ptr BSLen' -- ^ The (new) value of the attribute. + } -> `CInt' void-#} -{#fun igraph_haskell_attribute_EAS_setv as ^ { `IGraph', `String', `BSVector' } -> `Int' #} +-- | Set a string edge attribute for all edges. +{#fun igraph_haskell_attribute_EAS_setv as ^ + { `IGraph' + , `String' -- ^ Name of the attribute + , castPtr `Ptr BSVector' -- ^ String vector, the new attribute values. + -- The length of this vector must match the + -- number of edges. + } -> `CInt' void-#} -{#fun igraph_haskell_attribute_VAS_set as ^ { `IGraph', `String', `Int', castPtr `Ptr BSLen' } -> `Int' #} -{#fun igraph_haskell_attribute_EAS_set as ^ { `IGraph', `String', `Int', castPtr `Ptr BSLen' } -> `Int' #} +-------------------------------------------------------------------------------- +-- Arpack options +-------------------------------------------------------------------------------- + +data ArpackOpt + +allocaArpackOpt :: (Ptr ArpackOpt -> IO a) -> IO a +allocaArpackOpt fun = allocaBytes {# sizeof igraph_arpack_options_t #} $ \opt -> do + igraphArpackOptionsInit opt >> fun opt +{-# INLINE allocaArpackOpt #-} +{#fun igraph_arpack_options_init as ^ { castPtr `Ptr ArpackOpt' } -> `CInt' void- #} diff --git a/src/IGraph/Internal/Constants.chs b/src/IGraph/Internal/Constants.chs --- a/src/IGraph/Internal/Constants.chs +++ b/src/IGraph/Internal/Constants.chs @@ -9,6 +9,9 @@ {#enum igraph_edgeorder_type_t as EdgeOrderType {underscoreToCase} deriving (Show, Eq) #} +{#enum igraph_to_directed_t as ToDirected {underscoreToCase} + deriving (Eq) #} + {#enum igraph_spincomm_update_t as SpincommUpdate {underscoreToCase} deriving (Show, Eq) #} @@ -28,6 +31,9 @@ deriving (Show, Read, Eq) #} {#enum igraph_rewiring_t as Rewiring {underscoreToCase} + deriving (Show, Read, Eq) #} + +{#enum igraph_star_mode_t as StarMode {underscoreToCase} deriving (Show, Read, Eq) #} {#enum igraph_degseq_t as Degseq {underscoreToCase} diff --git a/src/IGraph/Internal/Types.chs b/src/IGraph/Internal/Types.chs deleted file mode 100644 --- a/src/IGraph/Internal/Types.chs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Types - ( -- * Vector type and basic operations - Vector(..) - , withVector - , allocaVector - , addVectorFinalizer - - -- * Pointer vector - , VectorPtr(..) - , withVectorPtr - , allocaVectorPtr - , addVectorPtrFinalizer - - -- * String vector - , StrVector(..) - , withStrVector - , allocaStrVector - , addStrVectorFinalizer - - -- * Bytestring - , BSLen(..) - , withBSLen - - -- * Bytestring vector - , BSVector(..) - , withBSVector - , allocaBSVector - , addBSVectorFinalizer - - -- * Igraph matrix type - , Matrix(..) - , withMatrix - , allocaMatrix - , addMatrixFinalizer - - -- * Igraph vertex selector - , IGraphVs(..) - , withIGraphVs - , allocaVs - , addVsFinalizer - - -- * Igraph vertex iterator - , IGraphVit(..) - , withIGraphVit - , allocaVit - , addVitFinalizer - - -- * Igraph edge Selector - , IGraphEs - , withIGraphEs - , allocaEs - , addEsFinalizer - - -- * Igraph edge iterator - , IGraphEit(..) - , withIGraphEit - , allocaEit - , addEitFinalizer - - -- * IGraph type and basic operations - , IGraph(..) - , withIGraph - , allocaIGraph - , addIGraphFinalizer - - -- * Igraph attribute record - , AttributeRecord(..) - , withAttributeRecord - - -- * Igraph arpack options type - , ArpackOpt(..) - , withArpackOpt - , igraphArpackNew - ) where - -import Foreign - -#include "haskell_attributes.h" -#include "haskell_igraph.h" - --------------------------------------------------------------------------------- --- Igraph vector --------------------------------------------------------------------------------- - -{#pointer *igraph_vector_t as Vector foreign finalizer - igraph_vector_destroy newtype#} - --- Construtors and destructors - -allocaVector :: (Ptr Vector -> IO a) -> IO a -allocaVector f = mallocBytes {# sizeof igraph_vector_t #} >>= f -{-# INLINE allocaVector #-} - -addVectorFinalizer :: Ptr Vector -> IO Vector -addVectorFinalizer ptr = do - vec <- newForeignPtr igraph_vector_destroy ptr - return $ Vector vec -{-# INLINE addVectorFinalizer #-} - - -{#pointer *igraph_vector_ptr_t as VectorPtr foreign finalizer - igraph_vector_ptr_destroy newtype#} - -allocaVectorPtr :: (Ptr VectorPtr -> IO a) -> IO a -allocaVectorPtr f = mallocBytes {# sizeof igraph_vector_ptr_t #} >>= f -{-# INLINE allocaVectorPtr #-} - -addVectorPtrFinalizer :: Ptr VectorPtr -> IO VectorPtr -addVectorPtrFinalizer ptr = do - vec <- newForeignPtr igraph_vector_ptr_destroy ptr - return $ VectorPtr vec -{-# INLINE addVectorPtrFinalizer #-} - --------------------------------------------------------------------------------- --- Igraph string vector --------------------------------------------------------------------------------- - -{#pointer *igraph_strvector_t as StrVector foreign finalizer igraph_strvector_destroy newtype#} - -allocaStrVector :: (Ptr StrVector -> IO a) -> IO a -allocaStrVector f = mallocBytes {# sizeof igraph_strvector_t #} >>= f -{-# INLINE allocaStrVector #-} - -addStrVectorFinalizer :: Ptr StrVector -> IO StrVector -addStrVectorFinalizer ptr = do - vec <- newForeignPtr igraph_strvector_destroy ptr - return $ StrVector vec -{-# INLINE addStrVectorFinalizer #-} - - --------------------------------------------------------------------------------- --- Customized string vector --------------------------------------------------------------------------------- - -{#pointer *bytestring_t as BSLen foreign newtype#} - -{#pointer *bsvector_t as BSVector foreign finalizer bsvector_destroy newtype#} - -allocaBSVector :: (Ptr BSVector -> IO a) -> IO a -allocaBSVector f = mallocBytes {# sizeof bsvector_t #} >>= f -{-# INLINE allocaBSVector #-} - -addBSVectorFinalizer :: Ptr BSVector -> IO BSVector -addBSVectorFinalizer ptr = do - vec <- newForeignPtr bsvector_destroy ptr - return $ BSVector vec -{-# INLINE addBSVectorFinalizer #-} - -{#pointer *igraph_matrix_t as Matrix foreign finalizer igraph_matrix_destroy newtype#} - -allocaMatrix :: (Ptr Matrix -> IO a) -> IO a -allocaMatrix f = mallocBytes {# sizeof igraph_matrix_t #} >>= f -{-# INLINE allocaMatrix #-} - -addMatrixFinalizer :: Ptr Matrix -> IO Matrix -addMatrixFinalizer ptr = do - vec <- newForeignPtr igraph_matrix_destroy ptr - return $ Matrix vec -{-# INLINE addMatrixFinalizer #-} - - -{#pointer *igraph_vs_t as IGraphVs foreign finalizer igraph_vs_destroy newtype #} - -allocaVs :: (Ptr IGraphVs -> IO a) -> IO a -allocaVs f = mallocBytes {# sizeof igraph_vs_t #} >>= f -{-# INLINE allocaVs #-} - -addVsFinalizer :: Ptr IGraphVs -> IO IGraphVs -addVsFinalizer ptr = newForeignPtr igraph_vs_destroy ptr >>= return . IGraphVs -{-# INLINE addVsFinalizer #-} - - --- Vertex iterator -{#pointer *igraph_vit_t as IGraphVit foreign finalizer igraph_vit_destroy newtype #} - -allocaVit :: (Ptr IGraphVit -> IO a) -> IO a -allocaVit f = mallocBytes {# sizeof igraph_vit_t #} >>= f -{-# INLINE allocaVit #-} - -addVitFinalizer :: Ptr IGraphVit -> IO IGraphVit -addVitFinalizer ptr = newForeignPtr igraph_vit_destroy ptr >>= return . IGraphVit -{-# INLINE addVitFinalizer #-} - --- Edge Selector - -{#pointer *igraph_es_t as IGraphEs foreign finalizer igraph_es_destroy newtype #} - -allocaEs :: (Ptr IGraphEs -> IO a) -> IO a -allocaEs f = mallocBytes {# sizeof igraph_es_t #} >>= f -{-# INLINE allocaEs #-} - -addEsFinalizer :: Ptr IGraphEs -> IO IGraphEs -addEsFinalizer ptr = newForeignPtr igraph_es_destroy ptr >>= return . IGraphEs -{-# INLINE addEsFinalizer #-} - --- Edge iterator - -{#pointer *igraph_eit_t as IGraphEit foreign finalizer igraph_eit_destroy newtype #} - -allocaEit :: (Ptr IGraphEit -> IO a) -> IO a -allocaEit f = mallocBytes {# sizeof igraph_eit_t #} >>= f -{-# INLINE allocaEit #-} - -addEitFinalizer :: Ptr IGraphEit -> IO IGraphEit -addEitFinalizer ptr = newForeignPtr igraph_eit_destroy ptr >>= return . IGraphEit -{-# INLINE addEitFinalizer #-} - - --------------------------------------------------------------------------------- --- Graph Constructors and Destructors --------------------------------------------------------------------------------- - -{#pointer *igraph_t as IGraph foreign finalizer igraph_destroy newtype#} - -allocaIGraph :: (Ptr IGraph -> IO a) -> IO a -allocaIGraph f = mallocBytes {# sizeof igraph_t #} >>= f -{-# INLINE allocaIGraph #-} - -addIGraphFinalizer :: Ptr IGraph -> IO IGraph -addIGraphFinalizer ptr = do - vec <- newForeignPtr igraph_destroy ptr - return $ IGraph vec -{-# INLINE addIGraphFinalizer #-} - -{#pointer *igraph_attribute_record_t as AttributeRecord foreign newtype#} - -{#pointer *igraph_arpack_options_t as ArpackOpt foreign newtype#} - -{#fun igraph_arpack_options_init as igraphArpackNew - { + } -> `ArpackOpt' #} diff --git a/src/IGraph/Isomorphism.chs b/src/IGraph/Isomorphism.chs --- a/src/IGraph/Isomorphism.chs +++ b/src/IGraph/Isomorphism.chs @@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} module IGraph.Isomorphism ( getSubisomorphisms , isomorphic @@ -8,6 +9,7 @@ ) where import System.IO.Unsafe (unsafePerformIO) +import Data.Singletons (SingI, Sing, sing, fromSing) import Foreign import Foreign.C.Types @@ -19,12 +21,10 @@ #include "haskell_igraph.h" -getSubisomorphisms :: Graph d - => LGraph d v1 e1 -- ^ graph to be searched in - -> LGraph d v2 e2 -- ^ smaller graph +getSubisomorphisms :: Graph d v1 e1 -- ^ graph to be searched in + -> Graph d v2 e2 -- ^ smaller graph -> [[Int]] -getSubisomorphisms g1 g2 = unsafePerformIO $ do - vpptr <- igraphVectorPtrNew 0 +getSubisomorphisms g1 g2 = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do igraphGetSubisomorphismsVf2 gptr1 gptr2 nullPtr nullPtr nullPtr nullPtr vpptr nullFunPtr nullFunPtr nullPtr (map.map) truncate <$> toLists vpptr @@ -39,16 +39,15 @@ , id `Ptr ()' , id `Ptr ()' , id `Ptr ()' - , `VectorPtr' + , castPtr `Ptr VectorPtr' , id `FunPtr (Ptr IGraph -> Ptr IGraph -> CInt -> CInt -> Ptr () -> IO CInt)' , id `FunPtr (Ptr IGraph -> Ptr IGraph -> CInt -> CInt -> Ptr () -> IO CInt)' , id `Ptr ()' } -> `CInt' void- #} -- | Determine whether two graphs are isomorphic. -isomorphic :: Graph d - => LGraph d v1 e1 - -> LGraph d v2 e2 +isomorphic :: Graph d v1 e1 + -> Graph d v2 e2 -> Bool isomorphic g1 g2 = unsafePerformIO $ alloca $ \ptr -> do _ <- igraphIsomorphic (_graph g1) (_graph g2) ptr @@ -58,27 +57,32 @@ -- | Creates a graph from the given isomorphism class. -- This function is implemented only for graphs with three or four vertices. -isoclassCreate :: Graph d +isoclassCreate :: forall d. SingI d => Int -- ^ The number of vertices to add to the graph. -> Int -- ^ The isomorphism class - -> d - -> LGraph d () () -isoclassCreate size idx d = unsafePerformIO $ do - gp <- igraphInit >> igraphIsoclassCreate size idx (isD d) - unsafeFreeze $ MLGraph gp + -> Graph d () () +isoclassCreate size idx = unsafePerformIO $ do + gp <- igraphInit >> igraphIsoclassCreate size idx directed + unsafeFreeze $ MGraph gp + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False {#fun igraph_isoclass_create as ^ { allocaIGraph- `IGraph' addIGraphFinalizer* , `Int', `Int', `Bool' } -> `CInt' void- #} -isoclass3 :: Graph d => d -> [LGraph d () ()] -isoclass3 d = map (flip (isoclassCreate 3) d) n +isoclass3 :: forall d. SingI d => [Graph d () ()] +isoclass3 = map (isoclassCreate 3) (if directed then [0..15] else [0..3]) where - n | isD d = [0..15] - | otherwise = [0..3] + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False -isoclass4 :: Graph d => d -> [LGraph d () ()] -isoclass4 d = map (flip (isoclassCreate 4) d) n +isoclass4 :: forall d. SingI d => [Graph d () ()] +isoclass4 = map (isoclassCreate 4) (if directed then [0..217] else [0..10]) where - n | isD d = [0..217] - | otherwise = [0..10] + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False diff --git a/src/IGraph/Layout.chs b/src/IGraph/Layout.chs --- a/src/IGraph/Layout.chs +++ b/src/IGraph/Layout.chs @@ -61,49 +61,49 @@ where area x = fromIntegral $ x^2 -getLayout :: Graph d => LGraph d v e -> LayoutMethod -> IO [(Double, Double)] -getLayout gr method = do - case method of - KamadaKawai seed niter sigma initemp coolexp kkconst -> do - mptr <- case seed of - Nothing -> igraphMatrixNew 0 0 - Just xs -> if length xs /= nNodes gr - then error "Seed error: incorrect size" - else fromRowLists $ (\(x,y) -> [x,y]) $ unzip xs - - igraphLayoutKamadaKawai gptr mptr niter (sigma n) initemp coolexp +getLayout :: Graph d v e -> LayoutMethod -> IO [(Double, Double)] +getLayout gr method = case method of + KamadaKawai seed niter sigma initemp coolexp kkconst -> case seed of + Nothing -> allocaMatrix $ \mat -> do + igraphLayoutKamadaKawai gptr mat niter (sigma n) initemp coolexp (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr - [x, y] <- toColumnLists mptr + [x, y] <- toColumnLists mat return $ zip x y + Just xs -> if length xs /= nNodes gr + then error "Seed error: incorrect size" + else withRowLists ((\(x,y) -> [x,y]) (unzip xs)) $ \mat -> do + igraphLayoutKamadaKawai gptr mat niter (sigma n) initemp coolexp + (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr + [x, y] <- toColumnLists mat + return $ zip x y - LGL niter delta area coolexp repulserad cellsize -> do - mptr <- igraphMatrixNew 0 0 - igraphLayoutLgl gptr mptr niter (delta n) (area n) coolexp - (repulserad n) (cellsize n) (-1) - [x, y] <- toColumnLists mptr - return $ zip x y + LGL niter delta area coolexp repulserad cellsize -> allocaMatrix $ \mat -> do + igraphLayoutLgl gptr mat niter (delta n) (area n) coolexp + (repulserad n) (cellsize n) (-1) + [x, y] <- toColumnLists mat + return $ zip x y where n = nNodes gr gptr = _graph gr {#fun igraph_layout_kamada_kawai as ^ { `IGraph' - , `Matrix' + , castPtr `Ptr Matrix' , `Int' , `Double' , `Double' , `Double' , `Double' , `Bool' - , id `Ptr Vector' - , id `Ptr Vector' - , id `Ptr Vector' - , id `Ptr Vector' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' } -> `CInt' void- #} {# fun igraph_layout_lgl as ^ { `IGraph' - , `Matrix' + , castPtr `Ptr Matrix' , `Int' , `Double' , `Double' diff --git a/src/IGraph/Motif.chs b/src/IGraph/Motif.chs --- a/src/IGraph/Motif.chs +++ b/src/IGraph/Motif.chs @@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DataKinds #-} module IGraph.Motif ( triad , triadCensus @@ -7,7 +8,7 @@ import Data.Hashable (Hashable) import System.IO.Unsafe (unsafePerformIO) -import qualified Foreign.Ptr as C2HSImp +import Foreign import IGraph {#import IGraph.Internal #} @@ -31,7 +32,7 @@ -- 120C: A->B->C, A<->C. -- 210: A->B<->C, A<->C. -- 300: A<->B<->C, A<->C, the complete graph. -triad :: [LGraph D () ()] +triad :: [Graph 'D () ()] triad = map make edgeList where edgeList = @@ -52,19 +53,18 @@ , [(0,1), (1,2), (2,1), (0,2), (2,0)] , [(0,1), (1,0), (1,2), (2,1), (0,2), (2,0)] ] - make :: [(Int, Int)] -> LGraph D () () + make :: [(Int, Int)] -> Graph 'D () () make xs = mkGraph (replicate 3 ()) $ zip xs $ repeat () -triadCensus :: (Hashable v, Eq v, Read v) => LGraph d v e -> [Int] -triadCensus gr = unsafePerformIO $ do - vptr <- igraphVectorNew 0 - igraphTriadCensus (_graph gr) vptr - map truncate <$> toList vptr +triadCensus :: (Hashable v, Eq v, Read v) => Graph d v e -> [Int] +triadCensus gr = unsafePerformIO $ allocaVector $ \result -> do + igraphTriadCensus (_graph gr) result + map truncate <$> toList result -- motifsRandesu {#fun igraph_triad_census as ^ { `IGraph' - , `Vector' } -> `CInt' void- #} + , castPtr `Ptr Vector' } -> `CInt' void- #} -{#fun igraph_motifs_randesu as ^ { `IGraph', `Vector', `Int' - , `Vector' } -> `CInt' void- #} +{#fun igraph_motifs_randesu as ^ { `IGraph', castPtr `Ptr Vector', `Int' + , castPtr `Ptr Vector' } -> `CInt' void- #} diff --git a/src/IGraph/Mutable.hs b/src/IGraph/Mutable.hs --- a/src/IGraph/Mutable.hs +++ b/src/IGraph/Mutable.hs @@ -1,111 +1,129 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + module IGraph.Mutable ( MGraph(..) - , MLGraph(..) + , new + , nNodes + , nEdges + , addNodes + , addLNodes + , delNodes + , addEdges + , addLEdges + , delEdges , setEdgeAttr , setNodeAttr + , initializeNullAttribute )where -import Control.Monad (when, forM) +import Control.Monad (forM) import Control.Monad.Primitive import Data.Serialize (Serialize, encode) -import Foreign +import Data.Singletons.Prelude (Sing, SingI, fromSing, sing) +import Foreign hiding (new) import IGraph.Internal import IGraph.Internal.Initialization import IGraph.Types -- | Mutable labeled graph. -newtype MLGraph m d v e = MLGraph IGraph - -class MGraph d where - -- | Create a new graph. - new :: PrimMonad m => Int -> m (MLGraph (PrimState m) d v e) - - -- | Add nodes to the graph. - addNodes :: PrimMonad m - => Int -- ^ The number of new nodes. - -> MLGraph(PrimState m) d v e -> m () - addNodes n (MLGraph g) = unsafePrimToPrim $ igraphAddVertices g n nullPtr +newtype MGraph m (d :: EdgeType) v e = MGraph IGraph - -- | Add nodes with labels to the graph. - addLNodes :: (Serialize v, PrimMonad m) - => [v] -- ^ vertices' labels - -> MLGraph (PrimState m) d v e -> m () - addLNodes labels (MLGraph g) = unsafePrimToPrim $ do - bsvec <- toBSVector $ map encode labels - withAttr vertexAttr bsvec $ \attr -> do - vptr <- fromPtrs [castPtr attr] - withVectorPtr vptr (igraphAddVertices g n . castPtr) - where - n = length labels +-- | Create a new graph. +new :: forall m d v e. (SingI d, PrimMonad m) + => Int -> m (MGraph (PrimState m) d v e) +new n = unsafePrimToPrim $ igraphInit >>= igraphNew n directed >>= return . MGraph + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False - -- | Delete nodes from the graph. - delNodes :: PrimMonad m => [Int] -> MLGraph (PrimState m) d v e -> m () - delNodes ns (MLGraph g) = unsafePrimToPrim $ do - vptr <- fromList $ map fromIntegral ns - vsptr <- igraphVsVector vptr - _ <- igraphDeleteVertices g vsptr - return () +-- | Return the number of nodes in a graph. +nNodes :: PrimMonad m => MGraph (PrimState m) d v e -> m Int +nNodes (MGraph gr) = unsafePrimToPrim $ igraphVcount gr +{-# INLINE nNodes #-} - -- | Add edges to the graph. - addEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m () - addEdges es (MLGraph g) = unsafePrimToPrim $ do - vec <- fromList xs - igraphAddEdges g vec nullPtr - where - xs = concatMap ( \(a,b) -> [fromIntegral a, fromIntegral b] ) es +-- | Return the number of edges in a graph. +nEdges :: PrimMonad m => MGraph (PrimState m) d v e -> m Int +nEdges (MGraph gr) = unsafePrimToPrim $ igraphEcount gr +{-# INLINE nEdges #-} - -- | Add edges with labels to the graph. - addLEdges :: (PrimMonad m, Serialize e) => [LEdge e] -> MLGraph (PrimState m) d v e -> m () - addLEdges es (MLGraph g) = unsafePrimToPrim $ do - bsvec <- toBSVector $ map encode vs - withAttr edgeAttr bsvec $ \attr -> do - vec <- fromList $ concat xs - vptr <- fromPtrs [castPtr attr] - withVectorPtr vptr (igraphAddEdges g vec . castPtr) - where - (xs, vs) = unzip $ map ( \((a,b),v) -> ([fromIntegral a, fromIntegral b], v) ) es +-- | Add nodes to the graph. +addNodes :: PrimMonad m + => Int -- ^ The number of new nodes. + -> MGraph(PrimState m) d v e -> m () +addNodes n (MGraph g) = unsafePrimToPrim $ igraphAddVertices g n nullPtr - -- | Delete edges from the graph. - delEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m () +-- | Add nodes with labels to the graph. +addLNodes :: (Serialize v, PrimMonad m) + => [v] -- ^ vertices' labels + -> MGraph (PrimState m) d v e -> m () +addLNodes labels (MGraph g) = unsafePrimToPrim $ + withAttr vertexAttr labels $ \attr -> + withPtrs [attr] (igraphAddVertices g n . castPtr) + where + n = length labels -instance MGraph U where - new n = unsafePrimToPrim $ igraphInit >>= igraphNew n False >>= return . MLGraph +-- | Delete nodes from the graph. +delNodes :: PrimMonad m => [Int] -> MGraph (PrimState m) d v e -> m () +delNodes ns (MGraph g) = unsafePrimToPrim $ withVerticesList ns $ \vs -> + igraphDeleteVertices g vs - delEdges es (MLGraph g) = unsafePrimToPrim $ do - eids <- forM es $ \(fr, to) -> igraphGetEid g fr to False True - vptr <- fromList $ map fromIntegral eids - esptr <- igraphEsVector vptr - _ <- igraphDeleteEdges g esptr - return () +-- | Add edges to the graph. +addEdges :: PrimMonad m => [(Int, Int)] -> MGraph (PrimState m) d v e -> m () +addEdges es (MGraph g) = unsafePrimToPrim $ withList xs $ \vec -> + igraphAddEdges g vec nullPtr + where + xs = concatMap ( \(a,b) -> [a, b] ) es -instance MGraph D where - new n = unsafePrimToPrim $ igraphInit >>= igraphNew n True >>= return . MLGraph +-- | Add edges with labels to the graph. +addLEdges :: (PrimMonad m, Serialize e) + => [LEdge e] -> MGraph (PrimState m) d v e -> m () +addLEdges es (MGraph g) = unsafePrimToPrim $ + withAttr edgeAttr vs $ \attr -> withList (concat xs) $ \vec -> + withPtrs [attr] (igraphAddEdges g vec . castPtr) + where + (xs, vs) = unzip $ map ( \((a,b),v) -> ([a, b], v) ) es - delEdges es (MLGraph g) = unsafePrimToPrim $ do - eids <- forM es $ \(fr, to) -> igraphGetEid g fr to True True - vptr <- fromList $ map fromIntegral eids - esptr <- igraphEsVector vptr - igraphDeleteEdges g esptr - return () +-- | Delete edges from the graph. +delEdges :: forall m d v e. (SingI d, PrimMonad m) + => [(Int, Int)] -> MGraph (PrimState m) d v e -> m () +delEdges es (MGraph g) = unsafePrimToPrim $ do + eids <- forM es $ \(fr, to) -> igraphGetEid g fr to directed True + withEdgeIdsList eids (igraphDeleteEdges g) + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False -- | Set node attribute. setNodeAttr :: (PrimMonad m, Serialize v) => Int -- ^ Node id -> v - -> MLGraph (PrimState m) d v e + -> MGraph (PrimState m) d v e -> m () -setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ asBS (encode x) $ \bs -> do - err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId bs - when (err /= 0) $ error "Fail to set node attribute!" +setNodeAttr nodeId x (MGraph gr) = unsafePrimToPrim $ + withByteString (encode x) $ igraphHaskellAttributeVASSet gr vertexAttr nodeId -- | Set edge attribute. setEdgeAttr :: (PrimMonad m, Serialize e) => Int -- ^ Edge id -> e - -> MLGraph (PrimState m) d v e + -> MGraph (PrimState m) d v e -> m () -setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ asBS (encode x) $ \bs -> do - err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId bs - when (err /= 0) $ error "Fail to set edge attribute!" +setEdgeAttr edgeId x (MGraph gr) = unsafePrimToPrim $ + withByteString (encode x) $ igraphHaskellAttributeEASSet gr edgeAttr edgeId + +initializeNullAttribute :: PrimMonad m + => MGraph (PrimState m) d () () + -> m () +initializeNullAttribute gr@(MGraph g) = do + nn <- nNodes gr + unsafePrimToPrim $ withByteStrings (map encode $ replicate nn ()) $ + igraphHaskellAttributeVASSetv g vertexAttr + ne <- nEdges gr + unsafePrimToPrim $ withByteStrings (map encode $ replicate ne ()) $ + igraphHaskellAttributeEASSetv g edgeAttr +{-# INLINE initializeNullAttribute #-} diff --git a/src/IGraph/Read.hs b/src/IGraph/Read.hs --- a/src/IGraph/Read.hs +++ b/src/IGraph/Read.hs @@ -4,20 +4,21 @@ , readAdjMatrixWeighted ) where -import qualified Data.ByteString.Char8 as B -import Data.ByteString.Lex.Fractional (readSigned, readExponential) -import Data.Maybe (fromJust) +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Lex.Fractional (readExponential, readSigned) +import Data.Maybe (fromJust) +import Data.Singletons (SingI) -import IGraph +import IGraph readDouble :: B.ByteString -> Double readDouble = fst . fromJust . readSigned readExponential {-# INLINE readDouble #-} -readAdjMatrix :: Graph d => FilePath -> IO (LGraph d B.ByteString ()) +readAdjMatrix :: SingI d => FilePath -> IO (Graph d B.ByteString ()) readAdjMatrix = fmap fromAdjMatrix . B.readFile -fromAdjMatrix :: Graph d => B.ByteString -> LGraph d B.ByteString () +fromAdjMatrix :: SingI d => B.ByteString -> Graph d B.ByteString () fromAdjMatrix bs = let (header:xs) = B.lines bs mat = map (map readDouble . B.words) xs @@ -31,7 +32,7 @@ f ((i,j),v) = i < j && v /= 0 {-# INLINE fromAdjMatrix #-} -readAdjMatrixWeighted :: Graph d => FilePath -> IO (LGraph d B.ByteString Double) +readAdjMatrixWeighted :: SingI d => FilePath -> IO (Graph d B.ByteString Double) readAdjMatrixWeighted fl = do c <- B.readFile fl let (header:xs) = B.lines c diff --git a/src/IGraph/Structure.chs b/src/IGraph/Structure.chs --- a/src/IGraph/Structure.chs +++ b/src/IGraph/Structure.chs @@ -5,7 +5,6 @@ , betweenness , eigenvectorCentrality , pagerank - , personalizedPagerank ) where import Control.Monad @@ -14,168 +13,132 @@ import qualified Data.HashMap.Strict as M import Data.Serialize (Serialize, decode) import System.IO.Unsafe (unsafePerformIO) +import Data.Maybe +import Data.Singletons (SingI) import Foreign import Foreign.C.Types import IGraph -import IGraph.Mutable +import IGraph.Mutable (MGraph(..)) {#import IGraph.Internal #} {#import IGraph.Internal.Constants #} #include "igraph/igraph.h" -inducedSubgraph :: (Hashable v, Eq v, Serialize v) => LGraph d v e -> [Int] -> LGraph d v e -inducedSubgraph gr vs = unsafePerformIO $ do - vs' <- fromList $ map fromIntegral vs - vsptr <- igraphVsVector vs' - igraphInducedSubgraph (_graph gr) vsptr IgraphSubgraphCreateFromScratch >>= - unsafeFreeze . MLGraph +inducedSubgraph :: (Hashable v, Eq v, Serialize v) + => Graph d v e + -> [Int] + -> Graph d v e +inducedSubgraph gr nds = unsafePerformIO $ withVerticesList nds $ \vs -> + igraphInducedSubgraph (_graph gr) vs IgraphSubgraphCreateFromScratch >>= + unsafeFreeze . MGraph +{#fun igraph_induced_subgraph as ^ + { `IGraph' + , allocaIGraph- `IGraph' addIGraphFinalizer* + , castPtr %`Ptr VertexSelector' + , `SubgraphImplementation' + } -> `CInt' void- #} -- | Closeness centrality closeness :: [Int] -- ^ vertices - -> LGraph d v e + -> Graph d v e -> Maybe [Double] -- ^ optional edge weights -> Neimode -> Bool -- ^ whether to normalize -> [Double] -closeness vs gr ws mode normal = unsafePerformIO $ do - vs' <- fromList $ map fromIntegral vs - vsptr <- igraphVsVector vs' - vptr <- igraphVectorNew 0 - ws' <- case ws of - Just w -> fromList w - _ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr - igraphCloseness (_graph gr) vptr vsptr mode ws' normal - toList vptr +closeness nds gr ws mode normal = unsafePerformIO $ allocaVector $ \result -> + withVerticesList nds $ \vs -> withListMaybe ws $ \ws' -> do + igraphCloseness (_graph gr) result vs mode ws' normal + toList result +{#fun igraph_closeness as ^ + { `IGraph' + , castPtr `Ptr Vector' + , castPtr %`Ptr VertexSelector' + , `Neimode' + , castPtr `Ptr Vector' + , `Bool' } -> `CInt' void- #} + -- | Betweenness centrality betweenness :: [Int] - -> LGraph d v e + -> Graph d v e -> Maybe [Double] -> [Double] -betweenness vs gr ws = unsafePerformIO $ do - vs' <- fromList $ map fromIntegral vs - vsptr <- igraphVsVector vs' - vptr <- igraphVectorNew 0 - ws' <- case ws of - Just w -> fromList w - _ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr - igraphBetweenness (_graph gr) vptr vsptr True ws' False - toList vptr +betweenness nds gr ws = unsafePerformIO $ allocaVector $ \result -> + withVerticesList nds $ \vs -> withListMaybe ws $ \ws' -> do + igraphBetweenness (_graph gr) result vs True ws' False + toList result +{#fun igraph_betweenness as ^ + { `IGraph' + , castPtr `Ptr Vector' + , castPtr %`Ptr VertexSelector' + , `Bool' + , castPtr `Ptr Vector' + , `Bool' } -> `CInt' void- #} -- | Eigenvector centrality -eigenvectorCentrality :: LGraph d v e +eigenvectorCentrality :: Graph d v e -> Maybe [Double] -> [Double] -eigenvectorCentrality gr ws = unsafePerformIO $ do - vptr <- igraphVectorNew 0 - ws' <- case ws of - Just w -> fromList w - _ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr - arparck <- igraphArpackNew - igraphEigenvectorCentrality (_graph gr) vptr nullPtr True True ws' arparck - toList vptr +eigenvectorCentrality gr ws = unsafePerformIO $ allocaArpackOpt $ \arparck -> + allocaVector $ \result -> withListMaybe ws $ \ws' -> do + igraphEigenvectorCentrality (_graph gr) result nullPtr True True ws' arparck + toList result +{#fun igraph_eigenvector_centrality as ^ + { `IGraph' + , castPtr `Ptr Vector' + , id `Ptr CDouble' + , `Bool' + , `Bool' + , castPtr `Ptr Vector' + , castPtr `Ptr ArpackOpt' } -> `CInt' void- #} --- | Google's PageRank -pagerank :: Graph d - => LGraph d v e - -> Maybe [Double] -- ^ edge weights +-- | Google's PageRank algorithm, with option to +pagerank :: SingI d + => Graph d v e + -> Maybe [Double] -- ^ Node weights or reset probability. If provided, + -- the personalized PageRank will be used + -> Maybe [Double] -- ^ Edge weights -> Double -- ^ damping factor, usually around 0.85 -> [Double] -pagerank gr ws d - | n == 0 = [] - | otherwise = unsafePerformIO $ alloca $ \p -> do - vptr <- igraphVectorNew 0 - vsptr <- igraphVsAll - ws' <- case ws of - Just w -> if length w /= m - then error "pagerank: incorrect length of edge weight vector" - else fromList w - _ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr - igraphPagerank (_graph gr) IgraphPagerankAlgoPrpack vptr p vsptr - (isDirected gr) d ws' nullPtr - toList vptr - where - n = nNodes gr - m = nEdges gr - --- | Personalized PageRank. -personalizedPagerank :: Graph d - => LGraph d v e - -> [Double] -- ^ reset probability - -> Maybe [Double] - -> Double - -> [Double] -personalizedPagerank gr reset ws d +pagerank gr reset ws d | n == 0 = [] - | length reset /= n = error "personalizedPagerank: incorrect length of reset vector" - | otherwise = unsafePerformIO $ alloca $ \p -> do - vptr <- igraphVectorNew 0 - vsptr <- igraphVsAll - ws' <- case ws of - Just w -> if length w /= m - then error "pagerank: incorrect length of edge weight vector" - else fromList w - _ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr - reset' <- fromList reset - igraphPersonalizedPagerank (_graph gr) IgraphPagerankAlgoPrpack vptr p vsptr - (isDirected gr) d reset' ws' nullPtr - toList vptr + | isJust ws && length (fromJust ws) /= m = error "incorrect length of edge weight vector" + | otherwise = unsafePerformIO $ alloca $ \p -> allocaVector $ \result -> + withVerticesAll $ \vs -> withListMaybe ws $ \ws' -> do + case reset of + Nothing -> igraphPagerank (_graph gr) IgraphPagerankAlgoPrpack + result p vs (isDirected gr) d ws' nullPtr + Just reset' -> withList reset' $ \reset'' -> igraphPersonalizedPagerank + (_graph gr) IgraphPagerankAlgoPrpack result p vs + (isDirected gr) d reset'' ws' nullPtr + toList result where n = nNodes gr m = nEdges gr -{#fun igraph_induced_subgraph as ^ - { `IGraph' - , allocaIGraph- `IGraph' addIGraphFinalizer* - , %`IGraphVs' - , `SubgraphImplementation' - } -> `CInt' void- #} - -{#fun igraph_closeness as ^ { `IGraph' - , `Vector' - , %`IGraphVs' - , `Neimode' - , `Vector' - , `Bool' } -> `CInt' void- #} - -{#fun igraph_betweenness as ^ { `IGraph' - , `Vector' - , %`IGraphVs' - , `Bool' - , `Vector' - , `Bool' } -> `CInt' void- #} - -{#fun igraph_eigenvector_centrality as ^ { `IGraph' - , `Vector' - , id `Ptr CDouble' - , `Bool' - , `Bool' - , `Vector' - , `ArpackOpt' } -> `CInt' void- #} - {#fun igraph_pagerank as ^ { `IGraph' , `PagerankAlgo' - , `Vector' + , castPtr `Ptr Vector' , id `Ptr CDouble' - , %`IGraphVs' + , castPtr %`Ptr VertexSelector' , `Bool' , `Double' - , `Vector' + , castPtr `Ptr Vector' , id `Ptr ()' } -> `CInt' void- #} {#fun igraph_personalized_pagerank as ^ { `IGraph' , `PagerankAlgo' - , `Vector' + , castPtr `Ptr Vector' , id `Ptr CDouble' - , %`IGraphVs' + , castPtr %`Ptr VertexSelector' , `Bool' , `Double' - , `Vector' - , `Vector' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' , id `Ptr ()' } -> `CInt' void- #} diff --git a/src/IGraph/Types.hs b/src/IGraph/Types.hs --- a/src/IGraph/Types.hs +++ b/src/IGraph/Types.hs @@ -1,17 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module IGraph.Types where +import Data.Serialize (Serialize) +import Data.Singletons.Prelude +import Data.Singletons.TH +import GHC.Generics (Generic) + +$(singletons [d| + data EdgeType = D + | U + deriving (Show, Read, Eq, Generic) + |]) + +instance Serialize EdgeType + type Node = Int type LNode a = (Node, a) type Edge = (Node, Node) type LEdge a = (Edge, a) - --- | Undirected graph. -data U - --- | Directed graph. -data D vertexAttr :: String vertexAttr = "vertex_attribute" diff --git a/tests/Test/Attributes.hs b/tests/Test/Attributes.hs --- a/tests/Test/Attributes.hs +++ b/tests/Test/Attributes.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} module Test.Attributes ( tests ) where @@ -31,14 +32,14 @@ nodeLabelTest :: TestTree nodeLabelTest = testCase "node label test" $ do let ns = sort $ map show [38..7000] - gr = mkGraph ns [] :: LGraph D String () + gr = mkGraph ns [] :: Graph 'D String () assertBool "" $ sort (map (nodeLab gr) $ nodes gr) == ns labelTest :: TestTree labelTest = testCase "edge label test" $ do dat <- randEdges 1000 10000 let es = sort $ zipWith (\a b -> (a,b)) dat $ map show [1..] - gr = fromLabeledEdges es :: LGraph D Int String + gr = fromLabeledEdges es :: Graph 'D Int String es' = sort $ map (\(a,b) -> ((nodeLab gr a, nodeLab gr b), edgeLab gr (a,b))) $ edges gr assertBool "" $ es == es' @@ -48,13 +49,10 @@ let es = map ( \(a, b) -> ( ( defaultNodeAttributes{_nodeZindex=a} , defaultNodeAttributes{_nodeZindex=b}), defaultEdgeAttributes) ) dat - gr = fromLabeledEdges es :: LGraph D NodeAttr EdgeAttr - gr' :: LGraph D NodeAttr EdgeAttr + gr = fromLabeledEdges es :: Graph 'D NodeAttr EdgeAttr + gr' :: Graph 'D NodeAttr EdgeAttr gr' = case decode $ encode gr of Left msg -> error msg Right r -> r es' = map (\(a,b) -> ((nodeLab gr' a, nodeLab gr' b), edgeLab gr' (a,b))) $ edges gr' - gr'' <- runConduit $ (yield $ encode gr) .| decodeC :: IO (LGraph D NodeAttr EdgeAttr) - let es'' = map (\(a,b) -> ((nodeLab gr'' a, nodeLab gr'' b), edgeLab gr'' (a,b))) $ edges gr'' - assertBool "" $ sort (map show es) == sort (map show es') && - sort (map show es) == sort (map show es'') + assertBool "" $ sort (map show es) == sort (map show es') diff --git a/tests/Test/Basic.hs b/tests/Test/Basic.hs --- a/tests/Test/Basic.hs +++ b/tests/Test/Basic.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} module Test.Basic ( tests ) where @@ -13,7 +14,7 @@ import Conduit import IGraph -import IGraph.Mutable +import qualified IGraph.Mutable as GM import IGraph.Structure tests :: TestTree @@ -33,8 +34,8 @@ where edgeList = sort $ unsafePerformIO $ randEdges 1000 100 m = length edgeList - gr = mkGraph (replicate 100 ()) $ zip edgeList $ repeat () :: LGraph D () () - simple = mkGraph (replicate 3 ()) $ zip [(0,1),(1,2),(2,0)] $ repeat () :: LGraph D () () + gr = mkGraph (replicate 100 ()) $ zip edgeList $ repeat () :: Graph 'D () () + simple = mkGraph (replicate 3 ()) $ zip [(0,1),(1,2),(2,0)] $ repeat () :: Graph 'D () () graphCreationLabeled :: TestTree graphCreationLabeled = testGroup "Graph creation -- with labels" @@ -49,15 +50,15 @@ randEdges 10000 1000) $ repeat 1 n = length $ nubSort $ concatMap (\((a,b),_) -> [a,b]) edgeList m = length edgeList - gr = fromLabeledEdges edgeList :: LGraph D String Int - gr' = runST $ fromLabeledEdges' edgeList yieldMany :: LGraph D String Int + gr = fromLabeledEdges edgeList :: Graph 'D String Int + gr' = unsafePerformIO $ fromLabeledEdges' edgeList yieldMany :: Graph 'D String Int graphEdit :: TestTree graphEdit = testGroup "Graph editing" [ testCase "" $ [(1,2)] @=? (sort $ edges simple') ] where - simple = mkGraph (replicate 3 ()) $ zip [(0,1),(1,2),(2,0)] $ repeat () :: LGraph U () () + simple = mkGraph (replicate 3 ()) $ zip [(0,1),(1,2),(2,0)] $ repeat () :: Graph 'U () () simple' = runST $ do g <- thaw simple - delEdges [(0,1),(0,2)] g + GM.delEdges [(0,1),(0,2)] g freeze g diff --git a/tests/Test/Clique.hs b/tests/Test/Clique.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Clique.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +module Test.Clique + ( tests + ) where + +import Control.Monad.ST +import Data.List +import System.IO.Unsafe +import Test.Tasty +import Test.Tasty.HUnit +import Test.Utils + +import IGraph +import IGraph.Clique +import IGraph.Generators +import IGraph.Mutable + +tests :: TestTree +tests = testGroup "Clique" + [ testCase "case 1" $ sort (map sort $ cliques gr (4,-1)) @=? c4 + , testCase "case 2" $ sort (map sort $ cliques gr (2,2)) @=? c2 + , testCase "case 3" $ sort (map sort $ largestCliques gr) @=? c4 + , testCase "case 4" $ sort (map sort $ cliques gr (-1,-1)) @=? + sort (map sort $ c1 ++ c2 ++ c3 ++ c4) + ] + where + gr = runST $ do + g <- unsafeThaw (full 6 False :: Graph 'U () ()) + delEdges [(0,1), (0,2), (3,5)] g + unsafeFreeze g + c1 = [[0], [1], [2], [3], [4], [5]] + c2 = [ [0,3], [0,4], [0,5], [1,2], [1,3], [1,4], [1,5], [2,3], [2,4] + , [2,5], [3,4], [4,5] ] + c3 = [ [0,3,4], [0,4,5], [1,2,3], [1,2,4], [1,2,5], [1,3,4], [1,4,5], + [2,3,4], [2,4,5] ] + c4 = [[1, 2, 3, 4], [1, 2, 4, 5]] diff --git a/tests/Test/Structure.hs b/tests/Test/Structure.hs --- a/tests/Test/Structure.hs +++ b/tests/Test/Structure.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} module Test.Structure ( tests ) where @@ -13,10 +14,12 @@ import IGraph import IGraph.Mutable import IGraph.Structure +import IGraph.Generators tests :: TestTree tests = testGroup "Structure property tests" [ subGraphs + , pagerankTest ] subGraphs :: TestTree @@ -27,7 +30,16 @@ , ["a","c"], [("a","c"), ("c","a")] ) test (ori,ns,expect) = sort expect @=? sort result where - gr = fromLabeledEdges $ zip ori $ repeat () :: LGraph D String () + gr = fromLabeledEdges $ zip ori $ repeat () :: Graph 'D String () ns' = map (head . getNodes gr) ns gr' = inducedSubgraph gr ns' result = map (nodeLab gr' *** nodeLab gr') $ edges gr' + +pagerankTest :: TestTree +pagerankTest = testGroup "PageRank" + [ testCase "case 1" $ ranks @=? ranks' ] + where + gr = star 11 + ranks = [0.47,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05] + ranks' = map ((/100) . fromIntegral . round. (*100)) $ + pagerank gr Nothing Nothing 0.85 diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,8 +1,9 @@ +import qualified Test.Attributes as Attributes import qualified Test.Basic as Basic +import qualified Test.Clique as Clique import qualified Test.Isomorphism as Isomorphism import qualified Test.Motif as Motif import qualified Test.Structure as Structure -import qualified Test.Attributes as Attributes import Test.Tasty main :: IO () @@ -12,4 +13,5 @@ , Motif.tests , Isomorphism.tests , Attributes.tests + , Clique.tests ]