haggle-0.3.1: tests/GraphTests.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | This module tests Haggle by comparing its results to those of FGL.
-- This assumes that FGL is reasonably correct.
--
-- The arbitrary instance for GraphPair generates a list of edges and
-- 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 )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Test.Framework.Providers.HUnit ( hUnitTestToTests )
import Test.HUnit
import Test.QuickCheck

import Control.Arrow ( first, second )
import qualified Data.Bifunctor as Bi
import Control.Monad ( replicateM )
import Data.Function ( on )
import qualified Data.Foldable as F
import qualified Data.List as L
import Data.Maybe ( fromJust, isNothing )
import qualified Data.Set as S
#if MIN_VERSION_base(4, 11, 0)
#else
import           Data.Monoid ( (<>) )
#endif

import qualified Data.Graph.Inductive as FGL
import qualified Data.Graph.Haggle as HGL
import qualified Data.Graph.Haggle.Algorithms.DFS as HGL
import qualified Data.Graph.Haggle.Algorithms.Dominators as HGL

-- import Debug.Trace
-- debug = flip trace

type BaseGraph = FGL.Gr Int ()
type TestGraph = HGL.VertexLabeledGraph HGL.SimpleBiDigraph Int

data GraphPair = GP [(Int, Int)] BaseGraph TestGraph

instance Arbitrary GraphPair where
  arbitrary = sized mkGraphPair

instance Show GraphPair where
  show (GP es _ _) = show es

newtype NodeId = NID Int
  deriving (Show)
instance Arbitrary NodeId where
  arbitrary = sized mkNodeId
    where
      mkNodeId n = do
        i <- choose (0, n)
        return (NID i)

-- | Generates a pair of a Haggle graph and the corresponding FGL graph to serve
-- as an oracle.
mkGraphPair :: Int -> Gen GraphPair
mkGraphPair sz = do
  nEdges <- choose (2, 2 * sz)
  srcs <- replicateM nEdges (choose (0, sz))
  dsts <- replicateM nEdges (choose (0, sz))
  let edges = unique $ zip srcs dsts
      nids = unique (srcs ++ dsts)
      ns = zip nids nids
      bg = FGL.mkGraph ns (map (\(s, d) -> (s, d, ())) edges)
      (tg, _) = HGL.fromEdgeList HGL.newMSimpleBiDigraph edges
  return $! GP edges bg tg



main :: IO ()
main = defaultMain tests

tests :: [Test.Framework.Test]
tests = [ testProperty "prop_sameVertexCount" prop_sameVertexCount
        , testProperty "prop_sameEdgeCount" prop_sameEdgeCount
        , testProperty "prop_sameSuccessorsAtLabel" prop_sameSuccessorsAtLabel
        , testProperty "prop_samePredecessorsAtLabel" prop_samePredecessorsAtLabel
        , testProperty "prop_dfsSame" prop_dfsSame
        , 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

        , testProperty "patricia match: remaining vertices" prop_match_patricia_remvertices
        , testProperty "patricia match: vertex label removed" prop_match_patricia_vlblremoved
        , testProperty "patricia match: disconnected to" prop_match_patricia_no_in_edges
        , testProperty "patricia match: disconnected from" prop_match_patricia_no_out_edges
        , testProperty "patricia match: edges removed" prop_match_patricia_remedges
        ] <>  testPatricia
        <> testExplicit

prop_sameVertexCount :: GraphPair -> Bool
prop_sameVertexCount (GP _ bg tg) =
  length (FGL.nodes bg) == length (HGL.vertices tg)

prop_sameEdgeCount :: GraphPair -> Bool
prop_sameEdgeCount (GP _ bg tg) =
  length (FGL.edges bg) == length (HGL.edges tg)

prop_sameSuccessorsAtLabel :: (NodeId, GraphPair) -> Bool
prop_sameSuccessorsAtLabel (NID nid, GP _ bg tg)
  | not (FGL.gelem nid bg) && isNothing (vertexFromLabel tg nid) = True
  | otherwise = bss == tss
  where
    bss = S.fromList $ fmap Just $ FGL.suc bg nid
    ts = maybe [] (map (HGL.vertexLabel tg) . HGL.successors tg) (vertexFromLabel tg nid)
    tss = S.fromList ts

