Rel.hs

{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
{- |
Module      :  ./Common/Lib/Rel.hs
Description :  Relations, based on maps
Copyright   :  (c) Uni Bremen 2003-2005
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.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 possibly
with 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.  But rather than
inserting self edges and element can be mapped to the empty set.

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, nullKeys, rmNullSets
    , insertPair, insertDiffPair, insertKeyOrPair
    , member, toMap, map
    , noPairs, insertKey, deleteKey, memberKey, keysSet
    , fromKeysSet
    , reflexive
    , getCycles
    , union, intersection, isSubrelOf, difference, path
    , delete, succs, predecessors, irreflex, sccOfClosure
    , transClosure, fromList, toList, toPrecMap
    , intransKernel, mostRight, restrict, delSet
    , toSet, fromSet, topSort, depSort, nodes, collaps
    , transpose, transReduce
    , fromMap, locallyFiltered
    , flatSet, partSet, partList, leqClasses
    ) where

import Prelude hiding (map, null)
import Data.Data
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List

import GHC.Generics (Generic)

import qualified Common.Lib.MapSet as MapSet

-- | no invariant is ensured for relations!
newtype Rel a = Rel { toMap :: Map.Map a (Set.Set a) }
  deriving (Eq, Ord, Typeable, Data, Generic)

instance Show a => Show (Rel a) where
    show = show . toMap

instance (Ord a, Read a) => Read (Rel a) where
    readsPrec d = List.map (\ (m, r) -> (fromMap m , r)) . readsPrec d

fromMap :: Map.Map a (Set.Set a) -> Rel a
fromMap = Rel

-- | the empty relation
empty :: Rel a
empty = Rel Map.empty

-- | test for 'empty'
nullKeys :: Rel a -> Bool
nullKeys (Rel m) = Map.null m

-- | keys of the relation
keysSet :: Rel a -> Set.Set a
keysSet = Map.keysSet . toMap

rmNullSets :: Ord a => Rel a -> Rel a
rmNullSets = Rel . MapSet.rmNullSets . toMap

-- | test for 'empty'
noPairs :: Ord a => Rel a -> Bool
noPairs = nullKeys . rmNullSets

-- | difference of two relations
difference :: Ord a => Rel a -> Rel a -> Rel a
difference (Rel m) = Rel . Map.differenceWith MapSet.setDifference m . toMap

-- | union of two relations
union :: Ord a => Rel a -> Rel a -> Rel a
union (Rel m) = Rel . Map.unionWith Set.union m . toMap

-- | intersection of two relations
intersection :: Ord a => Rel a -> Rel a -> Rel a
intersection (Rel m) = Rel . Map.intersectionWith Set.intersection m . toMap

-- | is the first relation a sub-relation of the second
isSubrelOf :: Ord a => Rel a -> Rel a -> Bool
isSubrelOf (Rel m) = Map.isSubmapOfBy Set.isSubsetOf m . toMap

-- | insert an ordered pair
insertPair :: Ord a => a -> a -> Rel a -> Rel a
insertPair a b = Rel . MapSet.setInsert a b . toMap

-- | insert a pair only if both sides are different
insertDiffPair :: Ord a => a -> a -> Rel a -> Rel a
insertDiffPair a b = if a == b then id else insertPair a b

-- | insert a pair only if both sides are different
insertKeyOrPair :: Ord a => a -> a -> Rel a -> Rel a
insertKeyOrPair a b = if a == b then insertKey a else insertPair a b

-- | insert an unrelated node
insertKey :: Ord a => a -> Rel a -> Rel a
insertKey k r@(Rel m) = if Map.member k m then r else
  Rel $ Map.insert k Set.empty m

-- | delete an ordered pair
delete :: Ord a => a -> a -> Rel a -> Rel a
delete a b (Rel m) =
    let t = Set.delete b $ MapSet.setLookup a m in
    Rel $ if Set.null t then Map.delete a m else Map.insert a t m

-- | delete a node and all its relations
deleteKey :: Ord a => a -> Rel a -> Rel a
deleteKey k = Rel . Map.delete k . toMap

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

memberKey :: Ord a => a -> Rel a -> Bool
memberKey k = Map.member k . toMap

-- | get direct successors
succs :: Ord a => Rel a -> a -> Set.Set a
succs (Rel m) a = Map.findWithDefault Set.empty a m

-- | get all transitive successors
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 of one node in the given set of a nodes
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
predecessors :: Ord a => Rel a -> a -> Set.Set a
predecessors (Rel m) a = Map.keysSet $ Map.filter (Set.member a) 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 transposed relation (losing unrelated keys)
transpose :: Ord a => Rel a -> Rel a
transpose = Rel . MapSet.toMap . MapSet.transpose . MapSet.fromMap . toMap

-- | make relation irreflexive
irreflex :: Ord a => Rel a -> Rel a
irreflex = Rel . Map.mapWithKey Set.delete . toMap

-- | add all keys as reflexive elements
reflexive :: Ord a => Rel a -> Rel a
reflexive = Rel . Map.mapWithKey Set.insert . toMap

-- | get entries that contain the key as element
getCycles :: Ord a => Rel a -> Rel a
getCycles = Rel . Map.filterWithKey Set.member . toMap

-- | compute strongly connected components for a transitively closed relation
sccOfClosure :: Ord a => Rel a -> [Set.Set a]
sccOfClosure r@(Rel m) =
        if Map.null m then []
        else let ((k, v), p) = Map.deleteFindMin m in
             if Set.member k v then -- has a cycle
                let c = preds r k v in -- get the cycle
                c : sccOfClosure (delSet c r)
             else sccOfClosure (Rel p)

{- | restrict strongly connected components to its minimal representative
     (input sets must be non-null). Direct cycles may remain. -}
collaps :: Ord a => [Set.Set a] -> Rel a -> Rel a
collaps = delSet . Set.unions . List.map Set.deleteMin

{- | transitive reduction (minimal relation with the same transitive closure)
     of a transitively closed DAG (i.e. without cycles)! -}
transReduce :: Ord a => Rel a -> Rel a
transReduce (Rel m) = Rel
-- keep all (i, j) in rel for which no c with (i, c) and (c, j) in rel
  $ Map.mapWithKey ( \ i s -> let d = MapSet.setToMap $ Set.delete i s in
        Set.filter ( \ j ->
            Map.null $ Map.filter (Set.member j)
                $ Map.intersection m $ Map.delete j d) s) m

-- | convert a list of ordered pairs to a relation
fromList :: Ord a => [(a, a)] -> Rel a
fromList = foldr (uncurry insertPair) empty

-- | convert a relation to a list of ordered pairs (this loses isolated keys!)
toList :: Rel a -> [(a, a)]
toList (Rel m) = concatMap (\ (a , bs) -> List.map ( \ b -> (a, b) )
                            (Set.toList bs)) $ Map.toList m

-- | map the values of a relation
map :: (Ord a, Ord b) => (a -> b) -> Rel a -> Rel b
map f = Rel . Map.mapKeysWith Set.union f . Map.map (Set.map f) . toMap

-- | Restriction of a relation under a set
restrict :: Ord a => Rel a -> Set.Set a -> Rel a
restrict r s = delSet (nodes r Set.\\ s) r

-- | restrict to elements not in the input set
delSet :: Ord a => Set.Set a -> Rel a -> Rel a
delSet s (Rel m) = Rel $ Map.map (Set.\\ s) $ m Map.\\ MapSet.setToMap s

-- | 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 = fromAscList . Set.toList

-- | convert a plain node set to a relation
fromKeysSet :: Ord a => Set.Set a -> Rel a
fromKeysSet = Rel . Set.fold (`Map.insert` Set.empty) Map.empty

-- | convert a sorted list of ordered pairs to a relation
fromAscList :: Ord a => [(a, a)] -> Rel a
fromAscList = Rel . Map.fromDistinctAscList
                  . List.map ( \ l -> (fst (head l),
                                  Set.fromDistinctAscList $ List.map snd l))
                        . List.groupBy ( \ (a, _) (b, _) -> a == b)

-- | all nodes of the edges
nodes :: Ord a => Rel a -> Set.Set a
nodes (Rel m) = Set.union (Map.keysSet m) $ MapSet.setElems m

{- | Construct a precedence map from a closed relation. Indices range
   between 1 and the second value that is output. -}
toPrecMap :: Ord a => Rel a -> (Map.Map a Int, Int)
toPrecMap = foldl ( \ (m1, c) s -> let n = c + 1 in
                    (Set.fold (`Map.insert` n) m1 s, n))
                 (Map.empty, 0) . topSort

topSortDAG :: Ord a => Rel a -> [Set.Set a]
topSortDAG r@(Rel m) = if Map.null m then [] else
    let es = MapSet.setElems m
        ml = Map.keysSet m Set.\\ es -- most left
        Rel m2 = delSet ml r
        rs = es Set.\\ Map.keysSet m2 -- re-insert loose ends
    in ml : topSortDAG (Rel $ Set.fold (`Map.insert` Set.empty) m2 rs)

-- | topologically sort a closed relation (ignore isolated cycles)
topSort :: Ord a => Rel a -> [Set.Set a]
topSort r = let cs = sccOfClosure r in
      List.map (expandCycle cs) $ topSortDAG $ irreflex $ collaps cs r

-- | find the cycle and add it to the result set
expandCycle :: Ord a => [Set.Set a] -> Set.Set a -> Set.Set a
expandCycle cs s = case cs of
  [] -> s
  c : r ->
    if Set.null $ Set.intersection c s then expandCycle r s else Set.union c s

-- dependency sort
depSort :: Ord a => Rel a -> [Set.Set a]
depSort r = let cs = sccOfClosure r in
  List.concatMap (List.map (depCycle cs) . Set.toList)
    $ topSortDAG $ irreflex $ collaps cs r

depCycle :: Ord a => [Set.Set a] -> a -> Set.Set a
depCycle cs a = case cs of
  [] -> Set.singleton a
  c : r ->
    if Set.member a c then c else depCycle r a

-- | gets the most right elements of a relation,
mostRightOfCollapsed :: Ord a => Rel a -> Set.Set a
mostRightOfCollapsed r@(Rel m) =
  Set.difference (nodes r) . Map.keysSet $ Map.filterWithKey
  (\ i s -> not (Set.null s) && s /= Set.singleton i) m

{- |
find s such that x in s => forall y . yRx or not yRx and not xRy

 * precondition: (transClosure r == r)

 * strongly connected components (cycles) are treated as a compound node
-}

mostRight :: Ord a => Rel a -> Set.Set a
mostRight r = let
    cs = sccOfClosure r
    in expandCycle cs (mostRightOfCollapsed $ collaps cs r)

{- |
intransitive kernel of a reflexive and transitive closure

 * precondition: (transClosure r == r)
 * cycles are uniquely represented (according to Ord)
-}
intransKernel :: Ord a => Rel a -> Rel a
intransKernel r =
    let cs = sccOfClosure r
    in foldr addCycle (transReduce $ collaps cs r) cs

-- add a cycle given by a set in the collapsed node
addCycle :: Ord a => Set.Set a -> Rel a -> Rel a
addCycle c r = if Set.null c then error "Common.Lib.Rel.addCycle" else
    let (a, b) = Set.deleteFindMin c
        (m, d) = Set.deleteFindMax c
    in insertPair m a $ foldr (uncurry insertPair) (delete a a r) $
       zip (Set.toList d) (Set.toList b)

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

 * if one of the arguments is not present False is returned
-}
haveCommonLeftElem :: Ord a => a -> a -> Rel a -> Bool
haveCommonLeftElem t1 t2 =
    Map.foldr (\ e -> (|| Set.member t1 e && Set.member t2 e)) False . toMap

