packages feed

union-find-array (empty) → 0.1

raw patch · 8 files changed

+427/−0 lines, 8 filesdep +arraydep +basedep +mtlsetup-changed

Dependencies added: array, base, mtl

Files

+ LICENSE view
@@ -0,0 +1,21 @@+union-find-array -- Union Find Data Structure++Copyright (c) 2010-2013, Bertram Felgenhauer++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runghc+> import Distribution.Simple (defaultMain)+> main = defaultMain
+ src/Control/Monad/Union.hs view
@@ -0,0 +1,106 @@+-- This file is part of the 'union-find-array' library. It is licensed+-- under an MIT license. See the accompanying 'LICENSE' file for details.+--+-- Authors: Bertram Felgenhauer++{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- Monadic interface for creating a disjoint set data structure.+--+module Control.Monad.Union (+  UnionM,+  Union (..),+  MonadUnion (..),+  Node,+  run,+  run',+) where++import Control.Monad.Union.Class+import qualified Data.Union.ST as US+import Data.Union.Type (Node (..), Union (..))++import Prelude hiding (lookup)+import Control.Monad.State+import Control.Monad.ST+import Control.Monad.Fix+import Control.Applicative+import Control.Arrow (first)++data UState s l = UState {+    next   :: !Int,+    forest :: US.UnionST s l+}++-- | Union find monad.+newtype UnionM l a = U {+    runU :: (forall s . StateT (UState s l) (ST s) a)+}++instance Monad (UnionM l) where+    return x =  U (return x)+    f >>= b = U (runU f >>= runU . b)++instance Functor (UnionM l) where+    fmap = liftM++instance Applicative (UnionM l) where+    pure = return+    (<*>) = ap++instance MonadFix (UnionM l) where+    mfix a = U (mfix (runU . a))++-- | Run a union find computation.+run :: UnionM l a -> a+run a = runST $ do+    u <- US.new 1 undefined+    evalStateT (runU a) UState{ next = 0, forest = u }++-- | Run a union find computation; also return the final disjoint set forest+-- for querying.+run' :: UnionM l a -> (Union l, a)+run' a = runST $ do+    u <- US.new 1 undefined+    (a, s) <- runStateT (runU a) UState{ next = 0, forest = u }+    f <- US.unsafeFreeze (forest s)+    return (f, a)++instance MonadUnion l (UnionM l) where+    -- Add a new node, with a given label.+    new l = U $ do+        u <- get+        let size = US.size (forest u)+            n    = next u+        if (size <= next u) then do+            forest' <- lift $ US.grow (forest u) (2*size)+            lift $ US.annotate forest' n l+            put u{ forest = forest', next = n + 1 }+         else do+            lift $ US.annotate (forest u) n l+            put u{ next = n + 1 }+        return (Node n)++    -- Find the node representing a given node, and its label.+    lookup (Node n) = U $ do+        dsf <- gets forest+        first Node <$> lift (US.lookup dsf n)++    -- Merge two sets. The first argument is a function that takes the labels+    -- of the corresponding sets' representatives and computes a new label for+    -- the joined set. Returns Nothing if the given nodes are in the same set+    -- already.+    merge f (Node n) (Node m) = U $ do+        dsf <- gets forest+        lift $ US.merge dsf f n m++    -- Re-label a node.+    annotate (Node n) l = U $ do+        dsf <- gets forest+        lift $ US.annotate dsf n l++    -- Flatten the disjoint set forest for faster lookups.+    flatten = U $ do+        dsf <- gets forest+        lift $ US.flatten dsf
+ src/Control/Monad/Union/Class.hs view
@@ -0,0 +1,40 @@+-- This file is part of the 'union-find-array' library. It is licensed+-- under an MIT license. See the accompanying 'LICENSE' file for details.+--+-- Authors: Bertram Felgenhauer++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+module Control.Monad.Union.Class (+    MonadUnion (..),+) where++import Data.Union.Type (Node (..), Union (..))+import Control.Monad.Trans (MonadTrans (..))+import Prelude hiding (lookup)++class Monad m => MonadUnion l m | m -> l where+    -- | Add a new node, with a given label.+    new :: l -> m Node++    -- | Find the node representing a given node, and its label.+    lookup :: Node -> m (Node, l)++    -- | Merge two sets. The first argument is a function that takes the labels+    -- of the corresponding sets' representatives and computes a new label for+    -- the joined set. Returns Nothing if the given nodes are in the same set+    -- already.+    merge :: (l -> l -> (l, a)) -> Node -> Node -> m (Maybe a)++    -- | Re-label a node.+    annotate :: Node -> l -> m ()++    -- | Flatten the disjoint set forest for faster lookups.+    flatten :: m ()++instance (MonadUnion l m, MonadTrans t, Monad (t m)) => MonadUnion l (t m) where+    new a = lift $ new a+    lookup a = lift $ lookup a+    merge a b c = lift $ merge a b c+    annotate a b = lift $ annotate a b+    flatten = lift $ flatten
+ src/Data/Union.hs view
@@ -0,0 +1,38 @@+-- This file is part of the 'union-find-array' library. It is licensed+-- under an MIT license. See the accompanying 'LICENSE' file for details.+--+-- Authors: Bertram Felgenhauer++-- |+-- Immutable disjoint set forests.+module Data.Union (+    Union,+    Node (..),+    size,+    lookup,+    lookupFlattened,+) where++import Prelude hiding (lookup)+import Data.Union.Type (Union, Node (..))+import qualified Data.Union.Type as T+import Data.Array.Base ((!))++-- | Get the number of nodes in the forest.+size :: Union l -> Int+size = T.size++-- | Look up the representative of a node, and its label.+lookup :: Union l -> Node -> (Node, l)+lookup u (Node n) = go n where+    go n | n' == n   = (Node n, T.label u ! n)+         | otherwise = go n'+      where+        n' = T.up u ! n++-- | Version of 'lookup' that assumes the forest to be flattened.+-- (cf. 'Control.Union.ST.flatten'.)+--+-- Do not use otherwise: It will give wrong results!+lookupFlattened :: Union a -> Node -> (Node, a)+lookupFlattened u (Node n) = (Node (T.up u ! n), T.label u ! n)
+ src/Data/Union/ST.hs view
@@ -0,0 +1,150 @@+-- This file is part of the 'union-find-array' library. It is licensed+-- under an MIT license. See the accompanying 'LICENSE' file for details.+--+-- Authors: Bertram Felgenhauer++{-# LANGUAGE RankNTypes, CPP #-}+-- |+-- Low-level interface for managing a disjoint set data structure, based on+-- 'Control.Monad.ST'. For a higher level convenience interface, look at+-- 'Control.Monad.Union'.+module Data.Union.ST (+    UnionST,+    runUnionST,+    new,+    grow,+    copy,+    lookup,+    annotate,+    merge,+    flatten,+    size,+    unsafeFreeze,+) where++import qualified Data.Union.Type as U++import Prelude hiding (lookup)+import Control.Monad.ST+import Control.Monad+import Control.Applicative+import Data.Array.Base hiding (unsafeFreeze)+import Data.Array.ST hiding (unsafeFreeze)+import qualified Data.Array.Base as A (unsafeFreeze)++-- | A disjoint set forest, with nodes numbered from 0, which can carry labels.+data UnionST s l = UnionST {+    up :: STUArray s Int Int,+    rank :: STUArray s Int Int,+    label :: STArray s Int l,+    size :: !Int,+    def :: l+}++#if __GLASGOW_HASKELL__ < 702+instance Applicative (ST s) where+    (<*>) = ap+    pure = return+#endif++-- Use http://www.haskell.org/pipermail/libraries/2008-March/009465.html ?++-- | Analogous to 'Data.Array.ST.runSTArray'.+runUnionST :: (forall s. ST s (UnionST s l)) -> U.Union l+runUnionST a = runST $ a >>= unsafeFreeze++-- | Analogous to 'Data.Array.Base.unsafeFreeze'+unsafeFreeze :: UnionST s l -> ST s (U.Union l)+unsafeFreeze u =+    U.Union (size u) <$> A.unsafeFreeze (up u) <*> A.unsafeFreeze (label u)++-- What about thawing?++-- | Create a new disjoint set forest, of given capacity.+new :: Int -> l -> ST s (UnionST s l)+new size def = do+    up <- newListArray (0, size-1) [0..]+    rank <- newArray (0, size-1) 0+    label <- newArray (0, size-1) def+    return UnionST{ up = up, rank = rank, label = label, size = size, def = def }++-- | Grow the capacity of a disjoint set forest. Shrinking is not possible.+-- Trying to shrink a disjoint set forest will return the same forest+-- unmodified.+grow :: UnionST s l -> Int -> ST s (UnionST s l)+grow u size' | size' <= size u = return u+grow u size' = grow' u size'++-- | Copy a disjoint set forest.+copy :: UnionST s l -> ST s (UnionST s l)+copy u = grow' u (size u)++grow' :: UnionST s l -> Int -> ST s (UnionST s l)+grow' u size' = do+    up' <- newListArray (0, size'-1) [0..]+    rank' <- newArray (0, size'-1) 0+    label' <- newArray (0, size'-1) (def u)+    forM_ [0..size u - 1] $ \i -> do+        readArray (up u) i >>= writeArray up' i+        readArray (rank u) i >>= writeArray rank' i+        readArray (label u) i >>= writeArray label' i+    return u{ up = up', rank = rank', label = label', size = size' }++-- | Annotate a node with a new label.+annotate :: UnionST s l -> Int -> l -> ST s ()+annotate u i v = writeArray (label u) i v++-- | Look up the representative of a given node.+--+-- lookup' does path compression.+lookup' :: UnionST s l -> Int -> ST s Int+lookup' u i = do+    i' <- readArray (up u) i+    if i == i' then return i else do+        i'' <- lookup' u i'+        writeArray (up u) i i''+        return i''++-- | Look up the representative of a given node and its label.+lookup :: UnionST s l -> Int -> ST s (Int, l)+lookup u i = do+    i' <- lookup' u i+    l' <- readArray (label u) i'+    return (i', l')++-- | Check whether two nodes are in the same set.+equals :: UnionST s l -> Int -> Int -> ST s Bool+equals u a b = do+    a' <- lookup' u a+    b' <- lookup' u b+    return (a' == b')++-- | Merge two nodes if they are in distinct equivalence classes. The+-- passed function is used to combine labels, if a merge happens.+merge :: UnionST s l -> (l -> l -> (l, a)) -> Int -> Int -> ST s (Maybe a)+merge u f a b = do+    (a', va) <- lookup u a+    (b', vb) <- lookup u b+    if a' == b' then return Nothing else do+        ra <- readArray (rank u) a'+        rb <- readArray (rank u) b'+        let cont x vx y vy = do+                writeArray (label u) y (error "invalid entry")+                let (v, w) = f vx vy+                writeArray (label u) x v+                return (Just w)+        case ra `compare` rb of+            LT -> do+                writeArray (up u) a' b'+                cont b' vb a' va+            GT -> do+                writeArray (up u) b' a'+                cont a' va b' vb+            EQ -> do+                writeArray (up u) a' b'+                writeArray (rank u) b' (ra + 1)+                cont b' vb a' va++-- | Flatten a disjoint set forest, for faster lookups.+flatten :: UnionST s l -> ST s ()+flatten u = forM_ [0..size u - 1] $ lookup' u
+ src/Data/Union/Type.hs view
@@ -0,0 +1,25 @@+-- This file is part of the 'union-find-array' library. It is licensed+-- under an MIT license. See the accompanying 'LICENSE' file for details.+--+-- Authors: Bertram Felgenhauer++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Union.Type (+    Union (..),+    Node (..),+) where++import Data.Array.Unboxed+import Data.Array++-- | An immutable disjoint set forest.+data Union a = Union {+    size  :: !Int,+    up    :: UArray Int Int,+    label :: Array Int a+}++-- | A node in a disjoint set forest.+newtype Node = Node { fromNode :: Int }+    deriving (Eq, Ord, Ix)
+ union-find-array.cabal view
@@ -0,0 +1,44 @@+name:          union-find-array+version:       0.1+stability:     experimental+author:        Bertram Felgenhauer+homepage:      http://cl-informatik.uibk.ac.at/software/haskell-rewriting/+maintainer:    Bertram Felgenhauer <int-e@gmx.de>+copyright:     Copyright (c) 2010-2013, Bertram Felgenhauer+license:       MIT+license-file:  LICENSE+category:      Algorithms, Data+synopsis:      union find data structure+description:+    ST based implementation of Tarjan\'s disjoint set forests, using mutable+    arrays storing indices instead of references internally. There is also+    a pure, immutable version of the data structure, which is useful for+    querying the result of a union find construction.+homepage:      https://github.com/haskell-rewriting/union-find-array+build-type:    Simple+cabal-version: >= 1.6++source-repository head+    type: git+    location: git://github.com/haskell-rewriting/union-find-array++library+    hs-source-dirs:+        src+    exposed-modules:+        Data.Union+        Data.Union.ST+        Data.Union.Type+        Control.Monad.Union.Class+        Control.Monad.Union+    build-depends:+        array >= 0.3 && < 0.5,+        mtl >= 1.1 && < 2.2,+        base >= 4 && < 5+    extensions:+        GeneralizedNewtypeDeriving+        RankNTypes+        MultiParamTypeClasses+        FunctionalDependencies+        FlexibleInstances+        UndecidableInstances