graph-core 0.2.0.1 → 0.2.1.0

raw patch · 12 files changed

+391/−398 lines, 12 filesdep −safecopydep ~HTFdep ~QuickCheckdep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: safecopy

Dependency ranges changed: HTF, QuickCheck, containers, deepseq, hashable, mtl, safe, unordered-containers, vector

API changes (from Hackage documentation)

Files

• graph-core.cabal +20/−22
• src/Data/Core/Graph.hs +20/−0
• src/Data/Core/Graph/NodeManager.hs +115/−0
• src/Data/Core/Graph/Persistence.hs +27/−0
• src/Data/Core/Graph/PureCore.hs +203/−0
• src/Data/Graph.hs +0/−20
• src/Data/Graph/NodeManager.hs +0/−115
• src/Data/Graph/Persistence.hs +0/−32
• src/Data/Graph/PureCore.hs +0/−203
• src/Test/Core.hs +2/−2
• src/Test/NodeManager.hs +1/−1
• src/Test/Persistence.hs +3/−3

@@ -1,5 +1,5 @@ name:                graph-core-version:             0.2.0.1+version:             0.2.1.0 synopsis:            Fast, memory efficient and persistent graph implementation description:         A small package providing a powerful and easy to use Haskell graph implementation. homepage:            https://github.com/factisresearch/graph-core@@ -13,18 +13,17 @@ cabal-version:       >=1.8  library-  exposed-modules:     Data.Graph, Data.Graph.NodeManager, Data.Graph.Persistence-  other-modules:       Data.Graph.PureCore+  exposed-modules:     Data.Core.Graph, Data.Core.Graph.NodeManager, Data.Core.Graph.Persistence+  other-modules:       Data.Core.Graph.PureCore   build-depends:       base >=4.6 && <4.8,-                       hashable >=1.2 && <1.3,-                       unordered-containers >=0.2 && <0.3,-                       containers >=0.5 && <0.6,-                       safe >=0.3 && <0.4,-                       deepseq >=1.3 && <1.4,-                       vector >=0.10 && <0.11,-                       QuickCheck >=2.6 && <2.7,-                       mtl >=2.1 && <2.2,-                       safecopy >=0.8 && <0.9+                       hashable >=1.2,+                       unordered-containers >=0.2,+                       containers >=0.5,+                       safe >=0.3,+                       deepseq >=1.3,+                       vector >=0.10,+                       QuickCheck >=2.6,+                       mtl >=2.1   hs-source-dirs:      src   ghc-options: -Wall -fno-warn-orphans @@ -34,16 +33,15 @@   main-is:             Tests.hs   other-modules:       Test.NodeManager, Test.Core, Test.Persistence   build-depends:       base >=4.6 && <4.8,-                       hashable >=1.2 && <1.3,-                       unordered-containers >=0.2 && <0.3,-                       containers >=0.5 && <0.6,-                       safe >=0.3 && <0.4,-                       deepseq >=1.3 && <1.4,-                       vector >=0.10 && <0.11,-                       QuickCheck >=2.6 && <2.7,-                       mtl >=2.1 && <2.2,-                       safecopy >=0.8 && <0.9,-                       HTF >=0.11 && <0.12+                       hashable >=1.2,+                       unordered-containers >=0.2,+                       containers >=0.5,+                       safe >=0.3,+                       deepseq >=1.3,+                       vector >=0.10,+                       QuickCheck >=2.6,+                       mtl >=2.1,+                       HTF >=0.11   ghc-options: -Wall -fno-warn-orphans  source-repository head

@@ -0,0 +1,20 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}+module Data.Core.Graph+  ( Graph, Node, NodeSet, Edge(..)+  , empty, fromEdges, fromAdj, isConsistent+  , nodes, edges, children, parents, hasEdge+  , edgeCount+  , hull, rhull, hullFold, hullFoldM, rhullFold+  , addEdge, addEdges, removeEdge, removeEdges+  , addNode, removeNode, solitaireNodes+  , edgesAdj+  )+where++import Data.Core.Graph.NodeManager hiding (isConsistent, nodes)+import Data.Core.Graph.PureCore

