module Main (main) where
import qualified Data.Graph.Comfort as Graph
import Data.Graph.Comfort (Graph)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Char as Char
import Data.Bool.HT (implies)
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import Control.Applicative (liftA2, pure)
import Data.Functor.Identity (Identity(Identity), runIdentity)
import qualified Test.QuickCheck as QC
type Edge = Graph.DirEdge
type Node = Int
type EdgeLabel = Integer
type NodeLabel = Char
type MonoGraph = Graph Edge Node EdgeLabel NodeLabel
newtype TestGraph = TestGraph {getTestGraph :: MonoGraph}
deriving (Show)
instance QC.Arbitrary TestGraph where
shrink (TestGraph g) =
case Graph.nodeSet g of
ns ->
map (TestGraph . flip Graph.deleteNodeSet g .
Set.difference ns . Set.fromList) $
QC.shrink $ Set.toList ns
arbitrary = do
nodes <- QC.arbitrary
fmap TestGraph $
if null nodes
then return Graph.empty
else do
let genNode = QC.elements $ map fst nodes
fmap (Graph.fromList nodes) $ QC.listOf $
liftA2 (,)
(liftA2 Graph.DirEdge genNode genNode) QC.arbitrary
data GraphAndEdge = GraphAndEdge MonoGraph (Edge Node)
deriving (Show)
instance QC.Arbitrary GraphAndEdge where
shrink (GraphAndEdge gr e) =
map (\(TestGraph g) -> GraphAndEdge g e) $ QC.shrink $ TestGraph gr
arbitrary =
let makeGraph p consEdge = do
TestGraph gr <- QC.suchThat QC.arbitrary $ p . getTestGraph
fmap (GraphAndEdge gr) $ consEdge gr
in QC.oneof
[makeGraph (not . null . Graph.edges) $ QC.elements . Graph.edges,
makeGraph (not . null . Graph.nodes) $
\gr ->
let selNode = QC.elements $ Graph.nodes gr
in liftA2 Graph.DirEdge selNode selNode]
test :: (QC.Testable prop) => String -> prop -> IO ()
test msg prop =
putStr (msg ++ ": ") >> QC.quickCheck prop
emptyIsEmpty :: Bool
emptyIsEmpty =
Graph.isEmpty (Graph.empty :: MonoGraph)
emptyIsConsistent :: Bool
emptyIsConsistent =
Graph.isEmpty (Graph.empty :: MonoGraph)
fromMapNodeEdgeLabels :: TestGraph -> Bool
fromMapNodeEdgeLabels (TestGraph gr) =
Graph.fromMap (Graph.nodeLabels gr) (Graph.edgeLabels gr) == gr
reverseIsConsistent :: TestGraph -> Bool
reverseIsConsistent (TestGraph gr) =
Graph.isConsistent (Graph.reverse gr)
reverseReverse :: TestGraph -> Bool
reverseReverse (TestGraph gr) =
Graph.reverse (Graph.reverse gr) == gr
mapNodeId :: TestGraph -> Bool
mapNodeId (TestGraph gr) =
Graph.mapNode id gr == gr
mapEdgeId :: TestGraph -> Bool
mapEdgeId (TestGraph gr) =
Graph.mapEdge id gr == gr
insertNodeIsConsistent :: TestGraph -> Node -> NodeLabel -> Bool
insertNodeIsConsistent (TestGraph gr) n nl =
Graph.isConsistent $ Graph.insertNode n nl gr
insertLookupNode :: TestGraph -> Node -> NodeLabel -> Bool
insertLookupNode (TestGraph gr) n nl =
Graph.lookupNode n (Graph.insertNode n nl gr) == Just nl
lookupNodeLabels :: TestGraph -> Node -> Bool
lookupNodeLabels (TestGraph gr) n =
Graph.lookupNode n gr == Map.lookup n (Graph.nodeLabels gr)
deleteNodeIfExists :: Node -> MonoGraph -> MonoGraph
deleteNodeIfExists n gr =
maybe gr (const $ Graph.deleteNode n gr) $ Graph.lookupNode n gr
deleteNodeIsConsistent :: TestGraph -> Node -> Bool
deleteNodeIsConsistent (TestGraph gr) n =
Graph.isConsistent $ deleteNodeIfExists n gr
deleteInsertNode :: TestGraph -> Node -> NodeLabel -> Bool
deleteInsertNode (TestGraph gr) n nl =
Graph.deleteNode n (Graph.insertNode n nl gr)
==
deleteNodeIfExists n gr
insertDeleteNode :: TestGraph -> Node -> NodeLabel -> Bool
insertDeleteNode (TestGraph gr) n nl =
let isolated =
maybe False (const True) (Graph.lookupNode n gr)
&&
Set.null (Graph.adjacentEdgeSet gr n)
in isolated `implies`
Graph.insertNode n nl gr
==
Graph.insertNode n nl (Graph.deleteNode n gr)
insertEdgeIsConsistent :: GraphAndEdge -> EdgeLabel -> Bool
insertEdgeIsConsistent (GraphAndEdge gr e) el =
Graph.isConsistent $ Graph.insertEdge e el gr
insertLookupEdge :: GraphAndEdge -> EdgeLabel -> Bool
insertLookupEdge (GraphAndEdge gr e) el =
Graph.lookupEdge e (Graph.insertEdge e el gr) == Just el
lookupEdgeLabels :: GraphAndEdge -> Bool
lookupEdgeLabels (GraphAndEdge gr e) =
Graph.lookupEdge e gr == Map.lookup e (Graph.edgeLabels gr)
deleteEdgeIsConsistent :: GraphAndEdge -> Bool
deleteEdgeIsConsistent (GraphAndEdge gr e) =
Graph.isConsistent $ Graph.deleteEdge e gr
deleteInsertEdge :: GraphAndEdge -> EdgeLabel -> Bool
deleteInsertEdge (GraphAndEdge gr e) el =
Graph.deleteEdge e (Graph.insertEdge e el gr)
==
Graph.deleteEdge e gr
insertDeleteEdge :: GraphAndEdge -> EdgeLabel -> Bool
insertDeleteEdge (GraphAndEdge gr e) el =
Graph.insertEdge e el gr
==
Graph.insertEdge e el (Graph.deleteEdge e gr)
filterDeleteEdge :: GraphAndEdge -> Bool
filterDeleteEdge (GraphAndEdge gr e) =
Graph.filterEdgeWithKey (\ei _ -> e/=ei) gr == Graph.deleteEdge e gr
nodeAction :: (Monad m) => NodeLabel -> MS.StateT NodeLabel m NodeLabel
nodeAction x = do y <- MS.get; MS.put x; return y
evalTraverseNode :: NodeLabel -> MonoGraph -> MonoGraph
evalTraverseNode nl =
flip MS.evalState nl . Graph.traverseNode nodeAction
traverseNodeIsConsistent :: TestGraph -> NodeLabel -> Bool
traverseNodeIsConsistent (TestGraph gr) nl =
Graph.isConsistent $ evalTraverseNode nl gr
edgeAction :: (Monad m) => EdgeLabel -> MS.StateT EdgeLabel m EdgeLabel
edgeAction x = MS.modify (x+) >> MS.get
evalTraverseEdge :: EdgeLabel -> MonoGraph -> MonoGraph
evalTraverseEdge el =
flip MS.evalState el . Graph.traverseEdge edgeAction
traverseEdgeIsConsistent :: TestGraph -> EdgeLabel -> Bool
traverseEdgeIsConsistent (TestGraph gr) el =
Graph.isConsistent $ evalTraverseEdge el gr
evalTraverse :: NodeLabel -> EdgeLabel -> MonoGraph -> MonoGraph
evalTraverse nl el =
flip MS.evalState el . flip MS.evalStateT nl .
Graph.traverse nodeAction (MT.lift . edgeAction)
traverseIsConsistent :: TestGraph -> NodeLabel -> EdgeLabel -> Bool
traverseIsConsistent (TestGraph gr) nl el =
Graph.isConsistent $ evalTraverse nl el gr
traverseNodeEdge :: TestGraph -> NodeLabel -> EdgeLabel -> Bool
traverseNodeEdge (TestGraph gr) nl el =
evalTraverseNode nl (evalTraverseEdge el gr)
==
evalTraverse nl el gr
traverseEdgeNode :: TestGraph -> NodeLabel -> EdgeLabel -> Bool
traverseEdgeNode (TestGraph gr) nl el =
evalTraverseEdge el (evalTraverseNode nl gr)
==
evalTraverse nl el gr
traverseNode :: TestGraph -> NodeLabel -> Bool
traverseNode (TestGraph gr) nl =
flip MS.evalState nl (Graph.traverseNode nodeAction gr)
==
flip MS.evalState nl (Graph.traverse nodeAction pure gr)
traverseEdge :: TestGraph -> EdgeLabel -> Bool
traverseEdge (TestGraph gr) el =
flip MS.evalState el (Graph.traverseEdge edgeAction gr)
==
flip MS.evalState el (Graph.traverse pure edgeAction gr)
traverseMapNode :: TestGraph -> Bool
traverseMapNode (TestGraph gr) =
runIdentity (Graph.traverseNode (Identity . Char.toUpper) gr)
==
Graph.mapNode Char.toUpper gr
traverseMapEdge :: TestGraph -> EdgeLabel -> Bool
traverseMapEdge (TestGraph gr) el =
runIdentity (Graph.traverseEdge (Identity . (el+)) gr)
==
Graph.mapEdge (el+) gr
main :: IO ()
main = do
test "emptyIsEmpty" $ emptyIsEmpty
test "emptyIsConsistent" $ emptyIsConsistent
test "fromMapNodeEdgeLabels" $ fromMapNodeEdgeLabels
test "reverseIsConsistent" $ reverseIsConsistent
test "reverseReverse" $ reverseReverse
test "mapNodeId" $ mapNodeId
test "mapEdgeId" $ mapEdgeId
test "insertNodeIsConsistent" $ insertNodeIsConsistent
test "insertLookupNode" $ insertLookupNode
test "lookupNodeLabels" $ lookupNodeLabels
test "deleteNodeIsConsistent" $ deleteNodeIsConsistent
test "deleteInsertNode" $ deleteInsertNode
test "insertDeleteNode" $ insertDeleteNode
test "insertEdgeIsConsistent" $ insertEdgeIsConsistent
test "insertLookupEdge" $ insertLookupEdge
test "lookupEdgeLabels" $ lookupEdgeLabels
test "deleteEdgeIsConsistent" $ deleteEdgeIsConsistent
test "deleteInsertEdge" $ deleteInsertEdge
test "insertDeleteEdge" $ insertDeleteEdge
test "filterDeleteEdge" $ filterDeleteEdge
test "traverseNodeIsConsistent" $ traverseNodeIsConsistent
test "traverseEdgeIsConsistent" $ traverseEdgeIsConsistent
test "traverseIsConsistent" $ traverseIsConsistent
test "traverseNodeEdge" $ traverseNodeEdge
test "traverseEdgeNode" $ traverseEdgeNode
test "traverseNode" $ traverseNode
test "traverseEdge" $ traverseEdge
test "traverseMapNode" $ traverseMapNode
test "traverseMapEdge" $ traverseMapEdge