7 , toRuleNet -- tricky function with unsafe operations inside
16 import Document hiding (ActiveCanvas(..))
18 import qualified Palette as Pal
20 import qualified Data.IntMap as IM
32 type AgentName = String
33 type Agent = (AgentName -- agent name
34 , Int -- the agent arity, this is, the number of ports
35 -- excludind the principal one
37 type Interface = [Term]
39 -- | (rules, <interface | equations>) is a configuration
40 data Net = Net { agents :: [Agent] -- ^ the list of agents and its arities
41 , equations :: [Equation] -- ^ the equations
42 , interface :: Interface -- ^ the interface of the net
44 , rules :: [Rule] -- ^ rules
47 type NodeApl = (AgentName, [Term])
48 data Term = Simple Edge' | Compound NodeApl deriving (Eq, Ord, Show)
49 type Equation = (Term, Term)
51 type Rule = (Maybe String, NodeApl, NodeApl)
54 instance Show Net where
55 show = showRepresentation PIN
58 generalRepresentation :: Net -> String
59 generalRepresentation = unlines . map showEquation . equations
60 where showEquation (edge, info) = (showEdge edge) ++ " = " ++ showNodeApl info ++ " ;"
61 showNodeApl (node, edges) =
62 showNode node ++ if null edges
64 else "(" ++ showTerm (head edges)
65 ++ showTail (tail edges)
68 showNode node = filter (not . isSpace) node
69 showTail = concatMap (\a -> ", " ++ showTerm a)
72 data Representation = AMIN | PIN deriving Show
74 repFold amin pin rep = case rep of
78 -- | Creates the string with the representation of a 'Net'
79 -- in the format of IN transformation tools:
82 showRepresentation :: Representation -> Net -> String
83 showRepresentation rep net =
85 [ "/* Automatically generated by " ++ toolName ++ " for " ++ show rep ++ " */"
87 , repFold "agents" "" rep
89 ] ++ map showAgent (agents net) ++
91 , repFold "rules" "" rep
93 ] ++ map showRule (rules net) ++
95 , repFold "net" "//test net\nstart :" rep
97 ] ++ map showEquation (equations net) ++
102 ] ++ map showEdge2 (interface net) ++
109 where showAgent :: Agent -> String
110 showAgent (name, arity) = sl (spaces2underscores name) (repFold "\t" ":" rep) $ show arity
112 showEquation :: Equation -> String
113 showEquation (lhs, rhs) = sl (showTerm lhs) (repFold " = " " - " rep) $ showTerm rhs
115 showTerm (Simple e) = showEdge e
116 showTerm (Compound c) = showNodeApl c
118 showNodeApl (node, edges) =
119 showNode node ++ if null edges
121 else "(" ++ showTerm (head edges)
122 ++ showTail (tail edges)
124 showNode node = spaces2underscores node
125 showTail = concatMap (\a -> ", " ++ showTerm a)
127 showEdge :: Edge' -> String
130 showEdge2 term = showTerm term ++ ";"
132 sl arg1 sep arg2 = '\t' : arg1 ++ sep ++ arg2 ++ repFold ";" [] rep
134 showRule (mStr, lhs, rhs) = repFold [] (maybe [] ((++ ":\n") . spaces2underscores) mStr) rep
135 ++ sl (showNodeApl lhs) " >< " (showNodeApl rhs) ++ "\n"
138 doc2net :: (InfoKind n g, InfoKind e g) => Document g n e -> Net
139 doc2net doc = nubAgents $ (network2net palette $ getNetwork doc)
141 (foldr1 join . mapRules (textualRule palette) $ getRules doc)
142 where palette = getPalette doc
144 nubAgents :: Net -> Net
145 nubAgents net = net { agents = nub $ agents net}
147 join :: Net -> Net -> Net
149 Net { agents = agents net1 ++ agents net2
150 , equations = equations net1 ++ equations net2
151 , interface = interface net1 ++ interface net2
152 , rules = rules net1 ++ rules net2
155 network2net :: Pal.Palette n -> Network g n e -> Net
156 network2net palette network =
157 Net { agents = delete (fst interfaceSymbol, 0) . nub
158 . map getAgent . IM.assocs $ nodeMap
159 , equations = sort eqs'
160 , interface = map fst inter
163 where nodeMap = networkNodes network
165 eqs = catMaybes $ IM.foldWithKey f [] nodeMap
166 (eqs', inter) = partition test eqs
167 f nodeNr node r = (node2net nodeNr node) : r
168 node2net :: NodeNr -> Node n -> Maybe Equation
170 do (pPort:otherPorts) <- getPorts palette network nr
171 pEdge <- edgeConnectedOnPort network nr (fst pPort)
172 let otherEdges = catMaybes $ map (edgeConnectedOnPort network nr . fst) otherPorts
173 return (Simple pEdge, Compound (getShape node, map Simple otherEdges))
174 test :: Equation -> Bool
175 test (Simple _, Compound (str, [])) = str /= fst interfaceSymbol
177 getAgent :: (NodeNr, Node n) -> (AgentName, Int)
178 getAgent (nr,node) = (getShape node, agentArity nr)
179 agentArity :: NodeNr -> Int
180 agentArity nr = length (maybe [] id $ getPorts palette network nr) - 1
182 -- | Generates the textual representation of a rule.
183 textualRule :: (InfoKind n g, InfoKind e g) => Pal.Palette n -> INRule g n e -> Net
184 textualRule palette rule =
185 let lhs = getLHS rule
187 ruleName = INRule.getName rule
188 (interface, others) = partition isInterfaceNode $ getNodeAssocs lhs
190 f :: (NodeNr -> NodeNr) -> Network g n e -> MappingElement -> Network g n e
191 f new oldnet (nil, nir) =
192 let redge = takeJust ("One interface agent in rhs of rule "
193 ++ ruleName ++ " is disconnected.")
194 $ edgeConnectedOnPort oldnet nir "interface"
195 (nl, pl) = takeJust ("One interface agent in lhs of rule "
196 ++ ruleName ++ " is disconnected.")
197 $ otherExtremeOfEdgeConnectedOnPort lhs nil "interface"
199 in removeNode nir . updateEdge redge (substBy (nir, "interface") (new nl, pl)) $ oldnet
200 f _ _ _ = error "unknow error"
202 substBy (oldNode, oldPort) (newNode, newPort) edge =
203 case getFullPortFrom edge of
204 (node, port) | node == oldNode && port == oldPort
205 -> setPortFrom newNode newPort edge
206 _ -> case getFullPortTo edge of
207 (node, port) | node == oldNode && port == oldPort
208 -> setPortTo newNode newPort edge
209 _ -> error "unexpected"
212 [(n1, a), (n2, b)] | hasActivePair n1 n2 lhs palette ->
213 let aPrincipalPort = head . fromJust $ getPorts palette lhs n1
214 bPrincipalPort = head . fromJust $ getPorts palette lhs n2
215 (na, rhs1) = addExistingNode a rhs
216 (nb, rhs2) = addExistingNode b rhs1
217 rhs3 = addEdge palette na (fst aPrincipalPort) nb (fst bPrincipalPort) rhs2
221 | otherwise = error "unknow error"
223 -- connect mapping with wires removing interface agents
224 rhs4 = foldl (f new) rhs3 $ getMapping rule
226 in toRuleNet ruleName . simplify . network2net palette $ rhs4
229 then error $ "LHS of rule " ++ ruleName ++ " is empty."
230 else error $ "LHS of rule " ++ ruleName ++ " must have just one active pair and interface and it was found something differente. Maybe it was a "
234 hasActivePair :: NodeNr-> NodeNr -> Network g n e -> Pal.Palette n -> Bool
235 hasActivePair n1 n2 net palette =
236 case (getPorts palette net n1, getPorts palette net n2) of
237 (Just ((ap,_):_), Just ((bp,_):_) ) ->
238 isJust ( findEdge n1 ap n2 bp net ) ||
239 isJust ( findEdge n2 bp n1 ap net )
242 toRuleNet :: String -> Net -> Net
243 toRuleNet ruleName net =
244 if null $ interface net
245 then case equations net of
246 [(Compound x, Compound y)] -> net {equations = [], rules = [(Just ruleName,x,y)]}
247 x:xs | not $ null xs -> error $ "Rule " ++ ruleName ++ " probably has active pair(s) in its rhs."
248 y -> error $ "Internal error in textual representation generation of rule "
249 ++ ruleName ++ " or unknow error." ++ show y
251 else error $ "Rule " ++ ruleName ++ " with interface: internal error in textual representation generation or mismatching interfaces between lhs and rhs."
253 simplify :: Net -> Net
254 simplify net = Net { agents = agents net
257 , rules = rules net }
258 where inter = interface net
259 eqs' = simp [] (equations net)
260 (eqs'', inter') = simp2 inter eqs'
262 -- | @ simp @ removes equations of form @ a = X @
263 -- for something as @ X @ and for any @ a @
264 -- that don't belong to the interface,
265 -- substituting the unique occurence of @ a @
266 -- in the others equations.
267 simp :: [Equation] -- ^ the equations already folded
268 -> [Equation] -- ^ the equations to fold
269 -> [Equation] -- ^ the result
271 simp eqsB (eq@(Compound _, _) : eqsA) = simp (eqsB ++ [eq]) eqsA
272 simp eqsB (eq@(Simple x , a) : eqsA)
273 | Simple x `elem` inter = simp (eqsB ++ [eq]) eqsA
274 | otherwise = simp eqsBS eqsAS
275 where (eqsBS, eqsAS) = subst2 (Simple x) a eqsB eqsA
277 -- | @ simp2 @ removes the equations of form @ a = X @
278 -- for something as @ X @ and for any @ a @
279 -- that belong to the interface,
280 -- substituting @ a @ by @ X @ in the interface.
281 simp2 :: Interface -> [Equation] -> ([Equation], Interface)
282 simp2 i = foldl f2 ([],i)
283 f2 :: ([Equation], Interface) -> Equation -> ([Equation], Interface)
284 f2 (eqsB, i) (Simple x , a)
285 | Simple x `elem` i = (eqsB, a : delete (Simple x) i)
286 | otherwise = error "unexpected case in the simplification of a net: free edge don't belong to the interface"
287 f2 (eqsB, i) eq = (eqsB ++ [eq], i)
289 -- | It's known that exactly one occurency of the edge will be found
290 -- in the equations (eqsB ++ eqsA).
291 -- In the future the function will be optimize for this invariant.
292 -- Now it simply transverse the whole tree and replaces in the correct place.
293 subst2 :: Term -> Term -> [Equation] -> [Equation]
294 -> ([Equation], [Equation])
295 subst2 (Compound _) _ _ _ = error "unexpected case"
296 subst2 (Simple x) rhs eqsB eqsA = (subst eqsB, subst eqsA)
297 where subst :: [Equation] -> [Equation]
298 subst = map (substTerm >< substTerm)
300 -- | Substitution in terms; t[rhs\/x]
301 -- with t the first argument of substTerm
302 -- the occurence of variable @ x @ in term @ t @
303 -- is replaced by term @ rhs @.
304 substTerm (Simple a) | a == x = rhs
305 | otherwise = Simple a
306 substTerm (Compound c) = Compound . substNA $ c
308 substNA (agent, args) = (agent, map substTerm args)
311 filterRules :: Net -> Net
312 filterRules net = net { equations = [], interface = [] }
314 filterNet :: Net -> Net
315 filterNet net = net { rules = []}