module Graphs.TopSort(
   topSort, -- :: Ord a => [(a,a)] -> [a]
   topSort1, -- :: Ord a => [(a,a)] -> [a] -> [a]
   ) where

import qualified Data.Map as Map

-- Based on the Art of Computer Programming
-- Chapter 1, 2.2.3.
data Ord a => TopSortState a = TopSortState {
   TopSortState a -> [a]
soFar :: [a],
   -- Elements so far added to the list.
   TopSortState a -> [a]
maximal :: [a],
   -- All elements with no remaining greater elements.
   -- When this is empty, soFar is the correct solution.
   TopSortState a -> Map a (Int, [a])
remaining :: Map.Map a (Int,[a])
   -- Map giving for each element
   -- (a) successors not yet added to soFar.
   -- (b) its direct predecessors.
   }

topSort :: Ord a => [(a,a)] -> [a]
topSort :: [(a, a)] -> [a]
topSort [(a, a)]
relations = [(a, a)] -> [a] -> [a]
forall a. Ord a => [(a, a)] -> [a] -> [a]
topSort1 [(a, a)]
relations []

topSort1 :: Ord a => [(a,a)] -> [a] -> [a]
topSort1 :: [(a, a)] -> [a] -> [a]
topSort1 [(a, a)]
relations [a]
nodes =
   let
      topSortState0 :: TopSortState a
topSortState0 = [(a, a)] -> TopSortState a
forall a. Ord a => [(a, a)] -> TopSortState a
initialise [(a, a)]
relations
      topSortState1 :: TopSortState a
topSortState1 = TopSortState a -> [a] -> TopSortState a
forall a. Ord a => TopSortState a -> [a] -> TopSortState a
ensureNodes TopSortState a
topSortState0 [a]
nodes

      doWork :: TopSortState a -> [a]
doWork TopSortState a
topSortState0 =
         case TopSortState a -> Either [a] (TopSortState a)
forall a. Ord a => TopSortState a -> Either [a] (TopSortState a)
oneStep TopSortState a
topSortState0 of
            Left [a]
result -> [a]
result
            Right TopSortState a
topSortState1 -> TopSortState a -> [a]
doWork TopSortState a
topSortState1
   in
      TopSortState a -> [a]
forall a. Ord a => TopSortState a -> [a]
doWork TopSortState a
topSortState1

ensureNodes :: Ord a => TopSortState a -> [a] -> TopSortState a
ensureNodes :: TopSortState a -> [a] -> TopSortState a
ensureNodes = (TopSortState a -> a -> TopSortState a)
-> TopSortState a -> [a] -> TopSortState a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TopSortState a -> a -> TopSortState a
forall a. Ord a => TopSortState a -> a -> TopSortState a
ensureNode

ensureNode :: Ord a => TopSortState a -> a -> TopSortState a
ensureNode :: TopSortState a -> a -> TopSortState a
ensureNode
   (state :: TopSortState a
state @ (
      TopSortState {soFar :: forall a. Ord a => TopSortState a -> [a]
soFar = [a]
soFar,maximal :: forall a. Ord a => TopSortState a -> [a]
maximal = [a]
maximal,remaining :: forall a. Ord a => TopSortState a -> Map a (Int, [a])
remaining = Map a (Int, [a])
remaining}))
   a
node =

   case a -> Map a (Int, [a]) -> Maybe (Int, [a])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
node Map a (Int, [a])
remaining of
      Maybe (Int, [a])
Nothing -> -- node not mentioned.  Add it to soFar
         TopSortState a
state {soFar :: [a]
soFar = a
node a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
soFar}
      Just (Int, [a])
_ -> TopSortState a
state

initialise :: Ord a => [(a,a)] -> TopSortState a
initialise :: [(a, a)] -> TopSortState a
initialise [(a, a)]
list =
   let
      soFar :: [a]
soFar = []
      map :: Map a (Int, [a])
map = ((a, a) -> Map a (Int, [a]) -> Map a (Int, [a]))
-> Map a (Int, [a]) -> [(a, a)] -> Map a (Int, [a])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
         (\ (a
from,a
to) Map a (Int, [a])
map ->
            let
               (Int
nFromSuccs,[a]
fromPredecessors) =
                  (Int, [a]) -> a -> Map a (Int, [a]) -> (Int, [a])
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Int
0,[]) a
from Map a (Int, [a])
map
               map2 :: Map a (Int, [a])
