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

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