X-Git-Url: https://gerrit.simantics.org/r/gitweb?a=blobdiff_plain;f=bundles%2Forg.simantics.modeling%2Fscl%2FSimantics%2FRouteGraph.scl;h=cacec102b700763288fcf09a132d21b22c859f77;hb=HEAD;hp=3c115c79decb6dedffc1ec5b3969502560cc3977;hpb=969bd23cab98a79ca9101af33334000879fb60c5;p=simantics%2Fplatform.git diff --git a/bundles/org.simantics.modeling/scl/Simantics/RouteGraph.scl b/bundles/org.simantics.modeling/scl/Simantics/RouteGraph.scl index 3c115c79d..cacec102b 100644 --- a/bundles/org.simantics.modeling/scl/Simantics/RouteGraph.scl +++ b/bundles/org.simantics.modeling/scl/Simantics/RouteGraph.scl @@ -1,143 +1,185 @@ -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] -> 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 -> Boolean) -> 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] -> 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 -> 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 "" - createConnectionUtil :: ConnectionUtil - - removeConnectionPart :: ConnectionUtil -> Resource -> () - -""" -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 -> () -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] -> [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 +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 + +import "Logging" as LOGGER + +importJava "org.simantics.modeling.scl.RouteGraphMatching" where + matchRouteGraph :: [Resource] -> Integer -> [Integer] -> 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 -> Boolean) -> 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] -> 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 -> 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 "" + createConnectionUtil :: ConnectionUtil + + removeConnectionPart :: ConnectionUtil -> Resource -> () + +""" +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 -> () +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] -> [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." + +// Connection and terminal judgements +importJava "org.simantics.structural2.modelingRules.CPTerminal" where + makeIConnectionPoint :: Resource -> Resource -> IConnectionPoint + +importJava "org.simantics.structural2.modelingRules.ConnectionJudgementType" where + data ConnectionJudgementType + LEGAL :: ConnectionJudgementType + ILLEGAL :: ConnectionJudgementType + CANBEMADELEGAL :: ConnectionJudgementType + +importJava "org.simantics.structural2.modelingRules.ConnectionJudgement" where + data ConnectionJudgement + @private + @JavaName "type" + getConnectionJudgementType :: ConnectionJudgement -> ConnectionJudgementType + +importJava "org.simantics.structural2.modelingRules.IConnectionPoint" where + data IConnectionPoint + + +importJava "org.simantics.modeling.ModelingUtils" where + getModelingRules :: Resource -> Maybe IModelingRules + +importJava "org.simantics.structural2.modelingRules.IModelingRules" where + data IModelingRules + + judgeConnection :: IModelingRules -> [IConnectionPoint] -> ConnectionJudgement + +canTerminalBeConnected :: Resource -> Resource -> Resource -> Boolean +canTerminalBeConnected diagram component terminal = match getModelingRules diagram with + Just modelingRules -> do + cpTerminal = makeIConnectionPoint component terminal + connectionJudgement = judgeConnection modelingRules [cpTerminal] + canBeConnected = getConnectionJudgementType connectionJudgement == LEGAL + LOGGER.info $ "canBeConnected : \(canBeConnected)" + canBeConnected + Nothing -> do + LOGGER.warn $ "No modeling rules available for diagram \(diagram) to resolve connection judgement" + False // true or false when no modeling rules available ?