Commits

Patrick Bahr committed dad9659

- fixed a number of bugs
- added test suite containing a number of quickcheck properties (covering all of Data.Equivalence.STT according to hpc)

Comments (0)

Files changed (5)

 #!/usr/bin/env runhaskell
+
 import Distribution.Simple
-main :: IO ()
-main = defaultMain
+import Distribution.Simple.LocalBuildInfo
+import Distribution.PackageDescription
+import System.Cmd
+import System.FilePath
+import System.Directory
+import System.IO.Error
+
+
+main = defaultMainWithHooks hooks
+  where hooks = simpleUserHooks { runTests = runTests'}
+
+
+hpcReportDir = "hpcreport"
+
+runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()
+runTests' _ _ _ lbi = do
+  res <- try (removeFile tixFile)
+  case res of
+    Left err
+        | not (isDoesNotExistError err) -> putStrLn "tix file could not be removed"
+    _ -> return ()
+  putStrLn "running tests ..."
+  system testprog
+  putStrLn "computing code coverage ..."
+  hpcReport
+  putStrLn "generating code coverage reports ..."
+  hpcMarkup
+  return ()
+    where testprog = (buildDir lbi) </> "test" </> "test"
+          tixFile = "test.tix"
+          hpcReport = system $ "hpc report test"++exclArgs
+          hpcMarkup = system $ "hpc markup test --destdir="++hpcReportDir++exclArgs
+          excludedModules = []
+          exclArgs = concatMap (" --exclude="++) excludedModules

equivalence.cabal

 Name:            equivalence
-Version:         0.1.1
+Version:         0.2.0
 License:         BSD3
 License-File:    LICENSE
 Author:          Patrick Bahr <paba@diku.dk>
   ST monad transformer (instead of the IO monad).
 Category:        Algorithms, Data
 Stability:       provisional
-Build-Type:      Simple
+Build-Type:      Custom
 Cabal-Version:   >= 1.6
 
+
+flag test
+  description: Build test executable.
+  default:     False
+
 Library
   Build-Depends:
     base >= 4 && < 5, containers, mtl, STMonadTrans
     Data.Equivalence.Monad
   Hs-Source-Dirs: src
 
+Executable test
+  Main-is:		Data_Test.hs
+  Build-Depends:	base >= 4, template-haskell, containers, mtl, QuickCheck >= 2, test-framework, test-framework-quickcheck2, test-framework-th
+  hs-source-dirs:	src testsuite/tests
+  ghc-options:          -fhpc
+  if !flag(test)
+    buildable:     False

src/Data/Equivalence/STT.hs

 import Data.Map (Map)
 import qualified Data.Map as Map
 
-newtype Class s c a = Class (Entry s c a)
+newtype Class s c a = Class (STRef s (Entry s c a))
 
 
 {-| This type represents a reference to an entry in the tree data
 indexed by @s@, contains equivalence class descriptors of type @c@ and
 has elements of type @a@.-}
 
-newtype Entry s c a = Entry (STRef s (EntryData s c a))
+newtype Entry s c a = Entry {unentry :: STRef s (EntryData s c a)}
 
 {-| This type represents entries (nodes) in the tree data
 structure. Entry data of type 'EntryData' @s c a@ lives in the state space
 equivalence class. This function performs path compression. -}
 
 classRep :: (Monad m, Ord a) => Equiv s c a -> Class s c a -> STT s m (Entry s c a)
-classRep eq (Class entry) = do
+classRep eq (Class p) = do
+  entry <- readSTRef p
   (mrepr,del) <- representative' entry
   if del -- check whether equivalence class was deleted
-    then mkEntry' eq entry -- if so, create a new entry
-    else case mrepr of
-           Nothing -> return entry
-           Just repr -> return repr
+    then do v <- liftM entryValue $ readSTRef (unentry entry)
+            en <- getEntry' eq v -- if so, create a new entry
+            (mrepr,del) <- representative' en
+            if del then do
+                en' <- mkEntry' eq en
+                writeSTRef p en'
+                return en'
+              else return (fromMaybe en mrepr)
+    else return (fromMaybe entry mrepr)
   
 
 {-| This function constructs a new (root) entry containing the given
 contained in. -}
 
 getClass :: (Monad m, Ord a) => Equiv s c a -> a -> STT s m (Class s c a)
-getClass eq v = liftM Class (getEntry' eq v)
+getClass eq v = do 
+  en <- (getEntry' eq v)
+  liftM Class $ newSTRef en
+  
 
 getEntry' :: (Monad m, Ord a) => Equiv s c a -> a -> STT s m (Entry s c a)
 getEntry' eq v = do
 
 {-| This function equates the two given elements. That is, it unions
 the equivalence classes of the two elements and combines their
-descriptor. -}
+descriptor. The returned entry is the representative of the new
+equivalence class -}
 
-equateEntry :: (Monad m, Ord a) => Equiv s c a -> Entry s c a -> Entry s c a -> STT s m ()
+equateEntry :: (Monad m, Ord a) => Equiv s c a -> Entry s c a -> Entry s c a -> STT s m (Entry s c a)
 equateEntry Equiv {combDesc = mkDesc} repx@(Entry rx) repy@(Entry ry) = 
-  when (rx /= ry) $ do
+  if (rx /= ry) then do
     dx@Root{entryWeight = wx, entryDesc = chx, entryValue = vx} <- readSTRef rx
     dy@Root{entryWeight = wy, entryDesc = chy, entryValue = vy} <- readSTRef ry
     if  wx >= wy
       then do
         writeSTRef ry Node {entryParent = repx, entryValue = vy}
         writeSTRef rx dx{entryWeight = wx + wy, entryDesc = mkDesc chx chy}
+        return repx
       else do
        writeSTRef rx Node {entryParent = repy, entryValue = vx}
        writeSTRef ry dy{entryWeight = wx + wy, entryDesc = mkDesc chx chy}
+       return repy
+    else return  repx
 
-{-| This function equates all elements given in the list by pairwise
-applying 'equateEntry'. -}
 
-equateEntries :: (Monad m, Ord a) => Equiv s c a -> [Entry s c a] -> STT s m ()
-equateEntries eq es = run es
-    where run (e:r@(f:_)) = equateEntry eq e f >> run r
-          run _ = return ()
 
+combineEntries :: (Monad m, Ord a)
+               => Equiv s c a -> [b] -> (b -> STT s m (Entry s c a)) -> STT s m ()
+combineEntries  _ [] _ = return ()
+combineEntries eq (e:es) rep = do
+  er <- rep e
+  run er es
+    where run er (f:r) = do
+            fr <- rep f
+            er' <- equateEntry eq er fr
+            run er' r
+          run _ _ = return ()
 
 
 {-| This function combines all equivalence classes in the given
 equivalence class! -}
 
 combineAll :: (Monad m, Ord a) => Equiv s c a -> [Class s c a] -> STT s m ()
-combineAll eq cs = mapM (classRep eq) cs >>= equateEntries eq
+combineAll eq cls = combineEntries eq cls (classRep eq)
 
 
 {-| This function combines the two given equivalence
 descriptor. -}
 
 equateAll :: (Monad m, Ord a) => Equiv s c a -> [a] -> STT s m ()
-equateAll eq els = mapM (representative eq) els >>= equateEntries eq
+equateAll eq cls = combineEntries eq cls (representative eq)
 
 {-| This function equates the two given elements. That is, it unions
 the equivalence classes of the two elements and combines their
 otherwise @True@. -}
 
 remove :: (Monad m, Ord a) => Equiv s c a -> Class s c a -> STT s m Bool
-remove _ (Class entry) = do
-  (mentry, del) <- representative' entry
-  if del 
-    then return False
-    else removeEntry (fromMaybe entry mentry)
+remove eq (Class p) = do
+  entry <- readSTRef p
+  (mrepr,del) <- representative' entry
+  if del then do
+        v <- liftM entryValue $ readSTRef (unentry entry)
+        men <- getEntry eq v
+        case men of
+          Nothing -> return False
+          Just en -> do      
+            writeSTRef p en
+            (mentry,del) <- representative' en
+            if del 
+              then return False
+              else removeEntry (fromMaybe en mentry)
+                   >> return True
+    else removeEntry (fromMaybe entry mrepr)
          >> return True
 
 {-| This function removes the equivalence class of the given

testsuite/tests/Data/Equivalence/Monad_Test.hs

+{-# LANGUAGE RankNTypes, TemplateHaskell #-}
+
+module Data.Equivalence.Monad_Test where
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+
+import Data.Equivalence.Monad
+
+import Control.Monad
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+main = defaultMain [tests]
+
+tests = testGroup "Monad" [testProperty "singleton" prop_singleton,
+         testProperty "equateAll" prop_equateAll,
+         testProperty "combineAll" prop_combineAll,
+         testProperty "equate" prop_equate,
+         testProperty "combine" prop_combine,
+         testProperty "equateOverlap" prop_equateOverlap,
+         testProperty "combineOverlap" prop_combineOverlap,
+         testProperty "equateAllOverlap" prop_equateAllOverlap,
+         testProperty "combineAllOverlap" prop_combineAllOverlap,
+         testProperty "removeClass" prop_removeClass,
+         testProperty "remove" prop_remove,
+         testProperty "removeClass'" prop_removeClass',
+         testProperty "remove'" prop_remove',
+         testProperty "classes" prop_classes
+         ]
+
+
+-- run :: (Ord a) => STT s Identity (Equiv s (Set a) a)
+run :: (Ord v) => (forall s. EquivM s (Set v) v a) -> a
+run = runEquivM Set.singleton Set.union
+
+runInt :: (forall s. EquivM s (Set Int) Int a) -> a
+runInt = run
+
+allM f l = liftM and $ mapM f l
+
+getClasses l1 = mapM getClass l1
+
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
+prop_singleton v = runInt $ do
+  d <- classDesc v
+  return (d == Set.singleton v)
+
+prop_equateAll l' v = runInt $ do
+  let l = v:l'
+  equateAll l
+  d <- classDesc v
+  return  (d == Set.fromList l)
+
+prop_combineAll l' v = runInt $ do
+  let l = v:l'
+  cls <- getClasses l
+  cl <- getClass v
+  combineAll cls
+  d <- desc cl
+  return (d == Set.fromList l)
+
+prop_equate x y = runInt $ do
+  equate x y
+  d <- classDesc x
+  return (d == Set.fromList [x,y])
+
+prop_combine x y = runInt $ do
+  [cx,cy] <- getClasses [x,y]
+  combine cx cy
+  d <- desc cx
+  return (d == Set.fromList [x,y])
+
+prop_equateOverlap x y z = runInt $ do
+  equate x y
+  equate y z
+  equivalent x z
+
+prop_combineOverlap x y z = runInt $ do
+  [cx,cy,cz] <- getClasses [x,y,z]
+  combine cx cy
+  combine cy cz
+  cx === cz
+
+prop_equateAllOverlap x y l1' l2' = runInt $ do
+  let l1 = x:l1'
+      l2 = y:l2'
+  equateAll l1
+  equateAll l2
+  if Set.null $ Set.fromList l1 `Set.intersection` Set.fromList l2
+    then liftM not $ equivalent x y
+    else equivalent x y
+
+prop_combineAllOverlap x y l1' l2' = runInt $ do
+  let l1 = x:l1'
+      l2 = y:l2'
+  cls1 <- getClasses l1
+  cls2 <- getClasses l2
+  [cx,cy] <- getClasses [x,y]
+  combineAll cls1
+  combineAll cls2
+  if Set.null $ Set.fromList l1 `Set.intersection` Set.fromList l2
+    then liftM not (cx === cy)
+    else cx === cy
+
+prop_removeClass x l' = runInt $ do
+  let l = x:l'
+  equateAll l
+  removeClass x
+  allM (\e -> liftM (== Set.singleton e) (classDesc e)) l
+
+prop_remove x l' = runInt $ do
+  let l = x:l'
+  cls <- getClasses l
+  combineAll cls
+  cx <- getClass x
+  remove cx
+  allM check l
+      where check e = liftM (== Set.singleton e) $ getClass e >>= desc 
+
+prop_removeClass' x y l1' l2' = runInt $ do
+  let l1 = x:l1'
+      l2 = x:y:l2'
+  equateAll l1
+  removeClass x
+  equateAll l2
+  d <- classDesc y
+  return (Set.fromList l2 == d)
+
+prop_remove' x y l1' l2' = runInt $ do
+  let l1 = x:l1'
+      l2 = x:y:l2'
+  cls1 <- getClasses l1
+  cls2 <- getClasses l2
+  cx <- getClass x
+  combineAll cls1
+  remove cx
+  combineAll cls2
+  cy <- getClass y
+  d <- desc cy
+  return (Set.fromList l2 == d)
+
+
+prop_classes l1 l1' l2 x y = putStrLn (show el ++ ";" ++ show cl) `whenFail` (el == cl)
+    where l3 = concat (l2 : l1)
+          el = runInt $ do
+                 mapM equateAll l1
+                 mapM removeClass l2
+                 mapM equateAll l1'
+                 res <- mapM classDesc l3
+                 eq <- equivalent x y
+                 return (res,eq)
+          cl = runInt $ do
+                 cls1 <- mapM getClasses l1
+                 mapM combineAll cls1
+                 cls2 <- getClasses l2
+                 mapM remove cls2
+                 cls1' <- mapM getClasses l1'
+                 mapM combineAll cls1'
+                 cls3 <- getClasses l3
+                 res <- mapM desc cls3
+                 [cx,cy] <- getClasses [x,y]
+                 eq <- cx === cy
+                 return (res,eq)

testsuite/tests/Data_Test.hs

+module Main where
+
+import Test.Framework
+import qualified Data.Equivalence.Monad_Test
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+main = defaultMain [tests]
+
+tests = testGroup "Data" [
+         Data.Equivalence.Monad_Test.tests
+       ]
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------