Select midpoint of network branches for flow velocity arrows.

[simantics/district.git] / org.simantics.district.network / scl / Simantics / District / Algorithm.scl

diff --git a/org.simantics.district.network/scl/Simantics/District/Algorithm.scl b/org.simantics.district.network/scl/Simantics/District/Algorithm.scl
index f8852bdba69f2a97e69e33781f9065fb2d695aff..259ad087620bed708791cb3887a4ba12f6977aef 100644 (file)
--- a/org.simantics.district.network/scl/Simantics/District/Algorithm.scl
+++ b/org.simantics.district.network/scl/Simantics/District/Algorithm.scl
@@ -1,7 +1,10 @@
 import "Simantics/Model"
 import "http://www.simantics.org/DistrictNetwork-1.0" as DN
+import "Map" as Map
+import "MMap" as MMap
 
 import "Comparator"
+
 @private
 importJava "org.simantics.utils.strings.AlphanumComparator" where
     @JavaName CASE_INSENSITIVE_COMPARATOR
@@ -114,3 +117,68 @@ reportDisconnectedSubnetworks vertexThreshold (diagram, subgraphs) = do
         forI (sortStrings (map showVertex vs)) (\i s -> print "* v\(i): \(s)")
         print ""
         forI (sortStrings (map showEdge es)) (\i s -> print "* e\(i): \(s)")
+
+"""
+Get a set of the edges that are at the middle points of each span between branch points.
+"""
+midBranchEdges :: Resource -> <ReadGraph> [Resource]
+midBranchEdges networkDiagram = runProc let
+    for edges storeDistance
+  in
+    filter isMiddle edges
+  where
+    all       = if isInstanceOf networkDiagram DIA.Diagram
+                then networkDiagram # L0.ConsistsOf
+                else singleObject networkDiagram MOD.CompositeToDiagram # L0.ConsistsOf
+    vertices  = filter (flip isInstanceOf DN.Vertex) all
+    edges     = filter (flip isInstanceOf DN.Edge) all
+    edgeLen   = fromJust . (index $ flip map edges \e -> do
+         v1 = singleObject e DN.HasStartVertex
+         v2 = singleObject e DN.HasEndVertex
+         [x1, y1] = relatedValue v1 DIA.HasLocation :: [Double]
+         [x2, y2] = relatedValue v2 DIA.HasLocation :: [Double]
+         (e, sqrt ((x2 - x1)^2 + (y2 - y1)^2)))
+    distances = runProc $ MMap.create () :: MMap.T Resource Double
+    isBranchPoint v = length (v # DN.HasEndVertex_Inverse) != 1 || length (v # DN.HasStartVertex_Inverse) != 1
+    setDistance e d = MMap.put distances e d
+    getDistance e = fromJust $ MMap.get distances e
+    forward r1 r2 e cont = do
+        v = singleObject e r1
+        l = edgeLen e
+        if isBranchPoint v
+            then do
+                setDistance e (l / 2)
+                cont l
+            else do
+                e2 = singleObject v r2
+                forward r1 r2 e2 (\d2 -> do
+                    setDistance e (d2 + l/2)
+                    cont (d2 + l))
+    backward r1 r2 e d = do
+        l = edgeLen e
+        setDistance e $ min (d + l/2) (getDistance e)
+        v = singleObject e r1
+        if isBranchPoint v then () else backward r1 r2 (singleObject v r2) (d + l)
+    storeDistance e = if MMap.containsKey distances e
+        then ()
+        else do
+            l = edgeLen e
+            forwardTo e (const ())
+            d1 = getDistance e
+            forwardFrom e (const ())
+            d2 = getDistance e
+            setDistance e (min d1 d2)
+            backwardFrom e (d1 - l/2)
+            backwardTo e (d2 - l/2)
+      where
+        forwardTo = forward DN.HasEndVertex DN.HasStartVertex_Inverse
+        forwardFrom = forward DN.HasStartVertex DN.HasEndVertex_Inverse
+        backwardTo = backward DN.HasEndVertex DN.HasStartVertex_Inverse
+        backwardFrom = backward DN.HasStartVertex DN.HasEndVertex_Inverse
+    isMiddle e = let
+        v1 = singleObject e DN.HasStartVertex
+        v2 = singleObject e DN.HasEndVertex
+        d = getDistance e
+      in
+        (isBranchPoint v1 || d > getDistance (singleObject v1 DN.HasEndVertex_Inverse)) &&
+        (isBranchPoint v2 || d > getDistance (singleObject v2 DN.HasStartVertex_Inverse))