INblobs-0.1.1: src/INTextual.hs
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, <interface | equations>) 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 = []}