-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Test.Graph
-- Copyright  : (c) Andrey Mokhov 2016-2018
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Testsuite for "Algebra.Graph" and polymorphic functions defined in
-- "Algebra.Graph.HigherKinded.Class".
-----------------------------------------------------------------------------
module Algebra.Graph.Test.Graph (
    -- * Testsuite
    testGraph
  ) where

import Data.Either

import Algebra.Graph
import Algebra.Graph.Test
import Algebra.Graph.Test.Generic
import Algebra.Graph.ToGraph (reachable)

t :: Testsuite
t = testsuite "Graph." empty

type G = Graph Int

testGraph :: IO ()
testGraph = do
    putStrLn "\n============ Graph ============"
    test "Axioms of graphs"   (axioms   :: GraphTestsuite G)
    test "Theorems of graphs" (theorems :: GraphTestsuite G)

    testBasicPrimitives t
    testIsSubgraphOf    t
    testToGraph         t
    testSize            t
    testGraphFamilies   t
    testTransformations t

    ----------------------------------------------------------------
    -- Generic relational composition tests, plus an additional one
    testCompose         t
    test "size (compose x y)                        <= edgeCount x + edgeCount y + 1" $ \(x :: G) y ->
          size (compose x y)                        <= edgeCount x + edgeCount y + 1
    ----------------------------------------------------------------

    putStrLn "\n============ Graph.(===) ============"
    test "    x === x         == True" $ \(x :: G) ->
             (x === x)        == True

    test "    x === x + empty == False" $ \(x :: G) ->
             (x === x + empty)== False

    test "x + y === x + y     == True" $ \(x :: G) y ->
         (x + y === x + y)    == True

    test "1 + 2 === 2 + 1     == False" $
         (1 + 2 === 2 + (1 :: G)) == False

    test "x + y === x * y     == False" $ \(x :: G) y ->
         (x + y === x * y)    == False

    putStrLn "\n============ Graph.mesh ============"
    test "mesh xs     []    == empty" $ \xs ->
          mesh xs     []    == (empty :: Graph (Int, Int))

    test "mesh []     ys    == empty" $ \ys ->
          mesh []     ys    == (empty :: Graph (Int, Int))

    test "mesh [x]    [y]   == vertex (x, y)" $ \(x :: Int) (y :: Int) ->
          mesh [x]    [y]   == vertex (x, y)

    test "mesh xs     ys    == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) ->
          mesh xs     ys    == box (path xs) (path ys)

    test "mesh [1..3] \"ab\"  == <correct result>" $
          mesh [1..3]  "ab"   == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b'))
                                    , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ]
    test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs :: [Int]) (ys :: [Int]) ->
          size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)

    putStrLn "\n============ Graph.torus ============"
    test "torus xs     []    == empty" $ \xs ->
          torus xs     []    == (empty :: Graph (Int, Int))

    test "torus []     ys    == empty" $ \ys ->
          torus []     ys    == (empty :: Graph (Int, Int))

    test "torus [x]    [y]   == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) ->
          torus [x]    [y]   == edge (x,y) (x,y)

    test "torus xs     ys    == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) ->
          torus xs     ys    == box (circuit xs) (circuit ys)

    test "torus [1,2]  \"ab\"  == <correct result>" $
          torus [1,2]   "ab"   == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b'))
                                      , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ]

    test "size (torus xs ys) == max 1 (3 * length xs * length ys)" $ \(xs :: [Int]) (ys :: [Int]) ->
          size (torus xs ys) == max 1 (3 * length xs * length ys)


    putStrLn "\n============ Graph.deBruijn ============"
    test "          deBruijn 0 xs               == edge [] []" $ \(xs :: [Int]) ->
                    deBruijn 0 xs               ==(edge [] [] :: Graph [Int])

    test "n > 0 ==> deBruijn n []               == empty" $ \n ->
          n > 0 ==> deBruijn n []               == (empty :: Graph [Int])

    test "          deBruijn 1 [0,1]            == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $
                    deBruijn 1 [0,1::Int]       == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]

    test "          deBruijn 2 \"0\"              == edge \"00\" \"00\"" $
                    deBruijn 2 "0"              == edge "00" "00"

    test "          deBruijn 2 \"01\"             == <correct result>" $
                    deBruijn 2 "01"             == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11")
                                                         , ("10","00"), ("10","01"), ("11","10"), ("11","11") ]

    test "          transpose   (deBruijn n xs) == fmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) ->
                    transpose   (deBruijn n xs) == fmap reverse (deBruijn n xs)

    test "          vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) ->
                    vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n

    test "n > 0 ==> edgeCount   (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) ->
          n > 0 ==> edgeCount   (deBruijn n xs) == (length $ nubOrd xs)^(n + 1)

    testSplitVertex t
    testBind        t
    testSimplify    t

    putStrLn "\n============ Graph.box ============"
    let unit = fmap $ \(a, ()) -> a
        comm = fmap $ \(a,  b) -> (b, a)
    test "box x y               ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) ->
          comm (box x y)        == box y x

    test "box x (overlay y z)   == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z ->
          box x (overlay y z)   == overlay (box x y) (box x z)

    test "box x (vertex ())     ~~ x" $ mapSize (min 10) $ \(x :: G) ->
     unit(box x (vertex ()))    == x

    test "box x empty           ~~ empty" $ mapSize (min 10) $ \(x :: G) ->
     unit(box x empty)          == empty

    let assoc = fmap $ \(a, (b, c)) -> ((a, b), c)
    test "box x (box y z)       ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: G) (y :: G) (z :: G) ->
      assoc (box x (box y z))   == box (box x y) z

    test "transpose   (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) ->
          transpose   (box x y) == box (transpose x) (transpose y)

    test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) ->
          vertexCount (box x y) == vertexCount x * vertexCount y

    test "edgeCount   (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) ->
          edgeCount   (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y

    putStrLn "\n============ Graph.sparsify ============"
    test "sort . reachable x       == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) ->
         (sort . reachable x) y    == (sort . rights . reachable (Right x) . sparsify) y

    test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) ->
          vertexCount (sparsify x) <= vertexCount x + size x + 1

    test "edgeCount   (sparsify x) <= 3 * size x" $ \(x :: G) ->
          edgeCount   (sparsify x) <= 3 * size x

    test "size        (sparsify x) <= 3 * size x" $ \(x :: G) ->
          size        (sparsify x) <= 3 * size x

    putStrLn "\n============ Labelled.Graph.context ============"
    test "context (const False) x                   == Nothing" $ \x ->
          context (const False) (x :: G)            == Nothing

    test "context (== 1)        (edge 1 2)          == Just (Context [   ] [2  ])" $
          context (== 1)        (edge 1 2 :: G)     == Just (Context [   ] [2  ])

    test "context (== 2)        (edge 1 2)          == Just (Context [1  ] [   ])" $
          context (== 2)        (edge 1 2 :: G)     == Just (Context [1  ] [   ])

    test "context (const True ) (edge 1 2)          == Just (Context [1  ] [2  ])" $
          context (const True ) (edge 1 2 :: G)     == Just (Context [1  ] [2  ])

    test "context (== 4)        (3 * 1 * 4 * 1 * 5) == Just (Context [3,1] [1,5])" $
          context (== 4)        (3 * 1 * 4 * 1 * 5 :: G) == Just (Context [3,1] [1,5])