@@ -0,0 +1,115 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+module Data.Core.Graph.NodeManager+    ( NodeManager, Node, NodeMap, NodeSet+    , emptyNode+    , initNodeManager, emptyNodeManager, getNodeMap+    , getNodeHandle, getExistingNodeHandle, lookupNode, unsafeLookupNode+    , removeNodeHandle+    , getNewNodesSince, keys, hasKey, nodes, toList+    , isConsistent+    )+where++import Control.Monad.State.Strict+import Data.Hashable+import Data.Maybe+import Test.QuickCheck (NonNegative(..), Arbitrary(..))+import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS+import qualified Data.List as L++type Node = Int+type NodeMap v = IM.IntMap v+type NodeSet = IS.IntSet++emptyNode :: Node+emptyNode = -1++data NodeManager k+    = NodeManager+    { nm_nodeToKey :: !(NodeMap k)+    , nm_keyToNode :: !(HM.HashMap k Node)+    , nm_nextNode :: !Node+    } deriving (Show, Eq)++swap :: forall a b. (a, b) -> (b, a)+swap (x,y) = (y,x)++isConsistent :: (Ord k) => NodeManager k -> Bool+isConsistent (NodeManager{..}) =+    IM.size nm_nodeToKey == HM.size nm_keyToNode+    && (IM.null nm_nodeToKey || (nm_nextNode > fst (IM.findMax nm_nodeToKey)+                              && emptyNode < fst (IM.findMin nm_nodeToKey)))+    && L.sort (HM.toList nm_keyToNode) == L.sort (map swap (IM.toList nm_nodeToKey))++-- map must contain only non-negative keys!+initNodeManager :: (Hashable k, Eq k) => NodeMap k -> NodeManager k+initNodeManager nm =+    case IM.minViewWithKey nm of+       Just ((n, _), _) | n <= emptyNode -> error $ "Invalid node ID: " ++ show n+       _ -> NodeManager nm (invert nm) nextNode+    where nextNode+            | IM.null nm = 0+            | otherwise = 1 + fst (IM.findMax nm)+          invert im = HM.fromList . map swap $ IM.toList im++getNodeMap :: (Hashable k, Eq k) => NodeManager k -> NodeMap k+getNodeMap = nm_nodeToKey++keys :: NodeManager k -> [k]+keys nm =+    HM.keys (nm_keyToNode nm)++hasKey :: (Eq k, Hashable k) => k -> NodeManager k -> Bool+hasKey k nm =+    isJust $ HM.lookup k (nm_keyToNode nm)++toList :: NodeManager k -> [(k, Node)]+toList nm = HM.toList (nm_keyToNode nm)++nodes :: NodeManager k -> [Node]+nodes nm = IM.keys (nm_nodeToKey nm)++getNewNodesSince :: Node -> NodeManager k -> NodeMap k+getNewNodesSince n (NodeManager{..}) = snd $ IM.split n nm_nodeToKey++emptyNodeManager :: forall k. NodeManager k+emptyNodeManager = NodeManager IM.empty HM.empty 0++getNodeHandle :: (Hashable k, Eq k, MonadState (NodeManager k) m) => k -> m Node+getNodeHandle k =+    do NodeManager{..} <- get+       case HM.lookup k nm_keyToNode of+          Just i -> return i+          Nothing ->+            do let i = nm_nextNode+               put $! NodeManager { nm_nodeToKey = IM.insert i k nm_nodeToKey+                                  , nm_keyToNode = HM.insert k i nm_keyToNode+                                  , nm_nextNode = i + 1+                                  }+               return i++removeNodeHandle :: (Hashable k, Eq k) => Node -> NodeManager k -> NodeManager k+removeNodeHandle i nm@(NodeManager{..}) =+    case IM.lookup i nm_nodeToKey of+      Just k ->+          nm { nm_nodeToKey = IM.delete i nm_nodeToKey+             , nm_keyToNode = HM.delete k nm_keyToNode+             }+      Nothing -> nm++getExistingNodeHandle :: (Hashable k, Eq k) => k -> NodeManager k -> Maybe Node+getExistingNodeHandle k (NodeManager{..}) = HM.lookup k nm_keyToNode++lookupNode :: Node -> NodeManager k -> Maybe k+lookupNode i (NodeManager{..}) = IM.lookup i nm_nodeToKey++unsafeLookupNode :: Node -> NodeManager k -> k+unsafeLookupNode i nm = fromJust $ lookupNode i nm++instance Arbitrary v => Arbitrary (IM.IntMap v) where+    arbitrary = fmap (IM.fromList . map (\(NonNegative i, x) -> (i, x))) arbitrary

