Commits

Patrick Bahr committed 42dcd7b

implementation of a graph-based union/find algorithm using the STT monad transformer
- cabalised
- still untested

  • Participants

Comments (0)

Files changed (5)

+syntax:glob
+dist
+dummy.cabal
+*~
+*\#
+*.orig
+*.o
+*.hi
+.hpc
+hpcreport
+*.tix
+*.log
+Copyright 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.

File src/Data/UnionFind/Monad.hs

+{-# LANGUAGE
+  RankNTypes,
+  FlexibleInstances,
+  MultiParamTypeClasses,
+  UndecidableInstances #-}
+
+
+module Data.UnionFind.Monad
+where
+
+import Data.UnionFind.STT hiding (equate, equivalent, equivalenceClass)
+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.ST.Trans
+
+newtype PartitionT s v m a = PartitionT {unPartitionT :: ReaderT (Partition s v) (STT s m) a}
+
+instance (Monad m) => Monad (PartitionT s v m) where
+    PartitionT m >>= f = PartitionT (m >>= (unPartitionT . f))
+    return = PartitionT . return
+
+instance MonadTrans (PartitionT s v) where
+    lift = PartitionT . lift . lift
+
+instance (MonadReader r m) => MonadReader r (PartitionT s 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 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 v m) where
+    get = PartitionT get
+    put s = PartitionT $ put s
+
+instance (MonadError e m) => MonadError e (PartitionT s v m) where
+    throwError e = lift $ throwError e
+    catchError (PartitionT m) f = PartitionT $ catchError m (unPartitionT . f)
+    
+
+runPartitionT :: (Monad m) => (forall s. PartitionT s v m a) -> m a
+runPartitionT m = runST $ do
+  p <- emptyPartition
+  (`runReaderT` p) $ unPartitionT m
+
+equivalent :: (Monad m, Ord v) => v -> v -> PartitionT s v m Bool
+equivalent x y = PartitionT $ do
+  part <- ask
+  lift $ S.equivalent part x y
+
+equivalenceClass :: (Monad m, Ord v) => v -> PartitionT s v m [v]
+equivalenceClass x = PartitionT $ do
+  part <- ask
+  lift $ S.equivalenceClass part x
+
+equate :: (Monad m, Ord v) => v -> v -> PartitionT s v m ()
+equate x y = PartitionT $ do
+  part <- ask
+  lift $ S.equate part x y

File 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
+  , equivalenceClass
+  , Partition
+  )
+where
+
+import Control.Monad.ST.Trans
+import Control.Monad
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+newtype Entry s a = Entry (STRef s (EntryData s a))
+    deriving (Eq)
+
+data EntryData s a = EntryData {
+      entryParent :: Maybe (Entry s a),
+      entryClass :: [a],
+      entryWeight :: Int,
+      entryValue :: a
+    }
+
+data Partition s a = Partition {
+      entries :: STRef s (Map a (Entry s a))
+      }
+
+modifySTRef :: (Monad m) => STRef s a -> (a -> a) -> STT s m ()
+modifySTRef r f = readSTRef r >>= (writeSTRef r . f)
+
+
+emptyPartition :: Monad m => STT s m (Partition s a)
+emptyPartition = liftM Partition $ newSTRef Map.empty
+
+
+-- | /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 a -> STT s m (Maybe (Entry s a))
+representative' (Entry e) = do
+  ed <- readSTRef e
+  case entryParent ed of
+    Nothing -> return Nothing
+    Just parent -> do
+      mparent' <- representative' parent
+      case mparent' of
+        Nothing -> return $ Just parent
+        Just parent' -> writeSTRef e ed{entryParent = Just 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 a -> STT s m (Entry s a)
+representative entry = do
+  mrepr <- representative' entry
+  case mrepr of
+    Nothing -> return entry
+    Just repr -> return repr
+
+
+getEntry' :: (Monad m, Ord a) => Partition s a -> a -> STT s m (Entry s a)
+getEntry' (Partition mref) val = do
+  m <- readSTRef mref
+  case Map.lookup val m of
+    Nothing -> do
+      e <- newSTRef EntryData
+            { entryParent = Nothing,
+              entryClass = [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 a -> a -> STT s m (Maybe (Entry s a))
+getEntry (Partition 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 a -> a -> a -> STT s m ()
+equate part x y = do
+  ex <- getEntry' part x
+  ey <- getEntry' part  y
+  equate' ex ey
+
+equate' :: (Monad m, Ord a) => Entry s a -> Entry s a -> STT s m ()
+equate' x y = do
+  repx@(Entry rx) <- representative x
+  repy@(Entry ry) <- representative y
+  when (rx /= ry) $ do
+    dx@EntryData{entryWeight = wx, entryClass = chx} <- readSTRef rx
+    dy@EntryData{entryWeight = wy, entryClass = chy} <- readSTRef ry
+    if  wx >= wy
+      then do
+        writeSTRef ry dy{entryParent = Just repx}
+        writeSTRef rx dx{entryWeight = wx + wy, entryClass = chx ++ chy}
+      else do
+       writeSTRef rx dx{entryParent = Just repy}
+       writeSTRef ry dy{entryWeight = wx + wy, entryClass = chx ++ chy}
+
+equivalenceClass :: (Monad m, Ord a) => Partition s a -> a -> STT s m [a]
+equivalenceClass p val = do
+  mentry <- getEntry p val
+  case mentry of
+    Nothing -> return [val]
+    Just entry -> equivalenceClass' entry
+
+equivalenceClass' :: (Monad m) => Entry s a -> STT s m [a]
+equivalenceClass' entry = do
+  Entry e <- representative entry
+  ed <- readSTRef e
+  return $ entryClass ed
+
+-- | /O(1)/. Return @True@ if both points belong to the same
+-- | equivalence class.
+equivalent :: (Monad m, Ord a) => Partition s 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 a -> Entry s a -> STT s m Bool
+equivalent' e1 e2 = liftM2 (==) (representative e1) (representative e2)
+

File 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
+