module INTextual ( Net (..) , doc2net , network2net , textualRule , toRuleNet -- tricky function with unsafe operations inside , simplify , filterRules , filterNet , Representation (..) , showRepresentation )where import Document hiding (ActiveCanvas(..)) import Network import qualified Palette as Pal import Constants import qualified Data.IntMap as IM import Data.Maybe import Data.Char import Data.List import Common import INRules import INRule import InfoKind import SpecialSymbols type Edge' = EdgeNr type AgentName = String type Agent = (AgentName -- agent name , Int -- the agent arity, this is, the number of ports -- excludind the principal one ) type Interface = [Term] -- | (rules, ) is a configuration data Net = Net { agents :: [Agent] -- ^ the list of agents and its arities , equations :: [Equation] -- ^ the equations , interface :: Interface -- ^ the interface of the net -- , rules :: [Rule] -- ^ rules } deriving (Eq) type NodeApl = (AgentName, [Term]) data Term = Simple Edge' | Compound NodeApl deriving (Eq, Ord, Show) type Equation = (Term, Term) type Rule = (Maybe String, NodeApl, NodeApl) instance Show Net where show = showRepresentation PIN {- generalRepresentation :: Net -> String generalRepresentation = unlines . map showEquation . equations where showEquation (edge, info) = (showEdge edge) ++ " = " ++ showNodeApl info ++ " ;" showNodeApl (node, edges) = showNode node ++ if null edges then "" else "(" ++ showTerm (head edges) ++ showTail (tail edges) ++ ")" showEdge = int2name showNode node = filter (not . isSpace) node showTail = concatMap (\a -> ", " ++ showTerm a) -} data Representation = AMIN | PIN deriving Show repFold amin pin rep = case rep of AMIN -> amin PIN -> pin -- | Creates the string with the representation of a 'Net' -- in the format of IN transformation tools: -- * AMIN -- * PIN showRepresentation :: Representation -> Net -> String showRepresentation rep net = unlines ( [ "/* Automatically generated by " ++ toolName ++ " for " ++ show rep ++ " */" , "" , repFold "agents" "" rep , "" ] ++ map showAgent (agents net) ++ [ "" , repFold "rules" "" rep , "" ] ++ map showRule (rules net) ++ [ "" , repFold "net" "//test net\nstart :" rep , "" ] ++ map showEquation (equations net) ++ case rep of AMIN -> [ "" , "interface" , "" ] ++ map showEdge2 (interface net) ++ [ "" , "" , "end" ] PIN -> [] ) where showAgent :: Agent -> String showAgent (name, arity) = sl (spaces2underscores name) (repFold "\t" ":" rep) $ show arity showEquation :: Equation -> String showEquation (lhs, rhs) = sl (showTerm lhs) (repFold " = " " - " rep) $ showTerm rhs showTerm (Simple e) = showEdge e showTerm (Compound c) = showNodeApl c showNodeApl (node, edges) = showNode node ++ if null edges then "" else "(" ++ showTerm (head edges) ++ showTail (tail edges) ++ ")" showNode node = spaces2underscores node showTail = concatMap (\a -> ", " ++ showTerm a) showEdge :: Edge' -> String showEdge = int2name showEdge2 term = showTerm term ++ ";" sl arg1 sep arg2 = '\t' : arg1 ++ sep ++ arg2 ++ repFold ";" [] rep showRule (mStr, lhs, rhs) = repFold [] (maybe [] ((++ ":\n") . spaces2underscores) mStr) rep ++ sl (showNodeApl lhs) " >< " (showNodeApl rhs) ++ "\n" doc2net :: (InfoKind n g, InfoKind e g) => Document g n e -> Net doc2net doc = nubAgents $ (network2net palette $ getNetwork doc) `join` (foldr1 join . mapRules (textualRule palette) $ getRules doc) where palette = getPalette doc nubAgents :: Net -> Net nubAgents net = net { agents = nub $ agents net} join :: Net -> Net -> Net join net1 net2 = Net { agents = agents net1 ++ agents net2 , equations = equations net1 ++ equations net2 , interface = interface net1 ++ interface net2 , rules = rules net1 ++ rules net2 } network2net :: Pal.Palette n -> Network g n e -> Net network2net palette network = Net { agents = delete (fst interfaceSymbol, 0) . nub . map getAgent . IM.assocs $ nodeMap , equations = sort eqs' , interface = map fst inter , rules = [] } where nodeMap = networkNodes network eqs = catMaybes $ IM.foldWithKey f [] nodeMap (eqs', inter) = partition test eqs f nodeNr node r = (node2net nodeNr node) : r node2net :: NodeNr -> Node n -> Maybe Equation node2net nr node = do (pPort:otherPorts) <- getPorts palette network nr pEdge <- edgeConnectedOnPort network nr (fst pPort) let otherEdges = catMaybes $ map (edgeConnectedOnPort network nr . fst) otherPorts return (Simple pEdge, Compound (getShape node, map Simple otherEdges)) test :: Equation -> Bool test (Simple _, Compound (str, [])) = str /= fst interfaceSymbol test _ = True getAgent :: (NodeNr, Node n) -> (AgentName, Int) getAgent (nr,node) = (getShape node, agentArity nr) agentArity :: NodeNr -> Int agentArity nr = length (maybe [] id $ getPorts palette network nr) - 1 -- | Generates the textual representation of a rule. textualRule :: (InfoKind n g, InfoKind e g) => Pal.Palette n -> INRule g n e -> Net textualRule palette rule = let lhs = getLHS rule rhs = getRHS rule ruleName = INRule.getName rule (interface, others) = partition isInterfaceNode $ getNodeAssocs lhs f :: (NodeNr -> NodeNr) -> Network g n e -> MappingElement -> Network g n e f new oldnet (nil, nir) = let redge = takeJust ("One interface agent in rhs of rule " ++ ruleName ++ " is disconnected.") $ edgeConnectedOnPort oldnet nir "interface" (nl, pl) = takeJust ("One interface agent in lhs of rule " ++ ruleName ++ " is disconnected.") $ otherExtremeOfEdgeConnectedOnPort lhs nil "interface" in removeNode nir . updateEdge redge (substBy (nir, "interface") (new nl, pl)) $ oldnet f _ _ _ = error "unknow error" substBy (oldNode, oldPort) (newNode, newPort) edge = case getFullPortFrom edge of (node, port) | node == oldNode && port == oldPort -> setPortFrom newNode newPort edge _ -> case getFullPortTo edge of (node, port) | node == oldNode && port == oldPort -> setPortTo newNode newPort edge _ -> error "unexpected" in case others of [(n1, a), (n2, b)] | hasActivePair n1 n2 lhs palette -> let aPrincipalPort = head . fromJust $ getPorts palette lhs n1 bPrincipalPort = head . fromJust $ getPorts palette lhs n2 (na, rhs1) = addExistingNode a rhs (nb, rhs2) = addExistingNode b rhs1 rhs3 = addEdge palette na (fst aPrincipalPort) nb (fst bPrincipalPort) rhs2 new n | n==n1 = na | n==n2 = nb | otherwise = error "unknow error" -- connect mapping with wires removing interface agents rhs4 = foldl (f new) rhs3 $ getMapping rule in toRuleNet ruleName . simplify . network2net palette $ rhs4 _ -> if isEmpty lhs then error $ "LHS of rule " ++ ruleName ++ " is empty." else error $ "LHS of rule " ++ ruleName ++ " must have just one active pair and interface and it was found something differente. Maybe it was a " hasActivePair :: NodeNr-> NodeNr -> Network g n e -> Pal.Palette n -> Bool hasActivePair n1 n2 net palette = case (getPorts palette net n1, getPorts palette net n2) of (Just ((ap,_):_), Just ((bp,_):_) ) -> isJust ( findEdge n1 ap n2 bp net ) || isJust ( findEdge n2 bp n1 ap net ) _ -> False toRuleNet :: String -> Net -> Net toRuleNet ruleName net = if null $ interface net then case equations net of [(Compound x, Compound y)] -> net {equations = [], rules = [(Just ruleName,x,y)]} x:xs | not $ null xs -> error $ "Rule " ++ ruleName ++ " probably has active pair(s) in its rhs." y -> error $ "Internal error in textual representation generation of rule " ++ ruleName ++ " or unknow error." ++ show y else error $ "Rule " ++ ruleName ++ " with interface: internal error in textual representation generation or mismatching interfaces between lhs and rhs." simplify :: Net -> Net simplify net = Net { agents = agents net , equations = eqs'' , interface = inter' , rules = rules net } where inter = interface net eqs' = simp [] (equations net) (eqs'', inter') = simp2 inter eqs' -- | @ simp @ removes equations of form @ a = X @ -- for something as @ X @ and for any @ a @ -- that don't belong to the interface, -- substituting the unique occurence of @ a @ -- in the others equations. simp :: [Equation] -- ^ the equations already folded -> [Equation] -- ^ the equations to fold -> [Equation] -- ^ the result simp eqsB [] = eqsB simp eqsB (eq@(Compound _, _) : eqsA) = simp (eqsB ++ [eq]) eqsA simp eqsB (eq@(Simple x , a) : eqsA) | Simple x `elem` inter = simp (eqsB ++ [eq]) eqsA | otherwise = simp eqsBS eqsAS where (eqsBS, eqsAS) = subst2 (Simple x) a eqsB eqsA -- | @ simp2 @ removes the equations of form @ a = X @ -- for something as @ X @ and for any @ a @ -- that belong to the interface, -- substituting @ a @ by @ X @ in the interface. simp2 :: Interface -> [Equation] -> ([Equation], Interface) simp2 i = foldl f2 ([],i) f2 :: ([Equation], Interface) -> Equation -> ([Equation], Interface) f2 (eqsB, i) (Simple x , a) | Simple x `elem` i = (eqsB, a : delete (Simple x) i) | otherwise = error "unexpected case in the simplification of a net: free edge don't belong to the interface" f2 (eqsB, i) eq = (eqsB ++ [eq], i) -- | It's known that exactly one occurency of the edge will be found -- in the equations (eqsB ++ eqsA). -- In the future the function will be optimize for this invariant. -- Now it simply transverse the whole tree and replaces in the correct place. subst2 :: Term -> Term -> [Equation] -> [Equation] -> ([Equation], [Equation]) subst2 (Compound _) _ _ _ = error "unexpected case" subst2 (Simple x) rhs eqsB eqsA = (subst eqsB, subst eqsA) where subst :: [Equation] -> [Equation] subst = map (substTerm >< substTerm) -- | Substitution in terms; t[rhs\/x] -- with t the first argument of substTerm -- the occurence of variable @ x @ in term @ t @ -- is replaced by term @ rhs @. substTerm (Simple a) | a == x = rhs | otherwise = Simple a substTerm (Compound c) = Compound . substNA $ c substNA (agent, args) = (agent, map substTerm args) filterRules :: Net -> Net filterRules net = net { equations = [], interface = [] } filterNet :: Net -> Net filterNet net = net { rules = []}