@@ -0,0 +1,27 @@+module Data.Core.Graph.Persistence+  ( PersistentGraph, persistGraph, loadGraph )+where++import Data.Core.Graph.PureCore+import Data.Core.Graph.NodeManager++import Data.Hashable+import qualified Data.IntMap.Strict as IM+import qualified Data.Vector.Unboxed as VU++data PersistentGraph k+   = PersistentGraph+   { pg_nodeData :: NodeMap k+   , pg_graphData :: [(Node, [Node])]+   } deriving (Show, Eq)++persistGraph :: (Eq k, Hashable k) => NodeManager k -> Graph -> PersistentGraph k+persistGraph nodeManager graph =+    PersistentGraph+    { pg_nodeData = getNodeMap nodeManager+    , pg_graphData = map (\(k, vals) -> (k, VU.toList vals)) (IM.toList $ g_adj graph)+    }++loadGraph :: (Eq k, Hashable k) => PersistentGraph k -> (NodeManager k, Graph)+loadGraph (PersistentGraph nodeData graphData) =+    (initNodeManager nodeData, fromAdj graphData)

@@ -0,0 +1,203 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}+module Data.Core.Graph.PureCore where++import Data.Core.Graph.NodeManager hiding (nodes, isConsistent)++import Control.Applicative hiding (empty)+import Control.Arrow+import Control.DeepSeq+import Control.Monad+import Control.Monad.Identity+import Control.Monad.ST+import Data.Function (on)+import Data.Hashable+import Data.Maybe+import Data.STRef+import Test.QuickCheck+import qualified Data.Foldable as F+import qualified Data.HashSet as HS+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS+import qualified Data.List as L+import qualified Data.Vector.Unboxed as VU++type AdjList = NodeMap (VU.Vector Node)+data Edge = Edge { src :: !Node, tgt :: !Node } deriving (Show, Eq, Ord)++instance Hashable Edge where+    hashWithSalt s (Edge x y) = s `hashWithSalt` x `hashWithSalt` y++data Graph+    = Graph+    { g_adj :: !AdjList+    , g_radj :: !AdjList+    }++empty :: Graph+empty = Graph IM.empty IM.empty++invert :: Edge -> Edge+invert (Edge x y) = Edge y x++instance Show Graph where+    show g = "< " ++ L.intercalate ",\n  " (map showNode (nodes g)) ++ " >"+        where showNode x = show x+                        ++ " -> ["+                        ++ L.intercalate "," (map show (VU.toList (children g x)))+                        ++ "]"++instance Eq Graph where+    a == b = sameItems (nodes a) (nodes b)+          && all (\x -> sameItems (VU.toList (children a x)) (VU.toList (children b x)))+                  (nodes a)+      where sameItems x y = IS.fromList x == IS.fromList y++instance NFData Graph where+    rnf (Graph a b) = rnf a `seq` rnf b++adjToEdges :: [(Node, [Node])] -> [Edge]+adjToEdges = concatMap (\(x, ys) -> map (Edge x) ys)++edgesAdj :: AdjList -> [Edge]+edgesAdj adj = adjToEdges . map (second VU.toList) $ IM.toList adj++isConsistent :: Graph -> Bool+isConsistent (Graph{..}) = L.sort forwardEdges == L.sort (map invert (edgesAdj g_radj))+                        && HS.size (HS.fromList forwardEdges) == length forwardEdges+    where forwardEdges = edgesAdj g_adj++fromEdges :: [Edge] -> Graph+fromEdges edgeList =+    Graph { g_adj = mkAdj edgeList+          , g_radj = mkAdj $ map invert edgeList+          }+    where+      mkAdj e = IM.fromList $ map (src . head &&& VU.fromList . map tgt)+                        . L.groupBy ((==) `on` src)+                        . L.sortBy (compare `on` src) $ e++fromAdj :: [(Node, [Node])] -> Graph+fromAdj l =+    let g1 = fromEdges (adjToEdges l)+        solitaires = map fst $ filter (\(_, xs) -> null xs) l+    in L.foldl' (\g n -> g { g_adj = IM.insert n VU.empty (g_adj g) }) g1 solitaires++nodes :: Graph -> [Node]+nodes g = IM.keys (IM.union (g_adj g) (g_radj g))++edges :: Graph -> [Edge]+edges = edgesAdj . g_adj++solitaireNodes :: Graph -> [Node]+solitaireNodes g = IM.keys (IM.filter VU.null (IM.union (g_adj g) (g_radj g)))++edgeCount :: Graph -> Int+edgeCount = F.foldl' (\old (_,adj) -> old + VU.length adj) 0+          . IM.toList . g_adj++children :: Graph -> Node -> VU.Vector Node+children g x = neighbors g (g_adj g) x++parents :: Graph -> Node -> VU.Vector Node+parents g x = neighbors g (g_radj g) x++neighbors :: Graph -> AdjList -> Node -> VU.Vector Node+neighbors (Graph{..}) adj x = IM.findWithDefault VU.empty x adj++hasEdge :: Node -> Node -> Graph -> Bool+hasEdge x y (Graph{..}) = y `VU.elem` IM.findWithDefault VU.empty x g_adj++addNode :: Node -> Graph -> Graph+addNode x g =+    g { g_adj = IM.insertWith (\_new old -> old) x VU.empty (g_adj g) }++removeNode :: Node -> Graph -> Graph+removeNode x g =+    let rmInAdj adj localF =+            foldl (\adjList child ->+                       IM.adjust (VU.filter (/=x)) child adjList+                  ) (IM.delete x adj) $ VU.toList (localF g x)++        newAdj = rmInAdj (g_adj g) parents+        newRAdj = rmInAdj (g_radj g) children+    in g { g_adj = newAdj+         , g_radj = newRAdj+         }++addEdge :: Node -> Node -> Graph -> Graph+addEdge x y g@(Graph{..}) =+   if hasEdge x y g+       then g+       else Graph { g_adj = alterDef VU.empty (flip VU.snoc y) x g_adj+                  , g_radj = alterDef VU.empty (flip VU.snoc x) y g_radj+                  }+   where alterDef def f = IM.alter (Just . f . fromMaybe def)++addEdges :: [Edge] -> Graph -> Graph+addEdges edgeList g = L.foldl' (flip (\(Edge x y) -> addEdge x y)) g edgeList++removeEdge :: Node -> Node -> Graph -> Graph+removeEdge x y (Graph{..}) =+    Graph { g_adj = IM.adjust (VU.filter (/=y)) x g_adj+          , g_radj = IM.adjust (VU.filter (/=x)) y g_radj+          }++removeEdges :: [Edge] -> Graph -> Graph+removeEdges edgeList g = L.foldl' (flip (\(Edge x y) -> removeEdge x y)) g edgeList++hull :: Graph -> Node -> NodeSet+hull g = hullImpl g (g_adj g)++rhull :: Graph -> Node -> NodeSet+rhull g = hullImpl g (g_radj g)++hullImpl :: Graph -> AdjList -> Node -> NodeSet+hullImpl (Graph{..}) adj root =+    runST $+       do vis <- newSTRef IS.empty+          let go x =+               (IS.member x <$> readSTRef vis) >>=+                  (flip unless $+                     do modifySTRef' vis (IS.insert x)+                        VU.forM_ (IM.findWithDefault VU.empty x adj) go)+          go root+          readSTRef vis++rhullFold :: Graph -> (b -> Node -> b) -> b -> Node -> b+rhullFold g f initial node =+    runIdentity $ hullFoldImpl (g_radj g) (\x y -> return (f x y)) initial node++-- FIXME: benchmark against old hullFold implementation+hullFold :: Graph -> (b -> Node -> b) -> b -> Node -> b+hullFold g f initial node =+    runIdentity $ hullFoldImpl (g_adj g) (\x y -> return (f x y)) initial node++hullFoldM :: Monad m => Graph -> (b -> Node -> m b) -> b -> Node -> m b+hullFoldM g = hullFoldImpl (g_adj g)++hullFoldImpl :: Monad m => AdjList -> (b -> Node -> m b) -> b -> Node -> m b+hullFoldImpl adj f initial root =+    go IS.empty initial [root]+    where+      go _ acc [] = return acc+      go !visited !acc (x:xs) =+          if (IS.member x visited)+          then go visited acc xs+          else do newAcc <- f acc x+                  let succs = IM.findWithDefault VU.empty x adj+                  go (IS.insert x visited) newAcc (xs ++ VU.toList succs)++instance Arbitrary Graph where+    arbitrary = frequency [(1, return empty), (20, denseGraph)]+        where denseGraph =+                do n <- choose (0, 30::Int)+                   let nodeList = [1..n]+                   adj <- forM nodeList $ \i ->+                            do bits <- vectorOf n arbitrary+                               return (i, [ x | (x,b) <- zip nodeList bits, b ])+                   return $ fromAdj adj

@@ -1,20 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-}-module Data.Graph-  ( Graph, Node, NodeSet, Edge(..)-  , empty, fromEdges, fromAdj, isConsistent-  , nodes, edges, children, parents, hasEdge-  , edgeCount-  , hull, rhull, hullFold, hullFoldM, rhullFold-  , addEdge, addEdges, removeEdge, removeEdges-  , addNode, removeNode, solitaireNodes-  , edgesAdj-  )-where--import Data.Graph.NodeManager hiding (isConsistent, nodes)-import Data.Graph.PureCore

