github.com/pf-qiu/concourse/v6@v6.7.3-0.20201207032516-1f455d73275f/web/elm/src/TopologicalSort.elm (about)

     1  module TopologicalSort exposing (Digraph, flattenToLayers, tsort)
     2  
     3  import List.Extra exposing (find)
     4  
     5  
     6  
     7  -- we use Tarjan's Algorithm
     8  -- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm
     9  
    10  
    11  type alias Digraph a =
    12      List ( a, List a )
    13  
    14  
    15  type alias InternalState a =
    16      { index : Int
    17      , stack : List a
    18      , indices : a -> Maybe Int
    19      , lowlinks : a -> Int
    20      , sccs : List (List a)
    21      }
    22  
    23  
    24  tsort : Digraph a -> List (List a)
    25  tsort graph =
    26      let
    27          strongconnect : InternalState a -> ( a, List a ) -> InternalState a
    28          strongconnect { index, stack, indices, lowlinks, sccs } ( v, children ) =
    29              let
    30                  newState : InternalState a
    31                  newState =
    32                      { index = index + 1
    33                      , stack = v :: stack
    34                      , indices = extendFun indices v (Just index)
    35                      , lowlinks = extendFun lowlinks v index
    36                      , sccs = sccs
    37                      }
    38  
    39                  foldConnect : a -> InternalState a -> InternalState a
    40                  foldConnect w state =
    41                      case state.indices w of
    42                          Nothing ->
    43                              let
    44                                  newState2 =
    45                                      strongconnect state ( w, getChildren graph w )
    46  
    47                                  newVLowlink : Int
    48                                  newVLowlink =
    49                                      min (newState2.lowlinks v) (newState2.lowlinks w)
    50                              in
    51                              { newState2 | lowlinks = extendFun newState2.lowlinks v newVLowlink }
    52  
    53                          Just wIndex ->
    54                              if List.member w state.stack then
    55                                  let
    56                                      newVLowlink : Int
    57                                      newVLowlink =
    58                                          min (state.lowlinks v) wIndex
    59                                  in
    60                                  { state | lowlinks = extendFun state.lowlinks v newVLowlink }
    61  
    62                              else
    63                                  state
    64  
    65                  newerState =
    66                      List.foldr foldConnect newState children
    67              in
    68              if Just (newerState.lowlinks v) == newerState.indices v then
    69                  let
    70                      ( component, newStack ) =
    71                          takeUpTo v newerState.stack
    72                  in
    73                  { newerState | stack = newStack, sccs = newerState.sccs ++ [ component ] }
    74  
    75              else
    76                  newerState
    77  
    78          foldGraph : ( a, List a ) -> InternalState a -> InternalState a
    79          foldGraph ( v, children ) state =
    80              if state.indices v == Nothing then
    81                  strongconnect state ( v, children )
    82  
    83              else
    84                  state
    85  
    86          initialState : InternalState a
    87          initialState =
    88              { index = 0
    89              , stack = []
    90              , indices = always Nothing
    91              , lowlinks = always 1000000
    92              , sccs = []
    93              }
    94      in
    95      (List.foldr foldGraph initialState graph).sccs
    96  
    97  
    98  
    99  -- we now need to flatten the strongly-connected components into "layers", which should be much easier now that there are no loops
   100  
   101  
   102  flattenToLayers : Digraph a -> List (List a)
   103  flattenToLayers graph =
   104      let
   105          depths : a -> Maybe Int
   106          depths =
   107              flattenToLayers_ graph (tsort graph) (always Nothing)
   108      in
   109      flattenMap (List.map Tuple.first graph) depths 0
   110  
   111  
   112  flattenToLayers_ : Digraph a -> List (List a) -> (a -> Maybe Int) -> (a -> Maybe Int)
   113  flattenToLayers_ graph stronglyConnectedComponents depths =
   114      case stronglyConnectedComponents of
   115          [] ->
   116              depths
   117  
   118          scc :: sccs ->
   119              let
   120                  children : List a
   121                  children =
   122                      scc
   123                          |> List.concatMap (getChildren graph)
   124                          |> List.filter (\x -> not (List.member x scc))
   125  
   126                  childDepths : Maybe (List Int)
   127                  childDepths =
   128                      List.map depths children
   129                          |> allDefined
   130              in
   131              case childDepths of
   132                  Nothing ->
   133                      -- "same size" recursion is safe here, because the tsort ensures we should never hit this case
   134                      -- (even if they weren't in order, we should always have at least one scc that depends only on previously covered sccs)
   135                      flattenToLayers_ graph (sccs ++ [ scc ]) depths
   136  
   137                  Just cds ->
   138                      let
   139                          depth : Maybe Int
   140                          depth =
   141                              cds
   142                                  |> List.maximum
   143                                  |> Maybe.map ((+) 1)
   144                                  |> Maybe.withDefault 0
   145                                  |> Just
   146                      in
   147                      flattenToLayers_ graph sccs (extendFunMany depths scc depth)
   148  
   149  
   150  
   151  -- helper functions
   152  
   153  
   154  extendFun : (a -> b) -> a -> b -> (a -> b)
   155  extendFun f a b =
   156      \x ->
   157          if x == a then
   158              b
   159  
   160          else
   161              f x
   162  
   163  
   164  extendFunMany : (a -> b) -> List a -> b -> (a -> b)
   165  extendFunMany f xs b =
   166      \x ->
   167          if List.member x xs then
   168              b
   169  
   170          else
   171              f x
   172  
   173  
   174  getChildren : Digraph a -> a -> List a
   175  getChildren graph v =
   176      case find (\( n, _ ) -> n == v) graph of
   177          Just ( _, children ) ->
   178              children
   179  
   180          Nothing ->
   181              -- impossible - each node should have an entry in the children list
   182              []
   183  
   184  
   185  takeUpTo : a -> List a -> ( List a, List a )
   186  takeUpTo t ts =
   187      case ts of
   188          [] ->
   189              ( [], [] )
   190  
   191          x :: xs ->
   192              if t == x then
   193                  ( [ x ], xs )
   194  
   195              else
   196                  let
   197                      ( init, end ) =
   198                          takeUpTo t xs
   199                  in
   200                  ( x :: init, end )
   201  
   202  
   203  allDefined : List (Maybe a) -> Maybe (List a)
   204  allDefined xs =
   205      case xs of
   206          [] ->
   207              Just []
   208  
   209          Nothing :: _ ->
   210              Nothing
   211  
   212          (Just a) :: ys ->
   213              case allDefined ys of
   214                  Nothing ->
   215                      Nothing
   216  
   217                  Just zs ->
   218                      Just (a :: zs)
   219  
   220  
   221  
   222  -- this assumes that every member of xs is in the domain of f
   223  -- For our usecase (flattenToLayers of a tsorted graph) this will be true
   224  
   225  
   226  flattenMap : List a -> (a -> Maybe Int) -> Int -> List (List a)
   227  flattenMap xs f n =
   228      if xs == [] then
   229          []
   230  
   231      else
   232          List.filter (\x -> f x == Just n) xs :: flattenMap (List.filter (\x -> f x /= Just n) xs) f (n + 1)