Simplify mergeEquivalent

src/Algebra/Graph.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE DeriveGeneric, RankNTypes #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RankNTypes    #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module     : Algebra.Graph
@@ -41,7 +42,7 @@ module Algebra.Graph (
 
     -- * Graph transformation
     removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex,
-    transpose, induce, induceJust, simplify, sparsify, sparsifyKL,
+    transpose, induce, induceJust, simplify, sparsify, sparsifyKL, lineGraph,
 
     -- * Graph composition
     compose, box,
@@ -50,20 +51,20 @@ module Algebra.Graph (
     Context (..), context
     ) where
 
-import Control.Applicative (Alternative)
-import Control.DeepSeq
-import Control.Monad (MonadPlus (..))
-import Control.Monad.State (runState, get, put)
-import Data.Foldable (toList)
-import Data.Maybe (fromMaybe, maybe)
-import Data.Semigroup ((<>))
-import Data.Tree
-import GHC.Generics
+import           Control.Applicative           (Alternative)
+import           Control.DeepSeq
+import           Control.Monad                 (MonadPlus (..))
+import           Control.Monad.State           (get, put, runState)
+import           Data.Foldable                 (toList)
+import           Data.Maybe                    (fromMaybe, maybe)
+import           Data.Semigroup                ((<>))
+import           Data.Tree
+import           GHC.Generics
 
-import Algebra.Graph.Internal
+import           Algebra.Graph.Internal
 
-import qualified Algebra.Graph.AdjacencyMap    as AM
 import qualified Algebra.Graph.AdjacencyIntMap as AIM
+import qualified Algebra.Graph.AdjacencyMap    as AM
 import qualified Control.Applicative           as Ap
 import qualified Data.Graph                    as KL
 import qualified Data.IntSet                   as IntSet
@@ -869,7 +870,7 @@ torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (
 
 -- | Auxiliary function for 'mesh' and 'torus'
 pairs :: [a] -> [(a, a)]
-pairs [] = []
+pairs []        = []
 pairs as@(x:xs) = zip as (xs ++ [x])
 
 -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols
@@ -1286,3 +1287,14 @@ context p g | ok f      = Just $ Context (toList $ is f) (toList $ os f)
             | otherwise = Nothing
   where
     f = focus p g
+
+
+lineGraph :: Ord a => Graph a -> Graph (a, a)
+lineGraph g = let
+    es = edgeList g
+  in overlay
+    (vertices es)
+    (edges [(e1, e2) | e1 <- es, e2 <- es, snd e1 == fst e2])
+
+grid :: Int -> Int -> Graph (Int, Int)
+grid x y = path [1..x] `box` path [1..y]

src/Algebra/Graph/NonEmpty.hs

@@ -62,7 +62,6 @@ import Control.DeepSeq
 import Control.Monad.State
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Semigroup ((<>))
-import Data.Array ((!))
 import Data.Traversable (for)
 
 import Algebra.Graph.Internal
@@ -71,7 +70,6 @@ import qualified Algebra.Graph                 as G
 import qualified Algebra.Graph.ToGraph         as T
 import qualified Algebra.Graph.AdjacencyMap    as AM
 import qualified Algebra.Graph.AdjacencyIntMap as AIM
-import qualified Data.Array                    as Array
 import qualified Data.Equivalence.Monad        as EQ
 import qualified Data.Graph                    as KL
 import qualified Data.IntSet                   as IntSet
@@ -1002,10 +1000,8 @@ components = G.foldg
 
   mergeEquivalent :: (Ord a) => (a -> a -> Bool) -> (a -> a -> a) -> ([a] -> [a])
   mergeEquivalent (===) (+) xs = let
-      len = length xs
       -- https://github.com/quchen/articles/blob/master/2018-11-22_zipWith_const.md
       indices = zipWith const [0..] xs -- Because just [0..len] generates [0] when xs == []!
-      arr = Array.listArray (0, len) xs
       combis = pairs indices
 
       update :: IntSet.IntSet -> (Int, Int) -> EQ.EquivM _ _ Int IntSet.IntSet
@@ -1023,7 +1019,7 @@ components = G.foldg
               else
                 pure s
 
-    in EQ.runEquivM (arr !) (+) $ do
+    in EQ.runEquivM (xs !!) (+) $ do
       s <- foldM update (IntSet.fromList indices) combis
       classes <- for (IntSet.toList s) EQ.classDesc
       pure classes

test/Algebra/Graph/Test.hs

@@ -21,6 +21,7 @@ module Algebra.Graph.Test (
     ) where
 
 import Data.List (sort)
+import Control.Monad (unless)
 import Data.List.Extra (nubOrd)
 import Prelude hiding ((+), (*))
 import System.Exit (exitFailure)
@@ -46,13 +47,9 @@ instance Functor Sum where
 
 test :: Testable a => String -> a -> IO ()
 test str p = do
-    result <- quickCheckWithResult (stdArgs { chatty = False }) p
-    if isSuccess result
-        then putStrLn $ "OK: " ++ str
-        else do
-            putStrLn $ "\nTest failure:\n    " ++ str ++ "\n"
-            putStrLn $ output result
-            exitFailure
+  result <- quickCheckWithResult (stdArgs { chatty = True }) p
+  putStrLn $ "+++ " ++ str
+  unless (isSuccess result) exitFailure
 
 (+) :: Graph g => g -> g -> g
 (+) = overlay

test/Algebra/Graph/Test/Generic.hs

@@ -1212,6 +1212,9 @@ testClique (prefix, API{..}) = do
     test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys ->
           clique (xs ++ ys) == connect (clique xs) (clique ys)
 
+    test "Set.fromList xs   == vertexSet (clique xs)" $ \xs ->
+          Set.fromList xs   == vertexSet (clique xs)
+
 testSymmetricClique :: TestsuiteInt g -> IO ()
 testSymmetricClique t@(_, API{..}) = do
     testClique t

test/Algebra/Graph/Test/Graph.hs

@@ -126,3 +126,6 @@ testGraph = do
 
     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])