{- | partitions a set into a list of disjoint non-empty subsets
determined by the given function as equivalence classes -}
partSet :: Ord a => (a -> a -> Bool) -> Set.Set a -> [Set.Set a]
partSet f = List.map Set.fromList . leqClasses f

{- | partitions a list into a list of disjoint non-empty lists
determined by the given function as equivalence classes -}
partList :: (a -> a -> Bool) -> [a] -> [[a]]
partList f l = case l of
  [] -> []
  x : r -> let
    (ds, es) = List.partition (not . any (f x)) $ partList f r
    in (x : concat es) : ds

-- | Divide a Set (List) into equivalence classes w.r.t. eq
leqClasses :: Ord a => (a -> a -> Bool) -> Set.Set a -> [[a]]
leqClasses f = partList f . Set.toList

{- | flattens a list of non-empty sets and uses the minimal element of
each set to represent the set -}
flatSet :: Ord a => [Set.Set a] -> Set.Set a
flatSet = Set.fromList . List.map (\ s -> if Set.null s
                         then error "Common.Lib.Rel.flatSet"
                         else Set.findMin s)

{- | checks if a given relation is locally filtered

 * precondition: the relation must already be closed by transitive closure
-}
locallyFiltered :: Ord a => Rel a -> Bool
locallyFiltered rel = check . flatSet . partSet iso $ mostRight rel
    where iso x y = member x y rel && member y x rel
          check s = Set.null s ||
                  Set.fold (\ y ->
                            (&& not (haveCommonLeftElem x y rel))) True s'
                  && check s'
              where (x, s') = Set.deleteFindMin s