@@ -1,115 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-module Data.Graph.NodeManager-    ( NodeManager, Node, NodeMap, NodeSet-    , emptyNode-    , initNodeManager, emptyNodeManager, getNodeMap-    , getNodeHandle, getExistingNodeHandle, lookupNode, unsafeLookupNode-    , removeNodeHandle-    , getNewNodesSince, keys, hasKey, nodes, toList-    , isConsistent-    )-where--import Control.Monad.State.Strict-import Data.Hashable-import Data.Maybe-import Test.QuickCheck (NonNegative(..), Arbitrary(..))-import qualified Data.HashMap.Strict as HM-import qualified Data.IntMap.Strict as IM-import qualified Data.IntSet as IS-import qualified Data.List as L--type Node = Int-type NodeMap v = IM.IntMap v-type NodeSet = IS.IntSet--emptyNode :: Node-emptyNode = -1--data NodeManager k-    = NodeManager-    { nm_nodeToKey :: !(NodeMap k)-    , nm_keyToNode :: !(HM.HashMap k Node)-    , nm_nextNode :: !Node-    } deriving (Show, Eq)--swap :: forall a b. (a, b) -> (b, a)-swap (x,y) = (y,x)--isConsistent :: (Ord k) => NodeManager k -> Bool-isConsistent (NodeManager{..}) =-    IM.size nm_nodeToKey == HM.size nm_keyToNode-    && (IM.null nm_nodeToKey || (nm_nextNode > fst (IM.findMax nm_nodeToKey)-                              && emptyNode < fst (IM.findMin nm_nodeToKey)))-    && L.sort (HM.toList nm_keyToNode) == L.sort (map swap (IM.toList nm_nodeToKey))---- map must contain only non-negative keys!-initNodeManager :: (Hashable k, Eq k) => NodeMap k -> NodeManager k-initNodeManager nm =-    case IM.minViewWithKey nm of-       Just ((n, _), _) | n <= emptyNode -> error $ "Invalid node ID: " ++ show n-       _ -> NodeManager nm (invert nm) nextNode-    where nextNode-            | IM.null nm = 0-            | otherwise = 1 + fst (IM.findMax nm)-          invert im = HM.fromList . map swap $ IM.toList im--getNodeMap :: (Hashable k, Eq k) => NodeManager k -> NodeMap k-getNodeMap = nm_nodeToKey--keys :: NodeManager k -> [k]-keys nm =-    HM.keys (nm_keyToNode nm)--hasKey :: (Eq k, Hashable k) => k -> NodeManager k -> Bool-hasKey k nm =-    isJust $ HM.lookup k (nm_keyToNode nm)--toList :: NodeManager k -> [(k, Node)]-toList nm = HM.toList (nm_keyToNode nm)--nodes :: NodeManager k -> [Node]-nodes nm = IM.keys (nm_nodeToKey nm)--getNewNodesSince :: Node -> NodeManager k -> NodeMap k-getNewNodesSince n (NodeManager{..}) = snd $ IM.split n nm_nodeToKey--emptyNodeManager :: forall k. NodeManager k-emptyNodeManager = NodeManager IM.empty HM.empty 0--getNodeHandle :: (Hashable k, Eq k, MonadState (NodeManager k) m) => k -> m Node-getNodeHandle k =-    do NodeManager{..} <- get-       case HM.lookup k nm_keyToNode of-          Just i -> return i-          Nothing ->-            do let i = nm_nextNode-               put $! NodeManager { nm_nodeToKey = IM.insert i k nm_nodeToKey-                                  , nm_keyToNode = HM.insert k i nm_keyToNode-                                  , nm_nextNode = i + 1-                                  }-               return i--removeNodeHandle :: (Hashable k, Eq k) => Node -> NodeManager k -> NodeManager k-removeNodeHandle i nm@(NodeManager{..}) =-    case IM.lookup i nm_nodeToKey of-      Just k ->-          nm { nm_nodeToKey = IM.delete i nm_nodeToKey-             , nm_keyToNode = HM.delete k nm_keyToNode-             }-      Nothing -> nm--getExistingNodeHandle :: (Hashable k, Eq k) => k -> NodeManager k -> Maybe Node-getExistingNodeHandle k (NodeManager{..}) = HM.lookup k nm_keyToNode--lookupNode :: Node -> NodeManager k -> Maybe k-lookupNode i (NodeManager{..}) = IM.lookup i nm_nodeToKey--unsafeLookupNode :: Node -> NodeManager k -> k-unsafeLookupNode i nm = fromJust $ lookupNode i nm--instance Arbitrary v => Arbitrary (IM.IntMap v) where-    arbitrary = fmap (IM.fromList . map (\(NonNegative i, x) -> (i, x))) arbitrary

