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