equivalence-0.4.1/0000755000000000000000000000000007346545000012206 5ustar0000000000000000equivalence-0.4.1/CHANGES.md0000644000000000000000000000177007346545000013605 0ustar00000000000000000.4.1 ----- _Andreas Abel, 2022-07-26_ * New methods `values` and `classes` to get all values and classes encountered [#7](https://github.com/pa-ba/equivalence/issues/7) [#13](https://github.com/pa-ba/equivalence/pull/13) (contributed by Jimmy Koppel). Tested with GHC 7.10 - 9.4.1 RC1. 0.4.0.1 ------- _Andreas Abel, 2022-05-26_ * add `LANGUAGE TypeOperators` for GHC 9.4 0.4 --- _Andreas Abel, 2022-02-03_ * remove `ErrorT` instance for compatibility with `transformers-0.6` and `mtl-2.3` 0.3.5 ----- _Patrick Bahr, 2019-09-09_ * 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.4.1/LICENSE0000644000000000000000000000265707346545000013225 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.4.1/Setup.hs0000644000000000000000000000005507346545000013642 0ustar0000000000000000import Distribution.Simple main = defaultMainequivalence-0.4.1/equivalence.cabal0000644000000000000000000000470707346545000015503 0ustar0000000000000000Cabal-Version: >= 1.10 Name: equivalence Version: 0.4.1 License: BSD3 License-File: LICENSE Author: Patrick Bahr Maintainer: Andreas Abel Homepage: https://github.com/pa-ba/equivalence bug-reports: https://github.com/pa-ba/equivalence/issues 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 tested-with: GHC == 9.4.1 GHC == 9.2.3 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4 GHC == 8.6.5 GHC == 8.4.4 GHC == 8.2.2 GHC == 8.0.2 GHC == 7.10.3 Extra-Source-Files: CHANGES.md source-repository head type: git location: https://github.com/pa-ba/equivalence Library Exposed-Modules: Data.Equivalence.STT Data.Equivalence.Monad Hs-Source-Dirs: src default-language: Haskell2010 Build-Depends: base >= 4.8 && < 5 , containers , mtl >= 2.2.1 , STMonadTrans >= 0.4.3 , transformers >= 0.2 , transformers-compat >= 0.3 if impl(ghc < 8.0) Build-Depends: fail ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-incomplete-record-updates if impl(ghc >= 8.0) ghc-options: -Wcompat 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 default-language: Haskell2010 Build-Depends: equivalence -- inherited dependencies from library , base , containers , mtl , STMonadTrans , transformers , transformers-compat -- Additional dependencies for testsuite , QuickCheck >= 2 , template-haskell if impl(ghc < 8.0) Build-Depends: fail ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-incomplete-record-updates -fno-warn-missing-signatures -fno-warn-unused-do-bind if impl(ghc >= 8.0) ghc-options: -Wcompat equivalence-0.4.1/src/Data/Equivalence/0000755000000000000000000000000007346545000016107 5ustar0000000000000000equivalence-0.4.1/src/Data/Equivalence/Monad.hs0000644000000000000000000002513407346545000017506 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- for type equality ~ {-# LANGUAGE TypeOperators #-} -- for type equality ~ with GHC 9.4 {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Equivalence.Monad -- Copyright : Patrick Bahr, 2010 -- License : BSD-3-Clause -- -- Maintainer : Patrick Bahr, Andreas Abel -- Stability : stable -- Portability : non-portable (MPTC with FD) -- -- 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, values , classes ) 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.Identity import Control.Monad.ST.Trans import Control.Monad.Trans.Except (ExceptT) 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} deriving (Functor, Applicative, Monad, MonadError e, MonadState st, MonadWriter w) {-| 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 -- Instances for EquivT: instance MonadTrans (EquivT s c v) where lift = EquivT . lift . lift instance Monad m => Fail.MonadFail (EquivT s c v m) where fail = error -- NB: This instance is beyond GeneralizedNewtypeDeriving -- because EquivT already contains a ReaderT in its monad transformer stack. 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) {-| This function runs a monadic computation that maintains an equivalence relation. The first two 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 = runSTT $ 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 of the given element. -} 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 exist anymore, @False@ is returned; otherwise @True@. -} remove :: c -> m Bool {-| This function returns all values represented by some equivalence class. @since 0.4.1 -} values :: m [v] {-| This function returns the list of all equivalence classes. @since 0.4.1 -} classes :: m [c] -- Default implementations for lifting via a monad transformer. -- Unfortunately, GHC does not permit us to give these also to -- 'equate' and 'combine', which already have a default implementation. default equivalent :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> v -> m Bool equivalent x y = lift $ equivalent x y default classDesc :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> m d classDesc = lift . classDesc default equateAll :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => [v] -> m () equateAll = lift . equateAll default removeClass :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> m Bool removeClass = lift . removeClass default getClass :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> m c getClass = lift . getClass default combineAll :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => [c] -> m () combineAll = lift . combineAll default (===) :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => c -> c -> m Bool x === y = lift $ (===) x y default desc :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => c -> m d desc = lift . desc default remove :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => c -> m Bool remove = lift . remove default values :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => m [v] values = lift values default classes :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => m [c] classes = lift classes 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 values = EquivT $ do part <- ask lift $ S.values part classes = EquivT $ do part <- ask lift $ S.classes part instance (MonadEquiv c v d m, Monoid w) => MonadEquiv c v d (WriterT w m) where equate x y = lift $ equate x y combine x y = lift $ combine x y instance (MonadEquiv c v d m) => MonadEquiv c v d (ExceptT e m) where equate x y = lift $ equate x y combine x y = lift $ combine x y instance (MonadEquiv c v d m) => MonadEquiv c v d (StateT s m) where equate x y = lift $ equate x y combine x y = lift $ combine x y instance (MonadEquiv c v d m) => MonadEquiv c v d (ReaderT r m) where equate x y = lift $ equate x y combine x y = lift $ combine x y equivalence-0.4.1/src/Data/Equivalence/STT.hs0000644000000000000000000003475307346545000017131 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Equivalence.STT -- Copyright : Patrick Bahr, 2010 -- License : BSD-3-Clause -- -- Maintainer : Patrick Bahr, Andreas Abel -- Stability : stable -- Portability : non-portable (MPTC) -- -- 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 -- Getting all represented items , values , classes ) where import Control.Monad.ST.Trans import Control.Monad import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map {-| Abstract representation of an equivalence class. -} 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 finest (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 exist 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 {-| This function returns all values represented by some equivalence class. -} values :: (Monad m, Applicative m, Ord a) => Equiv s c a -> STT s m [a] values Equiv {entries = mref} = Map.keys <$> readSTRef mref {-| This function returns the list of all equivalence classes. -} classes :: (Monad m, Applicative m, Ord a) => Equiv s c a -> STT s m [Class s c a] classes Equiv {entries = mref} = do allEntries <- Map.elems <$> readSTRef mref rootEntries <- filterM isRoot allEntries mapM (fmap Class . newSTRef) $ rootEntries where isRoot e = do x <- readSTRef (unentry e) case x of Node {} -> return False Root {} -> return True equivalence-0.4.1/testsuite/tests/Data/Equivalence/0000755000000000000000000000000007346545000020513 5ustar0000000000000000equivalence-0.4.1/testsuite/tests/Data/Equivalence/Monad_Test.hs0000644000000000000000000001074607346545000023114 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes, TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.Equivalence.Monad_Test where import Test.QuickCheck hiding ((===), classes) import Data.Equivalence.Monad import Control.Monad import Data.Function (on) import Data.Set (Set) import qualified Data.Set as Set import System.Exit -------------------------------------------------------------------------------- -- 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 infixr 9 <.> -- | Composition: pure function after functorial (monadic) function. (<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c (f <.> g) a = f <$> g a -------------------------------------------------------------------------------- -- 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_getClasses 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) prop_values l = runInt $ do mapM (\x -> equate x x) l sameSet l <$> values where sameSet = (==) `on` Set.fromList prop_classes l = runInt $ do mapM equateAll (l :: [[Int]]) classes1 <- uniqClass =<< mapM getClass =<< values sameClasses classes1 =<< classes where uniqClass [] = return [] uniqClass (c:cs) = (c :) <$> do uniqClass =<< filterM (not <.> (c ===)) cs sameClasses [] cs2 = return $ null cs2 sameClasses (c:cs1') cs2 = sameClasses cs1' =<< filterM (not <.> (c ===)) cs2 return [] main :: IO () main = do success <- $quickCheckAll if success then exitSuccess else exitFailure equivalence-0.4.1/testsuite/tests/0000755000000000000000000000000007346545000015401 5ustar0000000000000000equivalence-0.4.1/testsuite/tests/Data_Test.hs0000644000000000000000000000071307346545000017606 0ustar0000000000000000module Main where import qualified Data.Equivalence.Monad_Test -------------------------------------------------------------------------------- -- Test Suits -------------------------------------------------------------------------------- main = Data.Equivalence.Monad_Test.main -------------------------------------------------------------------------------- -- Properties --------------------------------------------------------------------------------