Migrated source code from Simantics SVN

[simantics/platform.git] / bundles / org.simantics.modeling / scl / Simantics / RouteGraph.scl

diff --git a/bundles/org.simantics.modeling/scl/Simantics/RouteGraph.scl b/bundles/org.simantics.modeling/scl/Simantics/RouteGraph.scl
new file mode 100644 (file)
index 0000000..3c115c7
--- /dev/null
+++ b/bundles/org.simantics.modeling/scl/Simantics/RouteGraph.scl
@@ -0,0 +1,143 @@
+import "Simantics/DB" hiding (resourceId)\r
+import "Simantics/GShow"\r
+import "ArrayList" as ArrayList\r
+import "http://www.simantics.org/Layer0-1.1" as L0\r
+import "http://www.simantics.org/Structural-1.2" as STR\r
+import "http://www.simantics.org/Diagram-2.2" as DIA\r
+import "http://www.simantics.org/Modeling-1.2" as MOD\r
+\r
+importJava "org.simantics.modeling.scl.RouteGraphMatching" where\r
+    matchRouteGraph :: [Resource] -> Integer -> [Integer] -> <ReadGraph> Maybe [Resource]\r
+\r
+data ConnectorIdentification =\r
+    ConnectionPoint String // component name \r
+                    String // connection point name\r
+  | Element String // element name\r
+\r
+deriving instance Show ConnectorIdentification\r
+\r
+"""\r
+The structure of the route graph.\r
+"""\r
+data RouteGraphStructure = RouteGraphStructure\r
+    Resource // Composite\r
+    [ConnectorIdentification] // Connectors\r
+    Integer   // Number of route lines\r
+    [Integer] // Links between route nodes\r
+\r
+instance GShow RouteGraphStructure where\r
+    gappend ctx sb (RouteGraphStructure composite connectors routeLineCount routeLinks) = do \r
+        sb << "RouteGraphStructure "\r
+        gappend ctx sb (Par 0 composite)\r
+        sb << " " <+ connectors << " " <+ routeLineCount << " " <+ routeLinks\r
+    graphPrecedence _ = 1\r
+\r
+@private\r
+@inline\r
+breakableFor :: [a] -> (a -> <e> Boolean) -> <e> Boolean\r
+breakableFor l f = loop 0\r
+  where\r
+    len = length l\r
+    loop i | i < len = if f (l!i) then loop (i+1) else False\r
+           | otherwise = True\r
+\r
+\r
+"""\r
+Finds connectors by given component and connection point names that\r
+belong to the same connection.\r
+"""\r
+@private\r
+resolveConnectors :: Resource -> Resource -> [ConnectorIdentification] -> <ReadGraph> Maybe (Resource, [Resource])\r
+resolveConnectors composite diagram descs = let\r
+    findCandidateConnectors (ConnectionPoint componentName connectionPointName) =\r
+        match possibleResourceChild composite componentName with\r
+                Nothing -> []\r
+                Just component -> match possibleObject component MOD.ComponentToElement with\r
+                    Nothing -> []\r
+                    Just element -> [ objectOf stat\r
+                                    | stat <- statements element STR.IsConnectedTo\r
+                                    , nameOf (predicateOf stat) == connectionPointName \r
+                                    ]\r
+    findCandidateConnectors (Element elementName) =\r
+        match possibleResourceChild diagram elementName with\r
+                Nothing -> []\r
+                Just element -> element # STR.IsConnectedTo\r
+    candidateConnectors = map findCandidateConnectors descs\r
+    connections = foldl1 intersect (map (map (`singleObject` DIA.IsConnectorOf)) candidateConnectors)\r
+ in if length connections != 1\r
+    then Nothing\r
+    else let connection = connections!0\r
+             chooseCandidate l = filter (\r -> singleObject r DIA.IsConnectorOf == connection) l ! 0\r
+         in  Just (connection, map chooseCandidate candidateConnectors)\r
+\r
+"""\r
+Finds the resource encoding the route graph structure or Nothing\r
+if the structure does not match any route graph.\r
+"""\r
+@private\r
+resolveRouteGraph :: RouteGraphStructure -> <Proc,ReadGraph> Maybe (Resource, [Resource])\r
+resolveRouteGraph (RouteGraphStructure composite connectorDescs routeLineCount routeLinks) = \r
+    match resolveConnectors composite (singleObject composite MOD.CompositeToDiagram) connectorDescs with \r
+      Nothing -> Nothing\r
+      Just (connection, connectors) -> map (\nodes -> (connection,nodes)) \r
+                                      (matchRouteGraph connectors routeLineCount routeLinks)\r
+\r
+type RId = Integer\r
+\r
+"""\r
+Atomic modifications to route graph\r
+"""\r
+data RouteGraphModification =\r
+    UpdateLine RId Double Boolean\r
+  | RemoveLink RId RId\r
+  | RemoveNode RId\r
+  | CreateLink RId RId\r
+  | CreateLine Double Boolean\r
+\r
+deriving instance Show RouteGraphModification\r
+instance GShow RouteGraphModification where\r
+    gappend _ = (<+)\r
+    graphPrecedence = precedence\r
+\r
+@private\r
+importJava "org.simantics.diagram.content.ConnectionUtil" where\r
+    data ConnectionUtil\r
+    \r
+    @JavaName "<init>"\r
+    createConnectionUtil :: <WriteGraph> ConnectionUtil\r
+    \r
+    removeConnectionPart :: ConnectionUtil -> Resource -> <WriteGraph> ()\r
+\r
+"""\r
+Executes one modification in the given connection with given connection node resources. May add a new route line \r
+to @resources@ array. \r
+"""\r
+@private\r
+executeAtomicModification :: Resource -> ArrayList.T Resource -> RouteGraphModification -> <Proc,WriteGraph> ()\r
+executeAtomicModification connection resources modi = match modi with\r
+    UpdateLine a position isHorizontal -> do\r
+        r = toR a\r
+        claimRelatedValue r DIA.HasPosition position\r
+        claimRelatedValue r DIA.IsHorizontal isHorizontal\r
+    RemoveLink a b -> deny (toR a) DIA.AreConnected (toR b)\r
+    RemoveNode a -> removeConnectionPart createConnectionUtil (toR a)\r
+                    //denyAllStatements (toR a)\r
+    CreateLink a b -> claim (toR a) DIA.AreConnected (toR b)\r
+    CreateLine position isHorizontal -> do\r
+        r = newResource ()\r
+        claim r L0.InstanceOf DIA.RouteLine \r
+        claimRelatedValue r DIA.HasPosition position\r
+        claimRelatedValue r DIA.IsHorizontal isHorizontal\r
+        claim connection DIA.HasInteriorRouteNode r\r
+        ArrayList.add resources r\r
+  where\r
+    toR id = ArrayList.get resources id\r
+\r
+modifyRouteGraph :: RouteGraphStructure -> [RouteGraphModification] -> <Proc,WriteGraph> [Resource]\r
+modifyRouteGraph structure modis = \r
+    match resolveRouteGraph structure with\r
+        Just (connection, nodes) -> do\r
+            ra = ArrayList.fromList nodes\r
+            for modis (executeAtomicModification connection ra)\r
+            ArrayList.freeze ra\r
+        Nothing -> fail "Couldn't resolve route graph structure."
\ No newline at end of file