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 import "Map" as Map
   4 import "MMap" as MMap
   5
   6 import "Comparator"
   7
   8 @private
   9 importJava "org.simantics.utils.strings.AlphanumComparator" where
  10     @JavaName CASE_INSENSITIVE_COMPARATOR
  11     alphanumericComparator :: Comparator String
  12
  13 type Subgraph = ([Resource], [Resource])
  14 type Subgraphs = (Resource, [Subgraph])
  15 type ElementFilter = (Resource -> <ReadGraph> Boolean)
  16
  17 @private
  18 floodFill :: ElementFilter -> Resource -> <ReadGraph, Proc> Subgraph
  19 floodFill edgeFilter fromVertex = do
  20     processVertex fromVertex
  21     (MSet.toList vertices, MSet.toList edges)
  22   where
  23     edgesOf vertex = (vertex # DN.HasStartVertex_Inverse, vertex # DN.HasEndVertex_Inverse)
  24     vertices              = MSet.create ()
  25     edges                 = MSet.create ()
  26     processVertex vertex  = if MSet.add vertices vertex then do
  27                                 (starts, ends) = edgesOf vertex
  28                                 for starts processEdgeStart
  29                                 for ends processEdgeEnd
  30                             else ()
  31     processEdgeStart edge = if MSet.add edges edge && edgeFilter edge then
  32                                 for (edge # DN.HasEndVertex) processVertex
  33                             else ()
  34     processEdgeEnd edge   = if MSet.add edges edge && edgeFilter edge then
  35                                 for (edge # DN.HasStartVertex) processVertex
  36                             else ()
  37
  38 @private
  39 findDisconnectedSubnetworksFromDiagram :: ElementFilter -> Resource -> <ReadGraph, Proc> Subgraphs
  40 findDisconnectedSubnetworksFromDiagram edgeFilter networkDiagram = let
  41     all       = networkDiagram # L0.ConsistsOf
  42     vertices  = filter (flip isInstanceOf DN.Vertex) all
  43     edges     = filter (flip isInstanceOf DN.Edge) all
  44     vertexSet = MSet.fromList vertices
  45     edgeSet   = MSet.fromList edges
  46     result    = MList.create ()
  47     take1 set = MSet.mapFirst Just vertexSet
  48
  49     loop Nothing       = ()
  50     loop (Just vertex) = do
  51         subgraph = floodFill edgeFilter vertex
  52         MList.add result subgraph
  53         (vs, es) = subgraph
  54         MSet.removeAll vertexSet vs
  55         MSet.removeAll edgeSet   es
  56         if not (MSet.isEmpty vertexSet) then
  57             loop (take1 vertexSet)
  58         else ()
  59   in do
  60     //print "Total number of vertices: \(length vertices)"
  61     //print "Total number of edges:    \(length edges)"
  62     loop (take1 vertexSet)
  63     if MSet.size edgeSet > 0 then
  64         MList.add result ([], MSet.toList edgeSet)
  65     else ()
  66     //print "Found \(MList.size result) disconnected sub-networks"
  67     (networkDiagram, (MList.freeze result))
  68
  69 """
  70 Finds disconnected district subnetworks from the provided district network diagram.
  71 The input can be either the network diagram resource or the configuration composite
  72 resource of the network diagram.
  73
  74 See [reportDisconnectedSubnetworks](#reportDisconnectedSubnetworks) for reporting the
  75 result by printing.
  76 """
  77 findDisconnectedSubnetworks :: ElementFilter -> Resource -> <ReadGraph, Proc> Subgraphs
  78 findDisconnectedSubnetworks edgeFilter networkDiagramOrComposite = findDisconnectedSubnetworksFromDiagram edgeFilter (toDiagram networkDiagramOrComposite)
  79   where
  80     toDiagram d = if isInstanceOf d DN.Diagram then d
  81                   else match (possibleObject d MOD.CompositeToDiagram) with
  82                       Just dia -> toDiagram dia
  83                       Nothing  -> fail "Provided diagram is not a district network diagram or configuration composite: \(possibleUriOf d)"
  84
  85 reportDisconnectedSubnetworks :: Integer -> Subgraphs -> <ReadGraph, Proc> ()
  86 reportDisconnectedSubnetworks vertexThreshold (diagram, subgraphs) = do
  87     print "## Disconnected sub-network analysis of district network \(relativeUri diagram)"
  88     print "* Detailed reporting vertex count threshold is <= \(vertexThreshold)"
  89     for subgraphs reportGraph
  90   where
  91     rootUri = match possibleIndexRoot diagram with
  92                   Nothing -> ""
  93                   Just root -> uriOf (parent root)
  94     relativeUri r = drop (length rootUri) (uriOf r)
  95
  96     showVertex v = nameOf v
  97
  98     edgeEnds e = (possibleObject e DN.HasStartVertex, possibleObject e DN.HasEndVertex)
  99     showEdgeEnds (Nothing, Nothing) = "(null, null)"
 100     showEdgeEnds (Just s, Nothing)  = "(\(nameOf s), null)"
 101     showEdgeEnds (Nothing, Just e)  = "(null, \(nameOf e))"
 102     showEdgeEnds (Just s, Just e)   = "(\(nameOf s), \(nameOf e))"
 103     showEdge e = (nameOf e) + " - " + (showEdgeEnds (edgeEnds e))
 104     sortStrings l = sortWithComparator alphanumericComparator l
 105
 106     reportGraph (vs, es) | length vs > vertexThreshold = reportShort vs es
 107                          | otherwise                   = reportFull vs es
 108     reportSubgraphTitle vs es = print "\n### Disconnected sub-network of \(length vs) vertices and \(length es) edges"
 109     reportShort vs es = do
 110         reportSubgraphTitle vs es
 111         print "* Details not reported because vertex count exceeds threshold"
 112         mapFirst (\s -> do print "* v0: \(s)"; Just s)
 113                  (sortStrings (map showVertex vs))
 114         print "* ..."
 115     reportFull vs es = do
 116         reportSubgraphTitle vs es
 117         forI (sortStrings (map showVertex vs)) (\i s -> print "* v\(i): \(s)")
 118         print ""
 119         forI (sortStrings (map showEdge es)) (\i s -> print "* e\(i): \(s)")
 120
 121 """
 122 Get a set of the edges that are at the middle points of each span between branch points.
 123 """
 124 midBranchEdges :: Resource -> <ReadGraph> [Resource]
 125 midBranchEdges networkDiagram = runProc let
 126     for edges storeDistance
 127   in
 128     filter isMiddle edges
 129   where
 130     all       = if isInstanceOf networkDiagram DIA.Diagram
 131                 then networkDiagram # L0.ConsistsOf
 132                 else singleObject networkDiagram MOD.CompositeToDiagram # L0.ConsistsOf
 133     vertices  = filter (flip isInstanceOf DN.Vertex) all
 134     edges     = filter (flip isInstanceOf DN.Edge) all
 135     edgeLen   = fromJust . (index $ flip map edges \e -> do
 136          v1 = singleObject e DN.HasStartVertex
 137          v2 = singleObject e DN.HasEndVertex
 138          [x1, y1] = relatedValue v1 DIA.HasLocation :: [Double]
 139          [x2, y2] = relatedValue v2 DIA.HasLocation :: [Double]
 140          (e, sqrt ((x2 - x1)^2 + (y2 - y1)^2)))
 141     distances = runProc $ MMap.create () :: MMap.T Resource Double
 142     isBranchPoint v = length (v # DN.HasEndVertex_Inverse) != 1 || length (v # DN.HasStartVertex_Inverse) != 1
 143     setDistance e d = MMap.put distances e d
 144     getDistance e = fromJust $ MMap.get distances e
 145     forward r1 r2 e cont = do
 146         v = singleObject e r1
 147         l = edgeLen e
 148         if isBranchPoint v
 149             then do
 150                 setDistance e (l / 2)
 151                 cont l
 152             else do
 153                 e2 = singleObject v r2
 154                 forward r1 r2 e2 (\d2 -> do
 155                     setDistance e (d2 + l/2)
 156                     cont (d2 + l))
 157     backward r1 r2 e d = do
 158         l = edgeLen e
 159         setDistance e $ min (d + l/2) (getDistance e)
 160         v = singleObject e r1
 161         if isBranchPoint v then () else backward r1 r2 (singleObject v r2) (d + l)
 162     storeDistance e = if MMap.containsKey distances e
 163         then ()
 164         else do
 165             l = edgeLen e
 166             forwardTo e (const ())
 167             d1 = getDistance e
 168             forwardFrom e (const ())
 169             d2 = getDistance e
 170             setDistance e (min d1 d2)
 171             backwardFrom e (d1 - l/2)
 172             backwardTo e (d2 - l/2)
 173       where
 174         forwardTo = forward DN.HasEndVertex DN.HasStartVertex_Inverse
 175         forwardFrom = forward DN.HasStartVertex DN.HasEndVertex_Inverse
 176         backwardTo = backward DN.HasEndVertex DN.HasStartVertex_Inverse
 177         backwardFrom = backward DN.HasStartVertex DN.HasEndVertex_Inverse
 178     isMiddle e = let
 179         v1 = singleObject e DN.HasStartVertex
 180         v2 = singleObject e DN.HasEndVertex
 181         d = getDistance e
 182       in
 183         (isBranchPoint v1 || d > getDistance (singleObject v1 DN.HasEndVertex_Inverse)) &&
 184         (isBranchPoint v2 || d > getDistance (singleObject v2 DN.HasStartVertex_Inverse))