packages feed

graph-core (empty) → 0.1.0.0

raw patch · 11 files changed

+569/−0 lines, 11 filesdep +HTFdep +QuickCheckdep +basesetup-changed

Dependencies added: HTF, QuickCheck, base, containers, deepseq, hashable, mtl, safe, safecopy, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2014 factis research GmbH++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ graph-core.cabal view
@@ -0,0 +1,51 @@+name:                graph-core+version:             0.1.0.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+license:             MIT+license-file:        LICENSE+author:              Stefan Wehr <wehr@cp-med.com>, David Leuschner <leuschner@cp-med.com>, Alexander Thiemann <thiemann@cp-med.com>+maintainer:          Alexander Thiemann <thiemann@cp-med.com>+copyright:           (c) 2014 factis research GmbH+category:            Data+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:     Data.Graph, Data.Graph.NodeManager, Data.Graph.Persistence+  other-modules:       Data.Graph.PureCore+  build-depends:       base >=4.6 && <4.7,+                       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+  hs-source-dirs:      src+  ghc-options: -Wall -fno-warn-orphans++test-suite graph-core-tests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      src+  main-is:             Tests.hs+  other-modules:       Test.NodeManager, Test.Core, Test.Persistence+  build-depends:       base >=4.6 && <4.7,+                       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+  ghc-options: -Wall -fno-warn-orphans++source-repository head+  type:     git+  location: git://github.com/factisresearch/graph-core.git
+ src/Data/Graph.hs view
@@ -0,0 +1,20 @@+{-# 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, solitaireNodes+  , edgesAdj+  )+where++import Data.Graph.NodeManager hiding (isConsistent, nodes)+import Data.Graph.PureCore
+ src/Data/Graph/NodeManager.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+module Data.Graph.NodeManager+    ( NodeManager, Node, NodeMap, NodeSet+    , emptyNode+    , initNodeManager, emptyNodeManager, getNodeMap+    , getNodeHandle, getExistingNodeHandle, lookupNode, unsafeLookupNode+    , 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++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
+ src/Data/Graph/Persistence.hs view
@@ -0,0 +1,32 @@+{-# 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)
+ src/Data/Graph/PureCore.hs view
@@ -0,0 +1,190 @@+{-# 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) }++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
+ src/Test/Core.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Test.Core where++import Data.Graph.PureCore+import Data.Graph.NodeManager (Node)++import Control.Monad+import Test.Framework+import qualified Data.IntSet as IS++e :: (Node, Node) -> Edge+e (x,y) = Edge x y++testGraphA :: Graph+testGraphA = fromAdj [(1, [2,3]), (2, [3,4]), (3, [4])]++testGraphB :: Graph+testGraphB = fromEdges [e (1,2), e (2,1)]++test_hasEdge :: IO ()+test_hasEdge =+    do assertEqual True $ hasEdge 2 4 testGraphA+       forM_ (edges testGraphA) $ \(Edge a b) ->+          assertEqual True (hasEdge a b testGraphA)+       assertEqual False $ hasEdge 1 4 testGraphA+       assertEqual False $ hasEdge 1000 200 testGraphA++test_removeEdges :: IO ()+test_removeEdges =+    do assertEqual (fromAdj [(1, [2]), (2, [3,4]), (3, [4]), (4, [])])+                   (removeEdges [e (1,3), e (4,1)] testGraphA)++test_hull :: IO ()+test_hull =+    do assertEqual (IS.fromList [4]) (hull testGraphA 4)+       assertEqual (IS.fromList [1,2,3,4]) (hull testGraphA 1)+       assertEqual (IS.fromList [2,3,4]) (hull testGraphA 2)+       assertEqual (IS.fromList [3,4]) (hull testGraphA 3)+       assertEqual (IS.fromList [100]) (hull testGraphA 100)+       assertEqual (IS.fromList [1,2]) (hull testGraphB 1)++test_rhull :: IO ()+test_rhull =+    do assertEqual (IS.fromList [1,2,3]) (rhull testGraphA 3)+       assertEqual (IS.fromList [1]) (rhull testGraphA 1)+       assertEqual (IS.fromList [1,2]) (rhull testGraphB 1)++test_hullFold :: IO ()+test_hullFold =+    do assertEqual 10 (hullFold testGraphA (+) 0 1)+       assertEqual 4 (hullFold testGraphA (+) 0 4)+       assertEqual 100 (hullFold testGraphA (+) 0 100)+       assertEqual 3 (hullFold testGraphB (+) 0 1)++prop_fromEdgesAddEdges :: Graph -> Bool+prop_fromEdgesAddEdges g =+    let isCons = isConsistent new+        isEq = new == g+    in if isCons && isEq+       then True+       else error ("g=" ++ show g ++ ", new=" ++ show new +++                   ", isCons=" ++ show isCons ++ ", isEq=" ++ show isEq)+    where+      new =+          foldl (\g' n -> addNode n g') (addEdges (edges g) empty) (solitaireNodes g)++prop_fromEdgesToEdges :: Graph -> Bool+prop_fromEdgesToEdges g = isConsistent new && new == g+    where+      new =+          foldl (\g' n -> addNode n g') (fromEdges (edges g)) (solitaireNodes g)
+ src/Test/NodeManager.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Test.NodeManager where++import Data.Graph.NodeManager++import Test.Framework+import Control.Monad.State.Strict+import qualified Data.IntMap.Strict as IM+import qualified Data.List as L++assertConsistent :: StateT (NodeManager Char) IO ()+assertConsistent = get >>= liftIO . assertEqual True . isConsistent++prop_init :: NodeMap String -> Property+prop_init m = uniqueValues m && all (>=0) (IM.keys m)+        ==> isConsistent new && m == getNodeMap new+    where new = initNodeManager m+          uniqueValues im = IM.size im == length (L.nub $ IM.elems im)++test_getNewNodesSince :: IO ()+test_getNewNodesSince =+    flip evalStateT emptyNodeManager $+        do _ <- getNodeHandle 'a'+           n2 <- getNodeHandle 'b'+           n3 <- getNodeHandle 'c'+           n4 <- getNodeHandle 'd'+           new <- gets (getNewNodesSince n2)+           liftIO $ assertEqual (IM.fromList [(n3, 'c'), (n4, 'd')]) new++test_getNodeHandle :: IO ()+test_getNodeHandle =+    flip evalStateT emptyNodeManager $+        do n1 <- getNodeHandle 'a'+           n2 <- getNodeHandle 'a'+           liftIO $ assertEqual n1 n2+           n3 <- getNodeHandle 'b'+           n4 <- getNodeHandle 'b'+           liftIO $ assertEqual n3 n4+           n5 <- getNodeHandle 'a'+           liftIO $ assertEqual n1 n5+           liftIO $ assertNotEqual n1 n3+           assertConsistent++test_lookupNode :: IO ()+test_lookupNode =+    flip evalStateT emptyNodeManager $+        do n1 <- getNodeHandle 'a'+           n2 <- getNodeHandle 'b'+           x1 <- gets $ lookupNode n1+           x2 <- gets $ lookupNode n2+           x3 <- gets $ lookupNode 123+           liftIO $ assertEqual (Just 'a') x1+           liftIO $ assertEqual (Just 'b') x2+           liftIO $ assertEqual Nothing x3+           assertConsistent
+ src/Test/Persistence.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Test.Persistence where++import Data.Graph+import Data.Graph.NodeManager+import Data.Graph.Persistence++import Test.Framework++prop_persistence :: NodeMap Char -> Graph -> Bool+prop_persistence nodeMap graph =+    let nodeMgr = initNodeManager nodeMap+        (nodeMgr', graph') = loadGraph (persistGraph nodeMgr graph)+    in (nodeMgr' == nodeMgr && graph == graph')
+ src/Tests.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import Test.Framework+import {-@ HTF_TESTS @-} Test.Core+import {-@ HTF_TESTS @-} Test.NodeManager+import {-@ HTF_TESTS @-} Test.Persistence++main :: IO ()+main = htfMain htf_importedTests