math-grads-0.1.6.2: test/Isomorphism.hs

{-# OPTIONS_GHC -fno-warn-orphans  #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Main where

import           Control.Arrow                      ((***))
import qualified Data.Array                         as A
import           Data.List                          (sort)
import           Data.Map.Strict                    (Map)
import qualified Data.Map.Strict                    as M
import           Math.Grads.Graph                   (fromList, toList)
import           Test.Hspec

import           Math.Grads.Algo.Isomorphism        (GComparable (..), isIsoSub)
import qualified Math.Grads.Algo.Isomorphism.RI     as RI
import qualified Math.Grads.Algo.Isomorphism.Ullman as UI
import           Math.Grads.GenericGraph            (GenericGraph, gIndex,
                                                     getEdge)

instance GComparable GenericGraph Int Int GenericGraph Int Int where
  vComparator g1 g2 ind1 ind2 = gIndex g1 A.! ind1 == gIndex g2 A.! ind2
  eComparator _ _ (_, _, t) (_, _, t') = t == t'

pathToGraphs :: FilePath
pathToGraphs = "data/Graphs.txt"

testMap :: IO (Map String (GenericGraph Int Int))
testMap = do
    graphsInLines <- lines <$> readFile pathToGraphs
    let graphsInWords = fmap words graphsInLines

    let forMap = fmap (\(x : y : _) -> (x, fromList (read y))) graphsInWords
    return (M.fromList forMap)

bigSubGraph :: GenericGraph Int Int
bigSubGraph = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]
                       , [ (0, 1, 1), (0, 26, 1), (1, 2, 1), (2, 3, 1), (3, 4, 1), (3, 25, 1), (4, 5, 1), (4, 11, 1), (5, 6, 1)
                         , (6, 7, 1), (7, 8, 1), (7, 10, 1), (8, 9, 1), (9, 10, 1), (11, 12, 1), (11, 24, 1), (12, 13, 1), (13, 14, 1)
                         , (13, 18, 1), (14, 15, 1), (15, 16, 1), (16, 17, 1), (17, 18, 1), (18, 19, 1), (19, 20, 1), (19, 24, 1)
                         , (20, 21, 1), (21, 22, 1), (22, 23, 1), (23, 24, 1), (25, 26, 1)
                         ]
                       )

pathGraph :: GenericGraph Int Int
pathGraph = fromList ([0, 0, 0, 0, 0, 0, 0], [(0, 1, 1), (0, 2, 1), (0, 3, 1), (0, 4, 1), (4, 5, 1), (4, 6, 1)])

conjugatedCycles :: GenericGraph Int Int
conjugatedCycles = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]
                            , [ (0, 1, 1), (0, 2, 1), (1, 3, 1), (2, 4, 1), (4, 5, 1), (3, 5, 1), (3, 6, 1), (5, 7, 1)
                              , (6, 8, 1), (7, 9, 1), (8, 9, 1), (1, 10, 1), (6, 11, 1), (10, 12, 1), (11, 12, 1)
                              ]
                            )

connectedCycles :: GenericGraph Int Int
connectedCycles = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]
                           , [ (0, 1, 1), (0, 2, 1), (1, 3, 1), (2, 4, 1), (4, 5, 1), (3, 5, 1), (3, 6, 1), (6, 7, 1)
                             , (6, 8, 1), (7, 9, 1), (8, 10, 1), (9, 11, 1), (10, 11, 1), (8, 12, 1)
                             ]
                           )

cycleAndTriangle :: GenericGraph Int Int
cycleAndTriangle = fromList ( [0, 0, 0, 0, 0, 0, 0, 0, 0, 0]
                            , [ (0, 1, 1), (0, 2, 1), (1, 3, 1), (2, 4, 1), (3, 4, 1), (4, 5, 1), (5, 6, 1), (6, 7, 1)
                              , (7, 8, 1), (7, 9, 1), (8, 9, 1)
                              ]
                            )

triangleAndTriangle :: GenericGraph Int Int
triangleAndTriangle = fromList ( [0, 0, 0, 0, 0, 0, 0]
                               , [(0, 1, 1), (0, 2, 1), (1, 2, 1), (1, 3, 1), (3, 4, 1), (3, 5, 1), (4, 5, 1)]
                               )

testIsIsoSub :: SpecWith ()
testIsIsoSub = describe "Check whether subgraph isomorphism algorithm is working correctly" $ do
    it "Path" $ do
        graph <- fmap (M.! "only_path") testMap
        graph `shouldSatisfy` isIsoSub pathGraph
        uiIsoEqRiIso pathGraph graph
    it "Conjugated cycles" $ do
        graph <- fmap (M.! "only_cycles") testMap
        graph `shouldSatisfy` isIsoSub conjugatedCycles
        uiIsoEqRiIso conjugatedCycles graph
    it "Connected cycles" $ do
        graph <- fmap (M.! "simple_drawing") testMap
        graph `shouldSatisfy` isIsoSub connectedCycles
        uiIsoEqRiIso connectedCycles graph
    it "Conjugated cycles again" $ do
        graph <- fmap (M.! "hard_drawing") testMap
        graph `shouldSatisfy` isIsoSub conjugatedCycles
        uiIsoEqRiIso conjugatedCycles graph
    it "Cycle and triangle" $ do
        graph <- fmap (M.! "paths_through_conjugated_cycles") testMap
        graph `shouldSatisfy` isIsoSub cycleAndTriangle
        uiIsoEqRiIso cycleAndTriangle graph
    it "Big graph" $ do
        graph <- fmap (M.! "takes_long_if_done_wrong") testMap
        graph `shouldSatisfy` isIsoSub bigSubGraph
        uiIsoEqRiIso bigSubGraph graph
    it "Triangle and triangle. No match" $ do
        graph <- fmap (M.! "paths_through_conjugated_cycles") testMap
        graph `shouldNotSatisfy` isIsoSub triangleAndTriangle
        uiIsoEqRiIso triangleAndTriangle graph
    it "Cycle and triangle. No match" $ do
        graph <- fmap (M.! "simple_drawing") testMap
        graph `shouldNotSatisfy` isIsoSub cycleAndTriangle
        uiIsoEqRiIso cycleAndTriangle graph

uiIsoEqRiIso :: GenericGraph Int Int -> GenericGraph Int Int -> Expectation
uiIsoEqRiIso query target = do
    mapM_ (`shouldSatisfy` isValidIso query target) uiIsos
    mapM_ (`shouldSatisfy` isValidIso query target) riIsos
    length uiIsos `shouldBe` length riIsos
    toIsoList uiIsos `shouldBe` toIsoList riIsos
  where
    uiIsos = UI.getMultiIso query target
    riIsos = RI.getMultiIso query target

    toIsoList = sort . fmap (sort . M.toList)

isValidIso :: GenericGraph Int Int -> GenericGraph Int Int -> Map Int Int -> Bool
isValidIso query target iso = vsEq && esEq
  where
    (queryVs, queryEs) = toList query
    targetVs           = fst $ toList target

    vsEq = all (uncurry (==) . ((queryVs !!) *** (targetVs !!))) $ M.toList iso
    esEq = all (\(v1, v2, t) -> t == getEdge target (iso M.! v1) (iso M.! v2)) queryEs


main :: IO ()
main = hspec testIsIsoSub