prop_samePredecessorsAtLabel :: (NodeId, GraphPair) -> Bool
prop_samePredecessorsAtLabel (NID nid, GP _ bg tg)
  | not (FGL.gelem nid bg) && isNothing (vertexFromLabel tg nid) = True
  | otherwise = bss == tss
  where
    bss = S.fromList $ fmap Just $ FGL.pre bg nid
    ts = maybe [] (map (HGL.vertexLabel tg) . HGL.predecessors tg) (vertexFromLabel tg nid)
    tss = S.fromList ts

-- Note that this is only checking the *set* of vertices reached.  Unfortunately,
-- verifying the *order* is difficult because there are many valid DFS orders
-- (depending on the order edges are stored).  A test using the DFS number
-- (derived from the depth in the depth-first tree) would be a good complement
-- to this.
prop_dfsSame :: (NodeId, GraphPair) -> Bool
prop_dfsSame (NID root, GP _ bg tg) =
  S.fromList bres == S.fromList tres
  where
    bres = map Just $ FGL.dfs [root] bg
    v = vertexFromLabel tg root
    tres = maybe [] (map (HGL.vertexLabel tg) . HGL.dfs tg . (:[])) v

prop_immDominatorsSame :: (NodeId, GraphPair) -> Bool
prop_immDominatorsSame (NID root, GP _ bg tg)
  | not (FGL.gelem root bg) && isNothing (vertexFromLabel tg root) = True
  | otherwise = S.fromList bdoms == S.fromList tdoms
  where
    bdoms = FGL.iDom bg root
    toLabs (v1, v2) =
      let Just v1l = HGL.vertexLabel tg v1
          Just v2l = HGL.vertexLabel tg v2
      in (v1l, v2l)
    tdoms = maybe [] (map toLabs . HGL.immediateDominators tg) (vertexFromLabel tg root)

prop_dominatorsSame :: (NodeId, GraphPair) -> Bool
prop_dominatorsSame (NID root, GP _ bg tg)
  | not (FGL.gelem root bg) && isNothing (vertexFromLabel tg root) = True
  | otherwise = S.fromList (map (first Just) bdoms) == S.fromList (map (first (HGL.vertexLabel tg)) tdoms)
  where
    bdoms = map (second (S.fromList . map Just)) $ FGL.dom bg root
    Just rv = vertexFromLabel tg root
    tdoms = map (second (S.fromList . map (HGL.vertexLabel tg))) $ HGL.dominators tg rv

prop_sameComponents :: GraphPair -> Bool
prop_sameComponents (GP _ bg tg) = bcs == tcs
  where
    bcs = S.map (S.fromList . map Just) $ S.fromList $ FGL.components bg
    tcs = S.map (S.fromList . map (HGL.vertexLabel tg)) $ S.fromList $ HGL.components tg

prop_sameNoComponents :: GraphPair -> Bool
prop_sameNoComponents (GP _ bg tg) =
  FGL.noComponents bg == HGL.noComponents tg

-- Helpers

vertexFromLabel :: TestGraph -> Int -> Maybe HGL.Vertex
vertexFromLabel g lbl = F.find labelMatch (HGL.vertices g)
  where
    labelMatch v = Just lbl == (HGL.vertexLabel g v)

unique :: (Ord a) => [a] -> [a]
unique = S.toList . S.fromList

----------------------------------------------------------------------

