## 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.