   ### 15.4.878  src/lib/src/digraph-strongly-connected-components-g.pkg

`## digraph-strongly-connected-components-g.pkg`
`## author: Matthias Blume`

`# Compiled by:`
`#     `src/lib/std/standard.lib

`#   Calculate the strongly-connected components (SCC)`
`#   of a directed graph.`
`#`
`#   The graph can have nodes with self-loops.`
`#`
`#`
`# See also:`
`#`
`#     `src/lib/graph/graph-strongly-connected-components.pkg

`###             "My mother said that anyone learning to cook`
`###              needed a large dog to eat the mistakes.`
`###`
`###              As a sculptor of wood`
`###              I have always tried to keep a fireplace."`
`###`
`###                          -- Norman Ridenour`

`generic package  digraph_strongly_connected_components_g  (nd: Key)                     # Key                                   is from   `src/lib/src/key.api
`:                Digraph_Strongly_Connected_Components                                  # Digraph_Strongly_Connected_Components is from   `src/lib/src/digraph-strongly-connected-components.api
`    where nd == nd`
`{`
`    package nd = nd;`

`    Node = nd::Key;`

`    package map =   red_black_map_g( nd );                                              # red_black_map_g                       is from   `src/lib/src/red-black-map-g.pkg

`    Component`
`      =  SIMPLE          Node`
`      ``|  RECURSIVE  List(Node)`
`      ;`

`    fun eq x y`
`        =`
`        (nd::compare( x, y ) == EQUAL);`

`    fun topological_order' { roots, follow }`
`        =`
`        {   fun get_node (n, nm as (npre, m))`
`                =`
`                case (map::get (m, n))`
`                  `
`                     THE r => (nm, r);`

`                     NULL  => {`
`                                   r = {   pre => npre,   low => REF npre };`

`                                   m' = map::set (m, n, r);`

`                                    ((npre + 1, m'), r);`
`                              };`
`                esac;`

`            fun component (x, [])`
`                    =>`
`                    if   (list::exists (eq x) (follow x)   )   RECURSIVE [x];`
`                                                          else   SIMPLE x;  fi;`
`                component (x, xl)`
`                    =>`
`                    RECURSIVE (x ! xl);`
`            end;`

`            #  Depth-first search in fate-passing, state-passing style:`
`            #`
`            fun dfs args`
`                =`
`                loop (reverse follow_nodes) (nodemap, stack, sccl)`
`                where`
`                    # The nodemap represents the mapping from`
`                    # nodes to pre-order numbers and low-numbers.`
`                    #`
`                    # The latter are ref-cells.`
`                    #`
`                    # The nodemap also remembers the next`
`                    # available pre-order number.`
`                    #`
`                    # The current node itself is not given as an argument.`
`                    #`
`                    # Instead, it is represented by grab_fate,`
`                    # a function that "grabs" a component from`
`                    # the current stack and then continues with`
`                    # the regular fate.`
`                    #`
`                    # We do it this way to be able to handle`
`                    # the topmost virtual component -- the one`
`                    # whose sole element is the virtual root node.`
`                    #`
`                    my {   follow_nodes,`
`                            grab_fate,`
`                            node_pre,`
`                            node_low,`
`                            parent_low,`
`                            nodemap,`
`                            stack,`
`                            sccl,`
`                            nograb_fate   }   =   args;`

`                    #  Loop over the follow-set of a node:`
`                    #`
`                    fun loop (tn ! tnl) (nodemap as (npre, the_map), stack, sccl)`
`                            =>`
`                            {   is_tn = eq tn;`

`                                case (map::get (the_map, tn))`
`                                   `
`                                     THE {   pre => tn_pre,   low => tn_low   }`
`                                         =>`
`                                         {`
`                                             tl = *tn_low;`

`                                             if   (tl  <  *node_low`
`                                             and  list::exists  is_tn  stack)`

`                                                  node_low := tl;`
`                                             fi;`

`                                             loop tnl (nodemap, stack, sccl);`
`                                         };`

`                                     NULL`
`                                         =>`
`                                         {`
`                                             #  Lookup failed -> tn is a new node `
`                                             tn_pre = npre;`
`                                             tn_low = REF npre;`
`                                             npre = npre + 1;`
`                                             the_map = map::set (the_map, tn, { pre => tn_pre, low => tn_low } );`
`                                             nodemap = (npre, the_map);`
`                                             tn_nograb_fate = loop tnl;`

`                                             fun tn_grab_fate (nodemap, sccl)`
`                                                 =`
`                                                 { fun grab (top ! stack, scc)`
`                                                         =>`
`                                                         if   (eq tn top)`

`                                                              tn_nograb_fate`
`                                                                 (nodemap, stack,`
`                                                                  component (top, scc) ! sccl);`
`                                                         else`
`                                                              grab (stack, top ! scc);`
`                                                         fi;`

`                                                        grab _`
`                                                         =>`
`                                                         raise exception DIE "scc: grab: empty stack"; end;`

`                                                    grab;`
`                                                };`

`                                            dfs {   follow_nodes => follow tn,`
`                                                    grab_fate => tn_grab_fate,`
`                                                    node_pre => tn_pre,`
`                                                    node_low => tn_low,`
`                                                    parent_low => node_low,`
`                                                    nodemap,`
`                                                    stack => tn ! stack,`
`                                                    sccl,`
`                                                    nograb_fate => tn_nograb_fate`
`                                                };`
`                                        };`
`                                esac;`
`                            };`

`                        loop [] (nodemap, stack, sccl)`
`                            =>`
`                            {   nl = *node_low;`

`                                if   (nl == node_pre)`

`                                     grab_fate (nodemap, sccl) (stack, []);`
`                                else`
`                                        #  Propagate node_low up: `
`                                         if   (nl < *parent_low)`

`                                              parent_low := nl;`
`                                         fi;`

`                                         #  `return' `
`                                         nograb_fate (nodemap, stack, sccl);`
`                                fi;`
`                            };`
`                    end;`
`            `

`                end;                                                                    # fun dfs`

`            fun top_grab_fate (nodemap, sccl) ([], [])`
`                    =>`
`                    sccl;`

`                top_grab_fate _ _`
`                    =>`
`                    raise exception DIE "scc: top_grab: stack not empty";`
`            end;`

`            dfs { follow_nodes        =>  roots,`
`                  grab_fate   =>  top_grab_fate,`
`                  node_pre            =>  0,`
`                  node_low            =>  REF 0,            #  low of virtual root `
`                  parent_low          =>  REF 0,   #  low of virtual parent of virtual root `
`                  nodemap             =>  (1, map::empty),`
`                  stack               =>  [],`
`                  sccl                =>  [],`
`                  nograb_fate =>  \\ (_, _, _) =  raise exception DIE "scc: top_nograb_fate"`
`                };`
`        };                                                                              # fun topological_order'`

`    fun topological_order { root, follow }`
`        =`
`        topological_order' { roots => [root], follow };`
`};`

`## COPYRIGHT (c) 1999 Lucent Bell Laboratories.`
`## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,`
`## released per terms of SMLNJ-COPYRIGHT.`   