+
+    test "edgeList x == vertexList (lineGraph x)" $ \(x :: G) ->
+          edgeList x == vertexList (lineGraph x)

test/Main.hs

@@ -1,41 +1,19 @@
-import Algebra.Graph.Test.Acyclic.AdjacencyMap
-import Algebra.Graph.Test.AdjacencyIntMap
-import Algebra.Graph.Test.AdjacencyMap
-import Algebra.Graph.Test.NonEmpty.AdjacencyMap
-import Algebra.Graph.Test.Export
-import Algebra.Graph.Test.Graph
-import Algebra.Graph.Test.NonEmpty.Graph
-import Algebra.Graph.Test.Internal
-import Algebra.Graph.Test.Labelled.AdjacencyMap
-import Algebra.Graph.Test.Labelled.Graph
-import Algebra.Graph.Test.Relation
-import Algebra.Graph.Test.Relation.SymmetricRelation
-import Data.Graph.Test.Typed
+import           Algebra.Graph                (Graph)
+import           Algebra.Graph.NonEmpty       (components, vertexCount)
+import           Algebra.Graph.Test.Arbitrary
+import           Data.Foldable
+import qualified Data.Set                     as S
+import           Test.QuickCheck
+import           Test.QuickCheck.Gen
+import           Test.QuickCheck.Random
 
-import Control.Monad
-import System.Environment
+genSeed seed (MkGen g) =
+  do let r = mkQCGen seed
+     return (g r 30)
 
--- | By default, all testsuites will be executed, which takes a few minutes. If
--- you would like to execute only some specific testsuites, you can specify
--- their names in the command line. For example:
---
--- stack test --test-arguments "Graph SymmetricRelation"
---
--- will test the modules "Algebra.Graph" and "Algebra.Graph.Symmetric.Relation".
 main :: IO ()
 main = do
-    selected <- getArgs
-    let go current = when (null selected || current `elem` selected)
-    go "AcyclicAdjacencyMap"  testAcyclicAdjacencyMap
-    go "AdjacencyIntMap"      testAdjacencyIntMap
-    go "AdjacencyMap"         testAdjacencyMap
-    go "Export"               testExport
-    go "Graph"                testGraph
-    go "Internal"             testInternal
-    go "LabelledAdjacencyMap" testLabelledAdjacencyMap
-    go "LabelledGraph"        testLabelledGraph
-    go "NonEmptyAdjacencyMap" testNonEmptyAdjacencyMap
-    go "NonEmptyGraph"        testNonEmptyGraph
-    go "Relation"             testRelation
-    go "SymmetricRelation"    testSymmetricRelation
-    go "Typed"                testTyped
+  let gen = (resize 100 $ arbitrary) :: Gen (Graph Int)
+  for_ [1..1000] $ \seed -> do
+    g <- genSeed seed gen
+    print (vertexCount <$> (S.toList $ components g))