map2 = a -> (Int, [a]) -> Map a (Int, [a]) -> Map a (Int, [a])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
from (Int
nFromSuccsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,[a]
fromPredecessors) Map a (Int, [a])
map
               (Int
nToSuccs,[a]
toPredecessors) =
                  (Int, [a]) -> a -> Map a (Int, [a]) -> (Int, [a])
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Int
0,[]) a
to Map a (Int, [a])
map2
               map3 :: Map a (Int, [a])
map3 = a -> (Int, [a]) -> Map a (Int, [a]) -> Map a (Int, [a])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
to (Int
nToSuccs,a
froma -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
toPredecessors) Map a (Int, [a])
map2
            in
               Map a (Int, [a])
map3
            )
         Map a (Int, [a])
forall k a. Map k a
Map.empty
         [(a, a)]
list
      mapEls :: [(a, (Int, [a]))]
mapEls =  Map a (Int, [a]) -> [(a, (Int, [a]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map a (Int, [a])
map
      maximal :: [a]
maximal = [ a
key | (a
key,(Int
nSuccs,[a]
_)) <- [(a, (Int, [a]))]
mapEls, Int
nSuccs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 ]
   in
      TopSortState :: forall a. [a] -> [a] -> Map a (Int, [a]) -> TopSortState a
TopSortState { soFar :: [a]
soFar = [a]
forall a. [a]
soFar, remaining :: Map a (Int, [a])
remaining = Map a (Int, [a])
map, maximal :: [a]
maximal = [a]
maximal }

oneStep :: Ord a => TopSortState a -> Either [a] (TopSortState a)
oneStep :: TopSortState a -> Either [a] (TopSortState a)
oneStep(TopSortState { soFar :: forall a. Ord a => TopSortState a -> [a]
soFar = [a]
soFar, remaining :: forall a. Ord a => TopSortState a -> Map a (Int, [a])
remaining = Map a (Int, [a])
map, maximal :: forall a. Ord a => TopSortState a -> [a]
maximal = [a]
maximal }) =
   case [a]
maximal of
      [] ->
         if Map a (Int, [a]) -> Bool
forall k a. Map k a -> Bool
Map.null Map a (Int, [a])
map
            then [a] -> Either [a] (TopSortState a)
forall a b. a -> Either a b
Left [a]
soFar
            else [Char] -> Either [a] (TopSortState a)
forall a. HasCallStack => [Char] -> a
error [Char]
"TopSort - cycle in data"
      a
next:[a]
newMaximal ->
         let
            Just (Int
0,[a]
nextPredecessors) = a -> Map a (Int, [a]) -> Maybe (Int, [a])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
next Map a (Int, [a])
map
            newSoFar :: [a]
newSoFar = a
nexta -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
soFar
            ([a]
newMaximal2,Map a (Int, [a])
newMap) =
               (a -> ([a], Map a (Int, [a])) -> ([a], Map a (Int, [a])))
-> ([a], Map a (Int, [a])) -> [a] -> ([a], Map a (Int, [a]))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                  (\ a
pred ([a]
maximal,Map a (Int, [a])
map) ->
                     let
                        Just (Int
nPredSuccs,[a]
predPredecessors) = a -> Map a (Int, [a]) -> Maybe (Int, [a])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
pred Map a (Int, [a])
map
                        newNPredSuccs :: Int
newNPredSuccs = Int
nPredSuccsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
                        newMap :: Map a (Int, [a])
newMap = a -> (Int, [a]) -> Map a (Int, [a]) -> Map a (Int, [a])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
pred
                           (Int
newNPredSuccs,[a]
predPredecessors) Map a (Int, [a])
map
                        newMaximal :: [a]
newMaximal = if Int
newNPredSuccs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                           then
                              (a
preda -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
maximal)
                           else
                              [a]
maximal
                     in
                        ([a]
newMaximal,Map a (Int, [a])
newMap)
                     )
                  ([a]
newMaximal,Map a (Int, [a])
map)
                  [a]
nextPredecessors
            newMap2 :: Map a (Int, [a])
newMap2 = a -> Map a (Int, [a]) -> Map a (Int, [a])
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
next Map a (Int, [a])
newMap
         in
            TopSortState a -> Either [a] (TopSortState a)
forall a b. b -> Either a b
Right(TopSortState :: forall a. [a] -> [a] -> Map a (Int, [a]) -> TopSortState a
TopSortState {
               soFar :: [a]
soFar = [a]
newSoFar,maximal :: [a]
maximal = [a]
newMaximal2,remaining :: Map a (Int, [a])
remaining = Map a (Int, [a])
newMap2
               })