equivalence-0.3.5/0000755000000000000000000000000007346545000012211 5ustar0000000000000000equivalence-0.3.5/CHANGES.txt0000755000000000000000000000072007346545000014024 0ustar00000000000000000.3.5 ----- * compatibility with GHC 8.8 0.3.4 ----- * MonadFail instance for EquivT 0.3.3 ----- * compatibility with GHC 8.6 0.3.2 ----- * add Applicative constraints for backwards compatibility with GHC 7.8 0.3.1 ----- * use transformers-compat for backwards compatibility with older versions of transformers 0.3.0.1 ------- * add CHANGES.txt to .cabal file 0.3 --- * add suport for Control.Monad.Except (thus the new dependency constraint 'mtl >= 2.2.1') equivalence-0.3.5/LICENSE0000644000000000000000000000265707346545000013230 0ustar0000000000000000Copyright 2010, Patrick Bahr All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. equivalence-0.3.5/Setup.hs0000644000000000000000000000005507346545000013645 0ustar0000000000000000import Distribution.Simple main = defaultMainequivalence-0.3.5/equivalence.cabal0000644000000000000000000000313207346545000015475 0ustar0000000000000000Name: equivalence Version: 0.3.5 License: BSD3 License-File: LICENSE Author: Patrick Bahr Maintainer: paba@itu.dk Homepage: https://github.com/pa-ba/equivalence bug-reports: https://github.com/pa-ba/equivalence/issues/new Synopsis: Maintaining an equivalence relation implemented as union-find using STT. Description: This is an implementation of Tarjan's Union-Find algorithm (Robert E. Tarjan. "Efficiency of a Good But Not Linear Set Union Algorithm", JACM 22(2), 1975) in order to maintain an equivalence relation. This implementation is a port of the /union-find/ package using the ST monad transformer (instead of the IO monad). Category: Algorithms, Data Stability: provisional Build-Type: Simple Cabal-Version: >=1.9.2 Extra-Source-Files: CHANGES.txt source-repository head type: git location: https://github.com/pa-ba/equivalence Test-Suite test Type: exitcode-stdio-1.0 Main-is: Data_Test.hs Other-Modules: Data.Equivalence.Monad_Test,Data.Equivalence.Monad, Data.Equivalence.STT hs-source-dirs: src testsuite/tests Build-Depends: base >= 4, template-haskell, containers, mtl >= 2.0.1, QuickCheck >= 2, STMonadTrans >= 0.4.3, transformers >= 0.2, transformers-compat >= 0.3, fail Library Build-Depends: base >= 4 && < 5, containers, mtl >= 2.0.1, STMonadTrans >= 0.4.3, transformers >= 0.2, transformers-compat >= 0.3 Exposed-Modules: Data.Equivalence.STT, Data.Equivalence.Monad Hs-Source-Dirs: src build-depends: fail equivalence-0.3.5/src/Data/Equivalence/0000755000000000000000000000000007346545000016112 5ustar0000000000000000equivalence-0.3.5/src/Data/Equivalence/Monad.hs0000644000000000000000000002572507346545000017517 0ustar0000000000000000{-# LANGUAGE RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, FunctionalDependencies #-} -- Suppress warnings about ''Control.Monad.Error'' being deprecated. {-# OPTIONS_GHC -fno-warn-deprecations #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Equivalence.Monad -- Copyright : Patrick Bahr, 2010 -- License : All Rights Reserved -- -- Maintainer : Patrick Bahr -- Stability : unknown -- Portability : unknown -- -- This is an alternative interface to the union-find implementation -- in ''Data.Equivalence.STT''. It is wrapped into the monad -- transformer 'EquivT'. -- -------------------------------------------------------------------------------- module Data.Equivalence.Monad ( MonadEquiv(..), EquivT(..), EquivT', EquivM, EquivM', runEquivT, runEquivT', runEquivM, runEquivM' ) where import Data.Equivalence.STT hiding (equate, equateAll, equivalent, classDesc, removeClass, getClass , combine, combineAll, same , desc , remove ) import qualified Data.Equivalence.STT as S import Control.Monad.Writer import Control.Monad.Reader import Control.Monad.Error.Class import Control.Monad.State import Control.Monad.Trans import Control.Monad.Identity import Control.Monad.ST.Trans import Control.Monad.Trans.Error (ErrorT) import Control.Monad.Trans.Except (ExceptT) import Control.Applicative import qualified Control.Monad.Fail as Fail {-| This monad transformer encapsulates computations maintaining an equivalence relation. A monadic computation of type 'EquivT' @s c v m a@ maintains a state space indexed by type @s@, maintains an equivalence relation over elements of type @v@ with equivalence class descriptors of type @c@ and contains an internal monadic computation of type @m a@. -} newtype EquivT s c v m a = EquivT {unEquivT :: ReaderT (Equiv s c v) (STT s m) a} {-| This monad transformer is a special case of 'EquivT' that only maintains trivial equivalence class descriptors of type @()@. -} type EquivT' s = EquivT s () {-| This monad encapsulates computations maintaining an equivalence relation. A monadic computation of type 'EquivM' @s c v a@ maintains a state space indexed by type @s@, maintains an equivalence relation over elements of type @v@ with equivalence class descriptors of type @c@ and returns a value of type @a@. -} type EquivM s c v = EquivT s c v Identity {-| This monad is a special case of 'EquivM' that only maintains trivial equivalence class descriptors of type @()@. -} type EquivM' s v = EquivM s () v instance Functor m => Functor (EquivT s c v m) where fmap f (EquivT m) = EquivT $ fmap f m instance (Applicative m, Monad m) => Applicative (EquivT s c v m) where pure = EquivT . pure (EquivT f) <*> (EquivT a) = EquivT (f <*> a) instance (Monad m) => Monad (EquivT s c v m) where EquivT m >>= f = EquivT (m >>= (unEquivT . f)) return = EquivT . return instance MonadTrans (EquivT s c v) where lift = EquivT . lift . lift instance Monad m => Fail.MonadFail (EquivT s c v m) where fail = error instance (MonadReader r m) => MonadReader r (EquivT s c v m) where ask = EquivT $ lift ask local f (EquivT (ReaderT m)) = EquivT $ ReaderT $ (\ r -> local f (m r)) instance (Monoid w, MonadWriter w m) => MonadWriter w (EquivT s c v m) where tell w = EquivT $ tell w listen (EquivT m) = EquivT $ listen m pass (EquivT m) = EquivT $ pass m instance (MonadState st m) => MonadState st (EquivT s c v m) where get = EquivT get put s = EquivT $ put s instance (MonadError e m) => MonadError e (EquivT s c v m) where throwError e = lift $ throwError e catchError (EquivT m) f = EquivT $ catchError m (unEquivT . f) {-| This function runs a monadic computation that maintains an equivalence relation. The first tow arguments specify how to construct an equivalence class descriptor for a singleton class and how to combine two equivalence class descriptors. -} runEquivT :: (Monad m, Applicative m) => (v -> c) -- ^ used to construct an equivalence class descriptor for a singleton class -> (c -> c -> c) -- ^ used to combine the equivalence class descriptor of two classes -- which are meant to be combined. -> (forall s. EquivT s c v m a) -> m a runEquivT mk com m = runST $ do p <- leastEquiv mk com (`runReaderT` p) $ unEquivT m {-| This function is a special case of 'runEquivT' that only maintains trivial equivalence class descriptors of type @()@. -} runEquivT' :: (Monad m, Applicative m) => (forall s. EquivT' s v m a) -> m a runEquivT' = runEquivT (const ()) (\_ _-> ()) {-| This function runs a monadic computation that maintains an equivalence relation. The first tow arguments specify how to construct an equivalence class descriptor for a singleton class and how to combine two equivalence class descriptors. -} runEquivM :: (v -> c) -- ^ used to construct an equivalence class descriptor for a singleton class -> (c -> c -> c) -- ^ used to combine the equivalence class descriptor of two classes -- which are meant to be combined. -> (forall s. EquivM s c v a) -> a runEquivM sing comb m = runIdentity $ runEquivT sing comb m {-| This function is a special case of 'runEquivM' that only maintains trivial equivalence class descriptors of type @()@. -} runEquivM' :: (forall s. EquivM' s v a) -> a runEquivM' = runEquivM (const ()) (\_ _ -> ()) {-| This class specifies the interface for a monadic computation that maintains an equivalence relation. -} class (Monad m, Applicative m, Ord v) => MonadEquiv c v d m | m -> v, m -> c, m -> d where {-| This function decides whether the two given elements are equivalent in the current equivalence relation -} equivalent :: v -> v -> m Bool {-| This function obtains the descriptor of the given element's equivalence class. -} classDesc :: v -> m d {-| This function equates the element in the given list. That is, it unions the equivalence classes of the elements and combines their descriptor. -} equateAll :: [v] -> m () {-| This function equates the given two elements. That is it unions the equivalence classes of the two elements. -} equate :: v -> v -> m () equate x y = equateAll [x,y] {-| This function removes the equivalence class of the given element. If there is no corresponding equivalence class, @False@ is returned; otherwise @True@. -} removeClass :: v -> m Bool {-| This function provides the equivalence class the given element is contained in. -} getClass :: v -> m c {-| This function combines all equivalence classes in the given list. Afterwards all elements in the argument list represent the same equivalence class! -} combineAll :: [c] -> m () {-| This function combines the two given equivalence classes. Afterwards both arguments represent the same equivalence class! One of it is returned in order to represent the new combined equivalence class. -} combine :: c -> c -> m c combine x y = combineAll [x,y] >> return x {-| This function decides whether the two given equivalence classes are the same. -} (===) :: c -> c -> m Bool {-| This function returns the descriptor of the given equivalence class. -} desc :: c -> m d {-| This function removes the given equivalence class. If the equivalence class does not exists anymore @False@ is returned; otherwise @True@. -} remove :: c -> m Bool instance (Monad m, Applicative m, Ord v) => MonadEquiv (Class s d v) v d (EquivT s d v m) where equivalent x y = EquivT $ do part <- ask lift $ S.equivalent part x y classDesc x = EquivT $ do part <- ask lift $ S.classDesc part x equateAll x = EquivT $ do part <- ask lift $ S.equateAll part x equate x y = EquivT $ do part <- ask lift $ S.equate part x y removeClass x = EquivT $ do part <- ask lift $ S.removeClass part x getClass x = EquivT $ do part <- ask lift $ S.getClass part x combineAll x = EquivT $ do part <- ask lift $ S.combineAll part x combine x y = EquivT $ do part <- ask lift $ S.combine part x y x === y = EquivT $ do part <- ask lift $ S.same part x y desc x = EquivT $ do part <- ask lift $ S.desc part x remove x = EquivT $ do part <- ask lift $ S.remove part x instance (MonadEquiv c v d m, Monoid w) => MonadEquiv c v d (WriterT w m) where equivalent x y = lift $ equivalent x y classDesc = lift . classDesc equateAll x = lift $ equateAll x equate x y = lift $ equate x y removeClass x = lift $ removeClass x getClass x = lift $ getClass x combineAll x = lift $ combineAll x combine x y = lift $ combine x y x === y = lift $ (===) x y desc x = lift $ desc x remove x = lift $ remove x instance (MonadEquiv c v d m, Error e) => MonadEquiv c v d (ErrorT e m) where equivalent x y = lift $ equivalent x y classDesc = lift . classDesc equateAll x = lift $ equateAll x equate x y = lift $ equate x y removeClass x = lift $ removeClass x getClass x = lift $ getClass x combineAll x = lift $ combineAll x combine x y = lift $ combine x y x === y = lift $ (===) x y desc x = lift $ desc x remove x = lift $ remove x instance (MonadEquiv c v d m) => MonadEquiv c v d (ExceptT e m) where equivalent x y = lift $ equivalent x y classDesc = lift . classDesc equateAll x = lift $ equateAll x equate x y = lift $ equate x y removeClass x = lift $ removeClass x getClass x = lift $ getClass x combineAll x = lift $ combineAll x combine x y = lift $ combine x y x === y = lift $ (===) x y desc x = lift $ desc x remove x = lift $ remove x instance (MonadEquiv c v d m) => MonadEquiv c v d (StateT s m) where equivalent x y = lift $ equivalent x y classDesc = lift . classDesc equateAll x = lift $ equateAll x equate x y = lift $ equate x y removeClass x = lift $ removeClass x getClass x = lift $ getClass x combineAll x = lift $ combineAll x combine x y = lift $ combine x y x === y = lift $ (===) x y desc x = lift $ desc x remove x = lift $ remove x instance (MonadEquiv c v d m) => MonadEquiv c v d (ReaderT r m) where equivalent x y = lift $ equivalent x y classDesc = lift . classDesc equateAll x = lift $ equateAll x equate x y = lift $ equate x y removeClass x = lift $ removeClass x getClass x = lift $ getClass x combineAll x = lift $ combineAll x combine x y = lift $ combine x y x === y = lift $ (===) x y desc x = lift $ desc x remove x = lift $ remove x equivalence-0.3.5/src/Data/Equivalence/STT.hs0000644000000000000000000003336707346545000017134 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Equivalence.STT -- Copyright : 3gERP, 2010 -- License : All Rights Reserved -- -- Maintainer : Patrick Bahr -- Stability : unknown -- Portability : unknown -- -- This is an implementation of Tarjan's Union-Find algorithm (Robert -- E. Tarjan. "Efficiency of a Good But Not Linear Set Union -- Algorithm", JACM 22(2), 1975) in order to maintain an equivalence -- relation. -- -- This implementation is a port of the /union-find/ package using the -- ST monad transformer (instead of the IO monad). -- -- The implementation is based on mutable references. Each -- equivalence class has exactly one member that serves as its -- representative element. Every element either is the representative -- element of its equivalence class or points to another element in -- the same equivalence class. Equivalence testing thus consists of -- following the pointers to the representative elements and then -- comparing these for identity. -- -- The algorithm performs lazy path compression. That is, whenever we -- walk along a path greater than length 1 we automatically update the -- pointers along the path to directly point to the representative -- element. Consequently future lookups will be have a path length of -- at most 1. -- -- Each equivalence class remains a descriptor, i.e. some piece of -- data attached to an equivalence class which is combined when two -- classes are unioned. -- -------------------------------------------------------------------------------- module Data.Equivalence.STT ( -- * Equivalence Relation Equiv , Class , leastEquiv -- * Operations on Equivalence Classes , getClass , combine , combineAll , same , desc , remove -- * Operations on Elements , equate , equateAll , equivalent , classDesc , removeClass ) where import Control.Monad.ST.Trans import Control.Monad import Control.Applicative import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map newtype Class s c a = Class (STRef s (Entry s c a)) {-| This type represents a reference to an entry in the tree data structure. An entry of type 'Entry' @s c a@ lives in the state space indexed by @s@, contains equivalence class descriptors of type @c@ and has elements of type @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 indexed by @s@, contains equivalence class descriptors of type @c@ and has elements of type @a@. -} data EntryData s c a = Node { entryParent :: Entry s c a, entryValue :: a } | Root { entryDesc :: c, entryWeight :: Int, entryValue :: a, entryDeleted :: Bool } type Entries s c a = STRef s (Map a (Entry s c a)) {-| This is the top-level data structure that represents an equivalence relation. An equivalence relation of type 'Equiv' @s c a@ lives in the state space indexed by @s@, contains equivalence class descriptors of type @c@ and has elements of type @a@. -} data Equiv s c a = Equiv { -- | maps elements to their entry in the tree data structure entries :: Entries s c a, -- | constructs an equivalence class descriptor for a singleton class singleDesc :: a -> c, -- | combines the equivalence class descriptor of two classes -- which are meant to be combined. combDesc :: c -> c -> c } {-| This function constructs the initial data structure for maintaining an equivalence relation. That is it represents, the fines (or least) equivalence class (of the set of all elements of type @a@). The arguments are used to maintain equivalence class descriptors. -} leastEquiv :: (Monad m, Applicative m) => (a -> c) -- ^ used to construct an equivalence class descriptor for a singleton class -> (c -> c -> c) -- ^ used to combine the equivalence class descriptor of two classes -- which are meant to be combined. -> STT s m (Equiv s c a) leastEquiv mk com = do es <- newSTRef Map.empty return Equiv {entries = es, singleDesc = mk, combDesc = com} {-| This function returns the representative entry of the argument's equivalence class (i.e. the root of its tree) or @Nothing@ if it is the representative itself. This function performs path compression. -} representative' :: (Monad m, Applicative m) => Entry s c a -> STT s m (Maybe (Entry s c a),Bool) representative' (Entry e) = do ed <- readSTRef e case ed of Root {entryDeleted = del} -> do return (Nothing, del) Node {entryParent = parent} -> do (mparent',del) <- representative' parent case mparent' of Nothing -> return $ (Just parent, del) Just parent' -> writeSTRef e ed{entryParent = parent'} >> return (Just parent', del) {-| This function returns the representative entry of the argument's equivalence class (i.e. the root of its tree). This function performs path compression. -} representative :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m (Entry s c a) representative eq v = do mentry <- getEntry eq v case mentry of -- check whether there is an entry Nothing -> mkEntry eq v -- if not, create a new one Just entry -> do (mrepr,del) <- representative' entry if del -- check whether equivalence class was deleted then mkEntry eq v -- if so, create a new entry else case mrepr of Nothing -> return entry Just repr -> return repr {-| This function provides the representative entry of the given equivalence class. This function performs path compression. -} classRep :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Class s c a -> STT s m (Entry s c a) classRep eq (Class p) = do entry <- readSTRef p (mrepr,del) <- representative' entry if del -- check whether equivalence class was deleted 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 entry's value, inserts it into the lookup table (thereby removing any existing entry). -} mkEntry' :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Entry s c a -> STT s m (Entry s c a) -- ^ the constructed entry mkEntry' eq (Entry e) = readSTRef e >>= mkEntry eq . entryValue {-| This function constructs a new (root) entry containing the given value, inserts it into the lookup table (thereby removing any existing entry). -} mkEntry :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m (Entry s c a) -- ^ the constructed entry mkEntry Equiv {entries = mref, singleDesc = mkDesc} val = do e <- newSTRef Root { entryDesc = mkDesc val, entryWeight = 1, entryValue = val, entryDeleted = False } let entry = Entry e m <- readSTRef mref writeSTRef mref (Map.insert val entry m) return entry {-| This function provides the equivalence class the given element is contained in. -} getClass :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m (Class s c a) getClass eq v = do en <- (getEntry' eq v) liftM Class $ newSTRef en getEntry' :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m (Entry s c a) getEntry' eq v = do mentry <- getEntry eq v case mentry of Nothing -> mkEntry eq v Just entry -> return entry {-| This function looks up the entry of the given element in the given equivalence relation representation or @Nothing@ if there is none, yet. -} getEntry :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m (Maybe (Entry s c a)) getEntry Equiv { entries = mref} val = do m <- readSTRef mref case Map.lookup val m of Nothing -> return Nothing Just entry -> return $ Just entry {-| This function equates the two given (representative) elements. That is, it unions the equivalence classes of the two elements and combines their descriptor. The returned entry is the representative of the new equivalence class -} equateEntry :: (Monad m, Applicative 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) = if (rx /= ry) then do dx <- readSTRef rx dy <- readSTRef ry case (dx, dy) of ( Root{entryWeight = wx, entryDesc = chx, entryValue = vx} , Root{entryWeight = wy, entryDesc = chy, entryValue = vy} ) -> 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 _ -> error "error on `equateEntry`" -- this should not happen as this function is only called by -- 'combineEntries', which always uses representative entries else return repx combineEntries :: (Monad m, Applicative 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 list. Afterwards all elements in the argument list represent the same equivalence class! -} combineAll :: (Monad m, Applicative m, Ord a) => Equiv s c a -> [Class s c a] -> STT s m () combineAll eq cls = combineEntries eq cls (classRep eq) {-| This function combines the two given equivalence classes. Afterwards both arguments represent the same equivalence class! One of it is returned in order to represent the new combined equivalence class. -} combine :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Class s c a -> Class s c a -> STT s m (Class s c a) combine eq x y = combineAll eq [x,y] >> return x {-| This function equates the element in the given list. That is, it unions the equivalence classes of the elements and combines their descriptor. -} equateAll :: (Monad m, Applicative m, Ord a) => Equiv s c a -> [a] -> STT s m () 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 descriptor. -} equate :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> a -> STT s m () equate eq x y = equateAll eq [x,y] {-| This function returns the descriptor of the given equivalence class. -} desc :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Class s c a -> STT s m c desc eq cl = do Entry e <- classRep eq cl liftM entryDesc $ readSTRef e {-| This function returns the descriptor of the given element's equivalence class. -} classDesc :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m c classDesc eq val = do Entry e <- representative eq val liftM entryDesc $ readSTRef e {-| This function decides whether the two given equivalence classes are the same. -} same :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Class s c a -> Class s c a -> STT s m Bool same eq c1 c2 = do (Entry r1) <- classRep eq c1 (Entry r2) <- classRep eq c2 return (r1 == r2) {-| This function decides whether the two given elements are in the same equivalence class according to the given equivalence relation representation. -} equivalent :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> a -> STT s m Bool equivalent eq v1 v2 = do (Entry r1) <- representative eq v1 (Entry r2) <- representative eq v2 return (r1 == r2) {-| This function modifies the content of a reference cell. -} modifySTRef :: (Monad m, Applicative m) => STRef s a -> (a -> a) -> STT s m () modifySTRef r f = readSTRef r >>= (writeSTRef r . f) {-| This function marks the given root entry as deleted. -} removeEntry :: (Monad m, Applicative m, Ord a) => Entry s c a -> STT s m () removeEntry (Entry r) = modifySTRef r change where change e = e {entryDeleted = True} {-| This function removes the given equivalence class. If the equivalence class does not exists anymore @False@ is returned; otherwise @True@. -} remove :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Class s c a -> STT s m Bool 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 element. If there is no corresponding equivalence class, @False@ is returned; otherwise @True@. -} removeClass :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m Bool removeClass eq v = do mentry <- getEntry eq v case mentry of Nothing -> return False Just entry -> do (mentry, del) <- representative' entry if del then return False else removeEntry (fromMaybe entry mentry) >> return True equivalence-0.3.5/testsuite/tests/Data/Equivalence/0000755000000000000000000000000007346545000020516 5ustar0000000000000000equivalence-0.3.5/testsuite/tests/Data/Equivalence/Monad_Test.hs0000644000000000000000000000747607346545000023125 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes, TemplateHaskell #-} module Data.Equivalence.Monad_Test where import Test.QuickCheck hiding ((===)) import Data.Equivalence.Monad import Control.Monad import Data.Set (Set) import qualified Data.Set as Set -------------------------------------------------------------------------------- -- Test Suits -------------------------------------------------------------------------------- -- 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' :: [[Int]]) 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) return [] main = $quickCheckAll equivalence-0.3.5/testsuite/tests/0000755000000000000000000000000007346545000015404 5ustar0000000000000000equivalence-0.3.5/testsuite/tests/Data_Test.hs0000644000000000000000000000071307346545000017611 0ustar0000000000000000module Main where import qualified Data.Equivalence.Monad_Test -------------------------------------------------------------------------------- -- Test Suits -------------------------------------------------------------------------------- main = Data.Equivalence.Monad_Test.main -------------------------------------------------------------------------------- -- Properties --------------------------------------------------------------------------------