content: -----------------------------------------------------------------------------
  -- |
  -- Module     : Algebra.Graph.Test.Graph
  -- Copyright  : (c) Andrey Mokhov 2016-2025
  -- 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.API (toIntAPI, graphAPI)
  import Algebra.Graph.Test.Generic
  import Algebra.Graph.ToGraph (reachable)
  
  import qualified Data.Graph as KL
  
  tPoly :: Testsuite Graph Ord
  tPoly = ("Graph.", graphAPI)
  
  t :: TestsuiteInt Graph
  t = fmap toIntAPI tPoly
  
  type G = Graph Int
  
  testGraph :: IO ()
  testGraph = do
      putStrLn "\n============ Graph ============"
      test "Axioms of graphs"   (axioms   @G)
      test "Theorems of graphs" (theorems @G)
  
      testBasicPrimitives t
      testIsSubgraphOf    t
      testToGraph         t
      testSize            t
      testGraphFamilies   t
      testTransformations t
      testInduceJust      tPoly
  
      ----------------------------------------------------------------
      -- 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
  
  
      testMesh        tPoly
      testTorus       tPoly
      testDeBruijn    tPoly
      testSplitVertex t
      testBind        t
      testSimplify    t
      testBox         tPoly
  
      putStrLn "\n============ Graph.sparsify ============"
      test "sort . reachable x       == sort . rights . reachable (sparsify x) . Right" $ \(x :: G) y ->
           (sort . reachable x) y    ==(sort . rights . reachable (sparsify x) . Right) 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============ Graph.sparsifyKL ============"
      test "sort . reachable x                 == sort . filter (<= n) . reachable (sparsifyKL n x)" $ \(Positive n) -> do
          let pairs = (,) <$> choose (1, n) <*> choose (1, n)
          es <- listOf pairs
          let x = vertices [1..n] `overlay` edges es
          y <- choose (1, n)
          return $ (sort . reachable x) y == (sort . filter (<= n) . KL.reachable (sparsifyKL n x)) y
  
      test "length (vertices $ sparsifyKL n x) <= vertexCount x + size x + 1" $ \(Positive n) -> do
          let pairs = (,) <$> choose (1, n) <*> choose (1, n)
          es <- listOf pairs
          let x = vertices [1..n] `overlay` edges es
          return $ length (KL.vertices $ sparsifyKL n x) <= vertexCount x + size x + 1
  
      test "length (edges    $ sparsifyKL n x) <= 3 * size x" $ \(Positive n) -> do
          let pairs = (,) <$> choose (1, n) <*> choose (1, n)
          es <- listOf pairs
          let x = vertices [1..n] `overlay` edges es
          return $ length (KL.edges $ sparsifyKL n x) <= 3 * size x
  
      putStrLn "\n============ 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])
  
      putStrLn "\n============ Graph.buildg ============"
      test "buildg (\\e _ _ _ -> e)                                     == empty" $
            buildg (\e _ _ _ -> e)                                      == (empty :: G)
  
      test "buildg (\\_ v _ _ -> v x)                                   == vertex x" $ \(x :: Int) ->
            buildg (\_ v _ _ -> v x)                                    == vertex x
  
      test "buildg (\\e v o c -> o (foldg e v o c x) (foldg e v o c y)) == overlay x y" $ \(x :: G) y ->
            buildg (\e v o c -> o (foldg e v o c x) (foldg e v o c y))  == overlay x y
  
      test "buildg (\\e v o c -> c (foldg e v o c x) (foldg e v o c y)) == connect x y" $ \(x :: G) y ->
            buildg (\e v o c -> c (foldg e v o c x) (foldg e v o c y))  == connect x y
  
      test "buildg (\\e v o _ -> foldr o e (map v xs))                  == vertices xs" $ \(xs :: [Int]) ->
            buildg (\e v o _ -> foldr o e (map v xs))                   == vertices xs
  
      test "buildg (\\e v o c -> foldg e v o (flip c) g)                == transpose g" $ \(g :: G) ->
            buildg (\e v o c -> foldg e v o (flip c) g)                 == transpose g
  