feedbackarcset.hs

Cores are generated from Confluence a modern logic design language. Confluence is a simple, yet high

-- | Heuristic optimizations for the Feedback Arc (Edge) Set problem.
--
--   Scheduling global, linear, fixed priority rules is equivalent to
--   minimizing the number of edges to remove to for a acyclic rule data dependency graph.

module Language.Atom.FeedbackArcSet
  ( optimize
  , Edge      (..)
  ) where

import Data.List
import qualified Data.Set as Set
import System.Cmd
import System.IO
import System.Random

-- | An 'Edge' connects an upstream and downstream vertix pair.
data Edge a
  = Soft a a   -- ^ A soft edge constraint may be removed from the scheduling graph.
  | Hard a a   -- ^ A hard edge constraint must not be removed from the graph.
  deriving (Show, Eq, Ord) 

-- | Optimizes the vertice order by minimizing the
--   number of soft edges removed to form an acyclic graph.
optimize :: (Show a, Ord a) => String -> Set.Set a -> Set.Set (Edge a) -> IO (Either (Set.Set a) ([a],String))
optimize name vertices edges' = do
  putStr "Attempting to satisfy hard constraints..."
  hFlush stdout
  if not $ Set.null remaining
    then do
      putStrLn "failed"
      return $ Left remaining
    else do
      putStrLn "success"
      finalOrder <- annealing hardEdges softEdges initOrder
      writeFile (name ++ ".dot") (dot name finalOrder edges')
      system $ "dot -o " ++ name ++ ".png  -Tpng " ++ name ++ ".dot"
      return $ Right (finalOrder, doc finalOrder softEdges)
  where

  edges'' = Set.filter isNotLoopback edges'
  acyclicEdges = Set.filter (not . isCyclic edges'') edges''
  edges = Set.union edges'' $ Set.map obviousHardEdge acyclicEdges

  isNotLoopback (Hard a b) | a == b = False
  isNotLoopback (Soft a b) | a == b = False
  isNotLoopback _ = True

  obviousHardEdge (Soft a b) = Hard a b
  obviousHardEdge (Hard a b) = Hard a b

  hardVertices = Set.fold addHard Set.empty edges
  addHard (Hard a b) s = Set.insert a $ Set.insert b s
  addHard _ s = s

  softVertices = vertices Set.\\ hardVertices

  hardEdges = Set.map extractVertices $ Set.filter isHard edges
  softEdges = Set.filter isNotRelatedToHardEdge $ Set.map extractVertices $ Set.filter (not . isHard) edges
  isHard (Hard _ _) = True
  isHard (Soft _ _) = False
  extractVertices (Hard a b) = (a,b)
  extractVertices (Soft a b) = (a,b)
  isNotRelatedToHardEdge (a,b) = not $ Set.member (a,b) hardEdges || Set.member (b,a) hardEdges

  hardRoots = Set.fold removeHard hardVertices hardEdges
  removeHard (_, a) s = Set.delete a s

  hardUpstreams v = Set.map fst $ Set.filter (\ (_,b) -> v == b) hardEdges

  (remaining, _, hardOrder) = topo (hardVertices Set.\\ hardRoots, hardRoots, [hardRoots])

  topo (remaining, computed, order) =
    if Set.null next
      then (remaining, computed, reverse order)
      else topo (remaining Set.\\ next, Set.union computed next, next : order)
    where
    next = Set.filter (\ v -> Set.isSubsetOf (hardUpstreams v) computed) remaining

  initOrder = concatMap Set.toList hardOrder ++ Set.toList softVertices

cost :: Ord a => Set.Set (a,a) -> [a] -> Int
cost softEdges vertices = c
  where
  (c,_) = foldl f (0,[]) vertices
  f (cost,higher) vertex = (foldl f' cost higher, vertex:higher)
    where
    f' cost vertexHigher | Set.member (vertex, vertexHigher) softEdges = cost + 1
    f' cost _ = cost

mutate :: Ord a => Set.Set (a,a) -> Int -> [a] -> Maybe [a]
mutate hardEdges index vertices = case splitAt index vertices of
  (a, b0:b1:b2) | not (Set.member (b0,b1) hardEdges) -> Just $ a ++ (b1:b0:b2)
  _ -> Nothing

annealing :: Ord a => Set.Set (a,a) -> Set.Set (a,a) -> [a] -> IO [a]
annealing hardEdges softEdges initOrder = do
  putStrLn "Starting vertex order optimization..."
  hFlush stdout
  putStrLn $ "  iteration 0 cost: " ++ show initCost
  hFlush stdout
  (order, cost) <- if initCost == 0 then return init else iterate 1 random init init
  putStrLn $ "  final cost: " ++ show cost
  hFlush stdout
  return order
  where
  random :: [Int]
  random = randomRs (0, length initOrder - 2) (mkStdGen 0)
  initCost = cost softEdges initOrder
  init = (initOrder,initCost)
  totalIterations = 20

  iterate count _ _ best | count >= totalIterations = return best
  iterate count index (currOrder, _) (bestOrder,bestCost) = do
    putStrLn $ "  iteration " ++ show count ++ " cost: " ++ show cost'
    hFlush stdout
    if cost' == 0
      then return (order', cost')
      else iterate (count + 1) (tail index) (order',cost') (if cost' < bestCost then (order', cost') else (bestOrder, bestCost))
    where
    order' = case mutate hardEdges (head index) currOrder of
      Nothing -> currOrder
      Just v  -> v
    cost' = cost softEdges order' 
    
doc :: Show a => [a] -> Set.Set (a,a) -> String
doc order _ = unlines names
  where
  names' = map show order
  maxLength = maximum $ map length names'
  names = map (\n -> n ++ replicate (maxLength - length n) ' ') names'

dot :: (Show a, Eq a) => String -> [a] -> Set.Set (Edge a) -> String
dot name order edges = unlines
  [ "digraph " ++ name ++ " {"
  , concatMap (\ (a,i) -> "  \"" ++ show a ++ "\" [label=\"" ++ show a ++ " (" ++ show i ++ ")\"];\n") $ zip order [0..]
  -- , concatMap (\ n     -> "  " ++ show (n - 1) ++ " -> " ++ show n ++ ";\n") [1 .. length order - 1]
  -- , concatMap (\ (a,b) -> "  " ++ show a ++ " -> " ++ show b ++ " [weight=100, color=white];\n") $ zip order (tail order)
  , concatMap dotEdge $ Set.toList edges
  , "}"
  ]
  where

  --dotEdge :: (Show a, Eq a) => Edge a -> String
  dotEdge (Hard a b)                     = "  \"" ++ show a ++ "\" -> \"" ++ show b ++ "\" [color=blue];\n"
  dotEdge (Soft a b) | index a < index b = "  \"" ++ show a ++ "\" -> \"" ++ show b ++ "\" [color=gray];\n"
  dotEdge (Soft a b)                     = "  \"" ++ show a ++ "\" -> \"" ++ show b ++ "\" [color=red];\n"

  index a = case elemIndex a order of
    Nothing -> error "Vertex not found."
    Just i -> i

isCyclic :: (Eq a, Ord a) => Set.Set (Edge a) -> Edge a -> Bool
isCyclic edges edge = Set.member a reachableFromB
  where
  (a,b) = case edge of
    Hard a b -> (a,b)
    Soft a b -> (a,b)
  reachableFromB = fixpoint $ Set.singleton b
  fixpoint a = if a == b then a else fixpoint b where b = nextSet a
  nextSet a = Set.fold (\ a b -> Set.union b $ next a) a a
  next v = Set.map next' $ Set.filter isV edges
    where
    isV (Soft a _) = a == v
    isV (Hard a _) = a == v
    next' (Soft _ b) = b
    next' (Hard _ b) = b