X-Git-Url: https://gerrit.simantics.org/r/gitweb?a=blobdiff_plain;f=bundles%2Forg.simantics.modeling%2Fscl%2FSimantics%2FRouteGraph.scl;fp=bundles%2Forg.simantics.modeling%2Fscl%2FSimantics%2FRouteGraph.scl;h=3c115c79decb6dedffc1ec5b3969502560cc3977;hb=969bd23cab98a79ca9101af33334000879fb60c5;hp=0000000000000000000000000000000000000000;hpb=866dba5cd5a3929bbeae85991796acb212338a08;p=simantics%2Fplatform.git

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