1(*
2    Copyright (c) 2016-17 David C.J. Matthews
3
4    This library is free software; you can redistribute it and/or
5    modify it under the terms of the GNU Lesser General Public
6    License version 2.1 as published by the Free Software Foundation.
7    
8    This library is distributed in the hope that it will be useful,
9    but WITHOUT ANY WARRANTY; without even the implied warranty of
10    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11    Lesser General Public License for more details.
12    
13    You should have received a copy of the GNU Lesser General Public
14    License along with this library; if not, write to the Free Software
15    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
16*)
17
18structure StronglyConnected:
19sig
20    val stronglyConnectedComponents: {nodeAddress: 'a -> int, arcs: 'a -> int list } -> 'a list -> 'a list list
21end
22=
23struct
24    fun stronglyConnectedComponents _ [] = []
25    |   stronglyConnectedComponents {nodeAddress, arcs} (rlist as firstNode :: _) =
26    (* In general any mutually recursive declaration can refer to any
27       other.  It's better to partition the recursive declarations into
28       strongly connected components i.e. those that actually refer
29       to each other.  *)
30    let
31        local
32            val anAddr = nodeAddress firstNode
33        in
34            val (startAddress, lastAddress) =
35                List.foldl (fn(item, (mn, mx)) => let val addr = nodeAddress item in (Int.min(addr, mn), Int.max(addr+1, mx)) end) (anAddr, anAddr) rlist
36        end
37        (* *)
38        val mapArray = Array.array(lastAddress - startAddress, NONE)
39        
40        fun updateMin(addr, try) =
41        let
42            val off = addr - startAddress
43            val { lowLink, index } = valOf(Array.sub(mapArray, off))
44        in
45            Array.update(mapArray, off, SOME{ index = index, lowLink = Int.min(lowLink, try) })
46        end
47
48        fun addrInList a = List.exists(fn item => a = nodeAddress item)
49
50        fun strongcomponent(item, (thisIndex, stack, resList)) =
51        let
52            val addr = nodeAddress item
53            val allArcs = arcs item
54            val newStack = item :: stack
55            val v = addr - startAddress
56            (* Mark this item as processed. *)
57            val () = Array.update(mapArray, v, SOME{index = thisIndex, lowLink = thisIndex})
58
59            (* Process links that refer to other items *)
60            fun processLink(a: int, args as (_, stack, _)) =
61                    if addrInList a rlist
62                    then (* It refers to another within this declaration *)
63                    let
64                        val w = a - startAddress
65                    in
66                        case Array.sub(mapArray, w) of
67                            NONE => (*  Not yet processed. *)
68                            let
69                                val result = strongcomponent(valOf(List.find(fn item => nodeAddress item = a) rlist), args);
70                            in
71                                updateMin(addr, #lowLink(valOf(Array.sub(mapArray, w))));
72                                result
73                            end
74                        |   SOME _ =>
75                            (
76                                (* Already processed - was it in this pass or a previous? *)
77                                if addrInList a stack (* On the stack so in the current SCC *)
78                                then updateMin(addr, #index(valOf(Array.sub(mapArray, w))))
79                                else (); (* Processed in previous pass *)
80                                args
81                            )
82                    end
83                    else args
84            
85            val (nextIndex, stack', subRes) = List.foldl processLink (thisIndex+1, newStack, resList) allArcs
86        in
87            (* Process references from this function. *)
88            if #lowLink(valOf(Array.sub(mapArray, v))) = thisIndex (* This is the minimum *)
89            then (* Create an SCC *)
90            let
91                fun popItems([], _) = raise Fail "stack empty"
92                |   popItems(item :: r, l) =
93                        if nodeAddress item = addr
94                        then (r, item :: l)
95                        else popItems(r, item :: l)
96                val (newStack, scc) = popItems(stack', [])
97            in
98                (nextIndex, newStack,  scc :: subRes)
99            end
100            else (nextIndex, stack', subRes)
101        end
102
103        (* Process items that have not yet been reached *)
104        fun processUnprocessed (item, args) =
105            case Array.sub(mapArray, nodeAddress item-startAddress) of 
106                NONE => strongcomponent(item, args)
107            |   _ => args
108
109        val (_, _, result) = List.foldl processUnprocessed (0, [], []) rlist
110    in
111        result
112    end
113end;
114