{- |

Module : $Header$

Copyright : (c) Christian Maeder, Till Mossakowski, Klaus L�ttich and Uni Bremen 2003

Licence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt

Maintainer : maeder@tzi.de

Stability : provisional

Portability : portable

supply a simple data type for (precedence or subsort) relations. A

relation is conceptually a set of (ordered) pairs,

but the hidden implementation is based on a map of sets.

An alternative view is that of a directed Graph

without isolated nodes.

'Rel' is a directed graph with elements (Ord a) as (uniquely labelled) nodes

and (unlabelled) edges (with a multiplicity of at most one).

Usage: start with an 'empty' relation, 'insert' edges, and test for

an edge 'member' (before or after calling 'transClosure').

It is possible to insert self edges or bigger cycles.

Checking for a 'path' corresponds to checking for a member in the

transitive (possibly non-reflexive) closure. A further 'insert', however,

may destroy the closedness property of a relation.

-}

module Common.Lib.Rel (Rel(), empty, isEmpty, insert, member, toMap,

union , subset, difference, path, delete,

succs, predecessors, irreflex, sccOfClosure,

transClosure, fromList, toList, image,

intransKernel, mostRight, rmSym, symmetricSets,

restrict, toSet, fromSet, topSort, nodes,

transpose, collaps, transReduce,

haveCommonLeftElem) where

import qualified Common.Lib.Map as Map

import qualified Common.Lib.Set as Set

import Data.List(groupBy)

import Data.Maybe (catMaybes)

data Rel a = Rel { toMap :: Map.Map a (Set.Set a) } deriving Eq

-- the invariant is that set values are never empty

-- | the empty relation

empty :: Rel a

empty = Rel Map.empty

-- | test for 'empty'

isEmpty :: Rel a -> Bool

isEmpty (Rel m) = Map.isEmpty m

-- | difference of two relations

difference :: Ord a => Rel a -> Rel a -> Rel a

difference a b = fromSet (toSet a Set.\\ toSet b)

-- | union of two relations

union :: Ord a => Rel a -> Rel a -> Rel a

union a b = fromSet $ Set.union (toSet a) $ toSet b

-- | is the first relation a subset of the second

subset :: Ord a => Rel a -> Rel a -> Bool

subset a b = Set.subset (toSet a) $ toSet b

-- | insert an ordered pair

insert :: Ord a => a -> a -> Rel a -> Rel a

insert a b (Rel m) = Rel $ Map.setInsert a b m

-- | delete an ordered pair

delete :: Ord a => a -> a -> Rel a -> Rel a

delete a b r

| member a b r = let s = Set.delete b (Map.find a (toMap r))

in if Set.isEmpty s

then Rel $ Map.delete a $ toMap r

else Rel $ Map.insert a s $ toMap r

| otherwise = r

-- | test for an (previously inserted) ordered pair

member :: Ord a => a -> a -> Rel a -> Bool

member a b r = Set.member b $ succs r a

{--------------------------------------------------------------------

SymMember (Added by K.L.)

--------------------------------------------------------------------}

-- | test if elements are related in both directions

symMember :: Ord a => a -> a -> Rel a -> Bool

symMember a b r = member a b r && member b a r

-- | get direct successors

succs :: Ord a => Rel a -> a -> Set.Set a

succs (Rel m) a = Map.findWithDefault Set.empty a m

reachable :: Ord a => Rel a -> a -> Set.Set a

reachable r a = Set.fold reach Set.empty $ succs r a where

reach e s = if Set.member e s then s

else Set.fold reach (Set.insert e s) $ succs r e

-- | predecessors in the given set of a node

preds :: Ord a => Rel a -> a -> Set.Set a -> Set.Set a

preds r a = Set.filter ( \ s -> member s a r)

-- | get direct predecessors inefficiently

predecessors :: Ord a => Rel a -> a -> Set.Set a

predecessors r@(Rel m) a = preds r a $ keySet m

-- | test for 'member' or transitive membership (non-empty path)

path :: Ord a => a -> a -> Rel a -> Bool

path a b r = Set.member b $ reachable r a

-- | compute transitive closure (make all transitive members direct members)

transClosure :: Ord a => Rel a -> Rel a

transClosure r@(Rel m) = Rel $ Map.mapWithKey ( \ k _ -> reachable r k) m

-- | get reverse relation

transpose :: Ord a => Rel a -> Rel a

transpose = fromList . map ( \ (a, b) -> (b, a)) . toList

-- | make relation irreflexive

irreflex :: Ord a => Rel a -> Rel a

irreflex (Rel m) = Rel $ Map.foldWithKey ( \ k s ->

let r = Set.delete k s in

if Set.isEmpty r then id else

Map.insert k r) Map.empty m

-- | compute strongly connected components for a transitively closed relation

sccOfClosure :: Ord a => Rel a -> Map.Map a (Set.Set a)

sccOfClosure r@(Rel m) =

fst $ Map.foldWithKey