@@ -1,32 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.Graph.Persistence-  ( PersistentGraph, persistGraph, loadGraph )-where--import Data.Graph.PureCore-import Data.Graph.NodeManager--import Data.Hashable-import Data.SafeCopy-import qualified Data.IntMap.Strict as IM-import qualified Data.Vector.Unboxed as VU--data PersistentGraph k-   = PersistentGraph-   { pg_nodeData :: NodeMap k-   , pg_graphData :: [(Node, [Node])]-   } deriving (Show, Eq)--persistGraph :: (Eq k, Hashable k) => NodeManager k -> Graph -> PersistentGraph k-persistGraph nodeManager graph =-    PersistentGraph-    { pg_nodeData = getNodeMap nodeManager-    , pg_graphData = map (\(k, vals) -> (k, VU.toList vals)) (IM.toList $ g_adj graph)-    }--loadGraph :: (Eq k, Hashable k) => PersistentGraph k -> (NodeManager k, Graph)-loadGraph (PersistentGraph nodeData graphData) =-    (initNodeManager nodeData, fromAdj graphData)--$(deriveSafeCopy 1 'base ''PersistentGraph)-$(deriveSafeCopy 1 'base ''Edge)

@@ -1,203 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-}-module Data.Graph.PureCore where--import Data.Graph.NodeManager hiding (nodes, isConsistent)--import Control.Applicative hiding (empty)-import Control.Arrow-import Control.DeepSeq-import Control.Monad-import Control.Monad.Identity-import Control.Monad.ST-import Data.Function (on)-import Data.Hashable-import Data.Maybe-import Data.STRef-import Test.QuickCheck-import qualified Data.Foldable as F-import qualified Data.HashSet as HS-import qualified Data.IntMap.Strict as IM-import qualified Data.IntSet as IS-import qualified Data.List as L-import qualified Data.Vector.Unboxed as VU--type AdjList = NodeMap (VU.Vector Node)-data Edge = Edge { src :: !Node, tgt :: !Node } deriving (Show, Eq, Ord)--instance Hashable Edge where-    hashWithSalt s (Edge x y) = s `hashWithSalt` x `hashWithSalt` y--data Graph-    = Graph-    { g_adj :: !AdjList-    , g_radj :: !AdjList-    }--empty :: Graph-empty = Graph IM.empty IM.empty--invert :: Edge -> Edge-invert (Edge x y) = Edge y x--instance Show Graph where-    show g = "< " ++ L.intercalate ",\n  " (map showNode (nodes g)) ++ " >"-        where showNode x = show x-                        ++ " -> ["-                        ++ L.intercalate "," (map show (VU.toList (children g x)))-                        ++ "]"--instance Eq Graph where-    a == b = sameItems (nodes a) (nodes b)-          && all (\x -> sameItems (VU.toList (children a x)) (VU.toList (children b x)))-                  (nodes a)-      where sameItems x y = IS.fromList x == IS.fromList y--instance NFData Graph where-    rnf (Graph a b) = rnf a `seq` rnf b--adjToEdges :: [(Node, [Node])] -> [Edge]-adjToEdges = concatMap (\(x, ys) -> map (Edge x) ys)--edgesAdj :: AdjList -> [Edge]-edgesAdj adj = adjToEdges . map (second VU.toList) $ IM.toList adj--isConsistent :: Graph -> Bool-isConsistent (Graph{..}) = L.sort forwardEdges == L.sort (map invert (edgesAdj g_radj))-                        && HS.size (HS.fromList forwardEdges) == length forwardEdges-    where forwardEdges = edgesAdj g_adj--fromEdges :: [Edge] -> Graph-fromEdges edgeList =-    Graph { g_adj = mkAdj edgeList-          , g_radj = mkAdj $ map invert edgeList-          }-    where-      mkAdj e = IM.fromList $ map (src . head &&& VU.fromList . map tgt)-                        . L.groupBy ((==) `on` src)-                        . L.sortBy (compare `on` src) $ e--fromAdj :: [(Node, [Node])] -> Graph-fromAdj l =-    let g1 = fromEdges (adjToEdges l)-        solitaires = map fst $ filter (\(_, xs) -> null xs) l-    in L.foldl' (\g n -> g { g_adj = IM.insert n VU.empty (g_adj g) }) g1 solitaires--nodes :: Graph -> [Node]-nodes g = IM.keys (IM.union (g_adj g) (g_radj g))--edges :: Graph -> [Edge]-edges = edgesAdj . g_adj--solitaireNodes :: Graph -> [Node]-solitaireNodes g = IM.keys (IM.filter VU.null (IM.union (g_adj g) (g_radj g)))--edgeCount :: Graph -> Int-edgeCount = F.foldl' (\old (_,adj) -> old + VU.length adj) 0-          . IM.toList . g_adj--children :: Graph -> Node -> VU.Vector Node-children g x = neighbors g (g_adj g) x--parents :: Graph -> Node -> VU.Vector Node-parents g x = neighbors g (g_radj g) x--neighbors :: Graph -> AdjList -> Node -> VU.Vector Node-neighbors (Graph{..}) adj x = IM.findWithDefault VU.empty x adj--hasEdge :: Node -> Node -> Graph -> Bool-hasEdge x y (Graph{..}) = y `VU.elem` IM.findWithDefault VU.empty x g_adj--addNode :: Node -> Graph -> Graph-addNode x g =-    g { g_adj = IM.insertWith (\_new old -> old) x VU.empty (g_adj g) }--removeNode :: Node -> Graph -> Graph-removeNode x g =-    let rmInAdj adj localF =-            foldl (\adjList child ->-                       IM.adjust (VU.filter (/=x)) child adjList-                  ) (IM.delete x adj) $ VU.toList (localF g x)--        newAdj = rmInAdj (g_adj g) parents-        newRAdj = rmInAdj (g_radj g) children-    in g { g_adj = newAdj-         , g_radj = newRAdj-         }--addEdge :: Node -> Node -> Graph -> Graph-addEdge x y g@(Graph{..}) =-   if hasEdge x y g-       then g-       else Graph { g_adj = alterDef VU.empty (flip VU.snoc y) x g_adj-                  , g_radj = alterDef VU.empty (flip VU.snoc x) y g_radj-                  }-   where alterDef def f = IM.alter (Just . f . fromMaybe def)--addEdges :: [Edge] -> Graph -> Graph-addEdges edgeList g = L.foldl' (flip (\(Edge x y) -> addEdge x y)) g edgeList--removeEdge :: Node -> Node -> Graph -> Graph-removeEdge x y (Graph{..}) =-    Graph { g_adj = IM.adjust (VU.filter (/=y)) x g_adj-          , g_radj = IM.adjust (VU.filter (/=x)) y g_radj-          }--removeEdges :: [Edge] -> Graph -> Graph-removeEdges edgeList g = L.foldl' (flip (\(Edge x y) -> removeEdge x y)) g edgeList--hull :: Graph -> Node -> NodeSet-hull g = hullImpl g (g_adj g)--rhull :: Graph -> Node -> NodeSet-rhull g = hullImpl g (g_radj g)--hullImpl :: Graph -> AdjList -> Node -> NodeSet-hullImpl (Graph{..}) adj root =-    runST $-       do vis <- newSTRef IS.empty-          let go x =-               (IS.member x <$> readSTRef vis) >>=-                  (flip unless $-                     do modifySTRef' vis (IS.insert x)-                        VU.forM_ (IM.findWithDefault VU.empty x adj) go)-          go root-          readSTRef vis--rhullFold :: Graph -> (b -> Node -> b) -> b -> Node -> b-rhullFold g f initial node =-    runIdentity $ hullFoldImpl (g_radj g) (\x y -> return (f x y)) initial node---- FIXME: benchmark against old hullFold implementation-hullFold :: Graph -> (b -> Node -> b) -> b -> Node -> b-hullFold g f initial node =-    runIdentity $ hullFoldImpl (g_adj g) (\x y -> return (f x y)) initial node--hullFoldM :: Monad m => Graph -> (b -> Node -> m b) -> b -> Node -> m b-hullFoldM g = hullFoldImpl (g_adj g)--hullFoldImpl :: Monad m => AdjList -> (b -> Node -> m b) -> b -> Node -> m b-hullFoldImpl adj f initial root =-    go IS.empty initial [root]-    where-      go _ acc [] = return acc-      go !visited !acc (x:xs) =-          if (IS.member x visited)-          then go visited acc xs-          else do newAcc <- f acc x-                  let succs = IM.findWithDefault VU.empty x adj-                  go (IS.insert x visited) newAcc (xs ++ VU.toList succs)--instance Arbitrary Graph where-    arbitrary = frequency [(1, return empty), (20, denseGraph)]-        where denseGraph =-                do n <- choose (0, 30::Int)-                   let nodeList = [1..n]-                   adj <- forM nodeList $ \i ->-                            do bits <- vectorOf n arbitrary-                               return (i, [ x | (x,b) <- zip nodeList bits, b ])-                   return $ fromAdj adj

@@ -1,8 +1,8 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-} module Test.Core where -import Data.Graph.PureCore-import Data.Graph.NodeManager (Node)+import Data.Core.Graph.PureCore+import Data.Core.Graph.NodeManager (Node)  import Control.Monad import Test.Framework

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-} module Test.NodeManager where -import Data.Graph.NodeManager+import Data.Core.Graph.NodeManager  import Test.Framework import Control.Monad.State.Strict

@@ -1,9 +1,9 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-} module Test.Persistence where -import Data.Graph-import Data.Graph.NodeManager-import Data.Graph.Persistence+import Data.Core.Graph+import Data.Core.Graph.NodeManager+import Data.Core.Graph.Persistence  import Test.Framework