Commits

Patrick Bahr committed 19ad6d3

changed name of the package and (accordingly) names of modules, functions, types

Comments (0)

Files changed (7)

 dummy.cabal
 *~
 *\#
+.\#*
 *.orig
 *.o
 *.hi

equivalence.cabal

+Name:            equivalence
+Version:         0.1
+License:         BSD3
+License-File:    LICENSE
+Author:          Patrick Bahr <paba@diku.dk>
+Maintainer:      Patrick Bahr <paba@diku.dk>
+Synopsis:        Maintaining an equivalence relation implemented as union-find using STT.
+Description:	 
+Category:        Algorithms, Data
+Stability:       provisional
+Build-Type:      Simple
+Cabal-Version:   >= 1.6
+
+Library
+  Build-Depends:
+    base >= 4 && < 5, containers, STMonadTrans >= 0.2, mtl
+  Exposed-Modules:
+    Data.Equivalence.STT,
+    Data.Equivalence.Monad
+  Hs-Source-Dirs: src
+

src/Data/Equivalence/Monad.hs

+{-# LANGUAGE
+  RankNTypes,
+  FlexibleInstances,
+  FlexibleContexts,
+  MultiParamTypeClasses,
+  UndecidableInstances,
+  FunctionalDependencies #-}
+
+
+module Data.Equivalence.Monad
+    (
+     MonadEquiv(..),
+     EquivT,
+     runEquivT
+     ) where
+
+import Data.Equivalence.STT hiding (equate, equivalent, classDesc)
+import qualified Data.Equivalence.STT  as S
+
+ 
+import Control.Monad.Writer
+import Control.Monad.Reader
+import Control.Monad.Error
+import Control.Monad.State
+import Control.Monad.Trans
+import Control.Monad.Identity
+import Control.Monad.ST.Trans
+
+
+
+newtype EquivT s c v m a = EquivT {unEquivT :: ReaderT (Equiv s c v) (STT s m) a}
+type EquivM s c v = EquivT s c v Identity
+
+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 (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)
+    
+
+runEquivT :: (Monad m) => (v -> c) -> (c -> c -> c) -> (forall s. EquivT s c v m a) -> m a
+runEquivT mk com m = runST $ do
+  p <- leastEquiv mk com
+  (`runReaderT` p) $ unEquivT m
+
+
+class (Monad m, Ord v) => MonadEquiv c v m | m -> v, m -> c where
+    equivalent :: v -> v -> m Bool
+    classDesc :: v -> m c
+    equate :: v -> v -> m ()
+
+instance (Monad m, Ord v) => MonadEquiv c v (EquivT s c 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
+           
+    equate x y = EquivT $ do
+      part <- ask
+      lift $ S.equate part x y
+
+instance (MonadEquiv c v m, MonadTrans t, Monad (t m)) => MonadEquiv c v (t m) where
+    equivalent x y = lift $ equivalent x y
+    classDesc = lift . classDesc
+    equate x y = lift $ equate x y

src/Data/Equivalence/STT.hs

+--------------------------------------------------------------------------------
+-- |
+-- 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. 
+-- 
+-- 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.
+--
+--
+--------------------------------------------------------------------------------
+
+module Data.Equivalence.STT
+  ( leastEquiv
+  , equate
+  , equivalent
+  , classDesc
+  , Equiv
+  ) where
+
+import Control.Monad.ST.Trans
+import Control.Monad
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+newtype Entry s c a = Entry (STRef s (EntryData s c a))
+    deriving (Eq)
+
+data EntryData s c a = Node {
+      entryParent :: Entry s c a,
+      entryValue :: a
+    }
+                     | Root {
+      entryDesc :: c,
+      entryWeight :: Int,
+      entryValue :: a
+    }
+
+data Equiv s c a = Equiv {
+      entries :: STRef s (Map a (Entry s c a)),
+      singleDesc :: a -> c,
+      combDesc :: c -> c -> c
+      }
+
+modifySTRef :: (Monad m) => STRef s a -> (a -> a) -> STT s m ()
+modifySTRef r f = readSTRef r >>= (writeSTRef r . f)
+
+
+leastEquiv :: Monad m => (a -> c) -> (c -> c -> c) -> STT s m (Equiv s c a)
+leastEquiv mk com = do 
+  es <- newSTRef Map.empty
+  return Equiv {entries = es, singleDesc = mk, combDesc = com}
+
+
+-- | /O(1)/. @repr point@ returns the representative point of
+-- @point@'s equivalence class or @Nothing$ if it itself is the
+-- representative of its class.
+--
+-- This method performs the path compresssion.
+representative' :: Monad m => Entry s c a -> STT s m (Maybe (Entry s c a))
+representative' (Entry e) = do
+  ed <- readSTRef e
+  case ed of
+    Root {} -> return Nothing
+    Node { entryParent = parent} -> do
+      mparent' <- representative' parent
+      case mparent' of
+        Nothing -> return $ Just parent
+        Just parent' -> writeSTRef e ed{entryParent = parent'} >> return (Just parent')
+
+
+-- | /O(1)/. @repr point@ returns the representative point of
+-- @point@'s equivalence class.
+--
+-- This method performs the path compresssion.
+representative :: Monad m => Entry s c a -> STT s m (Entry s c a)
+representative entry = do
+  mrepr <- representative' entry
+  case mrepr of
+    Nothing -> return entry
+    Just repr -> return repr
+
+
+getEntry' :: (Monad m, Ord a) => Equiv s c a -> a -> STT s m (Entry s c a)
+getEntry' Equiv {entries = mref, singleDesc = mkDesc} val = do
+  m <- readSTRef mref
+  case Map.lookup val m of
+    Nothing -> do
+      e <- newSTRef Root
+            { entryDesc = mkDesc val,
+              entryWeight = 1,
+              entryValue = val
+            }
+      let entry = Entry e
+      writeSTRef mref (Map.insert val entry m)
+      return entry
+    Just entry -> return entry
+
+
+getEntry :: (Monad 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
+
+equate :: (Monad m, Ord a) => Equiv s c a -> a -> a -> STT s m ()
+equate equiv x y = do
+  ex <- getEntry' equiv x
+  ey <- getEntry' equiv  y
+  equate' equiv ex ey
+
+equate' :: (Monad m, Ord a) => Equiv s c a -> Entry s c a -> Entry s c a -> STT s m ()
+equate' Equiv {combDesc = mkDesc} x y = do
+  repx@(Entry rx) <- representative x
+  repy@(Entry ry) <- representative y
+  when (rx /= ry) $ 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}
+      else do
+       writeSTRef rx Node {entryParent = repy, entryValue = vx}
+       writeSTRef ry dy{entryWeight = wx + wy, entryDesc = mkDesc chx chy}
+
+classDesc :: (Monad m, Ord a) => Equiv s c a -> a -> STT s m c
+classDesc eq val = do
+  mentry <- getEntry eq val
+  case mentry of
+    Nothing -> return $ singleDesc eq val
+    Just entry -> classDesc' entry
+
+classDesc' :: (Monad m) => Entry s c a -> STT s m c
+classDesc' entry = do
+  Entry e <- representative entry
+  liftM entryDesc $ readSTRef e
+
+-- | /O(1)/. Return @True@ if both points belong to the same
+-- | equivalence class.
+equivalent :: (Monad m, Ord a) => Equiv s c a -> a -> a -> STT s m Bool
+equivalent eq v1 v2 = do
+  me1 <- getEntry eq v1
+  me2 <- getEntry eq v2
+  case (me1,me2) of
+    (Just e1, Just e2) -> equivalent' e1 e2
+    (Nothing, Nothing) -> return $ v1 == v2
+    _ -> return False
+    
+
+equivalent' :: (Monad m, Ord a) => Entry s c a -> Entry s c a -> STT s m Bool
+equivalent' e1 e2 = liftM2 (==) (representative e1) (representative e2)
+

src/Data/UnionFind/Monad.hs

-{-# LANGUAGE
-  RankNTypes,
-  FlexibleInstances,
-  FlexibleContexts,
-  MultiParamTypeClasses,
-  UndecidableInstances,
-  FunctionalDependencies #-}
-
-
-module Data.UnionFind.Monad
-    (
-     MonadPartition(..),
-     PartitionT,
-     runPartitionT
-     ) where
-
-import Data.UnionFind.STT hiding (equate, equivalent, classDesc)
-import qualified Data.UnionFind.STT  as S
-
- 
-import Control.Monad.Writer
-import Control.Monad.Reader
-import Control.Monad.Error
-import Control.Monad.State
-import Control.Monad.Trans
-import Control.Monad.Identity
-import Control.Monad.ST.Trans
-
-
-
-newtype PartitionT s c v m a = PartitionT {unPartitionT :: ReaderT (Partition s c v) (STT s m) a}
-type PartitionM s c v = PartitionT s c v Identity
-
-instance (Monad m) => Monad (PartitionT s c v m) where
-    PartitionT m >>= f = PartitionT (m >>= (unPartitionT . f))
-    return = PartitionT . return
-
-instance MonadTrans (PartitionT s c v) where
-    lift = PartitionT . lift . lift
-
-instance (MonadReader r m) => MonadReader r (PartitionT s c v m) where
-    ask = PartitionT $ lift ask
-    local f (PartitionT (ReaderT m)) = PartitionT $ ReaderT $ (\ r -> local f (m r))
-
-instance (Monoid w, MonadWriter w m) => MonadWriter w (PartitionT s c v m) where
-    tell w = PartitionT $ tell w
-    listen (PartitionT m) = PartitionT $ listen m
-    pass (PartitionT m) = PartitionT $ pass m
-
-instance (MonadState st m) => MonadState st (PartitionT s c v m) where
-    get = PartitionT get
-    put s = PartitionT $ put s
-
-instance (MonadError e m) => MonadError e (PartitionT s c v m) where
-    throwError e = lift $ throwError e
-    catchError (PartitionT m) f = PartitionT $ catchError m (unPartitionT . f)
-    
-
-runPartitionT :: (Monad m) => (v -> c) -> (c -> c -> c) -> (forall s. PartitionT s c v m a) -> m a
-runPartitionT mk com m = runST $ do
-  p <- emptyPartition mk com
-  (`runReaderT` p) $ unPartitionT m
-
-
-class (Monad m, Ord v) => MonadPartition c v m | m -> v, m -> c where
-    equivalent :: v -> v -> m Bool
-    classDesc :: v -> m c
-    equate :: v -> v -> m ()
-
-instance (Monad m, Ord v) => MonadPartition c v (PartitionT s c v m) where
-    equivalent x y = PartitionT $ do
-      part <- ask
-      lift $ S.equivalent part x y
-
-    classDesc x = PartitionT $ do
-      part <- ask
-      lift $ S.classDesc part x
-           
-    equate x y = PartitionT $ do
-      part <- ask
-      lift $ S.equate part x y
-
-instance (MonadPartition c v m, MonadTrans t, Monad (t m)) => MonadPartition c v (t m) where
-    equivalent x y = lift $ equivalent x y
-    classDesc = lift . classDesc
-    equate x y = lift $ equate x y

src/Data/UnionFind/STT.hs

--- | 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)
---
--- The algorithm implements three operations efficiently (all amortised
--- @O(1)@):
---
---  1. Check whether two elements are in the same equivalence class.
---
---  2. Create a union of two equivalence classes.
---
---  3. Look up the descriptor of the equivalence class.
--- 
--- 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.
---
-module Data.UnionFind.STT
-  ( emptyPartition
-  , equate
-  , equivalent
-  , classDesc
-  , Partition
-  )
-where
-
-import Control.Monad.ST.Trans
-import Control.Monad
-
-import Data.Map (Map)
-import qualified Data.Map as Map
-
-newtype Entry s c a = Entry (STRef s (EntryData s c a))
-    deriving (Eq)
-
-data EntryData s c a = Node {
-      entryParent :: Entry s c a,
-      entryValue :: a
-    }
-                     | Root {
-      entryDesc :: c,
-      entryWeight :: Int,
-      entryValue :: a
-    }
-
-data Partition s c a = Partition {
-      entries :: STRef s (Map a (Entry s c a)),
-      singleDesc :: a -> c,
-      combDesc :: c -> c -> c
-      }
-
-modifySTRef :: (Monad m) => STRef s a -> (a -> a) -> STT s m ()
-modifySTRef r f = readSTRef r >>= (writeSTRef r . f)
-
-
-emptyPartition :: Monad m => (a -> c) -> (c -> c -> c) -> STT s m (Partition s c a)
-emptyPartition mk com = do 
-  es <- newSTRef Map.empty
-  return Partition {entries = es, singleDesc = mk, combDesc = com}
-
-
--- | /O(1)/. @repr point@ returns the representative point of
--- @point@'s equivalence class or @Nothing$ if it itself is the
--- representative of its class.
---
--- This method performs the path compresssion.
-representative' :: Monad m => Entry s c a -> STT s m (Maybe (Entry s c a))
-representative' (Entry e) = do
-  ed <- readSTRef e
-  case ed of
-    Root {} -> return Nothing
-    Node { entryParent = parent} -> do
-      mparent' <- representative' parent
-      case mparent' of
-        Nothing -> return $ Just parent
-        Just parent' -> writeSTRef e ed{entryParent = parent'} >> return (Just parent')
-
-
--- | /O(1)/. @repr point@ returns the representative point of
--- @point@'s equivalence class.
---
--- This method performs the path compresssion.
-representative :: Monad m => Entry s c a -> STT s m (Entry s c a)
-representative entry = do
-  mrepr <- representative' entry
-  case mrepr of
-    Nothing -> return entry
-    Just repr -> return repr
-
-
-getEntry' :: (Monad m, Ord a) => Partition s c a -> a -> STT s m (Entry s c a)
-getEntry' Partition {entries = mref, singleDesc = mkDesc} val = do
-  m <- readSTRef mref
-  case Map.lookup val m of
-    Nothing -> do
-      e <- newSTRef Root
-            { entryDesc = mkDesc val,
-              entryWeight = 1,
-              entryValue = val
-            }
-      let entry = Entry e
-      writeSTRef mref (Map.insert val entry m)
-      return entry
-    Just entry -> return entry
-
-
-getEntry :: (Monad m, Ord a) => Partition s c a -> a -> STT s m (Maybe (Entry s c a))
-getEntry Partition { entries = mref} val = do
-  m <- readSTRef mref
-  case Map.lookup val m of
-    Nothing -> return Nothing
-    Just entry -> return $ Just entry
-
-equate :: (Monad m, Ord a) => Partition s c a -> a -> a -> STT s m ()
-equate part x y = do
-  ex <- getEntry' part x
-  ey <- getEntry' part  y
-  equate' part ex ey
-
-equate' :: (Monad m, Ord a) => Partition s c a -> Entry s c a -> Entry s c a -> STT s m ()
-equate' Partition {combDesc = mkDesc} x y = do
-  repx@(Entry rx) <- representative x
-  repy@(Entry ry) <- representative y
-  when (rx /= ry) $ 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}
-      else do
-       writeSTRef rx Node {entryParent = repy, entryValue = vx}
-       writeSTRef ry dy{entryWeight = wx + wy, entryDesc = mkDesc chx chy}
-
-classDesc :: (Monad m, Ord a) => Partition s c a -> a -> STT s m c
-classDesc p val = do
-  mentry <- getEntry p val
-  case mentry of
-    Nothing -> return $ singleDesc p val
-    Just entry -> classDesc' entry
-
-classDesc' :: (Monad m) => Entry s c a -> STT s m c
-classDesc' entry = do
-  Entry e <- representative entry
-  liftM entryDesc $ readSTRef e
-
--- | /O(1)/. Return @True@ if both points belong to the same
--- | equivalence class.
-equivalent :: (Monad m, Ord a) => Partition s c a -> a -> a -> STT s m Bool
-equivalent p v1 v2 = do
-  me1 <- getEntry p v1
-  me2 <- getEntry p v2
-  case (me1,me2) of
-    (Just e1, Just e2) -> equivalent' e1 e2
-    (Nothing, Nothing) -> return $ v1 == v2
-    _ -> return False
-    
-
-equivalent' :: (Monad m, Ord a) => Entry s c a -> Entry s c a -> STT s m Bool
-equivalent' e1 e2 = liftM2 (==) (representative e1) (representative e2)
-

union-find-stt.cabal

-Name:            union-find
-Version:         0.1
-License:         BSD3
-License-File:    LICENSE
-Author:          Patrick Bahr <paba@diku.dk>
-Maintainer:      Patrick Bahr <paba@diku.dk>
-Synopsis:        Efficient union and equivalence testing of sets using STT.
-Description:	 
-Category:        Algorithms, Data
-Stability:       provisional
-Build-Type:      Simple
-Cabal-Version:   >= 1.6
-
-Library
-  Build-Depends:
-    base >= 4 && < 5, containers, STMonadTrans >= 0.2, mtl
-  Exposed-Modules:
-    Data.UnionFind.STT,
-    Data.UnionFind.Monad
-  Hs-Source-Dirs: src
-