-- 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)
                                          ]
     , "no cycle in [1-2,4] from 1" ~:
       do HGL.hasCycle (vs !! 0) gr1 @?= False

     , "cycle in [1-2-1,4] from 1" ~:
       do let tg = plusEdge gr1 (vs !! 1) (vs !! 0)
          HGL.hasCycle (vs !! 0) tg @?= True

     , "cycle in [1*-2,4] from 1" ~:
       do let tg = plusEdge gr1 (vs !! 0) (vs !! 0)
          HGL.hasCycle (vs !! 0) tg @?= True

     , "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)
            (HGL.emptyGraph :: HGL.PatriciaTree Int Char)
            [1,2,4,3,5,0]
      vs = fst <$> (L.sortBy (compare `on` snd) $ HGL.labeledVertices gr0)
      gr1 = foldl (\g (f,t,l) ->
                     snd $ fromJust $ HGL.insertLabeledEdge g f t l)
            gr0
            [ (vs !! 2, vs !! 4, 'a')
            , (vs !! 1, vs !! 4, 'b')
            , (vs !! 2, vs !! 0, 'c')
            ]
  in hUnitTestToTests $ test
     [ "create graph" ~:
       do sum (snd <$> HGL.labeledVertices gr1) @?= 15
          L.sort (snd <$> HGL.labeledEdges gr1) @?= "abc"

     , "bifunctor first (nodes)" ~:
       do let gr2 = Bi.first (+3) gr1
          sum (snd <$> HGL.labeledVertices gr2) @?= 33
          L.sort (snd <$> HGL.labeledEdges gr2) @?= "abc"

     , "bifunctor second (edges)" ~:
       do let gr2 = Bi.second (succ . succ . succ) gr1
          sum (snd <$> HGL.labeledVertices gr2) @?= 15
          L.sort (snd <$> HGL.labeledEdges gr2) @?= "def"

     , "bifunctor bimap" ~:
       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 !! 4) 11
          -- Vertex label changed?
          sum (snd <$> HGL.labeledVertices gr2) @?= (15 + (11 - 4))
          -- Edges are still in place?
          L.sort (snd <$> HGL.labeledEdges gr2) @?= "abc"
     ]


----------------------------------------------------------------------


newtype NodeLabel = NL Int deriving (Eq, Show)
newtype EdgeLabel = EL Int deriving (Eq, Show)

-- type InductiveGraphBuilder g = (g NodeLabel EdgeLabel -> g NodeLabel EdgeLabel)
data InductiveGraphBuilder g =
  IGB { build :: g NodeLabel EdgeLabel -> g NodeLabel EdgeLabel }

instance ( HGL.InductiveGraph (g NodeLabel EdgeLabel)
         , HGL.HasVertexLabel (g NodeLabel EdgeLabel)
         , HGL.HasEdgeLabel (g NodeLabel EdgeLabel)
         , HGL.VertexLabel (g NodeLabel EdgeLabel) ~ NodeLabel
         , HGL.EdgeLabel (g NodeLabel EdgeLabel) ~ EdgeLabel
         ) => Arbitrary (InductiveGraphBuilder g) where
  arbitrary = oneof [ solitaryNode
                    , edgeToNewNode
                    , edgeBetweenExistingNodes
                    , edgeToSelf
                    ]
    where solitaryNode = return $ IGB $ \g ->
            let vLabel = NL $ length $ HGL.vertices g
            in snd $ HGL.insertLabeledVertex g vLabel
          edgeToNewNode = do
            srcNum <- choose (0, 1024)
            return $ IGB $ \g ->
              let vs = HGL.vertices g
                  srcV = cycle vs !! srcNum
                  vLabel = NL $ length $ vs
                  eLabel = EL $ length $ HGL.edges g
                  (nv, ng) = HGL.insertLabeledVertex g vLabel
              in if null vs
                 then ng
                 else maybe g snd $ HGL.insertLabeledEdge ng srcV nv eLabel
          edgeBetweenExistingNodes = do
            srcNum <- choose (0, 1024)
            dstNum <- choose (0, 1024)
            -- n.b. the inductive graphs don't like duplicated edges, but they
            -- will just return Nothing on inserting the edge, which returns the
            -- existing graph, so this duplication attempt is quietly ignored.
            return $ IGB $ \g ->
              let vs = HGL.vertices g
                  srcV = cycle (HGL.vertices g) !! srcNum
                  dstV = cycle (HGL.vertices g) !! dstNum
                  eLabel = EL $ length $ HGL.edges g
              in if null vs
                 then snd $ HGL.insertLabeledVertex g $ NL 0
                 else maybe g snd $ HGL.insertLabeledEdge g srcV dstV eLabel
          edgeToSelf = do
            srcNum <- choose (0, 1024)
            -- see note above re: duplicate edges
            return $ IGB $ \g ->
              let vs = HGL.vertices g
                  srcV = cycle (HGL.vertices g) !! srcNum
                  eLabel = EL $ length $ HGL.edges g
              in if null vs
                 then snd $ HGL.insertLabeledVertex g $ NL 0
                 else maybe g snd $ HGL.insertLabeledEdge g srcV srcV eLabel


