diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +0.3 (2023-08-20) +---------------- + +- Add `Functor` instances for `PatriciaTree` and `Ctx` (@RyanGlScott) +- Support building with vector-0.13.* (@RyanGlScott) +- Remove an unused dependency on monad-primitive (@RyanGlScott) +- Add `replaceLabeledVertex` to the `InductiveGraph` interface (@kquick) +- Fixed a bug in the dominators calculation (@kquick) + 0.2 (2022-05-08) ---------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ # Overview -![travis-ci status](https://travis-ci.org/travitch/haggle.svg?branch=master) +![Github Actions status](https://github.com/travitch/haggle/actions/workflows/haskell-ci.yml/badge.svg) Haggle is a graph library for Haskell. It aims to support large graphs efficiently and compactly. It differs from diff --git a/haggle.cabal b/haggle.cabal --- a/haggle.cabal +++ b/haggle.cabal @@ -1,5 +1,5 @@ name: haggle -version: 0.2 +version: 0.3 synopsis: A graph library offering mutable, immutable, and inductive graphs description: This library provides mutable (in ST or IO), immutable, and inductive graphs. There are multiple graphs implementations provided to support different use @@ -16,7 +16,7 @@ category: Data Structures, Graphs build-type: Simple cabal-version: >=1.10 -tested-with: GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2 +tested-with: GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 || ==0.6.2 extra-source-files: ChangeLog.md README.md @@ -43,13 +43,12 @@ Data.Graph.Haggle.Internal.BitSet build-depends: base >= 4.5 && < 5, ref-tf >= 0.4 && < 0.6, - vector >= 0.9 && < 0.13, + vector >= 0.9 && < 0.14, vector-th-unbox >= 0.2.1.3 && < 0.3, primitive >= 0.4 && < 0.9, containers >= 0.4, hashable >= 1.2 && < 1.5, - deepseq >= 1 && < 2, - monad-primitive < 0.2 + deepseq >= 1 && < 2 test-suite GraphTests type: exitcode-stdio-1.0 @@ -60,7 +59,8 @@ build-depends: haggle, base >= 4.5, containers, - fgl, + -- fgl 5.8.1.1 is required for its dom fix for oracle testing here + fgl >= 5.8.1.1, HUnit, QuickCheck > 2.4, test-framework, diff --git a/src/Data/Graph/Haggle.hs b/src/Data/Graph/Haggle.hs --- a/src/Data/Graph/Haggle.hs +++ b/src/Data/Graph/Haggle.hs @@ -157,6 +157,7 @@ deleteEdge, deleteEdgesBetween, replaceLabeledEdge, + replaceLabeledVertex, deleteVertex, I.Context(..), @@ -379,6 +380,10 @@ replaceLabeledEdge :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> I.Vertex -> I.EdgeLabel g -> Maybe (I.Edge, g) replaceLabeledEdge = I.replaceLabeledEdge {-# INLINABLE replaceLabeledEdge #-} + +replaceLabeledVertex :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> I.VertexLabel g -> g +replaceLabeledVertex = I.replaceLabeledVertex +{-# INLINABLE replaceLabeledVertex #-} deleteVertex :: (I.InductiveGraph g, I.Graph g, I.HasEdgeLabel g, I.HasVertexLabel g) => g -> I.Vertex -> g deleteVertex = I.deleteVertex diff --git a/src/Data/Graph/Haggle/Algorithms/Dominators.hs b/src/Data/Graph/Haggle/Algorithms/Dominators.hs --- a/src/Data/Graph/Haggle/Algorithms/Dominators.hs +++ b/src/Data/Graph/Haggle/Algorithms/Dominators.hs @@ -61,7 +61,7 @@ (res, toNode, fromNode) <- domWork g root let dom' = getDom toNode res rest = M.keys (M.filter (-1 ==) fromNode) - verts = vertices g + verts = reachable root g return $ [(toNode ! i, dom' ! i) | i <- [0..V.length dom' - 1]] ++ [(n, verts) | n <- rest] @@ -70,6 +70,7 @@ | null trees = Nothing | otherwise = return (idom, toNode, fromNode) where + vlist = reachable root g -- Build up a depth-first tree from the root as a first approximation trees@(~[tree]) = dff g [root] (s, ntree) = numberTree 0 tree @@ -83,7 +84,7 @@ -- are the rest of the nodes in the graph, mapped to -1 (since they aren't -- going to be in the result) treeNodes = M.fromList $ zip (T.flatten tree) (T.flatten ntree) - otherNodes = M.fromList $ zip (vertices g) (repeat (-1)) + otherNodes = M.fromList $ zip vlist (repeat (-1)) fromNode = M.unionWith const treeNodes otherNodes -- Translate from internal nodes back to graph nodes (only need the nodes -- in the depth-first tree) @@ -93,7 +94,7 @@ -- Use a pre-pass over the graph to collect predecessors so that we don't -- require a Bidirectional graph. We need a linear pass over the graph -- here anyway, so we don't lose anything. - predMap = fmap S.toList $ foldr (toPredecessor g) M.empty (vertices g) + predMap = fmap S.toList $ foldr (toPredecessor g) M.empty vlist preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i))) | i <- [1..s-1]] idom = fixEq (refineIDom preds) idom0 diff --git a/src/Data/Graph/Haggle/Classes.hs b/src/Data/Graph/Haggle/Classes.hs --- a/src/Data/Graph/Haggle/Classes.hs +++ b/src/Data/Graph/Haggle/Classes.hs @@ -208,6 +208,10 @@ let g' = deleteEdgesBetween g src dst in insertLabeledEdge g' src dst lbl + -- | Used to update the label for a Vertex. The Vertex itself remains, but the + -- label associated with the vertex is modified. + replaceLabeledVertex :: g -> Vertex -> VertexLabel g -> g + -- | Remove a 'Vertex' from the graph deleteVertex :: g -> Vertex -> g deleteVertex g v = fromMaybe g $ do diff --git a/src/Data/Graph/Haggle/PatriciaTree.hs b/src/Data/Graph/Haggle/PatriciaTree.hs --- a/src/Data/Graph/Haggle/PatriciaTree.hs +++ b/src/Data/Graph/Haggle/PatriciaTree.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, BangPatterns #-} +{-# LANGUAGE TypeFamilies, BangPatterns, DeriveFunctor #-} -- | This graph is based on the implementation in fgl (using -- big-endian patricia-tries -- IntMap). -- @@ -20,6 +20,7 @@ import qualified Data.Graph.Haggle.Internal.Basic as I data Ctx nl el = Ctx !(IntMap el) I.Vertex nl !(IntMap el) + deriving Functor instance (NFData nl, NFData el) => NFData (Ctx nl el) where rnf (Ctx p v nl s) = @@ -37,6 +38,7 @@ -- This graph type is most useful for incremental construction in pure -- code. It also supports node removal from pure code. data PatriciaTree nl el = Gr { graphRepr :: IntMap (Ctx nl el) } + deriving Functor instance (NFData nl, NFData el) => NFData (PatriciaTree nl el) where rnf (Gr im) = im `deepseq` () @@ -120,6 +122,17 @@ v = I.V vid g' = IM.insert vid (Ctx mempty v lab mempty) g in (v, Gr g') + replaceLabeledVertex (Gr g) (I.V v) vl = + let updLabel (Ctx ie nv _nl oe) = Ctx ie nv vl oe + in Gr $ IM.adjust updLabel v g + insertLabeledEdge gr@(Gr g) v1@(I.V src) (I.V dst) lab | src == dst = do + guard (IM.member src g) + guard (not (I.edgeExists gr v1 v1)) + let e = I.E (-1) src src + Ctx spp sv sl sss <- IM.lookup src g + let ctx' = Ctx (IM.insert src lab spp) sv sl (IM.insert dst lab sss) + !g' = IM.insert src ctx' g + return (e, Gr g') insertLabeledEdge gr@(Gr g) v1@(I.V src) v2@(I.V dst) lab = do guard (IM.member src g && IM.member dst g) guard (not (I.edgeExists gr v1 v2)) @@ -132,6 +145,11 @@ !g'' = IM.insert dst dctx' g' return (e, Gr g'') deleteEdge g (I.E _ s d) = I.deleteEdgesBetween g (I.V s) (I.V d) + deleteEdgesBetween gr@(Gr g) (I.V src) (I.V dst) | src == dst = fromMaybe gr $ do + Ctx spp sv sl sss <- IM.lookup src g + let ctx' = Ctx (IM.delete src spp) sv sl (IM.delete src sss) + !g' = IM.insert src ctx' g + return (Gr g') deleteEdgesBetween gr@(Gr g) (I.V src) (I.V dst) = fromMaybe gr $ do Ctx spp sv sl sss <- IM.lookup src g Ctx dpp dv dl dss <- IM.lookup dst g diff --git a/src/Data/Graph/Haggle/VertexLabelAdapter.hs b/src/Data/Graph/Haggle/VertexLabelAdapter.hs --- a/src/Data/Graph/Haggle/VertexLabelAdapter.hs +++ b/src/Data/Graph/Haggle/VertexLabelAdapter.hs @@ -229,7 +229,7 @@ -- > import Data.Graph.Haggle.VertexLabelAdapter -- > import Data.Graph.Haggle.SimpleBiDigraph -- > --- > let g = fromEdgeList newMSimpleBiDigraph [(0,1), (1,2), (2,3), (3,0)] +-- > let (g,m) = fromEdgeList newMSimpleBiDigraph [(0,1), (1,2), (2,3), (3,0)] -- -- @g@ has type SimpleBiDigraph. -- diff --git a/tests/GraphTests.hs b/tests/GraphTests.hs --- a/tests/GraphTests.hs +++ b/tests/GraphTests.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + -- | This module tests Haggle by comparing its results to those of FGL. -- This assumes that FGL is reasonably correct. -- @@ -6,6 +8,7 @@ -- then constructs equivalent FGL and Haggle graphs. The quickcheck -- properties for each operation try to ensure that the two implementations -- return the same results. + module Main ( main ) where import Test.Framework ( defaultMain, Test ) @@ -80,8 +83,13 @@ , testProperty "prop_sameComponents" prop_sameComponents , testProperty "prop_sameNoComponents" prop_sameNoComponents , testProperty "prop_immDominatorsSame" prop_immDominatorsSame + + -- prop_dominatorsSame requires fgl 5.8.1.1, which fixes errors in fgl's + -- dom functionality that is used as the oracle for the tests here. , testProperty "prop_dominatorsSame" prop_dominatorsSame + ] <> testPatricia + <> testExplicit prop_sameVertexCount :: GraphPair -> Bool prop_sameVertexCount (GP _ bg tg) = @@ -167,6 +175,70 @@ -- Explicit tests for various functionality +testExplicit :: [Test.Framework.Test] +testExplicit = + let gr0 = foldl (\g -> snd . HGL.insertLabeledVertex g) + (HGL.emptyGraph :: HGL.PatriciaTree Int Char) + [1,2,4] + vs = fst <$> HGL.labeledVertices gr0 + + plusEdge g f t = snd $ fromJust $ HGL.insertLabeledEdge g f t 'a' + + gr1 = plusEdge gr0 (vs !! 0) (vs !! 1) + -- gr1 has three nodes, two are connected, one is not connected (i.e. two + -- independent subgraphs) + + gr2 = plusEdge (plusEdge gr0 (vs !! 1) (vs !! 0)) (vs !! 1) (vs !! 1) + + + in hUnitTestToTests $ test + [ "haggle (patricia) [1-2,4] reachable from 1" ~: + do HGL.reachable (vs !! 0) gr1 @?= [ (vs !! 0) + , (vs !! 1) + ] + , "haggle (patricia) [1-2,4] reachable from 2" ~: + do HGL.reachable (vs !! 1) gr1 @?= [ (vs !! 1) + ] + , "haggle (patricia) [2-1,2-2] reachable from 1" ~: + do HGL.reachable (vs !! 0) gr2 @?= [ (vs !! 0) + ] + + , "haggle dominator [1-2,4] from 1" ~: + do HGL.dominators gr1 (vs !! 0) @?= [ (vs !! 0, [ (vs !! 0) ]) + , (vs !! 1, [ (vs !! 1), (vs !! 0) ]) + ] + + , "haggle dominator [2-1,2-2,4] from 1" ~: + do HGL.dominators gr2 (vs !! 0) @?= [ (vs !! 0, [ (vs !! 0) ]) + ] + + , "haggle add self-edge" ~: + do let Just (e,g) = HGL.insertLabeledEdge gr0 (vs!!0) (vs!!0) 's' + HGL.edges g @?= [e] + + , "haggle delete self-edge" ~: + do let Just (_,g) = HGL.insertLabeledEdge gr0 (vs!!0) (vs!!0) 's' + HGL.edges (HGL.deleteEdgesBetween g (vs!!0) (vs!!0)) @?= [] + + + -- n.b. fgl's dominator is broken (as haggle's original version also was) in + -- that its return includes (4, [1,2,4]), which is invalid: 4 is in an + -- independent subgraph and cannot be dominated by 1. + -- , "fgl dominator for [1-2,4] from 1" ~: + -- do let fgr0 = FGL.mkGraph [(1,1), (2,2), (4,4)] [(0, 1, 'f')] :: FGL.Gr Int Char + -- FGL.dom fgr0 1 @?= [ (1, [ 1 ]) + -- , (2, [ 1, 2 ]) + -- ] + + -- n.b. fgl's dominator is also broken in regards to reachability. For a + -- dom return for [2-1, 2-2] from 1 also returns (2, [1,2]) which is + -- invalid, because 2 is not reachable from 1 and so 1 cannot be a dominator + -- for 2 + -- , "fgl dominator for [2-1,2-2] from 1" ~: + -- do let fgr2 = FGL.mkGraph [(1,1), (2,2)] [(2,1,'f'), (2,2,'s')] :: FGL.Gr Int Char + -- FGL.dom fgr2 1 @?= [ (1, [ 1 ]) ] + ] + testPatricia :: [Test.Framework.Test] testPatricia = let gr0 = foldl (\g -> snd . HGL.insertLabeledVertex g) @@ -199,4 +271,11 @@ do let gr2 = Bi.bimap (+2) (succ . succ) gr1 sum (snd <$> HGL.labeledVertices gr2) @?= 27 L.sort (snd <$> HGL.labeledEdges gr2) @?= "cde" + + , "replaceLabeledVertex" ~: + do let gr2 = HGL.replaceLabeledVertex gr1 (vs !! 2) 11 + -- Vertex label changed? + sum (snd <$> HGL.labeledVertices gr2) @?= (15 + (11 - 4)) + -- Edges are still in place? + L.sort (snd <$> HGL.labeledEdges gr2) @?= "abc" ]