content: module DDC.Core.Flow.Transform.Rates.Clusters.Greedy
      (cluster_greedy)
  where
  import DDC.Core.Flow.Transform.Rates.Graph
  import DDC.Core.Flow.Transform.Rates.Clusters.Base
  
  cluster_greedy 
          :: (Ord n, Eq t) 
          => Graph n t -> TransducerMap n -> [[n]]
  cluster_greedy g trans
   -- First find a greedy vertical clustering, then merge any leftover horizontal opportunities
   --
   -- The clusters are built in reverse order, so fix them up.
   = reverse
   $ map reverse
   $ fuse_rest vertical
   where
    -- Vertical fusion.
    -- Go through the graph in topo order, inserting each node into a cluster
    vertical
     = foldl go_vertical []
     $ graphTopoOrder g
  
    -- Insert node n into the clusters ns
    go_vertical ns n
           -- Find the parent we'd like to fuse n into. It has to be a fusible edge.
     = let parent = [ n' | (n',fusible) <- nodeInEdges g n, fusible]
           -- The default unfused clustering to use if we can't merge n into parent
           unfused  = [n] : ns
       in  case parent of
            -- There is no parent (that is fusible)
            []
             -> unfused
            -- Check that n and n' are the same type (can be fused).
            (n':_)
             | tcmp n n'
             -> case insert n n' ns of
                 Just ns' -> ns'
                 Nothing  -> unfused
             | otherwise
             -> unfused
  
    -- Try to insert n into the same cluster as n'.
    -- If n relies on output of clusters after n' (before in cs - list is reversed), we cannot put
    -- n in the n' cluster.
    -- Also check that there are no fusion-preventing paths between cluster and n.
  
    -- We haven't seen n' yet and we're at the end, so can't put n into same cluster as n'
    insert _n _n' []
     = Nothing
  
    insert n n' (c:cs) 
     -- We've reached n' cluster.
     -- If there are no fusion-preventing edges between n and these nodes, we can fuse.
     | n' `elem` c
     = if   any (not . checkPath n) c
       then Nothing
       else Just ((n:c) : cs)
  
     -- If n relies on any of these nodes and we haven't reached n',
     -- we won't be able to merge n with n'
     -- (because it would not be able to execute without result of these nodes)
     | any (edge n) c
     = Nothing
  
     | otherwise
     = do cs' <- insert n n' cs
          return (c : cs')
  
  
    -- Do any leftover horizontal fusion that we can
    fuse_rest [] = []
    fuse_rest (c:cs)
     = case try_merge c cs of
        Nothing
         -> c : fuse_rest cs
        Just cs'
         -> fuse_rest cs'
  
    -- Nothing to merge s with
    try_merge _ []
     = Nothing
  
    try_merge s (c:cs)
     -- Can s and c be merged together?
     | miscible s c
     = if   all (\a -> all (checkPath a) s) c
       then Just ((s ++ c) : cs)
       else Nothing
  
     -- s and c can't be merged together, but we can't move s any further back
     | any (\a -> any (edge a) s) c
     = Nothing
  
     | otherwise
     = do cs' <- try_merge s cs
          return (c : cs')
  
  
    -- Helper functions
    edge a b = hasEdge g (a,b) || hasEdge g (b,a)
  
    checkPath = noFusionPreventingPath arcs
    arcs = snd $ listOfGraph g
  
    tcmp = typeComparable g trans
  
    -- Check if two clusters can be merged together
    miscible s c
     = let sc = s ++ c
           -- For each a in c and b in s
       in  all (\a -> all (\b ->
             -- If a and b have same type, they can be merged fine
             case (nodeType g a, nodeType g b) of
                  (Just ta, Just tb)
                   -> if   ta == tb
                      then True
                      -- If they have different types, but share parent transducers,
                      -- they can only be merged if they are merged with both parents.
                      else case trans a b of
                       Just (a',b')  -> a' `elem` sc && b' `elem` sc
                       Nothing       -> False
                  _
                    -> False
              ) s) c
  
  