fgl-5.5.3.1: test/Data/Graph/Inductive/Graph/Properties.hs
{-# LANGUAGE CPP #-}
{- |
Module : Data.Graph.Inductive.Properties
Description : Expected properties of inductive graphs
Copyright : (c) Ivan Lazar Miljenovic
License : BSD3
Maintainer : Ivan.Miljenovic@gmail.com
-}
module Data.Graph.Inductive.Graph.Properties where
import Data.Graph.Inductive
import Data.Graph.Inductive.Arbitrary
import Data.Graph.Inductive.Proxy
import Test.QuickCheck
import Control.Applicative (liftA2)
import Control.Arrow ((***))
import Data.Function (on)
import Data.List (groupBy, sort, sortBy)
import qualified Data.Set as S
#if __GLASGOW_HASKELL__ < 710
import Data.Functor ((<$>))
#endif
{-# ANN module "HLint: ignore Use camelCase" #-}
-- -----------------------------------------------------------------------------
-- Non-dynamic graphs
-- | Ensure that a custom 'Eq' instance matches the behaviour of the
-- 'equal' function.
valid_Eq :: (Graph gr, Eq a, Eq b, Eq (gr a b)) => gr a b -> gr a b -> Bool
valid_Eq g1 g2 = (equal g1 g1 && g1 == g1)
&& (equal g2 g2 && g2 == g2)
&& (equal g1 g2 == (g1 == g2))
-- | Ensure that the definition of 'noNodes' matches the default
-- implementation.
valid_node_count :: (Graph gr) => gr a b -> Bool
valid_node_count g = noNodes g == length (nodes g)
-- | Ensure that the definition of 'nodeRange' matches the default
-- implementation.
valid_nodeRange :: (Graph gr) => gr a b -> Property
valid_nodeRange g = not (isEmpty g) ==>
nodeRange g == (minimum vs, maximum vs)
where
vs = nodes g
-- | Make sure that a graph created with specified nodes contains
-- those nodes (and only those nodes) and no edges are created.
valid_mkGraph_nodes :: (Graph gr, Arbitrary a, Eq a) => Proxy (gr a b) -> Gen Bool
valid_mkGraph_nodes p = do ns <- arbitraryNodes
let g = mkGraph ns [] `asProxyTypeOf` p
return ( sortOn fst (labNodes g) == ns
&& null (labEdges g))
-- | Make sure that a graph created with specified edges contains
-- those edges (and only those edges), and that no additional nodes
-- are created.
valid_mkGraph_edges :: (Graph gr, Eq a, Eq b) => Proxy (gr a b)
-> GraphNodesEdges a b -> Bool
valid_mkGraph_edges p (GNEs ns es) = sortOn toEdge (labEdges g) == es'
&& sortOn fst (labNodes g) == ns
where
es' = uniqBy toEdge es
g = mkGraph ns es' `asProxyTypeOf` p
-- | The resultant graph shouldn't matter on the order of nodes and
-- edges provided.
valid_mkGraph_order :: (Graph gr, Eq a, Eq b) => Proxy (gr a b)
-> GraphNodesEdges a b -> Bool
valid_mkGraph_order p (GNEs ns es) = all (equal g)
[ mkGraph ns esR
, mkGraph nsR es
, mkGraph nsR esR
]
where
g = mkGraph ns es `asProxyTypeOf` p
nsR = reverse ns
esR = reverse es
-- | Ensure that when a node is matched, it is indeed removed from the
-- resulting graph.
valid_match :: (Graph gr) => gr a b -> Property
valid_match g = not (isEmpty g) ==> check_match <$> elements (nodes g)
where
ordr = noNodes g
check_match n = maybe False check_context mc
where
(mc, g') = match n g
check_context c = (node' c `notElem` nodes g')
&& (noNodes g' == ordr - 1)
-- Edges were previously in the graph
&& all (elem (node' c) . pre g) (sucC c)
&& all (elem (node' c) . suc g) (preC c)
-- Edges not in new graph
&& all (notElem (node' c) . pre g') (sucC c)
&& all (notElem (node' c) . suc g') (preC c)
-- | Ensure that 'matchAny' is valid by verifying that it achieves the
-- same result as matching for that node specifically.
valid_matchAny :: (Graph gr, Eq a, Ord b) => gr a b -> Property
valid_matchAny g = not (isEmpty g) ==>
(uncurry (&&)
. (maybe False ((c'==) . sortContext) *** equal g')
$ match (node' c) g)
where
(c,g') = matchAny g
c' = sortContext c
-- | newNodes should return Nodes that aren't already in the graph.
newNodes_really_new :: (Graph gr) => gr a b -> NonNegative Int -> Bool
newNodes_really_new g (NonNegative n) = liftA2 (&&) (all (not . (`gelem`g)))
((n==) . length)
(newNodes n g)
-- | ufold should create a Context for each node.
ufold_all_nodes :: (Graph gr) => gr a b -> Bool
ufold_all_nodes g = sort (ufold ((:) . node') [] g)
== sort (nodes g)
-- | All nodes should indeed be elements of the graph.
all_nodes_gelem :: (Graph gr) => gr a b -> Bool
all_nodes_gelem g = all (`gelem`g) (nodes g)
-- | If a potential 'Node' is 'gelem' then it should also be in the
-- output of 'nodes'.
gelem_in_nodes :: (Graph gr) => gr a b -> [Node] -> Bool
gelem_in_nodes g = all (liftA2 (==) (`gelem`g) (`S.member`ns))
where
ns = S.fromList $ nodes g
-- | Check that having a labelled edge in a graph is equivalent to
-- 'hasNeighborAdj' reporting that the edge is there.
valid_hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> Node -> b -> Bool
valid_hasNeighborAdj gr v w l = any (`elem` [(v,w,l), (w,v,l)]) (labEdges gr)
== (hasNeighborAdj gr v (l,w) && hasNeighborAdj gr w (l,v))
-- | Check that having an edge in a graph is equivalent to
-- 'hasNeighbor' reporting that the edge is there.
valid_hasNeighbor :: (Graph gr) => gr a b -> Node -> Node -> Bool
valid_hasNeighbor gr v w =
any (`elem` [(v,w), (w,v)]) (edges gr) == (hasNeighbor gr v w && hasNeighbor gr w v)
-- | Check that having a labelled edge in a graph is equivalent to
-- 'hasLEdge' reporting that the edge is there.
valid_hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool
valid_hasLEdge gr e = (e `elem` labEdges gr) == hasLEdge gr e
-- -----------------------------------------------------------------------------
-- Dynamic graphs
-- | Ensure that matching and then merging using '&' produces the
-- original graph again.
--
-- We do it this way because it isn't possible to generate an
-- arbitrary 'Context' to test against; 'valid_match' \"proves\"
-- that matching is valid, so if merging produces the original graph
-- again then it must be valid as well.
valid_merge :: (DynGraph gr, Eq a, Eq b) => gr a b -> Property
valid_merge g = not (isEmpty g) ==> check_merge <$> elements (nodes g)
where
-- Using equal here rather than requiring an Eq instance.
check_merge n = maybe False (equal g . (&g')) mc
where
(mc, g') = match n g
-- | Applying a mapping over contexts shouldn't actually change the
-- structure of the graph.
--
-- Note that 'nmap', 'emap' and 'nemap' are specialised versions of
-- 'gmap' and thus this property also covers those.
gmap_id :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool
gmap_id g = equal (gmap id g) g
-- | 'insNode' inserts a single node and doesn't add or delete any
-- edges.
--
-- This is technically also tested using 'valid_insEdge'.
--
-- Note that we specifically use 'newNodes' to test this, as the
-- current behaviour is to throw an error if an existing node is
-- used.
valid_insNode :: (DynGraph gr, Ord a, Ord b) => gr a b -> a -> Bool
valid_insNode g l = gelem v g'
&& sort (labNodes g') == sort (vl : labNodes g)
&& sort (labEdges g') == sort (labEdges g)
-- Note: not testing whether this changes
-- nodeRange because newNodes /might/ return
-- unused nodes in the middle.
where
[v] = newNodes 1 g
vl = (v,l)
g' = insNode vl g
-- | Insert a node for every label in the list, but don't add any new
-- edges.
--
-- Note that we specifically use 'newNodes' to test this, as the
-- current behaviour is to throw an error if an existing node is
-- used.
valid_insNodes :: (DynGraph gr, Ord a, Ord b) => gr a b -> [a] -> Bool
valid_insNodes g as = all (`gelem`g') ns
&& sort (labNodes g') == sort (lns ++ labNodes g)
&& sort (labEdges g') == sort (labEdges g)
where
c = length as
ns = newNodes c g
lns = zip ns as
g' = insNodes lns g
-- | Test inserting an edge. This could possibly be a multiple edge
-- or loop.
valid_insEdge :: (DynGraph gr, Ord a, Ord b) => gr a b -> b -> Property
valid_insEdge g b = not (isEmpty g) ==>
do v <- pickN
w <- pickN
let el = (v,w,b)
g' = insEdge el g
return ( sort (labEdges g') == sort (el : labEdges g)
&& sort (labNodes g') == sort (labNodes g))
where
pickN = elements (nodes g)
-- | Insert an edge for every label in the list. Multiple edges and
-- loops allowed.
valid_insEdges :: (DynGraph gr, Ord a, Ord b) => gr a b -> [b] -> Property
valid_insEdges g bs = not (isEmpty g) ==>
do es <- mapM toLE bs
let g' = insEdges es g
return ( sort (labEdges g') == sort (es ++ labEdges g)
&& sort (labNodes g') == sort (labNodes g))
where
pickN = elements (nodes g)
toLE b = do v <- pickN
w <- pickN
return (v,w,b)
-- | Explicitly test adding multiple edges.
valid_insEdges_multiple :: (DynGraph gr, Ord b) => gr a b -> b -> NonNegative Int
-> Property
valid_insEdges_multiple g b (NonNegative c) = not (isEmpty g) ==>
do v <- pickN
w <- pickN
let bes = replicate c (v,w,b)
g' = insEdges bes g
es' = bes ++ es
return $ sort (labEdges g') == sort es'
where
pickN = elements (nodes g)
es = labEdges g
-- | Delete a node, and ensure there are no edges
-- referencing that node afterwards.
valid_delNode :: (DynGraph gr) => gr a b -> Node -> Bool
valid_delNode g v = not (gelem v g')
&& (v `S.notMember` S.fromList (esToNs (labEdges g')))
where
g' = delNode v g
-- | Test deleting a sub-set of nodes.
valid_delNodes :: (DynGraph gr) => gr a b -> [Node] -> Bool
valid_delNodes g vs = all (liftA2 (&&) (not . (`gelem` g')) (`S.notMember` ens)) vs
where
g' = delNodes vs g
ens = S.fromList (esToNs (labEdges g'))
-- | Delete an edge, and ensure that the nodes from that
-- edge are still there (if that edge was present in the graph to
-- start with).
valid_delEdge :: (DynGraph gr) => gr a b -> (Node,Node) -> Bool
valid_delEdge g e@(v,w) = notElem e (edges g')
&& ifOrig v
&& ifOrig w
where
g' = delEdge e g
ifOrig n = not (n `gelem` g) || (n `gelem` g')
-- | Test deleting multiple edges.
valid_delEdges :: (DynGraph gr) => gr a b -> [Edge] -> Bool
valid_delEdges g es = all check_E es
where
origEs = S.fromList (edges g)
g' = delEdges es g
newEs = S.fromList (edges g')
check_E e@(v,w) = (e `S.notMember` origEs)
|| ( (e `S.notMember` newEs)
&& (v `gelem` g')
&& (w `gelem` g')
)
-- | Add a 'LEdge' then delete it; the resulting graph should be the
-- same as the original graph.
valid_delLEdge :: (DynGraph gr, Eq a, Eq b) => gr a b -> b -> Property
valid_delLEdge g b = not (isEmpty g) ==>
do v <- pickN
w <- pickN
let le = (v,w,b)
g' = insEdge le g
g'' = delLEdge le g'
return (equal g g'')
where
pickN = elements (nodes g)
-- | Test deleting all labelled edges equal to the specified one, by
-- adding the specified number to the graph and then deleting them.
valid_delAllLEdge :: (DynGraph gr, Eq a, Eq b) => gr a b -> NonNegative Int
-> a -> a -> b -> Bool
valid_delAllLEdge g (NonNegative c) a1 a2 b = equal g' (delAllLEdge le g'')
where
[v,w] = newNodes 2 g
g' = insNodes [(v,a1),(w,a2)] g
le = (v,w,b)
g'' = insEdges (replicate c le) g'
-- | There is a version of 'mkGraph' in its documentation that uses
-- 'DynGraph' (hence why it isn't used by default). This ensures
-- that the optimised variants match this \"default\" definition.
valid_mkGraph :: (DynGraph gr, Eq a, Eq b) => Proxy (gr a b)
-> GraphNodesEdges a b -> Bool
valid_mkGraph p (GNEs ns es) = equal mkGr (mkGraph ns es)
where
mkGr = (insEdges es . insNodes ns) empty `asProxyTypeOf` p
-- | 'buildGr' re-creates the original graph after 'ufold' obtains all
-- the contexts.
valid_buildGr :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool
valid_buildGr g = equal g (buildGr cs)
where
cs = ufold (:) [] g
-- | Tests `gfiltermap` with a function accepting all contexts.
gfiltermap_id :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool
gfiltermap_id g = equal (gfiltermap Just g) g
-- | Tests `nfilter` with a function accepting all nodes.
nfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool
nfilter_true g = equal (nfilter (const True) g) g
-- | Tests `labnfilter` with a function accepting all nodes.
labnfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool
labnfilter_true g = equal (labnfilter (const True) g) g
-- | Tests `labnfilter` with a function accepting all nodes.
labfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool
labfilter_true g = equal (labfilter (const True) g) g
-- | The subgraph induced by a list of nodes should contain exactly
-- the nodes from this list, as well as all edges between these nodes.
valid_subgraph :: (DynGraph gr, Ord b) => gr a b -> Gen Bool
valid_subgraph gr = do
vs <- sublistOf $ nodes gr
let sg = subgraph vs gr
svs = S.fromList vs
subedges = filter (\(v,w,_) -> v `S.member` svs && w `S.member` svs) $ labEdges gr
return $ sort (nodes sg) == sort vs && sort (labEdges sg) == sort subedges
-- -----------------------------------------------------------------------------
-- Miscellaneous
-- | Ensure the edge projection functions work as intended.
edge_projections :: (Eq b) => LEdge b -> Bool
edge_projections le = le == toLEdge (toEdge le) (edgeLabel le)
-- -----------------------------------------------------------------------------
esToNs :: [LEdge b] -> [Node]
esToNs = uniqBy id . concatMap (\(v,w,_) -> [v,w])
uniqBy :: (Ord b) => (a -> b) -> [a] -> [a]
uniqBy f = map head . groupBy ((==) `on` f) . sortOn f
sortOn :: (Ord b) => (a -> b) -> [a] -> [a]
sortOn f = sortBy (compare `on` f)
-- | As with suc', but also remove any loops
sucC :: Context a b -> [Node]
sucC c = filter (/= node' c) (suc' c)
-- | As with pre', but also remove any loops
preC :: Context a b -> [Node]
preC c = filter (/= node' c) (pre' c)
-- In case a Context is produced with the Adj lists in different
-- orders, sort them so that they can then be equality tested.
sortContext :: (Ord b) => Context a b -> Context a b
sortContext (p,v,l,s) = (sort p, v, l, sort s)