content: {-# 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
  