( \ k v (m1, s) ->

let s1 = Set.delete k s in

if Set.member k v then

if Set.member k s then (m1, s1)

else let s2 = preds r k v in

(Map.insert k s2 m1, Set.union s1

$ Set.filter (> k) s2)

else (m1, s1)) (Map.empty, Set.empty) m

-- | collaps strongly connected components to its minimal representative

collaps :: Ord a => Map.Map a a -> Rel a -> Rel a

collaps c = image (\ e -> Map.findWithDefault e e c)

{- | transitive reduction (minimal relation with the same transitive closure)

of a DAG. -}

transReduce :: Ord a => Rel a -> Rel a

transReduce rel@(Rel m) =

Map.foldWithKey ( \ i ->

flip $ Set.fold ( \ j ->

if covers i j rel then

insert i j else id)) empty m

where

-- (a, b) in r but no c with (a, c) and (c, b) in r

covers :: Ord a => a -> a -> Rel a -> Bool

covers a b r = Set.all ( \ c -> not $ path c b r)

(Set.delete a $ Set.delete b $ reachable r a)

-- | convert a list of ordered pairs to a relation

fromList :: Ord a => [(a, a)] -> Rel a

fromList = foldr (uncurry insert) empty

-- | convert a relation to a list of ordered pairs

toList :: Rel a -> [(a, a)]

toList (Rel m) = concatMap (\ (a , bs) -> map ( \ b -> (a, b) )

(Set.toList bs)) $ Map.toList m

instance (Show a, Ord a) => Show (Rel a) where

show = show . Set.fromDistinctAscList . toList

{--------------------------------------------------------------------

Image (Added by T.M.) (implementation changed by C.M.)

--------------------------------------------------------------------}

-- | Image of a relation under a function

image :: (Ord a, Ord b) => (a -> b) -> Rel a -> Rel b

image f (Rel m) = Rel $ Map.foldWithKey

( \ a v -> Map.insertWith Set.union (f a) $ Set.image f v) Map.empty m

{--------------------------------------------------------------------

Restriction (Added by T.M.)

--------------------------------------------------------------------}

-- | Restriction of a relation under a set

restrict :: Ord a => Rel a -> Set.Set a -> Rel a

restrict (Rel m) s = Rel $ Map.foldWithKey

( \ a v -> if Set.member a s then

let r = Set.intersection v s in

if Set.isEmpty r then id else Map.insert a r

else id) Map.empty m

{--------------------------------------------------------------------

Conversion from/to sets (Added by T.M.) (implementation changed by C.M.)

--------------------------------------------------------------------}

-- | convert a relation to a set of ordered pairs

toSet :: (Ord a) => Rel a -> Set.Set (a, a)

toSet = Set.fromDistinctAscList . toList

-- | convert a set of ordered pairs to a relation

fromSet :: (Ord a) => Set.Set (a, a) -> Rel a

fromSet s = fromAscList $ Set.toList s

-- | convert a sorted list of ordered pairs to a relation

fromAscList :: (Ord a) => [(a, a)] -> Rel a

fromAscList = Rel . Map.fromDistinctAscList

. map ( \ l -> (fst (head l),

Set.fromDistinctAscList $ map snd l))

. groupBy ( \ (a, _) (b, _) -> a == b)

-- | all nodes of the edges

nodes :: Ord a => Rel a -> Set.Set a

nodes (Rel m) = Set.union (keySet m) $ elemSet m

keySet :: Ord a => Map.Map a b -> Set.Set a

keySet = Set.fromDistinctAscList . Map.keys

elemSet :: Ord a => Map.Map a (Set.Set a) -> Set.Set a

elemSet = Set.unions . Map.elems

-- | topological sort a relation (more efficient for a closed relation)

topSort :: Ord a => Rel a -> [Set.Set a]

topSort r@(Rel m) =

if isEmpty r then []

else let ms = keySet m Set.\\ elemSet m in

if Set.isEmpty ms then case removeCycle r of

Nothing -> topSort (transClosure r)

Just (a, cyc, restRel) ->

map ( \ s -> if Set.member a s then

Set.union s cyc else s) $ topSort restRel

else let (lowM, rest) =

Map.partitionWithKey (\ k _ -> Set.member k ms) m

-- no not forget loose ends

ls = elemSet lowM Set.\\ keySet rest in

-- put them as low as possible

ms : (topSort $ Rel $ Set.fold ( \ i ->

Map.insert i Set.empty) rest ls)

-- | try to remove a cycle

removeCycle :: Ord a => Rel a -> Maybe (a, Set.Set a, Rel a)

removeCycle r@(Rel m) =

let cycles = Map.filterWithKey Set.member m in

if Map.isEmpty cycles then Nothing

else let (a, os) = Map.findMin cycles

cs = preds r a os

m1 = Map.foldWithKey

( \ k v -> let i = v Set.\\ cs

in if Set.member k cs

then Map.insertWith Set.union a i

else Map.insert k

(if Set.size v > Set.size i

then Set.insert a i else i))

