diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,14 @@ Revision history for haskell-igraph =================================== +v0.5.0 -- 2018-04-25 +------------------- + +* Fix memory leaks. +* Interface change: `mapNodes`, `mapEdges`, `filterNodes`, `filterEdges` become +`nmap`, `emap`, `nfilter`, `efilter`. + + v0.4.0 -- 2018-04-20 ------------------- diff --git a/cbits/haskell_attributes.c b/cbits/haskell_attributes.c --- a/cbits/haskell_attributes.c +++ b/cbits/haskell_attributes.c @@ -466,6 +466,8 @@ } if (oldrec->type == IGRAPH_ATTRIBUTE_STRING) { if (ne != bsvector_size(newstr)) { + printf("number of edges: %d\n", ne); + printf("number of attributes: %d\n", bsvector_size(newstr)); IGRAPH_ERROR("Invalid string attribute length", IGRAPH_EINVAL); } IGRAPH_CHECK(bsvector_append(oldstr, newstr)); 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.4.0 +version: 0.5.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 @@ -25,6 +25,10 @@ library exposed-modules: + IGraph.Internal.Initialization + IGraph.Internal.Constants + IGraph.Internal.Types + IGraph.Internal IGraph IGraph.Types IGraph.Mutable @@ -37,19 +41,6 @@ IGraph.Layout IGraph.Generators IGraph.Exporter.GEXF - IGraph.Internal.Initialization - IGraph.Internal.Constants - IGraph.Internal.Arpack - IGraph.Internal.Data - IGraph.Internal.Graph - IGraph.Internal.Attribute - IGraph.Internal.Isomorphism - IGraph.Internal.Selector - IGraph.Internal.Structure - IGraph.Internal.Motif - IGraph.Internal.Clique - IGraph.Internal.Community - IGraph.Internal.Layout other-modules: IGraph.Internal.C2HS @@ -78,6 +69,7 @@ extra-libraries: igraph hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall build-tools: c2hs >=0.25.0 c-sources: cbits/haskell_igraph.c diff --git a/src/IGraph.hs b/src/IGraph.hs --- a/src/IGraph.hs +++ b/src/IGraph.hs @@ -3,8 +3,8 @@ module IGraph ( Graph(..) , LGraph(..) - , U(..) - , D(..) + , U + , D , decodeC , empty , mkGraph @@ -20,38 +20,32 @@ , pre , suc - , mapNodes - , mapEdges - , filterNodes - , filterEdges - , nmap , emap + + , nfilter + , efilter ) where import Conduit -import Control.Arrow ((***)) -import Control.Monad (forM, forM_, liftM, replicateM, - unless) +import Control.Arrow ((&&&)) +import Control.Monad (forM, forM_, liftM, replicateM) 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 import qualified Data.HashSet as S import Data.List (sortBy) -import Data.Maybe import Data.Ord (comparing) import Data.Serialize -import Foreign (castPtr, with) +import Foreign (castPtr) import System.IO.Unsafe (unsafePerformIO) -import IGraph.Internal.Attribute +import IGraph.Internal import IGraph.Internal.Constants -import IGraph.Internal.Data -import IGraph.Internal.Graph -import IGraph.Internal.Selector import IGraph.Mutable import IGraph.Types @@ -70,6 +64,10 @@ 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 @@ -77,11 +75,13 @@ -- | Return all edges. edges :: LGraph d v e -> [Edge] - edges gr@(LGraph g _) = unsafePerformIO $ mapM (igraphEdge g) [0..n-1] - where - n = nEdges gr + 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 @@ -92,7 +92,8 @@ -- | Return the label of given node. nodeLab :: Serialize v => LGraph d v e -> Node -> v nodeLab (LGraph g _) i = unsafePerformIO $ - igraphHaskellAttributeVAS g vertexAttr i >>= fromBS + igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>= + return . fromRight (error "decode failed") . decode {-# INLINE nodeLab #-} -- | Return all nodes that are associated with given label. @@ -104,19 +105,21 @@ edgeLab :: Serialize e => LGraph d v e -> Edge -> e edgeLab (LGraph g _) (fr,to) = unsafePerformIO $ igraphGetEid g fr to True True >>= - igraphHaskellAttributeEAS g edgeAttr >>= fromBS + 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 gr@(LGraph g _) i = unsafePerformIO $ igraphEdge g i + getEdgeByEid (LGraph g _) i = unsafePerformIO $ igraphEdge g i {-# INLINE getEdgeByEid #-} -- | Find the edge label by edge ID. - edgeLabByEid :: Serialize e => LGraph d v e -> Int -> e - edgeLabByEid (LGraph g _) i = unsafePerformIO $ - igraphHaskellAttributeEAS g edgeAttr i >>= fromBS - {-# INLINE edgeLabByEid #-} + 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 @@ -138,7 +141,7 @@ put $ nNodes gr go (nodeLab gr) (nNodes gr) 0 put $ nEdges gr - go (\i -> (getEdgeByEid gr i, edgeLabByEid gr i)) (nEdges gr) 0 + go (\i -> (getEdgeByEid gr i, getEdgeLabByEid gr i)) (nEdges gr) 0 where go f n i | i >= n = return () | otherwise = put (f i) >> go f n (i+1) @@ -175,8 +178,6 @@ addLNodes vattr g addLEdges es g unsafeFreeze g - where - n = length vattr -- | Create a graph from labeled edges. fromLabeledEdges :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e) @@ -220,12 +221,12 @@ let f i ((fr, to), attr) = unsafePrimToPrim $ do igraphVectorSet evec (i*2) $ fromIntegral fr igraphVectorSet evec (i*2+1) $ fromIntegral to - asBS attr $ \bs -> with bs $ \ptr -> bsvectorSet bsvec i $ castPtr ptr + bsvectorSet bsvec i $ encode attr return $ i + 1 - foldMC f 0 + _ <- foldMC f 0 gr@(MLGraph g) <- new 0 addLNodes nds gr - unsafePrimToPrim $ withEdgeAttr $ \eattr -> with (mkStrRec eattr bsvec) $ \ptr -> do + unsafePrimToPrim $ withAttr edgeAttr bsvec $ \ptr -> do vptr <- fromPtrs [castPtr ptr] withVectorPtr vptr (igraphAddEdges g evec . castPtr) unsafeFreeze gr @@ -245,7 +246,8 @@ unsafeFreeze (MLGraph g) = unsafePrimToPrim $ do nV <- igraphVcount g labels <- forM [0 .. nV - 1] $ \i -> - igraphHaskellAttributeVAS g vertexAttr i >>= fromBS + igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>= + return . fromRight (error "decode failed") . decode return $ LGraph g $ M.fromListWith (++) $ zip labels $ map return [0..nV-1] where @@ -278,63 +280,40 @@ vit <- igraphVitNew (_graph gr) vs vitToList vit --- | Keep nodes that satisfy the constraint -filterNodes :: (Hashable v, Eq v, Serialize v, Graph d) - => (LGraph d v e -> Node -> Bool) -> LGraph d v e -> LGraph d v e -filterNodes f gr = runST $ do - let deleted = filter (not . f gr) $ nodes gr - gr' <- thaw gr - delNodes deleted gr' - unsafeFreeze gr' - -- | Apply a function to change nodes' labels. -mapNodes :: (Graph d, Serialize v1, Serialize v2, Hashable v2, Eq v2) - => (Node -> v1 -> v2) -> LGraph d v1 e -> LGraph d v2 e -mapNodes f gr = runST $ do +nmap :: (Graph d, Serialize v1, Serialize v2, Hashable v2, Eq v2) + => (LNode v1 -> v2) -> LGraph d v1 e -> LGraph 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' + forM_ (nodes gr) $ \x -> setNodeAttr x (f (x, nodeLab gr x)) gr' unsafeFreeze gr' -- | Apply a function to change edges' labels. -mapEdges :: (Graph d, Serialize e1, Serialize e2, Hashable v, Eq v, Serialize v) - => (Edge -> e1 -> e2) -> LGraph d v e1 -> LGraph d v e2 -mapEdges f gr = runST $ do +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 f gr = runST $ do (MLGraph gptr) <- thaw gr let gr' = MLGraph gptr - forM_ [0 .. nEdges gr - 1] $ \x -> do - e <- unsafePrimToPrim $ igraphEdge (_graph gr) x - setEdgeAttr x (f e $ edgeLabByEid gr x) gr' + forM_ [0 .. nEdges gr - 1] $ \i -> do + let lab = f (getEdgeByEid gr i, getEdgeLabByEid gr i) + setEdgeAttr i lab gr' unsafeFreeze gr' -- | Keep nodes that satisfy the constraint. -filterEdges :: (Hashable v, Eq v, Serialize v, Graph d) - => (LGraph d v e -> Edge -> Bool) -> LGraph d v e -> LGraph d v e -filterEdges f gr = runST $ do - let deleted = filter (not . f gr) $ edges gr +nfilter :: (Hashable v, Eq v, Serialize v, Graph d) + => (LNode v -> Bool) -> LGraph d v e -> LGraph d v e +nfilter f gr = runST $ do + let deleted = fst $ unzip $ filter (not . f) $ labNodes gr gr' <- thaw gr - delEdges deleted gr' + delNodes deleted gr' unsafeFreeze gr' --- | Map a function over the node labels in a graph. -nmap :: (Graph d, Serialize v, Hashable u, Serialize u, Eq u) - => ((Node, v) -> u) -> LGraph d v e -> LGraph d u e -nmap fn gr = unsafePerformIO $ do - (MLGraph g) <- thaw gr - forM_ (nodes gr) $ \i -> do - let label = fn (i, nodeLab gr i) - asBS label $ \bs -> - with bs (igraphHaskellAttributeVASSet g vertexAttr i) - unsafeFreeze (MLGraph g) - --- | Map a function over the edge labels in a graph. -emap :: (Graph d, Serialize v, Hashable v, Eq v, Serialize e1, Serialize e2) - => ((Edge, e1) -> e2) -> LGraph d v e1 -> LGraph d v e2 -emap fn gr = unsafePerformIO $ do - (MLGraph g) <- thaw gr - forM_ (edges gr) $ \(fr, to) -> do - i <- igraphGetEid g fr to True True - let label = fn ((fr,to), edgeLabByEid gr i) - asBS label $ \bs -> - with bs (igraphHaskellAttributeEASSet g edgeAttr i) - unsafeFreeze (MLGraph g) +-- | 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 f gr = runST $ do + let deleted = fst $ unzip $ filter (not . f) $ labEdges gr + gr' <- thaw gr + delEdges deleted gr' + unsafeFreeze gr' diff --git a/src/IGraph/Clique.chs b/src/IGraph/Clique.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Clique.chs @@ -0,0 +1,35 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Clique + ( cliques + , maximalCliques + ) where + +import Control.Applicative ((<$>)) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Foreign.Ptr as C2HSImp + +import IGraph +{#import IGraph.Internal #} + +#include "haskell_igraph.h" + +cliques :: LGraph 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' #} + +maximalCliques :: LGraph 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 + (map.map) truncate <$> toLists vpptr +{#fun igraph_maximal_cliques as ^ { `IGraph', `VectorPtr', `Int', `Int' } -> `Int' #} diff --git a/src/IGraph/Clique.hs b/src/IGraph/Clique.hs deleted file mode 100644 --- a/src/IGraph/Clique.hs +++ /dev/null @@ -1,29 +0,0 @@ -module IGraph.Clique - ( cliques - , maximalCliques - ) where - -import Control.Applicative ((<$>)) -import System.IO.Unsafe (unsafePerformIO) - -import IGraph -import IGraph.Internal.Clique -import IGraph.Internal.Data - -cliques :: LGraph 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 - -maximalCliques :: LGraph 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 - (map.map) truncate <$> toLists vpptr diff --git a/src/IGraph/Community.chs b/src/IGraph/Community.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Community.chs @@ -0,0 +1,114 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Community + ( CommunityOpt(..) + , CommunityMethod(..) + , findCommunity + ) where + +import Data.Default.Class +import Data.Function (on) +import Data.List (sortBy, groupBy) +import Data.Ord (comparing) +import System.IO.Unsafe (unsafePerformIO) + +import Foreign +import Foreign.C.Types + +import IGraph +{#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 + +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 + } + +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 + + _ <- 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) + IgraphSpincommImpOrig 1.0 + + 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' #} + +{#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' #} + +type T = FunPtr ( Ptr Vector + -> CLong + -> CDouble + -> Ptr Vector + -> FunPtr (Ptr CDouble -> Ptr CDouble -> CInt -> Ptr () -> IO CInt) + -> Ptr () + -> Ptr () + -> IO CInt) diff --git a/src/IGraph/Community.hs b/src/IGraph/Community.hs deleted file mode 100644 --- a/src/IGraph/Community.hs +++ /dev/null @@ -1,71 +0,0 @@ -module IGraph.Community - ( CommunityOpt(..) - , CommunityMethod(..) - , findCommunity - ) where - -import Control.Applicative ((<$>)) -import Control.Monad -import Data.Default.Class -import Data.Function (on) -import Data.List -import Data.Ord -import Foreign -import Foreign.C.Types -import System.IO.Unsafe (unsafePerformIO) - -import IGraph -import IGraph.Internal.Arpack -import IGraph.Internal.Community -import IGraph.Internal.Constants -import IGraph.Internal.Data - -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 - -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 - } - -findCommunity :: LGraph U v e -> CommunityOpt -> [[Int]] -findCommunity gr opt = unsafePerformIO $ do - result <- igraphVectorNew 0 - ws <- case _weights opt of - Just w -> fromList w - _ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr - - 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) - IgraphSpincommImpOrig 1.0 - - liftM ( map (fst . unzip) . groupBy ((==) `on` snd) - . sortBy (comparing snd) . zip [0..] ) $ toList result 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 @@ -15,11 +15,9 @@ channelRed, toSRGB24) import Data.Hashable import Data.Serialize -import Data.Tree.NTree.TypeDefs import GHC.Generics import IGraph import Text.XML.HXT.Core -import Text.XML.HXT.DOM.TypeDefs instance Serialize (AlphaColour Double) where get = do diff --git a/src/IGraph/Generators.chs b/src/IGraph/Generators.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Generators.chs @@ -0,0 +1,73 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Generators + ( full + , ErdosRenyiModel(..) + , erdosRenyiGame + , degreeSequenceGame + , rewire + ) where + +import Control.Monad (when) +import Data.Hashable (Hashable) +import Data.Serialize (Serialize) + +import qualified Foreign.Ptr as C2HSImp + +import IGraph +import IGraph.Mutable +{#import IGraph.Internal #} +{#import IGraph.Internal.Constants #} +{# import IGraph.Internal.Initialization #} + +#include "haskell_igraph.h" + +{#fun igraph_full as full + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Int', `Bool', `Bool' + } -> `CInt' void- #} + +data ErdosRenyiModel = GNP Int Double + | GNM Int Int + +erdosRenyiGame :: Graph 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 +{#fun igraph_erdos_renyi_game as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `ErdosRenyi', `Int', `Double', `Bool', `Bool' + } -> `CInt' void- #} + +-- | 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 +{#fun igraph_degree_sequence_game as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Vector', `Vector', `Degseq' + } -> `CInt' void- #} + +-- | Randomly rewires a graph while preserving the degree distribution. +rewire :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e) + => Int -- ^ Number of rewiring trials to perform. + -> LGraph d v e + -> IO (LGraph 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' #} diff --git a/src/IGraph/Generators.hs b/src/IGraph/Generators.hs deleted file mode 100644 --- a/src/IGraph/Generators.hs +++ /dev/null @@ -1,54 +0,0 @@ -module IGraph.Generators - ( ErdosRenyiModel(..) - , erdosRenyiGame - , degreeSequenceGame - , rewire - ) where - -import Control.Monad (when) -import Data.Hashable (Hashable) -import Data.Serialize (Serialize) - -import IGraph -import IGraph.Internal.Constants -import IGraph.Internal.Data -import IGraph.Internal.Graph -import IGraph.Internal.Initialization -import IGraph.Mutable - -data ErdosRenyiModel = GNP Int Double - | GNM Int Int - -erdosRenyiGame :: Graph 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 - --- | 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 - --- | Randomly rewires a graph while preserving the degree distribution. -rewire :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e) - => Int -- ^ Number of rewiring trials to perform. - -> LGraph d v e - -> IO (LGraph 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 diff --git a/src/IGraph/Internal.chs b/src/IGraph/Internal.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Internal.chs @@ -0,0 +1,503 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Internal + ( module IGraph.Internal.Types + -- * Vector type and basic operations + , igraphVectorNew + , fromList + , toList + , igraphVectorNull + , igraphVectorFill + , igraphVectorE + , igraphVectorSet + , igraphVectorTail + , igraphVectorSize + , igraphVectorCopyTo + + -- * Pointer vector + , igraphVectorPtrNew + , fromPtrs + , toLists + + -- * String vector + , igraphStrvectorNew + , igraphStrvectorGet + , toStrVector + + -- * Bytestring + , asBS + , bsToByteString + + -- * Bytestring vector + , bsvectorNew + , bsvectorSet + , toBSVector + + -- * Igraph matrix type + , igraphMatrixNew + , igraphMatrixNull + , igraphMatrixFill + , igraphMatrixE + , igraphMatrixSet + , igraphMatrixCopyTo + , igraphMatrixNrow + , igraphMatrixNcol + , fromRowLists + , toRowLists + , toColumnLists + + -- * Igraph vertex selector + , igraphVsAll + , igraphVsAdj + , igraphVsVector + + -- * Igraph vertex iterator + , igraphVitNew + , vitToList + + -- * Igraph edge Selector + , igraphEsAll + , igraphEsVector + + -- * Igraph edge iterator + , igraphEitNew + , eitToList + + -- * IGraph type and basic operations + , igraphNew + , igraphCopy + , igraphVcount + , igraphEcount + , igraphGetEid + , igraphEdge + , igraphAddVertices + , igraphAddEdge + , igraphAddEdges + , igraphDeleteVertices + , igraphDeleteEdges + + -- * Igraph attribute record + , withAttr + , igraphHaskellAttributeHasAttr + , igraphHaskellAttributeGANSet + , igraphHaskellAttributeGAN + , igraphHaskellAttributeVAS + , igraphHaskellAttributeEAN + , igraphHaskellAttributeEAS + , igraphHaskellAttributeEASSetv + , igraphHaskellAttributeVASSet + , igraphHaskellAttributeEASSet + ) where + +import Control.Monad +import qualified Data.ByteString.Char8 as B +import Data.ByteString (packCStringLen) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.List (transpose) +import Data.List.Split (chunksOf) + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import IGraph.Internal.C2HS + +{#import IGraph.Internal.Initialization #} +{#import IGraph.Internal.Types #} +{#import IGraph.Internal.Constants #} + +#include "haskell_attributes.h" +#include "haskell_igraph.h" + +-------------------------------------------------------------------------------- +-- Igraph vector +-------------------------------------------------------------------------------- + +{#fun igraph_vector_init as igraphVectorNew + { allocaVector- `Vector' addVectorFinalizer* + , `Int' } -> `CInt' void- #} + +{#fun igraph_vector_init_copy as ^ + { allocaVector- `Vector' addVectorFinalizer* + , id `Ptr CDouble', `Int' } -> `CInt' void- #} + +fromList :: [Double] -> IO Vector +fromList xs = withArrayLen (map realToFrac xs) $ \n ptr -> + igraphVectorInitCopy ptr n +{-# INLINE fromList #-} + +toList :: Vector -> IO [Double] +toList vec = do + n <- igraphVectorSize vec + allocaArray n $ \ptr -> do + igraphVectorCopyTo vec ptr + liftM (map realToFrac) $ peekArray n ptr +{-# INLINE toList #-} + +-- Initializing elements + +{#fun igraph_vector_null as ^ { `Vector' } -> `()' #} + +{#fun igraph_vector_fill as ^ { `Vector', `Double' } -> `()' #} + + +-- Accessing elements + +{#fun pure igraph_vector_e as ^ { `Vector', `Int' } -> `Double' #} + +{#fun igraph_vector_set as ^ { `Vector', `Int', `Double' } -> `()' #} + +{#fun pure igraph_vector_tail as ^ { `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_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 +-------------------------------------------------------------------------------- + +{#fun igraph_strvector_init as igraphStrvectorNew + { allocaStrVector- `StrVector' addStrVectorFinalizer* + , `Int' + } -> `CInt' void-#} + +{#fun igraph_strvector_get as ^ + { `StrVector' + , `Int' + , alloca- `String' peekString* + } -> `CInt' void-#} + +peekString :: Ptr CString -> IO String +peekString ptr = peek ptr >>= peekCString +{-# INLINE peekString #-} + +{#fun igraph_strvector_set as ^ { `StrVector', `Int', id `CString'} -> `()' #} +{#fun igraph_strvector_set2 as ^ { `StrVector', `Int', id `CString', `Int'} -> `()' #} + +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 + where + n = length xs + + +-------------------------------------------------------------------------------- +-- Customized string vector +-------------------------------------------------------------------------------- + +bsToByteString :: Ptr BSLen -> IO B.ByteString +bsToByteString ptr = do + n <- {#get bytestring_t->len #} ptr + str <- {#get bytestring_t->value #} ptr + packCStringLen (str, fromIntegral n) +{-# INLINE bsToByteString #-} + +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 + {#set bytestring_t.len #} ptr (fromIntegral n) + {#set bytestring_t.value #} ptr str + f ptr +{-# INLINE asBS #-} + +{#fun bsvector_init as bsvectorNew + { allocaBSVector- `BSVector' addBSVectorFinalizer* + , `Int' + } -> `CInt' void- #} + +{#fun bsvector_set as bsvectorSet' { `BSVector', `Int', castPtr `Ptr BSLen' } -> `()' #} + +bsvectorSet :: BSVector -> Int -> B.ByteString -> IO () +bsvectorSet vec i bs = asBS bs (bsvectorSet' vec i) +{-# INLINE bsvectorSet #-} + +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 + where + n = length xs + + +{#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' #} + +{#fun igraph_matrix_set as ^ { `Matrix', `Int', `Int', `Double' } -> `()' #} + +{#fun igraph_matrix_copy_to as ^ { `Matrix', id `Ptr CDouble' } -> `()' #} + +{#fun igraph_matrix_nrow as ^ { `Matrix' } -> `Int' #} + +{#fun igraph_matrix_ncol as ^ { `Matrix' } -> `Int' #} + +-- row lists to matrix +fromRowLists :: [[Double]] -> IO Matrix +fromRowLists xs + | all (==c) $ map length xs = do + mptr <- igraphMatrixNew r c + forM_ (zip [0..] xs) $ \(i, row) -> + forM_ (zip [0..] row) $ \(j,v) -> + igraphMatrixSet mptr i j v + return mptr + | otherwise = error "Not a matrix." + where + r = length xs + c = length $ head xs + +-- to row lists +toRowLists :: Matrix -> IO [[Double]] +toRowLists = liftM transpose . toColumnLists + +toColumnLists :: Matrix -> IO [[Double]] +toColumnLists mptr = do + r <- igraphMatrixNrow mptr + c <- igraphMatrixNcol mptr + xs <- allocaArray (r*c) $ \ptr -> do + igraphMatrixCopyTo mptr ptr + peekArray (r*c) ptr + return $ chunksOf r $ map realToFrac xs + + +{#fun igraph_vs_all as ^ + { allocaVs- `IGraphVs' addVsFinalizer* + } -> `CInt' void- #} + +{#fun igraph_vs_adj as ^ + { allocaVs- `IGraphVs' addVsFinalizer* + , `Int', `Neimode' + } -> `CInt' void- #} + +{#fun igraph_vs_vector as ^ + { allocaVs- `IGraphVs' addVsFinalizer* + , `Vector' + } -> `CInt' void- #} + +-- Vertex iterator + +#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 ^ { `IGraphVit' } -> `Bool' #} + +{#fun igraph_vit_next as ^ { `IGraphVit' } -> `()' #} + +{#fun igraph_vit_get as ^ { `IGraphVit' } -> `Int' #} + +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 + + +-- Edge Selector + +{#fun igraph_es_all as ^ + { allocaEs- `IGraphEs' addEsFinalizer* + , `EdgeOrderType' + } -> `CInt' void- #} + +{# fun igraph_es_vector as ^ + { allocaEs- `IGraphEs' addEsFinalizer* + , `Vector' + } -> `CInt' void- #} + +-- Edge iterator + +#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 + + +-------------------------------------------------------------------------------- +-- 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 +-------------------------------------------------------------------------------- + +{#fun igraph_vcount as ^ { `IGraph' } -> `Int' #} + +{#fun igraph_ecount as ^ { `IGraph' } -> `Int' #} + +{#fun igraph_get_eid as ^ + { `IGraph' + , alloca- `Int' peekIntConv* + , `Int' + , `Int' + , `Bool' + , `Bool' + } -> `CInt' void-#} + +{#fun igraph_edge as ^ + { `IGraph' + , `Int' + , alloca- `Int' peekIntConv* + , alloca- `Int' peekIntConv* + } -> `CInt' void-#} + +-- Adding and Deleting Vertices and Edges + +{# fun igraph_add_vertices as ^ { `IGraph', `Int', id `Ptr ()' } -> `()' #} + +{# fun igraph_add_edge as ^ { `IGraph', `Int', `Int' } -> `()' #} + +-- | The edges are given in a vector, the first two elements define the first +-- edge (the order is from , to for directed graphs). The vector should +-- contain even number of integer numbers between zero and the number of +-- vertices in the graph minus one (inclusive). If you also want to add +-- 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. + , id `Ptr ()' -- ^ The attributes of the new edges. + } -> `()' #} + +-- | delete vertices +{# fun igraph_delete_vertices as ^ { `IGraph', %`IGraphVs' } -> `Int' #} + +-- | delete edges +{# fun igraph_delete_edges as ^ { `IGraph', %`IGraphEs' } -> `Int' #} + + + +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' + {#set igraph_attribute_record_t.type #} attr 2 + {#set igraph_attribute_record_t.value #} attr $ castPtr ptr + f attr +{-# INLINE withAttr #-} + +{#fun igraph_haskell_attribute_has_attr as ^ { `IGraph', `AttributeElemtype', `String' } -> `Bool' #} + +{#fun igraph_haskell_attribute_GAN_set as ^ { `IGraph', `String', `Double' } -> `Int' #} + +{#fun igraph_haskell_attribute_GAN as ^ { `IGraph', `String' } -> `Double' #} + +{#fun igraph_haskell_attribute_VAS as ^ { `IGraph', `String', `Int' } -> `Ptr BSLen' castPtr #} + +{#fun igraph_haskell_attribute_EAN as ^ { `IGraph', `String', `Int' } -> `Double' #} + +{#fun igraph_haskell_attribute_EAS as ^ { `IGraph', `String', `Int' } -> `Ptr BSLen' castPtr #} + +{#fun igraph_haskell_attribute_EAS_setv as ^ { `IGraph', `String', `BSVector' } -> `Int' #} + +{#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' #} diff --git a/src/IGraph/Internal/Arpack.chs b/src/IGraph/Internal/Arpack.chs deleted file mode 100644 --- a/src/IGraph/Internal/Arpack.chs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Arpack where - -import Control.Monad -import Foreign -import Foreign.C.Types - -#include "haskell_igraph.h" - -{#pointer *igraph_arpack_options_t as ArpackOpt foreign newtype#} - -{#fun igraph_arpack_options_init as igraphArpackNew - { + } -> `ArpackOpt' #} diff --git a/src/IGraph/Internal/Attribute.chs b/src/IGraph/Internal/Attribute.chs deleted file mode 100644 --- a/src/IGraph/Internal/Attribute.chs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Attribute where - -import Data.ByteString (packCStringLen) -import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import Control.Monad -import Control.Applicative -import Data.Serialize (Serialize, decode, encode) -import Foreign -import Foreign.C.Types -import Foreign.C.String -import System.IO.Unsafe (unsafePerformIO) - -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Data #} -{#import IGraph.Internal.Constants #} - -#include "igraph/igraph.h" -#include "haskell_attributes.h" - --- The returned object will not be trackced by Haskell's GC. It should be freed --- by foreign codes. -asBS :: Serialize a => a -> (BSLen -> IO b) -> IO b -asBS x fn = unsafeUseAsCStringLen (encode x) (fn . BSLen) -{-# INLINE asBS #-} - -asBSVector :: Serialize a => [a] -> (BSVector -> IO b) -> IO b -asBSVector values fn = loop [] values - where - loop acc (x:xs) = unsafeUseAsCStringLen (encode x) $ \ptr -> - loop (BSLen ptr : acc) xs - loop acc _ = toBSVector (reverse acc) >>= fn -{-# INLINE asBSVector #-} - -fromBS :: Serialize a => Ptr BSLen -> IO a -fromBS ptr = do - BSLen x <- peek ptr - result <- decode <$> packCStringLen x - case result of - Left msg -> error msg - Right r -> return r -{-# INLINE fromBS #-} - -mkStrRec :: CString -- ^ name of the attribute - -> BSVector -- ^ values of the attribute - -> AttributeRecord -mkStrRec name xs = AttributeRecord name 2 xs -{-# INLINE mkStrRec #-} - -data AttributeRecord = AttributeRecord CString Int BSVector - -instance Storable AttributeRecord where - sizeOf _ = {#sizeof igraph_attribute_record_t #} - alignment _ = {#alignof igraph_attribute_record_t #} - peek p = AttributeRecord - <$> ({#get igraph_attribute_record_t->name #} p) - <*> liftM fromIntegral ({#get igraph_attribute_record_t->type #} p) - <*> ( do ptr <- {#get igraph_attribute_record_t->value #} p - fptr <- newForeignPtr_ . castPtr $ ptr - return $ BSVector fptr ) - poke p (AttributeRecord name t vptr) = do - {#set igraph_attribute_record_t.name #} p name - {#set igraph_attribute_record_t.type #} p $ fromIntegral t - withBSVector vptr $ \ptr -> - {#set igraph_attribute_record_t.value #} p $ castPtr ptr - -{#fun igraph_haskell_attribute_has_attr as ^ { `IGraph', `AttributeElemtype', `String' } -> `Bool' #} - -{#fun igraph_haskell_attribute_GAN_set as ^ { `IGraph', `String', `Double' } -> `Int' #} - -{#fun igraph_haskell_attribute_GAN as ^ { `IGraph', `String' } -> `Double' #} - -{#fun igraph_haskell_attribute_VAS as ^ { `IGraph', `String', `Int' } -> `Ptr BSLen' castPtr #} - -{#fun igraph_haskell_attribute_EAN as ^ { `IGraph', `String', `Int' } -> `Double' #} - -{#fun igraph_haskell_attribute_EAS as ^ { `IGraph', `String', `Int' } -> `Ptr BSLen' castPtr #} - -{#fun igraph_haskell_attribute_EAS_setv as ^ { `IGraph', `String', `BSVector' } -> `Int' #} - -{#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' #} diff --git a/src/IGraph/Internal/Clique.chs b/src/IGraph/Internal/Clique.chs deleted file mode 100644 --- a/src/IGraph/Internal/Clique.chs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Clique where - -import qualified Foreign.Marshal.Utils as C2HSImp -import qualified Foreign.Ptr as C2HSImp - -import Foreign -import Foreign.C.Types - -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Data #} - -#include "haskell_igraph.h" - -{#fun igraph_cliques as ^ { `IGraph', `VectorPtr', `Int', `Int' } -> `Int' #} - -{#fun igraph_maximal_cliques as ^ { `IGraph', `VectorPtr', `Int', `Int' } -> `Int' #} diff --git a/src/IGraph/Internal/Community.chs b/src/IGraph/Internal/Community.chs deleted file mode 100644 --- a/src/IGraph/Internal/Community.chs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Community where - -import Foreign -import Foreign.C.Types - -{#import IGraph.Internal.Arpack #} -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Data #} -{#import IGraph.Internal.Constants #} - -#include "haskell_igraph.h" - -{#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' #} - -{#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' #} - -type T = FunPtr ( Ptr Vector - -> CLong - -> CDouble - -> Ptr Vector - -> FunPtr (Ptr CDouble -> Ptr CDouble -> CInt -> Ptr () -> IO CInt) - -> Ptr () - -> Ptr () - -> IO CInt) 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 @@ -1,8 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface #-} module IGraph.Internal.Constants where -import Foreign - #include "igraph/igraph.h" {#enum igraph_neimode_t as Neimode {underscoreToCase} diff --git a/src/IGraph/Internal/Data.chs b/src/IGraph/Internal/Data.chs deleted file mode 100644 --- a/src/IGraph/Internal/Data.chs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Data - ( Vector(..) - , withVector - , igraphVectorNew - , fromList - , toList - , igraphVectorNull - , igraphVectorFill - , igraphVectorE - , igraphVectorSet - , igraphVectorTail - , igraphVectorSize - , igraphVectorCopyTo - - , VectorPtr(..) - , withVectorPtr - , igraphVectorPtrNew - , fromPtrs - , toLists - - , StrVector(..) - , withStrVector - , igraphStrvectorNew - , igraphStrvectorGet - , toStrVector - - , BSLen(..) - , BSVector(..) - , withBSVector - , bsvectorNew - , bsvectorSet - , toBSVector - - , Matrix(..) - , withMatrix - , igraphMatrixNew - , igraphMatrixNull - , igraphMatrixFill - , igraphMatrixE - , igraphMatrixSet - , igraphMatrixCopyTo - , igraphMatrixNrow - , igraphMatrixNcol - , fromRowLists - , toRowLists - , toColumnLists - ) where - -import Control.Monad -import qualified Data.ByteString.Char8 as B -import Foreign -import Foreign.C.Types -import Foreign.C.String -import System.IO.Unsafe (unsafePerformIO) -import Data.List (transpose) -import Data.List.Split (chunksOf) - -#include "haskell_igraph.h" -#include "bytestring.h" - --------------------------------------------------------------------------------- --- Igraph vector --------------------------------------------------------------------------------- - -{#pointer *igraph_vector_t as Vector foreign finalizer - igraph_vector_destroy newtype#} - --- Construtors and destructors - -{#fun igraph_vector_init as igraphVectorNew { +, `Int' } -> `Vector' #} - -{#fun igraph_vector_init_copy as ^ { +, id `Ptr CDouble', `Int' } -> `Vector' #} - -fromList :: [Double] -> IO Vector -fromList xs = withArrayLen (map realToFrac xs) $ \n ptr -> - igraphVectorInitCopy ptr n -{-# INLINE fromList #-} - -toList :: Vector -> IO [Double] -toList vec = do - n <- igraphVectorSize vec - allocaArray n $ \ptr -> do - igraphVectorCopyTo vec ptr - liftM (map realToFrac) $ peekArray n ptr -{-# INLINE toList #-} - --- Initializing elements - -{#fun igraph_vector_null as ^ { `Vector' } -> `()' #} - -{#fun igraph_vector_fill as ^ { `Vector', `Double' } -> `()' #} - - --- Accessing elements - -{#fun pure igraph_vector_e as ^ { `Vector', `Int' } -> `Double' #} - -{#fun igraph_vector_set as ^ { `Vector', `Int', `Double' } -> `()' #} - -{#fun pure igraph_vector_tail as ^ { `Vector' } -> `Double' #} - - --- Copying vectors - -{#fun igraph_vector_copy_to as ^ { `Vector', id `Ptr CDouble' } -> `()' #} - --- Vector properties -{#fun igraph_vector_size as ^ { `Vector' } -> `Int' #} - - -{#pointer *igraph_vector_ptr_t as VectorPtr foreign finalizer - igraph_vector_ptr_destroy_all newtype#} - -{#fun igraph_vector_ptr_init as igraphVectorPtrNew { +, `Int' } -> `VectorPtr' #} - -{#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 *igraph_strvector_t as StrVector foreign finalizer igraph_strvector_destroy newtype#} - -{#fun igraph_strvector_init as igraphStrvectorNew { +, `Int' } -> `StrVector' #} - -{#fun igraph_strvector_get as ^ - { `StrVector' - , `Int' - , alloca- `String' peekString* - } -> `CInt' void-#} - -peekString :: Ptr CString -> IO String -peekString ptr = peek ptr >>= peekCString -{-# INLINE peekString #-} - -{#fun igraph_strvector_set as ^ { `StrVector', `Int', id `CString'} -> `()' #} -{#fun igraph_strvector_set2 as ^ { `StrVector', `Int', id `CString', `Int'} -> `()' #} - -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 - where - n = length xs - - --------------------------------------------------------------------------------- --- Customized string vector --------------------------------------------------------------------------------- - -newtype BSLen = BSLen CStringLen - -instance Storable BSLen where - sizeOf _ = {#sizeof bytestring_t #} - alignment _ = {#alignof bytestring_t #} - peek p = do - n <- ({#get bytestring_t->len #} p) - ptr <- {#get bytestring_t->value #} p - return $ BSLen (ptr, fromIntegral n) - poke p (BSLen (ptr, n)) = {#set bytestring_t.len #} p (fromIntegral n) >> - {#set bytestring_t.value #} p ptr - -{#pointer *bsvector_t as BSVector foreign finalizer bsvector_destroy newtype#} - -{#fun bsvector_init as bsvectorNew { +, `Int' } -> `BSVector' #} - ---{#fun bsvector_get as bsVectorGet { `BSVectorPtr', `Int', + } -> `Ptr (Ptr BSLen)' id #} - -{- -bsVectorGet :: BSVectorPtr -> Int -> BSLen -bsVectorGet vec i = unsafePerformIO $ do - ptrptr <- bsVectorGet vec i - peek ptrptr >>= peek - -} - -{#fun bsvector_set as ^ { `BSVector', `Int', `Ptr ()'} -> `()' #} - -toBSVector :: [BSLen] -> IO BSVector -toBSVector xs = do - vec <- bsvectorNew n - forM_ (zip [0..] xs) $ \(i, x) -> with x $ \ptr -> bsvectorSet vec i $ castPtr ptr - return vec - where - n = length xs - - -{#pointer *igraph_matrix_t as Matrix foreign finalizer igraph_matrix_destroy newtype#} - -{#fun igraph_matrix_init as igraphMatrixNew { +, `Int', `Int' } -> `Matrix' #} - -{#fun igraph_matrix_null as ^ { `Matrix' } -> `()' #} - -{#fun igraph_matrix_fill as ^ { `Matrix', `Double' } -> `()' #} - -{#fun igraph_matrix_e as ^ { `Matrix', `Int', `Int' } -> `Double' #} - -{#fun igraph_matrix_set as ^ { `Matrix', `Int', `Int', `Double' } -> `()' #} - -{#fun igraph_matrix_copy_to as ^ { `Matrix', id `Ptr CDouble' } -> `()' #} - -{#fun igraph_matrix_nrow as ^ { `Matrix' } -> `Int' #} - -{#fun igraph_matrix_ncol as ^ { `Matrix' } -> `Int' #} - --- row lists to matrix -fromRowLists :: [[Double]] -> IO Matrix -fromRowLists xs - | all (==c) $ map length xs = do - mptr <- igraphMatrixNew r c - forM_ (zip [0..] xs) $ \(i, row) -> - forM_ (zip [0..] row) $ \(j,v) -> - igraphMatrixSet mptr i j v - return mptr - | otherwise = error "Not a matrix." - where - r = length xs - c = length $ head xs - --- to row lists -toRowLists :: Matrix -> IO [[Double]] -toRowLists = liftM transpose . toColumnLists - -toColumnLists :: Matrix -> IO [[Double]] -toColumnLists mptr = do - r <- igraphMatrixNrow mptr - c <- igraphMatrixNcol mptr - xs <- allocaArray (r*c) $ \ptr -> do - igraphMatrixCopyTo mptr ptr - peekArray (r*c) ptr - return $ chunksOf r $ map realToFrac xs diff --git a/src/IGraph/Internal/Graph.chs b/src/IGraph/Internal/Graph.chs deleted file mode 100644 --- a/src/IGraph/Internal/Graph.chs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Graph where - -import Control.Monad -import Foreign -import Foreign.C.Types -import System.IO.Unsafe (unsafePerformIO) - -import IGraph.Internal.C2HS -{#import IGraph.Internal.Initialization #} -{#import IGraph.Internal.Data #} -{#import IGraph.Internal.Constants #} - -#include "haskell_igraph.h" - --------------------------------------------------------------------------------- --- Graph Constructors and Destructors --------------------------------------------------------------------------------- - -{#pointer *igraph_t as IGraph foreign finalizer igraph_destroy newtype#} - -{#fun igraph_empty as igraphNew' { +, `Int', `Bool' } -> `IGraph' #} - -{#fun igraph_copy as ^ { +, `IGraph' } -> `IGraph' #} - --- | Create a igraph object and attach a finalizer -igraphNew :: Int -> Bool -> HasInit -> IO IGraph -igraphNew n directed _ = igraphNew' n directed - --------------------------------------------------------------------------------- --- Basic Query Operations --------------------------------------------------------------------------------- - -{#fun igraph_vcount as ^ { `IGraph' } -> `Int' #} - -{#fun igraph_ecount as ^ { `IGraph' } -> `Int' #} - -{#fun igraph_get_eid as ^ - { `IGraph' - , alloca- `Int' peekIntConv* - , `Int' - , `Int' - , `Bool' - , `Bool' - } -> `CInt' void-#} - -{#fun igraph_edge as ^ - { `IGraph' - , `Int' - , alloca- `Int' peekIntConv* - , alloca- `Int' peekIntConv* - } -> `CInt' void-#} - --- Adding and Deleting Vertices and Edges - -{# fun igraph_add_vertices as ^ { `IGraph', `Int', id `Ptr ()' } -> `()' #} - -{# fun igraph_add_edge as ^ { `IGraph', `Int', `Int' } -> `()' #} - --- | The edges are given in a vector, the first two elements define the first --- edge (the order is from , to for directed graphs). The vector should --- contain even number of integer numbers between zero and the number of --- vertices in the graph minus one (inclusive). If you also want to add --- 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. - , id `Ptr ()' -- ^ The attributes of the new edges. - } -> `()' #} - - --- generators - -{#fun igraph_full as ^ { +, `Int', `Bool', `Bool' } -> `IGraph' #} - -{#fun igraph_erdos_renyi_game as ^ { +, `ErdosRenyi', `Int', `Double', `Bool' - , `Bool' } -> `IGraph' #} - -{#fun igraph_degree_sequence_game as ^ { +, `Vector', `Vector' - , `Degseq' } -> `IGraph' #} - -{#fun igraph_rewire as ^ { `IGraph', `Int', `Rewiring' } -> `Int' #} - - -{#fun igraph_isoclass_create as ^ { +, `Int', `Int', `Bool' } -> `IGraph' #} diff --git a/src/IGraph/Internal/Isomorphism.chs b/src/IGraph/Internal/Isomorphism.chs deleted file mode 100644 --- a/src/IGraph/Internal/Isomorphism.chs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Isomorphism where - -import Foreign -import Foreign.C.Types - -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Data #} - -#include "haskell_igraph.h" - -{#fun igraph_get_subisomorphisms_vf2 as ^ { `IGraph', `IGraph', - id `Ptr ()', id `Ptr ()', id `Ptr ()', id `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 ()'} -> `Int' #} - -{#fun igraph_isomorphic as ^ { `IGraph', `IGraph', id `Ptr CInt' } -> `Int' #} diff --git a/src/IGraph/Internal/Layout.chs b/src/IGraph/Internal/Layout.chs deleted file mode 100644 --- a/src/IGraph/Internal/Layout.chs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Layout where - -import qualified Foreign.Marshal.Utils as C2HSImp -import qualified Foreign.Ptr as C2HSImp - -import Foreign -import Foreign.C.Types - -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Data #} - -#include "igraph/igraph.h" - -{#fun igraph_layout_kamada_kawai as ^ { `IGraph' -, `Matrix' -, `Int' -, `Double' -, `Double' -, `Double' -, `Double' -, `Bool' -, id `Ptr Vector' -, id `Ptr Vector' -, id `Ptr Vector' -, id `Ptr Vector' -} -> `Int' #} - -{# fun igraph_layout_lgl as ^ { `IGraph' -, `Matrix' -, `Int' -, `Double' -, `Double' -, `Double' -, `Double' -, `Double' -, `Int' -} -> `Int' #} diff --git a/src/IGraph/Internal/Motif.chs b/src/IGraph/Internal/Motif.chs deleted file mode 100644 --- a/src/IGraph/Internal/Motif.chs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Motif where - -import qualified Foreign.Marshal.Utils as C2HSImp -import qualified Foreign.Ptr as C2HSImp -import Foreign -import Foreign.C.Types - -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Selector #} -{#import IGraph.Internal.Constants #} -{#import IGraph.Internal.Data #} - -#include "haskell_igraph.h" - -{#fun igraph_triad_census as ^ { `IGraph' - , `Vector' } -> `Int' #} - -{#fun igraph_motifs_randesu as ^ { `IGraph', `Vector', `Int' - , `Vector' } -> `Int' #} diff --git a/src/IGraph/Internal/Selector.chs b/src/IGraph/Internal/Selector.chs deleted file mode 100644 --- a/src/IGraph/Internal/Selector.chs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Selector where - -import Control.Monad -import Foreign -import Foreign.C.Types -import System.IO.Unsafe (unsafePerformIO) - -{#import IGraph.Internal.Constants #} -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Data #} - -#include "haskell_igraph.h" - -{#pointer *igraph_vs_t as IGraphVs foreign finalizer igraph_vs_destroy newtype #} - -{#fun igraph_vs_all as ^ { + } -> `IGraphVs' #} - -{#fun igraph_vs_adj as ^ { +, `Int', `Neimode' } -> `IGraphVs' #} - -{#fun igraph_vs_vector as ^ { +, `Vector' } -> `IGraphVs' #} - - --- Vertex iterator - -{#pointer *igraph_vit_t as IGraphVit foreign finalizer igraph_vit_destroy newtype #} - -#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', + } -> `IGraphVit' #} - -{#fun igraph_vit_end as ^ { `IGraphVit' } -> `Bool' #} - -{#fun igraph_vit_next as ^ { `IGraphVit' } -> `()' #} - -{#fun igraph_vit_get as ^ { `IGraphVit' } -> `Int' #} - -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 - - --- Edge Selector - -{#pointer *igraph_es_t as IGraphEs foreign finalizer igraph_es_destroy newtype #} - -{#fun igraph_es_all as ^ { +, `EdgeOrderType' } -> `IGraphEs' #} - -{# fun igraph_es_vector as ^ { +, `Vector' } -> `IGraphEs' #} - - --- Edge iterator - -{#pointer *igraph_eit_t as IGraphEit foreign finalizer igraph_eit_destroy newtype #} - -#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', + } -> `IGraphEit' #} - -{#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 - --- delete vertices - -{# fun igraph_delete_vertices as ^ { `IGraph', %`IGraphVs' } -> `Int' #} - - --- delete edges - -{# fun igraph_delete_edges as ^ { `IGraph', %`IGraphEs' } -> `Int' #} diff --git a/src/IGraph/Internal/Structure.chs b/src/IGraph/Internal/Structure.chs deleted file mode 100644 --- a/src/IGraph/Internal/Structure.chs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Internal.Structure where - -import Foreign -import Foreign.C.Types - -{#import IGraph.Internal.Graph #} -{#import IGraph.Internal.Selector #} -{#import IGraph.Internal.Constants #} -{#import IGraph.Internal.Data #} -{#import IGraph.Internal.Arpack #} - -#include "igraph/igraph.h" - -{#fun igraph_induced_subgraph as ^ { `IGraph' - , +160 - , %`IGraphVs' - , `SubgraphImplementation' } -> `IGraph' #} - -{#fun igraph_closeness as ^ { `IGraph' - , `Vector' - , %`IGraphVs' - , `Neimode' - , `Vector' - , `Bool' } -> `Int' #} - -{#fun igraph_betweenness as ^ { `IGraph' - , `Vector' - , %`IGraphVs' - , `Bool' - , `Vector' - , `Bool' } -> `Int' #} - -{#fun igraph_eigenvector_centrality as ^ { `IGraph' - , `Vector' - , id `Ptr CDouble' - , `Bool' - , `Bool' - , `Vector' - , `ArpackOpt' } -> `Int' #} - -{#fun igraph_pagerank as ^ { `IGraph' - , `PagerankAlgo' - , `Vector' - , id `Ptr CDouble' - , %`IGraphVs' - , `Bool' - , `Double' - , `Vector' - , id `Ptr ()' } -> `Int' #} - -{#fun igraph_personalized_pagerank as ^ { `IGraph' - , `PagerankAlgo' - , `Vector' - , id `Ptr CDouble' - , %`IGraphVs' - , `Bool' - , `Double' - , `Vector' - , `Vector' - , id `Ptr ()' } -> `Int' #} diff --git a/src/IGraph/Internal/Types.chs b/src/IGraph/Internal/Types.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Internal/Types.chs @@ -0,0 +1,231 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/IGraph/Isomorphism.chs @@ -0,0 +1,84 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Isomorphism + ( getSubisomorphisms + , isomorphic + , isoclassCreate + , isoclass3 + , isoclass4 + ) where + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign +import Foreign.C.Types + +import IGraph +import IGraph.Internal.Initialization (igraphInit) +import IGraph.Mutable +{#import IGraph.Internal #} + +#include "haskell_igraph.h" + +getSubisomorphisms :: Graph d + => LGraph d v1 e1 -- ^ graph to be searched in + -> LGraph d v2 e2 -- ^ smaller graph + -> [[Int]] +getSubisomorphisms g1 g2 = unsafePerformIO $ do + vpptr <- igraphVectorPtrNew 0 + igraphGetSubisomorphismsVf2 gptr1 gptr2 nullPtr nullPtr nullPtr nullPtr vpptr + nullFunPtr nullFunPtr nullPtr + (map.map) truncate <$> toLists vpptr + where + gptr1 = _graph g1 + gptr2 = _graph g2 +{-# INLINE getSubisomorphisms #-} +{#fun igraph_get_subisomorphisms_vf2 as ^ + { `IGraph' + , `IGraph' + , id `Ptr ()' + , id `Ptr ()' + , id `Ptr ()' + , id `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 + -> Bool +isomorphic g1 g2 = unsafePerformIO $ alloca $ \ptr -> do + _ <- igraphIsomorphic (_graph g1) (_graph g2) ptr + x <- peek ptr + return (x /= 0) +{#fun igraph_isomorphic as ^ { `IGraph', `IGraph', id `Ptr CInt' } -> `CInt' void- #} + +-- | Creates a graph from the given isomorphism class. +-- This function is implemented only for graphs with three or four vertices. +isoclassCreate :: Graph 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 +{#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 + where + n | isD d = [0..15] + | otherwise = [0..3] + +isoclass4 :: Graph d => d -> [LGraph d () ()] +isoclass4 d = map (flip (isoclassCreate 4) d) n + where + n | isD d = [0..217] + | otherwise = [0..10] diff --git a/src/IGraph/Isomorphism.hs b/src/IGraph/Isomorphism.hs deleted file mode 100644 --- a/src/IGraph/Isomorphism.hs +++ /dev/null @@ -1,65 +0,0 @@ -module IGraph.Isomorphism - ( getSubisomorphisms - , isomorphic - , isoclassCreate - , isoclass3 - , isoclass4 - ) where - -import Foreign -import Foreign.C.Types -import System.IO.Unsafe (unsafePerformIO) - -import IGraph -import IGraph.Internal.Data -import IGraph.Internal.Graph -import IGraph.Internal.Initialization (igraphInit) -import IGraph.Internal.Isomorphism -import IGraph.Mutable - -getSubisomorphisms :: Graph d - => LGraph d v1 e1 -- ^ graph to be searched in - -> LGraph d v2 e2 -- ^ smaller graph - -> [[Int]] -getSubisomorphisms g1 g2 = unsafePerformIO $ do - vpptr <- igraphVectorPtrNew 0 - igraphGetSubisomorphismsVf2 gptr1 gptr2 nullPtr nullPtr nullPtr nullPtr vpptr - nullFunPtr nullFunPtr nullPtr - (map.map) truncate <$> toLists vpptr - where - gptr1 = _graph g1 - gptr2 = _graph g2 -{-# INLINE getSubisomorphisms #-} - --- | Determine whether two graphs are isomorphic. -isomorphic :: Graph d - => LGraph d v1 e1 - -> LGraph d v2 e2 - -> Bool -isomorphic g1 g2 = unsafePerformIO $ alloca $ \ptr -> do - _ <- igraphIsomorphic (_graph g1) (_graph g2) ptr - x <- peek ptr - return (x /= 0) - --- | Creates a graph from the given isomorphism class. --- This function is implemented only for graphs with three or four vertices. -isoclassCreate :: Graph 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 - -isoclass3 :: Graph d => d -> [LGraph d () ()] -isoclass3 d = map (flip (isoclassCreate 3) d) n - where - n | isD d = [0..15] - | otherwise = [0..3] - -isoclass4 :: Graph d => d -> [LGraph d () ()] -isoclass4 d = map (flip (isoclassCreate 4) d) n - where - n | isD d = [0..217] - | otherwise = [0..10] diff --git a/src/IGraph/Layout.chs b/src/IGraph/Layout.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Layout.chs @@ -0,0 +1,114 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Layout + ( getLayout + , LayoutMethod(..) + , defaultKamadaKawai + , defaultLGL + ) where + +import Data.Maybe (isJust) +import Foreign (nullPtr) + +import qualified Foreign.Ptr as C2HSImp +import Foreign + +import IGraph +{#import IGraph.Internal #} + +#include "igraph/igraph.h" + +data LayoutMethod = + KamadaKawai { kk_seed :: !(Maybe [(Double, Double)]) + , kk_nIter :: !Int + , kk_sigma :: (Int -> Double) -- ^ The base standard deviation of + -- position change proposals + , kk_startTemp :: !Double -- ^ The initial temperature for the annealing + , kk_coolFact :: !Double -- ^ The cooling factor for the simulated annealing + , kk_const :: (Int -> Double) -- ^ The Kamada-Kawai vertex attraction constant + } + | LGL { lgl_nIter :: !Int + , lgl_maxdelta :: (Int -> Double) -- ^ The maximum length of the move allowed + -- for a vertex in a single iteration. A reasonable default is the number of vertices. + , lgl_area :: (Int -> Double) -- ^ This parameter gives the area + -- of the square on which the vertices will be placed. A reasonable + -- default value is the number of vertices squared. + , lgl_coolexp :: !Double -- ^ The cooling exponent. A reasonable default value is 1.5. + , lgl_repulserad :: (Int -> Double) -- ^ Determines the radius at which + -- vertex-vertex repulsion cancels out attraction of adjacent vertices. + -- A reasonable default value is area times the number of vertices. + , lgl_cellsize :: (Int -> Double) + } + +defaultKamadaKawai :: LayoutMethod +defaultKamadaKawai = KamadaKawai + { kk_seed = Nothing + , kk_nIter = 10 + , kk_sigma = \x -> fromIntegral x / 4 + , kk_startTemp = 10 + , kk_coolFact = 0.99 + , kk_const = \x -> fromIntegral $ x^2 + } + +defaultLGL :: LayoutMethod +defaultLGL = LGL + { lgl_nIter = 100 + , lgl_maxdelta = \x -> fromIntegral x + , lgl_area = area + , lgl_coolexp = 1.5 + , lgl_repulserad = \x -> fromIntegral x * area x + , lgl_cellsize = \x -> area x ** 0.25 + } + 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 + (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr + [x, y] <- toColumnLists mptr + 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 + where + n = nNodes gr + gptr = _graph gr + +{#fun igraph_layout_kamada_kawai as ^ + { `IGraph' + , `Matrix' + , `Int' + , `Double' + , `Double' + , `Double' + , `Double' + , `Bool' + , id `Ptr Vector' + , id `Ptr Vector' + , id `Ptr Vector' + , id `Ptr Vector' + } -> `CInt' void- #} + +{# fun igraph_layout_lgl as ^ + { `IGraph' + , `Matrix' + , `Int' + , `Double' + , `Double' + , `Double' + , `Double' + , `Double' + , `Int' + } -> `CInt' void- #} diff --git a/src/IGraph/Layout.hs b/src/IGraph/Layout.hs deleted file mode 100644 --- a/src/IGraph/Layout.hs +++ /dev/null @@ -1,86 +0,0 @@ -module IGraph.Layout - ( getLayout - , LayoutMethod(..) - , defaultKamadaKawai - , defaultLGL - ) where - -import Control.Applicative ((<$>)) -import Data.Default.Class -import Data.Maybe (isJust) -import Foreign (nullPtr) -import System.IO.Unsafe (unsafePerformIO) - -import IGraph -import IGraph.Internal.Clique -import IGraph.Internal.Data -import IGraph.Internal.Layout - -data LayoutMethod = - KamadaKawai { kk_seed :: !(Maybe [(Double, Double)]) - , kk_nIter :: !Int - , kk_sigma :: (Int -> Double) -- ^ The base standard deviation of - -- position change proposals - , kk_startTemp :: !Double -- ^ The initial temperature for the annealing - , kk_coolFact :: !Double -- ^ The cooling factor for the simulated annealing - , kk_const :: (Int -> Double) -- ^ The Kamada-Kawai vertex attraction constant - } - | LGL { lgl_nIter :: !Int - , lgl_maxdelta :: (Int -> Double) -- ^ The maximum length of the move allowed - -- for a vertex in a single iteration. A reasonable default is the number of vertices. - , lgl_area :: (Int -> Double) -- ^ This parameter gives the area - -- of the square on which the vertices will be placed. A reasonable - -- default value is the number of vertices squared. - , lgl_coolexp :: !Double -- ^ The cooling exponent. A reasonable default value is 1.5. - , lgl_repulserad :: (Int -> Double) -- ^ Determines the radius at which - -- vertex-vertex repulsion cancels out attraction of adjacent vertices. - -- A reasonable default value is area times the number of vertices. - , lgl_cellsize :: (Int -> Double) - } - -defaultKamadaKawai :: LayoutMethod -defaultKamadaKawai = KamadaKawai - { kk_seed = Nothing - , kk_nIter = 10 - , kk_sigma = \x -> fromIntegral x / 4 - , kk_startTemp = 10 - , kk_coolFact = 0.99 - , kk_const = \x -> fromIntegral $ x^2 - } - -defaultLGL :: LayoutMethod -defaultLGL = LGL - { lgl_nIter = 100 - , lgl_maxdelta = \x -> fromIntegral x - , lgl_area = area - , lgl_coolexp = 1.5 - , lgl_repulserad = \x -> fromIntegral x * area x - , lgl_cellsize = \x -> area x ** 0.25 - } - 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 - (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr - [x, y] <- toColumnLists mptr - 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 - where - n = nNodes gr - gptr = _graph gr diff --git a/src/IGraph/Motif.chs b/src/IGraph/Motif.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Motif.chs @@ -0,0 +1,70 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Motif + ( triad + , triadCensus + ) where + +import Data.Hashable (Hashable) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Foreign.Ptr as C2HSImp + +import IGraph +{#import IGraph.Internal #} + +#include "haskell_igraph.h" + +-- | Every triple of vertices in a directed graph +-- 003: A, B, C, the empty graph. +-- 012: A->B, C, a graph with a single directed edge. +-- 102: A<->B, C, a graph with a mutual connection between two vertices. +-- 021D: A<-B->C, the binary out-tree. +-- 021U: A->B<-C, the binary in-tree. +-- 021C: A->B->C, the directed line. +-- 111D: A<->B<-C. +-- 111U: A<->B->C. +-- 030T: A->B<-C, A->C. Feed forward loop. +-- 030C: A<-B<-C, A->C. +-- 201: A<->B<->C. +-- 120D: A<-B->C, A<->C. +-- 120U: A->B<-C, A<->C. +-- 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 = map make edgeList + where + edgeList = + [ [] + , [(0,1)] + , [(0,1), (1,0)] + , [(1,0), (1,2)] + , [(0,1), (2,1)] + , [(0,1), (1,2)] + , [(0,1), (1,0), (2,1)] + , [(0,1), (1,0), (1,2)] + , [(0,1), (2,1), (0,2)] + , [(1,0), (2,1), (0,2)] + , [(0,1), (1,0), (0,2), (2,0)] + , [(1,0), (1,2), (0,2), (2,0)] + , [(0,1), (2,1), (0,2), (2,0)] + , [(0,1), (1,2), (0,2), (2,0)] + , [(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 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 + +-- motifsRandesu + +{#fun igraph_triad_census as ^ { `IGraph' + , `Vector' } -> `CInt' void- #} + +{#fun igraph_motifs_randesu as ^ { `IGraph', `Vector', `Int' + , `Vector' } -> `CInt' void- #} diff --git a/src/IGraph/Motif.hs b/src/IGraph/Motif.hs deleted file mode 100644 --- a/src/IGraph/Motif.hs +++ /dev/null @@ -1,60 +0,0 @@ -module IGraph.Motif - ( triad - , triadCensus - ) where - -import Data.Hashable (Hashable) -import System.IO.Unsafe (unsafePerformIO) - -import IGraph -import IGraph.Internal.Motif -import IGraph.Internal.Data - --- | Every triple of vertices in a directed graph --- 003: A, B, C, the empty graph. --- 012: A->B, C, a graph with a single directed edge. --- 102: A<->B, C, a graph with a mutual connection between two vertices. --- 021D: A<-B->C, the binary out-tree. --- 021U: A->B<-C, the binary in-tree. --- 021C: A->B->C, the directed line. --- 111D: A<->B<-C. --- 111U: A<->B->C. --- 030T: A->B<-C, A->C. Feed forward loop. --- 030C: A<-B<-C, A->C. --- 201: A<->B<->C. --- 120D: A<-B->C, A<->C. --- 120U: A->B<-C, A<->C. --- 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 = map make edgeList - where - edgeList = - [ [] - , [(0,1)] - , [(0,1), (1,0)] - , [(1,0), (1,2)] - , [(0,1), (2,1)] - , [(0,1), (1,2)] - , [(0,1), (1,0), (2,1)] - , [(0,1), (1,0), (1,2)] - , [(0,1), (2,1), (0,2)] - , [(1,0), (2,1), (0,2)] - , [(0,1), (1,0), (0,2), (2,0)] - , [(1,0), (1,2), (0,2), (2,0)] - , [(0,1), (2,1), (0,2), (2,0)] - , [(0,1), (1,2), (0,2), (2,0)] - , [(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 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 - --- motifsRandesu diff --git a/src/IGraph/Mutable.hs b/src/IGraph/Mutable.hs --- a/src/IGraph/Mutable.hs +++ b/src/IGraph/Mutable.hs @@ -4,40 +4,17 @@ , MLGraph(..) , setEdgeAttr , setNodeAttr - , edgeAttr - , vertexAttr - , withVertexAttr - , withEdgeAttr )where import Control.Monad (when, forM) import Control.Monad.Primitive -import qualified Data.ByteString.Char8 as B -import Data.Serialize (Serialize) +import Data.Serialize (Serialize, encode) import Foreign -import Foreign.C.String (CString, withCString) -import IGraph.Internal.Attribute -import IGraph.Internal.Data -import IGraph.Internal.Graph +import IGraph.Internal import IGraph.Internal.Initialization -import IGraph.Internal.Selector import IGraph.Types -vertexAttr :: String -vertexAttr = "vertex_attribute" - -edgeAttr :: String -edgeAttr = "edge_attribute" - -withVertexAttr :: (CString -> IO a) -> IO a -withVertexAttr = withCString vertexAttr -{-# INLINE withVertexAttr #-} - -withEdgeAttr :: (CString -> IO a) -> IO a -withEdgeAttr = withCString edgeAttr -{-# INLINE withEdgeAttr #-} - -- | Mutable labeled graph. newtype MLGraph m d v e = MLGraph IGraph @@ -55,10 +32,11 @@ addLNodes :: (Serialize v, PrimMonad m) => [v] -- ^ vertices' labels -> MLGraph (PrimState m) d v e -> m () - addLNodes labels (MLGraph g) = unsafePrimToPrim $ withVertexAttr $ - \vattr -> asBSVector labels $ \bsvec -> with (mkStrRec vattr bsvec) $ - \ptr -> do vptr <- fromPtrs [castPtr ptr] - withVectorPtr vptr (igraphAddVertices g n . castPtr) + 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 @@ -67,7 +45,7 @@ delNodes ns (MLGraph g) = unsafePrimToPrim $ do vptr <- fromList $ map fromIntegral ns vsptr <- igraphVsVector vptr - igraphDeleteVertices g vsptr + _ <- igraphDeleteVertices g vsptr return () -- | Add edges to the graph. @@ -80,10 +58,11 @@ -- | 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 $ withEdgeAttr $ \eattr -> - asBSVector vs $ \bsvec -> with (mkStrRec eattr bsvec) $ \ptr -> do + addLEdges es (MLGraph g) = unsafePrimToPrim $ do + bsvec <- toBSVector $ map encode vs + withAttr edgeAttr bsvec $ \attr -> do vec <- fromList $ concat xs - vptr <- fromPtrs [castPtr ptr] + vptr <- fromPtrs [castPtr attr] withVectorPtr vptr (igraphAddEdges g vec . castPtr) where (xs, vs) = unzip $ map ( \((a,b),v) -> ([fromIntegral a, fromIntegral b], v) ) es @@ -98,7 +77,7 @@ eids <- forM es $ \(fr, to) -> igraphGetEid g fr to False True vptr <- fromList $ map fromIntegral eids esptr <- igraphEsVector vptr - igraphDeleteEdges g esptr + _ <- igraphDeleteEdges g esptr return () instance MGraph D where @@ -117,10 +96,9 @@ -> v -> MLGraph (PrimState m) d v e -> m () -setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ asBS x $ \bs -> - with bs $ \bsptr -> do - err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId bsptr - when (err /= 0) $ error "Fail to set node attribute!" +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!" -- | Set edge attribute. setEdgeAttr :: (PrimMonad m, Serialize e) @@ -128,7 +106,6 @@ -> e -> MLGraph (PrimState m) d v e -> m () -setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ asBS x $ \bs -> - with bs $ \bsptr -> do - err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId bsptr - when (err /= 0) $ error "Fail to set edge attribute!" +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!" diff --git a/src/IGraph/Structure.chs b/src/IGraph/Structure.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Structure.chs @@ -0,0 +1,181 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Structure + ( inducedSubgraph + , closeness + , betweenness + , eigenvectorCentrality + , pagerank + , personalizedPagerank + ) where + +import Control.Monad +import Data.Either (fromRight) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as M +import Data.Serialize (Serialize, decode) +import System.IO.Unsafe (unsafePerformIO) + +import Foreign +import Foreign.C.Types + +import IGraph +import IGraph.Mutable +{#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 + +-- | Closeness centrality +closeness :: [Int] -- ^ vertices + -> LGraph 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 + +-- | Betweenness centrality +betweenness :: [Int] + -> LGraph 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 + +-- | Eigenvector centrality +eigenvectorCentrality :: LGraph 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 + +-- | Google's PageRank +pagerank :: Graph d + => LGraph d v e + -> 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 + | 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 + 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' + , id `Ptr CDouble' + , %`IGraphVs' + , `Bool' + , `Double' + , `Vector' + , id `Ptr ()' + } -> `CInt' void- #} + +{#fun igraph_personalized_pagerank as ^ + { `IGraph' + , `PagerankAlgo' + , `Vector' + , id `Ptr CDouble' + , %`IGraphVs' + , `Bool' + , `Double' + , `Vector' + , `Vector' + , id `Ptr ()' + } -> `CInt' void- #} diff --git a/src/IGraph/Structure.hs b/src/IGraph/Structure.hs deleted file mode 100644 --- a/src/IGraph/Structure.hs +++ /dev/null @@ -1,130 +0,0 @@ -module IGraph.Structure - ( inducedSubgraph - , closeness - , betweenness - , eigenvectorCentrality - , pagerank - , personalizedPagerank - ) where - -import Control.Monad -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as M -import Data.Serialize (Serialize) -import Foreign -import Foreign.C.Types -import System.IO.Unsafe (unsafePerformIO) - -import IGraph -import IGraph.Internal.Arpack -import IGraph.Internal.Attribute -import IGraph.Internal.Constants -import IGraph.Internal.Data -import IGraph.Internal.Graph -import IGraph.Internal.Selector -import IGraph.Internal.Structure -import IGraph.Mutable - -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' - g' <- igraphInducedSubgraph (_graph gr) vsptr IgraphSubgraphCreateFromScratch - nV <- igraphVcount g' - labels <- forM [0 .. nV - 1] $ \i -> - igraphHaskellAttributeVAS g' vertexAttr i >>= fromBS - return $ LGraph g' $ M.fromListWith (++) $ zip labels $ map return [0..nV-1] - --- | Closeness centrality -closeness :: [Int] -- ^ vertices - -> LGraph 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 - --- | Betweenness centrality -betweenness :: [Int] - -> LGraph 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 - --- | Eigenvector centrality -eigenvectorCentrality :: LGraph 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 - --- | Google's PageRank -pagerank :: Graph d - => LGraph d v e - -> 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 - | 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 - where - n = nNodes gr - m = nEdges gr diff --git a/src/IGraph/Types.hs b/src/IGraph/Types.hs --- a/src/IGraph/Types.hs +++ b/src/IGraph/Types.hs @@ -1,11 +1,9 @@ module IGraph.Types where -import qualified Data.HashMap.Strict as M - -import IGraph.Internal.Graph - type Node = Int +type LNode a = (Node, a) + type Edge = (Node, Node) type LEdge a = (Edge, a) @@ -14,3 +12,9 @@ -- | Directed graph. data D + +vertexAttr :: String +vertexAttr = "vertex_attribute" + +edgeAttr :: String +edgeAttr = "edge_attribute" diff --git a/tests/Test/Attributes.hs b/tests/Test/Attributes.hs --- a/tests/Test/Attributes.hs +++ b/tests/Test/Attributes.hs @@ -17,7 +17,7 @@ import IGraph import IGraph.Exporter.GEXF -import IGraph.Internal.Attribute +import IGraph.Internal import IGraph.Mutable import IGraph.Structure