org.simantics.district.network/scl/Simantics/District/Algorithm.scl

   1 type Subgraph = [([Resource], [Resource])]
   2 data Subgraphs = Subgraphs Resource Subgraph
   3
   4 @private
   5 floodFill :: Resource -> <ReadGraph, Proc> Subgraph
   6 floodFill fromVertex = do
   7     processVertex fromVertex
   8     (MSet.toList vertices, MSet.toList edges)
   9   where
  10     edgesOf vertex = (vertex # DN.HasStartVertex_Inverse, vertex # DN.HasEndVertex_Inverse)
  11     vertices              = MSet.create ()
  12     edges                 = MSet.create ()
  13     processVertex vertex  = if MSet.add vertices vertex then do
  14                                 (starts, ends) = edgesOf vertex
  15                                 for starts processEdgeStart
  16                                 for ends processEdgeEnd
  17                             else ()
  18     processEdgeStart edge = if MSet.add edges edge then for (edge # DN.HasEndVertex) processVertex else ()
  19     processEdgeEnd   edge = if MSet.add edges edge then for (edge # DN.HasStartVertex) processVertex else ()
  20
  21 @private
  22 findDisconnectedSubnetworksFromDiagram :: Resource -> <ReadGraph, Proc> Subgraphs
  23 findDisconnectedSubnetworksFromDiagram networkDiagram = let
  24     all       = networkDiagram # L0.ConsistsOf
  25     vertices  = filter (flip isInstanceOf DN.Vertex) all
  26     edges     = filter (flip isInstanceOf DN.Edge) all
  27     vertexSet = MSet.fromList vertices
  28     edgeSet   = MSet.fromList edges
  29     result    = MList.create ()
  30     take1 set = MSet.mapFirst Just vertexSet
  31
  32     loop Nothing       = ()
  33     loop (Just vertex) = do
  34         subgraph = floodFill vertex
  35         MList.add result subgraph
  36         (vs, es) = subgraph
  37         MSet.removeAll vertexSet vs
  38         MSet.removeAll edgeSet   es
  39         if not (MSet.isEmpty vertexSet) then
  40             loop (take1 vertexSet)
  41         else ()
  42   in do
  43     print "Total number of vertices: \(length vertices)"
  44     print "Total number of edges:    \(length edges)"
  45     loop (take1 vertexSet)
  46     if MSet.size edgeSet > 0 then
  47         MList.add result ([], MSet.toList edgeSet)
  48     else ()
  49     print "Found \(MList.size result) disconnected sub-networks"
  50     Subgraphs networkDiagram (MList.freeze result)
  51
  52 """
  53 Finds disconnected district subnetworks from the provided district network diagram.
  54 The input can be either the network diagram resource or the configuration composite
  55 resource of the network diagram.
  56
  57 See [reportDisconnectedSubnetworks](#reportDisconnectedSubnetworks) for reporting
  58 """
  59 findDisconnectedSubnetworks :: Resource -> <ReadGraph, Proc> Subgraphs
  60 findDisconnectedSubnetworks networkDiagramOrComposite = findDisconnectedSubnetworksFromDiagram (toDiagram networkDiagramOrComposite)
  61   where
  62     toDiagram d = if isInstanceOf d DN.Diagram then d
  63                   else match (possibleObject d MOD.CompositeToDiagram) with
  64                       Just dia -> toDiagram dia
  65                       Nothing  -> fail "Provided diagram is not a district network diagram or configuration composite: \(possibleUriOf d)"
  66
  67 import "Comparator"
  68 @private
  69 importJava "org.simantics.utils.strings.AlphanumComparator" where
  70   @JavaName CASE_INSENSITIVE_COMPARATOR
  71   alphanumericComparator :: Comparator String
  72
  73 reportDisconnectedSubnetworks :: Integer -> Subgraphs -> <ReadGraph, Proc> ()
  74 reportDisconnectedSubnetworks vertexThreshold (Subgraphs diagram subgraphs) = do
  75     print "## Disconnected sub-network analysis of district network \(relativeUri diagram)"
  76     print "* Detailed reporting vertex count threshold is <= \(vertexThreshold)"
  77     for subgraphs reportGraph
  78   where
  79     rootUri = match possibleIndexRoot diagram with
  80                   Nothing -> ""
  81                   Just root -> uriOf (parent root)
  82     relativeUri r = drop (length rootUri) (uriOf r)
  83
  84     showVertex v = nameOf v
  85
  86     edgeEnds e = (possibleObject e DN.HasStartVertex, possibleObject e DN.HasEndVertex)
  87     showEdgeEnds (Nothing, Nothing) = "(null, null)"
  88     showEdgeEnds (Just s, Nothing)  = "(\(nameOf s), null)"
  89     showEdgeEnds (Nothing, Just e)  = "(null, \(nameOf e))"
  90     showEdgeEnds (Just s, Just e)   = "(\(nameOf s), \(nameOf e))"
  91     showEdge e = (nameOf e) + " - " + (showEdgeEnds (edgeEnds e))
  92     sortStrings l = sortWithComparator alphanumericComparator l
  93
  94     reportGraph (vs, es) | length vs > vertexThreshold = reportShort vs es
  95                          | otherwise                   = reportFull vs es
  96     reportSubgraphTitle vs es = print "\n### Disconnected sub-network of \(length vs) vertices and \(length es) edges"
  97     reportShort vs es = do
  98         reportSubgraphTitle vs es
  99         print "* Details not reported because vertex count exceeds threshold"
 100     reportFull vs es = do
 101         reportSubgraphTitle vs es
 102         forI (sortStrings (map showVertex vs)) (\i s -> print "* v\(i): \(s)")
 103         print ""
 104         forI (sortStrings (map showEdge es)) (\i s -> print "* e\(i): \(s)")