content: {- |
  Module      :  ./CSL/DependencyGraph.hs
  Description :  Definition of Dependency Graph with utils
  Copyright   :  (c) Ewaryst Schulz, DFKI Bremen 2011
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Ewaryst.Schulz@dfki.de
  Stability   :  experimental
  Portability :  portable
  
  Definition of Dependency Graph and utils to be applied to dependency stores
  -}
  
  
  module CSL.DependencyGraph
      where
  
  import Common.Doc
  import Common.DocUtils
  
  import CSL.AS_BASIC_CSL
  import CSL.ASUtils
  import CSL.Sign as Sign
  
  import qualified Data.Set as Set
  import qualified Data.Map as Map
  import Data.Maybe
  
  -- * Dependency Graph datatype for various algorithms on Dependency Graphs
  
  data DepGraph a b c = DepGraph
      { dataMap :: Map.Map a
                   ( b         -- the annotation
                   , Set.Set a -- the direct successors (smaller elements)
                   , Set.Set c -- the direct predecessors (bigger elements)
                   )
      {- function returning for a given element and value the predecessors
      of this element -}
      , getPredecessors :: a -> b -> [c]
      {- function returning for a given element and value the predecessors
      of this element -}
      , getKey :: c -> a
      }
  
  instance (Show a, Show b, Show c) => Show (DepGraph a b c) where
      show = show . dataMap
  
  depGraphLookup :: Ord a =>
                    DepGraph a b c -> a -> Maybe (b, Set.Set a, Set.Set c)
  depGraphLookup gr x = Map.lookup x $ dataMap gr
  
  prettyDepGraph :: (a -> Doc) -> (b -> Doc) -> (c -> Doc) -> DepGraph a b c
                 -> Doc
  prettyDepGraph pa pb pc gr =
      ppMap pa pf ((text "DepGraph" <+>) . braces) vcat f $ dataMap gr where
          f a b = a <> text ":" <+> b
          pf (v, dss, dps) =
              ps pa dss <+> text " << x << " <+> ps pc dps <> text ":" <+> pb v
          ps g = braces . (sepByCommas . map g) . Set.toList
  
  
  instance (Pretty a, Pretty b, Pretty c) => Pretty (DepGraph a b c) where
      pretty = prettyDepGraph pretty pretty pretty
  
  
  emptyDepGraph :: (a -> b -> [c]) -> (c -> a) -> DepGraph a b c
  emptyDepGraph f pf = DepGraph { dataMap = Map.empty, getPredecessors = f
                                , getKey = pf }
  
  
  {- TODO: merge the type Rel2 and DepGraph in order to work only on the
  new type, and implement a construction of this graph from a list
  without the necessity to order the elements first. -}
  
  {- | It is important to have the elements given in an order with
  biggest elements first (elements which depend on nothing) -}
  depGraphFromDescList :: (Ord a, Ord c) => (a -> b -> [c]) ->
                          (c -> a) -> [(a, b)] -> DepGraph a b c
  depGraphFromDescList f pf = foldl g (emptyDepGraph f pf) where
      g x (y, z) = updateGraph x y z
  
  maybeSetUnions :: Ord a => Set.Set (Maybe (Set.Set a)) -> Set.Set a
  maybeSetUnions = Set.fold f Set.empty where
      f mS s' = maybe s' (Set.union s') mS
  
  upperLevel :: (Ord a, Ord c) => DepGraph a b c -> Set.Set a -> Set.Set c
  upperLevel gr = maybeSetUnions . Set.map f where
      f a = fmap g $ Map.lookup a $ dataMap gr
      g (_, _, dps) = dps
  
  lowerLevel :: Ord a => DepGraph a b c -> [a] -> Set.Set a
  lowerLevel gr = Set.unions . mapMaybe f where
      f a = fmap g $ Map.lookup a $ dataMap gr
      g (_, dss, _) = dss
  
  
  setFilterLookup :: (Ord a, Ord b, Ord d, Show a) =>
                     (d -> a) -- ^ projection function
                  -> (a -> b -> Bool) -- ^ filter predicate
                  -> DepGraph a b c -- ^ dependency graph for lookup
                  -> Set.Set d -- ^ filter this set
                  -> Set.Set (d, b)
  setFilterLookup pf fp gr s = Set.map h $ Set.filter g $ Set.map f s where
      f x = (x, fmap ( \ (v, _, _) -> v ) $ Map.lookup (pf x) $ dataMap gr)
      g (x, Just val) = fp (pf x) val
      g _ = False
      h (x, Just val) = (x, val)
      h _ = error "setFilterLookup: Impossible case"
  
  
  lowerUntil :: (Pretty a, Ord a, Ord b, Show a) =>
                (a -> b -> Bool) -- ^ cut-off predicate
             -> DepGraph a b c -- ^ dependency graph to be traversed
             -> [a] -- ^ compare entries to this element
             -> Set.Set (a, b)
  lowerUntil _ _ [] = Set.empty
  lowerUntil cop gr al =
      let s = lowerLevel gr al
          cop' x = not . cop x
          s' = setFilterLookup id cop' gr s
          s'' = lowerUntil cop gr $ map fst $ Set.toList s'
      in Set.union s' s''
  
  upperUntil :: (Ord a, Ord b, Ord c, Show a) =>
                (a -> b -> Bool) -- ^ cut-off predicate
             -> DepGraph a b c -- ^ dependency graph to be traversed
             -> Set.Set a -- ^ compare entries to these elements
             -> Set.Set (c, b)
  upperUntil cop gr es
      | Set.null es = Set.empty
      | otherwise =
          let s = upperLevel gr es
              cop' x = not . cop x
              s' = setFilterLookup (getKey gr) cop' gr s
              s'' = upperUntil cop gr $ Set.map (getKey gr . fst) s'
          in Set.union s' s''
  
  -- | Reflexive version of 'upperUntil'
  upperUntilRefl :: (Ord a, Ord b, Show a) =>
                    (a -> b -> Bool) -- ^ cut-off predicate
                 -> DepGraph a b a -- ^ dependency graph to be traversed
                 -> Set.Set a -- ^ compare entries to these elements
                 -> Set.Set (a, b)
  upperUntilRefl cop gr es
      | Set.null es = Set.empty
      | otherwise =
          Set.union (setFilterLookup (getKey gr) (const $ const True) gr es)
                 $ upperUntil cop gr es
  
  
  {- | Updates the depgraph at the given key with the update function.
  The dependencies are NOT recomputed. No new elements are added to the graph. -}
  updateValue :: Ord a => DepGraph a b c -> (b -> b) -> a -> DepGraph a b c
  updateValue gr uf key = gr { dataMap = Map.adjust uf' key $ dataMap gr } where
      uf' (x, y, z) = (uf x, y, z)
  
  
  {- | Updates the depgraph at the given key with the new value.
  The dependencies are recomputed. If the key does not exist in the graph
  it is added to the graph. -}
  updateGraph :: (Ord a, Ord c) => DepGraph a b c -> a -> b -> DepGraph a b c
  updateGraph gr key val =
      -- update the pred-set of all smaller entries
      let (mOv, nm) = Map.insertLookupWithKey f key nval $ dataMap gr
          npl = getPredecessors gr key val
          nval = (val, Set.empty, Set.fromList npl)
          f _ (v', _, nps) (_, oss, _) = (v', oss, nps)
          nm' = case mOv of
                  Just (_, _, ops) ->
                      Set.fold rmFromSucc nm ops
                  _ -> nm
          rmFromSucc c = Map.adjust g1 (getKey gr c)
          g1 (x, dss, dps) = (x, Set.delete key dss, dps)
          nm'' = foldl insSucc nm' npl
          insSucc m c = Map.adjust g2 (getKey gr c) m
          g2 (x, dss, dps) = (x, Set.insert key dss, dps)
      in gr { dataMap = nm'' }
  
  data DepGraphAnno a = DepGraphAnno
      { annoDef :: AssDefinition
      , annoVal :: a } deriving (Show, Eq, Ord)
  
  instance Pretty a => Pretty (DepGraphAnno a) where
      pretty (DepGraphAnno { annoDef = def, annoVal = av }) =
          braces $ pretty def <> text ":" <+> pretty av
  
  type AssignmentDepGraph a =
      DepGraph ConstantName (DepGraphAnno a) ConstantName
  
  assDepGraphFromDescList :: (ConstantName -> AssDefinition -> a)
                          -> [(ConstantName, AssDefinition)]
                          -> AssignmentDepGraph a
  assDepGraphFromDescList f l = depGraphFromDescList getPs id $ map g l where
      g (cn, ad) = (cn, DepGraphAnno { annoDef = ad, annoVal = f cn ad })
      getPs _ = map SimpleConstant . Set.toList . setOfUserDefined . getDefiniens
                . annoDef
  