type InductiveProperty g = InductiveCase g -> Bool

data InductiveCase g = IGC g HGL.Vertex deriving Show

instance (Arbitrary g, HGL.Graph g) => Arbitrary (InductiveCase g) where
  arbitrary = do g <- arbitrary
                 v <- elements $ HGL.vertices g
                 return $ IGC g v

onMatchResult :: HGL.InductiveGraph g
              => HGL.Graph g
              => (g -> HGL.Vertex -> (HGL.Context g, g) -> Bool)
              -> InductiveProperty g
onMatchResult prop (IGC g v) =
  case HGL.match g v of
    Nothing -> False
    Just mr -> prop g v mr

prop_match_inductive_remvertices :: HGL.InductiveGraph g => InductiveProperty g
prop_match_inductive_remvertices = onMatchResult $ \g -> \_ -> \(_ctxt, g') ->
  length (HGL.vertices g) == length (HGL.vertices g') + 1

prop_match_inductive_vlblremoved :: HGL.InductiveGraph g
                                 => Eq (HGL.VertexLabel g)
                                 => InductiveProperty g
prop_match_inductive_vlblremoved = onMatchResult $ \_ -> \v -> \(ctxt, g') ->
  let HGL.Context _ vl _ = ctxt
  in not $ (v,vl) `elem` HGL.labeledVertices g'

prop_match_inductive_no_in_edges :: HGL.InductiveGraph g
                                 => InductiveProperty g
prop_match_inductive_no_in_edges = onMatchResult $ \_ -> \v -> \(ctxt, g') ->
  let HGL.Context intos _ _ = ctxt
      edgeInTo (_,sv) = v /= sv && v `elem` HGL.successors g' sv
  in not $ any edgeInTo intos

prop_match_inductive_no_out_edges :: HGL.InductiveGraph g
                                  => HGL.Bidirectional g
        => Show g
                                  => InductiveProperty g
prop_match_inductive_no_out_edges = onMatchResult $ \_ -> \v -> \(ctxt, g') ->
  let HGL.Context _ _ outs = ctxt
      edgeOutTo (_,dv) = v /= dv && v `elem` HGL.predecessors g' dv
  in not $ any edgeOutTo outs

prop_match_inductive_remedges :: HGL.InductiveGraph g
                              => HGL.HasEdgeLabel g
                              => Eq (HGL.EdgeLabel g)
                              => InductiveProperty g
prop_match_inductive_remedges = onMatchResult $ \_ -> \_ -> \(ctxt, g') ->
  let HGL.Context intos _ outs = ctxt
      remainingEdgeLabels = snd <$> HGL.labeledEdges g'
      hasEdge (el,_) = el `elem` remainingEdgeLabels
  in not $ any hasEdge $ intos <> outs

--------------------

type PatriciaProperty = InductiveProperty (HGL.PatriciaTree NodeLabel EdgeLabel)

instance Arbitrary (HGL.PatriciaTree NodeLabel EdgeLabel) where
  arbitrary = do mkGraph <- listOf1 arbitrary
                 return $ foldr build HGL.emptyGraph mkGraph

instance Show (HGL.PatriciaTree NodeLabel EdgeLabel) where
  show g = "PatriciaTree/" <> show (length $ HGL.vertices g)
           <> "/" <> show (length $ HGL.edges g)

prop_match_patricia_remvertices :: PatriciaProperty
prop_match_patricia_remvertices = prop_match_inductive_remvertices

prop_match_patricia_vlblremoved :: PatriciaProperty
prop_match_patricia_vlblremoved = prop_match_inductive_vlblremoved

prop_match_patricia_no_in_edges :: PatriciaProperty
prop_match_patricia_no_in_edges = prop_match_inductive_no_in_edges

prop_match_patricia_no_out_edges :: PatriciaProperty
prop_match_patricia_no_out_edges = prop_match_inductive_no_out_edges

prop_match_patricia_remedges :: PatriciaProperty
prop_match_patricia_remedges = prop_match_inductive_remedges