packages feed

equivalence (empty) → 0.1

raw patch · 5 files changed

+476/−0 lines, 5 filesdep +STMonadTransdep +basedep +containerssetup-changed

Dependencies added: STMonadTrans, base, containers, mtl

Files

+ LICENSE view
@@ -0,0 +1,28 @@+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.
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main :: IO ()+main = defaultMain
+ equivalence.cabal view
@@ -0,0 +1,28 @@+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:	 +  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.6++Library+  Build-Depends:+    base >= 4 && < 5, containers, mtl, STMonadTrans+  Exposed-Modules:+    Data.Equivalence.STT,+    Data.Equivalence.Monad+  Hs-Source-Dirs: src+
+ src/Data/Equivalence/Monad.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE+  RankNTypes,+  FlexibleInstances,+  FlexibleContexts,+  MultiParamTypeClasses,+  UndecidableInstances,+  FunctionalDependencies #-}++--------------------------------------------------------------------------------+-- |+-- 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(..),+     EquivM,+     runEquivT,+     runEquivM+     ) 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+++{-| 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 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++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)+    +{-| 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)+          -- | used to construct an equivalence class descriptor for a singleton class+          => (v -> c)+          -- | used to combine the equivalence class descriptor of two classes+          --   which are meant to be combined.+          -> (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++{-| 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 ::+          -- | used to construct an equivalence class descriptor for a singleton class+             (v -> c)+          -- | used to combine the equivalence class descriptor of two classes+          --   which are meant to be combined.+          -> (c -> c -> c)+          -> (forall s. EquivM s c v a)+          -> a+runEquivM sing comb m = runIdentity $ runEquivT sing comb m++{-| This class specifies the interface for a monadic computation that+maintains an equivalence relation.  -}++class (Monad m, Ord v) => MonadEquiv c v m | m -> v, m -> c 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 c+    +    {-| This function equates the given two elements. That is it+        unions the equivalence classes of the two elements. -}++    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, Monoid w) => MonadEquiv c v (WriterT w m) where+    equivalent x y = lift $ equivalent x y+    classDesc = lift . classDesc+    equate x y = lift $ equate x y++instance (MonadEquiv c v m, Error e) => MonadEquiv c v (ErrorT e m) where+    equivalent x y = lift $ equivalent x y+    classDesc = lift . classDesc+    equate x y = lift $ equate x y++instance (MonadEquiv c v m) => MonadEquiv c v (StateT s m) where+    equivalent x y = lift $ equivalent x y+    classDesc = lift . classDesc+    equate x y = lift $ equate x y++instance (MonadEquiv c v m) => MonadEquiv c v (ReaderT r m) where+    equivalent x y = lift $ equivalent x y+    classDesc = lift . classDesc+    equate x y = lift $ equate x y
+ src/Data/Equivalence/STT.hs view
@@ -0,0 +1,248 @@+--------------------------------------------------------------------------------+-- |+-- 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+  ( leastEquiv+  , equate+  , equivalent+  , classDesc+  , Equiv+  ) where++import Control.Monad.ST.Trans+import Control.Monad++import Data.Map (Map)+import qualified Data.Map as Map++{-| 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 (STRef s (EntryData s c a))+    deriving (Eq)++{-| 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+    }++{-| 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 :: STRef s (Map a (Entry 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+      }+{-+   not used++{-|+  This function modifies the content of a reference cell.+-}++modifySTRef :: (Monad m) => STRef s a -> (a -> a) -> STT s m ()+modifySTRef r f = readSTRef r >>= (writeSTRef r . f)++-}++{-| 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+          -- | used to construct an equivalence class descriptor for a singleton class+           => (a -> c)+          -- | used to combine the equivalence class descriptor of two classes+          --   which are meant to be combined.+           -> (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}++++{-| 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 => 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')+++++{-| 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 => 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+++{-| This function looks up the entry of the given element in the given+equivalence relation representation. If there is none yet, then a+fresh one is constructed which then represents a new singleton+equivalence class! -}++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++{-| 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, 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 elements. That is, it unions+the equivalence classes of the two elements and combines their+descriptor. -}++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+++{-| This function equates the two given entries. That is, it performs+a weighted union of their trees combines their descriptor. -}++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}++{-| This function returns the descriptor of the given element's+equivalence class. -}++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++{-| This function returns the descriptor of the given entry's tree. -}++classDesc' :: (Monad m) => Entry s c a -> STT s m c+classDesc' entry = do+  Entry e <- representative entry+  liftM entryDesc $ readSTRef e++{-| This function decides whether the two given elements are in the+same equivalence class according to the given equivalence relation+representation. -}++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+    +{-| This function decides whether the two given entries are in the+same tree (by comparing their roots).-}++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)+