0.3.0

haskell-igraph.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                haskell-igraph
-version:             0.2.3-dev
+version:             0.3.0
 synopsis:            Imcomplete igraph bindings
 description:         This is an attempt to create a complete bindings for the
                      igraph<"http://igraph.org/c/"> library.
@@ -80,6 +80,7 @@ test-suite tests
   other-modules:
     Test.Basic
     Test.Structure
+    Test.Isomorphism
     Test.Motif
     Test.Utils
 

src/IGraph.hs

@@ -17,8 +17,10 @@ module IGraph
     , pre
     , suc
 
-    , filterNode
-    , filterEdge
+    , mapNodes
+    , mapEdges
+    , filterNodes
+    , filterEdges
 
     , nmap
     , emap
@@ -193,18 +195,39 @@ pre gr i = unsafePerformIO $ do
     vitToList vit
 
 -- | Keep nodes that satisfy the constraint
-filterNode :: (Hashable v, Eq v, Read v, Graph d)
+filterNodes :: (Hashable v, Eq v, Read v, Graph d)
             => (LGraph d v e -> Node -> Bool) -> LGraph d v e -> LGraph d v e
-filterNode f gr = runST $ do
+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, Read v1, Show v2, Hashable v2, Eq v2, Read v2)
+         => (Node -> v1 -> v2) -> LGraph d v1 e -> LGraph d v2 e
+mapNodes f gr = runST $ do
+    (MLGraph gptr) <- thaw gr
+    let gr' = MLGraph gptr
+    forM_ (nodes gr) $ \x -> setNodeAttr x (f x $ nodeLab gr x) gr'
+    unsafeFreeze gr'
+
+-- | Apply a function to change edges' labels.
+mapEdges :: (Graph d, Read e1, Show e2, Hashable v, Eq v, Read v)
+         => (Edge -> e1 -> e2) -> LGraph d v e1 -> LGraph d v e2
+mapEdges 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'
+    unsafeFreeze gr'
+
+
 -- | Keep nodes that satisfy the constraint
-filterEdge :: (Hashable v, Eq v, Read v, Graph d)
+filterEdges :: (Hashable v, Eq v, Read v, Graph d)
             => (LGraph d v e -> Edge -> Bool) -> LGraph d v e -> LGraph d v e
-filterEdge f gr = runST $ do
+filterEdges f gr = runST $ do
     let deleted = filter (not . f gr) $ edges gr
     gr' <- thaw gr
     delEdges deleted gr'

src/IGraph/Exporter/GEXF.hs

@@ -53,8 +53,8 @@ defaultEdgeAttributes = EdgeAttr
     { _edgeLabel = ""
     , _edgeColour = opaque black
     , _edgeWeight = 1.0
-    , _edgeArrowLength = 5.0
-    , _edgeZindex = 0
+    , _edgeArrowLength = 10
+    , _edgeZindex = 2
     }
 
 genXMLTree :: (ArrowXml a, Graph d) => LGraph d NodeAttr EdgeAttr -> a XmlTree XmlTree

src/IGraph/Exporter/Graphics.hs

@@ -26,19 +26,24 @@ graphToDiagram gr = mconcat $ fst $ unzip $ sortBy (flip (comparing snd)) $
                  , _nodeZindex nattr )
       where
         nattr = nodeLab gr x