Map.empty m

in Just (a, Set.delete a cs, Rel m1)

{- The result is a representative "a", the cycle "cs", i.e. all other

elements that are represented by "a" and the remaining relation with

all elements from "cs" replaced by "a" and without the cycle "(a,a)"

-}

{--------------------------------------------------------------------

MostRight (Added by K.L.)

--------------------------------------------------------------------}

{- |

find s such that forall y . yRx and x in s (only the maximal element

of symmetric most right elements is inlcuded in s; all elements in s

are not symmetric)

* precondition: (transClosure r == r)

* only the greatest element of symmetric elements is shown

according to Ord

* Cyclic relations have no toplevel element!

-}

mostRight :: (Ord a) => Rel a -> (Set.Set a)

mostRight r =

let rmp = toMap $ rmSym $ rmReflex r

in (Set.unions $ Map.elems rmp) Set.\\

(Set.fromDistinctAscList $ Map.keys rmp)

{--------------------------------------------------------------------

symmetricSets (Added by K.L.)

--------------------------------------------------------------------}

-- | symmetricSets calculates a Set of Sets of Symmetric elements

--

-- * precondition: (transClosure r == r)

symmetricSets :: (Ord a) => Rel a -> Set.Set (Set.Set a)

symmetricSets rel =

fst $ Map.foldWithKey

(\k e (s,seen) ->

if not (Set.isEmpty seen) &&

k == Set.findMin seen

then (s,seen)

else (let sym = Set.fold (\ e1 s1 ->

if member e1 k rel

then Set.insert k $

Set.insert e1 s1

else s1) Set.empty e

in if Set.isEmpty sym

then s

else Set.insert sym s

,Set.insert k seen `Set.union` e))

(Set.empty,Set.empty) $

toMap $ rmReflex rel

symmetricMap :: (Ord a) => Rel a -> Map.Map a (Set.Set a)

symmetricMap = Set.fold (\s mp ->

Set.fold (\k mp1 ->

Map.insert k s mp1) mp s)

Map.empty . symmetricSets

{--------------------------------------------------------------------

remove reflexive (Added by K.L.)

--------------------------------------------------------------------}

-- | remove reflexive relations

-- Warning: this function violates the empty set condition

rmReflex :: (Ord a) => Rel a -> Rel a

rmReflex = Rel . Map.mapWithKey Set.delete . toMap

{--------------------------------------------------------------------

intransitive kernel (Added by K.L.)

--------------------------------------------------------------------}

-- |

-- intransitive kernel of a reflexive and transitive closure

--

-- * every left element is related to all symmetric right elements if (transClosure r == r)

--

-- * Warning: all reflexive relations are removed!!

intransKernel :: (Show a ,Ord a) => Rel a -> Rel a

intransKernel r =

let rmap = toMap $ rmReflex $ rmSym r

insDirR k set m = Map.insert k (dirRight set) m

dirRight set = set Set.\\ transRight set

transRight = Set.unions . map lkup . Set.toList

lkup = (\ e -> maybe Set.empty id (Map.lookup e rmap))

addSym sm mp =

let checkAllSym m =

Set.fold (\k cm -> if Map.member k cm

then cm

else Map.insert k

(Map.find k sm) cm)

m $ Set.unions $ Map.elems sm

in Rel $ checkAllSym

$ Map.mapWithKey

(\ k s -> Set.delete k $

Set.unions (s:catMaybes (concatMap

(\x-> let ms = Map.lookup x sm

in maybe ([ms])

(\ _ -> [ms,

Map.lookup x

mp])

ms)

(k:Set.toList s))))

$ mp

in addSym (symmetricMap r) $

Map.foldWithKey insDirR Map.empty rmap

{--------------------------------------------------------------------

remove symmetric relations (Added by K.L.)

--------------------------------------------------------------------}

-- extend to

-- aRb /\ bRa /\ bRc /\ aRd ~~> aRb /\ bRc /\ aRd /\ aRc /\ bRd with a<b /\ a/=b/=c/=d

-- | remove symmetric relations aRb and bRa ~~> aRb with a < b

--

-- * precondition: (transClosure r == r)

rmSym :: (Ord a) => Rel a -> Rel a

rmSym rel =

let rl = Map.keys (toMap rel)

sym (x,y) r1 = if symMember x y rel

then delete y x r1

else r1

in foldr sym rel [(x,y) | x <- rl, y <- rl, x<y]

{--------------------------------------------------------------------

common transitive left element of two elements (Added by K.L.)

--------------------------------------------------------------------}

-- | calculates if two given elements have a common left element

--

-- * precondition: (transClosure r == r)

--

-- * if one of the arguments is not present False is returned

haveCommonLeftElem :: (Ord a) => a -> a -> Rel a -> Bool

haveCommonLeftElem t1 t2 =

Map.fold(\ e rs -> rs || (t1 `Set.member` e &&

t2 `Set.member` e)) False . toMap