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 vertices that acts as break points between network branches.
 123 """
 124 branchPoints :: Resource -> <ReadGraph> [Resource]
 125 branchPoints networkDiagram = runProc let
 126   in
 127     filter isBranchPoint vertices
 128   where
 129     all       = if isInstanceOf networkDiagram DIA.Diagram
 130                 then networkDiagram # L0.ConsistsOf
 131                 else singleObject networkDiagram MOD.CompositeToDiagram # L0.ConsistsOf
 132     vertices = filter (flip isInstanceOf DN.Vertex) all
 133     isBranchPoint v = length (v # DN.HasEndVertex_Inverse) != 1 || length (v # DN.HasStartVertex_Inverse) != 1
 134
 135 """
 136 Get a set of the edges that are at the middle points of each span between branch points.
 137 """
 138 midBranchEdges :: Resource -> <ReadGraph> [Resource]
 139 midBranchEdges networkDiagram = runProc let
 140     for edges storeDistance
 141   in
 142     filter isMiddle edges
 143   where
 144     all       = if isInstanceOf networkDiagram DIA.Diagram
 145                 then networkDiagram # L0.ConsistsOf
 146                 else singleObject networkDiagram MOD.CompositeToDiagram # L0.ConsistsOf
 147     vertices  = filter (flip isInstanceOf DN.Vertex) all
 148     edges     = filter (flip isInstanceOf DN.Edge) all
 149     edgeLen   = fromJust . (index $ flip map edges \e -> do
 150          v1 = singleObject e DN.HasStartVertex
 151          v2 = singleObject e DN.HasEndVertex
 152          [x1, y1] = relatedValue v1 DIA.HasLocation :: [Double]
 153          [x2, y2] = relatedValue v2 DIA.HasLocation :: [Double]
 154          (e, sqrt ((x2 - x1)^2 + (y2 - y1)^2)))
 155     distances = runProc $ MMap.create () :: MMap.T Resource Double
 156     isBranchPoint v = length (v # DN.HasEndVertex_Inverse) != 1 || length (v # DN.HasStartVertex_Inverse) != 1
 157     setDistance e d = MMap.put distances e d
 158     getDistance e = fromJust $ MMap.get distances e
 159     forward r1 r2 e cont = do
 160         v = singleObject e r1
 161         l = edgeLen e
 162         if isBranchPoint v
 163             then do
 164                 setDistance e (l / 2)
 165                 cont l
 166             else do
 167                 e2 = singleObject v r2
 168                 forward r1 r2 e2 (\d2 -> do
 169                     setDistance e (d2 + l/2)
 170                     cont (d2 + l))
 171     backward r1 r2 e d = do
 172         l = edgeLen e
 173         setDistance e $ min (d + l/2) (getDistance e)
 174         v = singleObject e r1
 175         if isBranchPoint v then () else backward r1 r2 (singleObject v r2) (d + l)
 176     storeDistance e = if MMap.containsKey distances e
 177         then ()
 178         else do
 179             l = edgeLen e
 180             forwardTo e (const ())
 181             d1 = getDistance e
 182             forwardFrom e (const ())
 183             d2 = getDistance e
 184             setDistance e (min d1 d2)
 185             backwardFrom e (d1 - l/2)
 186             backwardTo e (d2 - l/2)
 187       where
 188         forwardTo = forward DN.HasEndVertex DN.HasStartVertex_Inverse
 189         forwardFrom = forward DN.HasStartVertex DN.HasEndVertex_Inverse
 190         backwardTo = backward DN.HasEndVertex DN.HasStartVertex_Inverse
 191         backwardFrom = backward DN.HasStartVertex DN.HasEndVertex_Inverse
 192     isMiddle e = let
 193         v1 = singleObject e DN.HasStartVertex
 194         v2 = singleObject e DN.HasEndVertex
 195         d = getDistance e
 196       in
 197         (isBranchPoint v1 || d > getDistance (singleObject v1 DN.HasEndVertex_Inverse)) &&
 198         (isBranchPoint v2 || d > getDistance (singleObject v2 DN.HasStartVertex_Inverse))