-    drawEdge (from, to) = {-arrowBetween'
+    drawEdge (from, to) = ( arrowBetween'
         ( with & arrowTail .~ noTail
                & arrowHead .~ arrowH
+               & headStyle %~ fc red
                & headLength .~ output (_edgeArrowLength eattr)
-        ) start end-}
-        ( fromVertices [start, end]
-        # lwO (_edgeWeight eattr) # lcA (_edgeColour eattr), _edgeZindex eattr )
+        ) start end # lwO (_edgeWeight eattr) # lcA (_edgeColour eattr), _edgeZindex eattr )
       where
         eattr = edgeLab gr (from, to)
-        start = _positionX nattr1 ^& _positionY nattr1
-        end = _positionX nattr2 ^& _positionY nattr2
+        start = x1 ^& y1
+        end = (alpha * x1 + (1 - alpha) * x2) ^& (alpha * y1 + (1 - alpha) * y2)
+        x1 = _positionX nattr1
+        y1 = _positionY nattr1
+        x2 = _positionX nattr2
+        y2 = _positionY nattr2
+        alpha = r / sqrt ((x1 - x2)**2 + (y1 - y2)**2)
+        r = _size nattr2
         nattr1 = nodeLab gr from
         nattr2 = nodeLab gr to
-    --arrowH | isDirected gr = dart
-    --       | otherwise = noHead
+        arrowH | isDirected gr = dart
+               | otherwise = noHead
 {-# INLINE graphToDiagram #-}

src/IGraph/Internal/Graph.chs

@@ -53,4 +53,7 @@ igraphEdge g i = alloca $ \fr -> alloca $ \to -> do
 
 {#fun igraph_full as ^ { +, `Int', `Bool', `Bool' } -> `IGraphPtr' #}
 
-{#fun igraph_erdos_renyi_game as ^ {+, `ErdosRenyi', `Int', `Double', `Bool', `Bool'} -> `IGraphPtr' #}
+{#fun igraph_erdos_renyi_game as ^ { +, `ErdosRenyi', `Int', `Double', `Bool'
+    , `Bool'} -> `IGraphPtr' #}
+    
+{#fun igraph_isoclass_create as ^ { +, `Int', `Int', `Bool' } -> `IGraphPtr' #}

src/IGraph/Internal/Isomorphism.chs

@@ -14,3 +14,5 @@ import Foreign.C.Types
     id `FunPtr (Ptr IGraphPtr -> Ptr IGraphPtr -> CInt -> CInt -> Ptr () -> IO CInt)',
     id `FunPtr (Ptr IGraphPtr -> Ptr IGraphPtr -> CInt -> CInt -> Ptr () -> IO CInt)',
     id `Ptr ()'} -> `Int' #}
+
+{#fun igraph_isomorphic as ^ { `IGraphPtr', `IGraphPtr', id `Ptr CInt' } -> `Int' #}

src/IGraph/Internal/Motif.chs

@@ -15,3 +15,6 @@ import Foreign.C.Types
 
 {#fun igraph_triad_census as ^ { `IGraphPtr'
                                , `VectorPtr' } -> `Int' #}
+
+{#fun igraph_motifs_randesu as ^ { `IGraphPtr', `VectorPtr', `Int'
+                                 , `VectorPtr' } -> `Int' #}

src/IGraph/Isomorphism.hs

-module IGraph.Isomorphism (getSubisomorphisms) where
+module IGraph.Isomorphism
+    ( getSubisomorphisms
+    , isomorphic
+    , isoclassCreate
+    , isoclass3
+    , isoclass4
+    ) where
 
 import           Foreign
 import           Foreign.C.Types
@@ -6,7 +12,10 @@ 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
@@ -21,3 +30,36 @@ getSubisomorphisms g1 g2 = unsafePerformIO $ do
     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]

src/IGraph/Motif.hs

@@ -56,3 +56,5 @@ triadCensus gr = unsafePerformIO $ do
     vptr <- igraphVectorNew 0
     igraphTriadCensus (_graph gr) vptr
     map truncate <$> vectorPtrToList vptr
+
+-- motifsRandesu

src/IGraph/Mutable.hs

 {-# LANGUAGE MultiParamTypeClasses #-}
 module IGraph.Mutable where
 
-import Foreign
+import           Control.Monad                  (when)
 import           Control.Monad.Primitive
+import qualified Data.ByteString.Char8          as B
+import           Foreign
 
-import IGraph.Internal.Graph
-import IGraph.Internal.Selector
-import IGraph.Internal.Data
 import           IGraph.Internal.Attribute
+import           IGraph.Internal.Data
+import           IGraph.Internal.Graph
 import           IGraph.Internal.Initialization
+import           IGraph.Internal.Selector
 
 -- constants
 vertexAttr :: String
@@ -110,3 +112,21 @@ instance MGraph D where
         return ()
       where
         eids = flip map es $ \(fr, to) -> igraphGetEid g fr to True True
+
+setNodeAttr :: (PrimMonad m, Show v)
+            => Int   -- ^ Node id
+            -> v
+            -> MLGraph (PrimState m) d v e
+            -> m ()
+setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ do
+    err <- igraphCattributeVASSet gr vertexAttr nodeId $ show x
+    when (err /= 0) $ error "Fail to set node attribute!"
+
+setEdgeAttr :: (PrimMonad m, Show v)
+            => Int   -- ^ Edge id
+            -> v
+            -> MLGraph (PrimState m) d v e
+            -> m ()
+setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ do
+    err <- igraphCattributeEASSet gr edgeAttr edgeId $ show x
+    when (err /= 0) $ error "Fail to set edge attribute!"

stack.yaml

+flags:
+  haskell-igraph:
+    graphics: true
+
 packages:
     - '.'
+
 extra-deps: []
+
 resolver: lts-8.5

tests/Test/Isomorphism.hs

+module Test.Isomorphism
+    ( tests
+    ) where
+
+import           Control.Arrow
+import           Control.Monad.ST
+import           Data.List
+import qualified Data.Matrix.Unboxed as M
+import           System.IO.Unsafe
+import           Test.Tasty
+import           Test.Tasty.HUnit
+import           Test.Utils
+
+import           IGraph
+import           IGraph
+import           IGraph.Motif
+import IGraph.Isomorphism
+
+tests :: TestTree
+tests = testGroup "Isomorphism"
+    [ graphIsomorphism ]
+
+graphIsomorphism :: TestTree
+graphIsomorphism = testCase "Graph isomorphism" $ assertBool "" $
+    and (zipWith isomorphic triad triad) &&
+    (not . or) (zipWith isomorphic triad $ reverse triad)

tests/test.hs

 import qualified Test.Basic       as Basic
+import qualified Test.Isomorphism as Isomorphism
 import qualified Test.Motif       as Motif
 import qualified Test.Structure   as Structure
 import           Test.Tasty
@@ -8,4 +9,5 @@ main = defaultMain $ testGroup "Haskell-igraph Tests"
     [ Basic.tests
     , Structure.tests
     , Motif.tests
+    , Isomorphism.tests
     ]