INblobs-0.1.1: src/Functional/Compiler.hs
{-|
Module : Functional.Compiler
Copyright : (c) Daniel Mendes and Miguel Vilaça 2007
Maintainer : danielgomesmendes@gmail.com and jmvilaca@di.uminho.pt
Stability : experimental
Portability : portable
Small Functional Language: Compiler -}
module Functional.Compiler ( compile) where
import Network
import InfoKind
import Palette
import Shape
import Document
import Ports
import Math
import List
import INRule
import INRules
import Common
import CommonUI
import Functional.Language
import Data.Maybe
import Data.List
import qualified Data.Map as Map
type Context = Map.Map Variable ConnectionPoint
data AgentType = Syntactical | Computational
-- | Given a strategy, a closed term and a list of names for iter agents,
-- update the document with the dynamic part of the IN system.
compile :: (Eq n, InfoKind n g, InfoKind e g) => g -> n -> e -> CallBy -> FuncLang -> [(FuncLang, String)] -> Document g n e -> IO (Document g n e)
compile g n e callBy term names doc
| callBy `elem` [Name,Value] =
-- add iter symbols
let symbs = foldr (\h r-> createIterSymbol Syntactical h : createIterSymbol Computational h :r) [] names
repeated = map fst symbs `intersect` (shapesNames $ getPalette doc)
in if null repeated
then
do
let doc1 = joinPalette (Palette symbs) doc
palette = getPalette doc1
tokenRules <- mapM (createIterTokenRule g n e palette) names
lrules <- mapM (createIterConstructorRules g n e palette names) names
return $ setNetwork (draw term names palette $ Network.empty g n e)
$ updateRules (++ tokenRules ++ concat lrules) doc1
else fail $ "Give different names to iter symbols. This ones are already in use:\n"
++ commasAnd repeated
| otherwise = fail "unknown strategy"
-- | Create the main net.
draw ::(InfoKind n g, InfoKind e g) => FuncLang -> [(FuncLang, String)] -> Palette n -> Network g n e -> Network g n e
draw t names p network = let (x,net) = addNode "interface" p network
(n,net1) = addNode "evaluation" p net
net2 = setNodePosition n (DoublePoint 15 1.03)
. setNodePosition x (DoublePoint 15 0.01)
. connectNodes p (x,"interface","interface") (n,"evaluation","res") $ net1
in iso p names (n,"evaluation","arg") (0,1.6) t Map.empty net2
-- | The \cal{T} function of the paper.
iso :: (InfoKind n g, InfoKind e g) => Palette n
-> [(FuncLang, String)] -- ^ list of names for Iter_TYPE symbols
-> ConnectionPoint -- point to connect the root of the IN term
-> (Double,Double) -- translation from connection node
-> FuncLang -- term to translate to INs
-> Context -- free variables and their respective connection points
-> Network g n e -- already constructed net
-> Network g n e -- resulting net
iso palette names point trans term ctx net = -- trace ("ISO: TERM: " ++ show term ++ " CTX: " ++ show (Map.keys ctx)) $
case term of
Var v -> case Map.lookup v ctx of
Just pointVar -> connectNodes palette point pointVar net
Nothing -> error $ "Internal Error: variable \"" ++ v ++ "\" is not in context " ++ show (Map.keys ctx)
Abst v t -> let (abstNr, net1) = addNode "lambda" palette net
net2 = connectNodes palette point (abstNr,"lambda","res")
. moveNode abstNr trans point
$ net1
abstPoint = translate (getNodePosition net2 abstNr) (DoublePoint (-1) 1)
(net3, ctx1) = if v `elem` (freeVars t)
then (net2, Map.insert v (abstNr,"lambda","var") ctx)
else let (eraseNr,net4) = addNode "Erase" palette net2
in (connectNodes palette (eraseNr,"Erase","down") (abstNr,"lambda","var")
$ setNodePosition eraseNr abstPoint net4, ctx)
in iso palette names (abstNr,"lambda","body") (1,1.2) t ctx1 net3
Appl t u -> createNet2 "beforeApplication" t "func" u "arg"
TT -> createNet0 "True"
FF -> createNet0 "False"
Zero -> createNet0 "Zero"
Succ t -> createNet1 "Succ" t "arg"
Nil -> createNet0 "Nil"
Cons t u -> createNet2 "Cons" t "head" u "tail"
iter@(IterBool v f b) -> createNetIter iter [(v, 'v'),(f, 'f')] b "arg"
iter@(IterNat x s z n) -> createNetIter iter [(Abst x s, 's'),(z, 'z')] n "arg"
iter@(IterList x y c n l) -> createNetIter iter [(Abst x $ Abst y c, 'c'),(n, 'n')] l "arg"
_ -> error "Internal Error: none exaustive patterns in function iso."
where
-- | Create a net with the agent of arity 0 and connect it to the given point.
-- createNet0 :: String -> Network g n e
createNet0 agentName = let (nr, net1) = addNode agentName palette net
in connectNodes palette point (nr,agentName,"res")
$ moveNode nr trans point net1
-- | Create a net with the agent of arity 1 and connect
-- it to the given point and to the translation of the subterm.
-- createNet1 :: String -> FuncLang -> PortName -> Network g n e
createNet1 agentName term portName =
let (nr, net1) = addNode agentName palette net
in iso palette names (nr,agentName,portName) (0,1) term ctx
. connectNodes palette point (nr,agentName,"res")
. moveNode nr trans point
$ net1
-- | Create a net with the agent of arity 2 and connect it to the given
-- point and to the subterms, taking care of shared variables.
-- createNet2 :: String -> FuncLang -> PortName -> FuncLang -> PortName -> Network g n e
createNet2 agentName tLeft portLeft tRight portRight =
let (nr, net1) = addNode agentName palette net
net2 = connectNodes palette point (nr,agentName,"res")
. moveNode nr trans point
$ net1
(net3, [ctxL,ctxR]) = shareCommonVariables palette [tLeft, tRight] ctx net2
in iso palette names (nr,agentName,portLeft) (-5,1) tLeft ctxL
. iso palette names (nr,agentName,portRight) (5,1) tRight ctxR
$ net3
-- | Create a net with the iter agent and connect it to the given
-- point and to the subterms, taking care of shared variables.
-- createNetIter :: FuncLang -- iter_TYPE term
-- -> [(FuncLang, Char)] -- list of sub terms and respective port prefixs
-- -> FuncLang -- middle (arg) sub term
-- -> PortName -- middle (arg) port name
-- -> Network g n e
createNetIter term l tMiddle portMiddle =
case lookupIterName term names of
Just agentName ->
let (nr, net1) = addNode agentName palette net
net2 = connectNodes palette point (nr,agentName,"res")
. moveNode nr trans point
$ net1
(terms,portPrefixs) = unzip l
(net3, ctxM:ctxs) = shareCommonVariables palette (tMiddle:terms) ctx net2
in iso palette names (nr,agentName,portMiddle) (0,1.5) tMiddle ctxM
. foldlCont (connect2Iter nr agentName) (zip portPrefixs ctxs)
$ net3
Nothing -> error $ "Internal Error: symbol " ++ show term ++ "not found in list of symbol's names."
-- connect2Iter :: (InfoKind e g) => NodeNr -> String -> Network g n e -> (Char,Context) -> Network g n e
connect2Iter nr agentName net (portPrefix, ctx) =
connectPorts palette portPrefix nr agentName ctx net
-- | Connect the set of ports with prefix 'pF' from given agent to the context.
connectPorts :: (InfoKind e g) => Palette n ->
Char -- port prefix
-> NodeNr -- iter agent
-> String -- iter agent
-> Context
-> Network g n e -> Network g n e
connectPorts palette pF iterNr iterAgent ctx net = Map.foldWithKey (connectIterZs iterNr) net ctx
where -- connectIterZs :: (InfoKind e g) => NodeNr
-- -> Variable -> ConnectionPoint -> Network g n e
-- -> Network g n e
connectIterZs iterNr var point net =
connectNodes palette (iterNr,iterAgent,pF:'_':var) point net
type RichCtx = Map.Map Variable [ConnectionPoint]
-- | Add as many copy agents as necessary for variables that are shared between sub-terms.
shareCommonVariables :: (InfoKind n g,InfoKind e g) =>
Palette n
-> [FuncLang] -- list of n subterms
-> Context
-> Network g n e
-> (Network g n e, [Context]) -- new net with necessary copy agents
-- and n contexts: respectively for each subterm
shareCommonVariables palette l ctx net =
let
lVars = map freeVars l
(net1, richCtx) =
Map.mapAccumWithKey copyPointInNet net . Map.mapWithKey count $ ctx
in (net1, snd $ mapAccumL subTermCtx richCtx lVars)
where
lVars = map freeVars l
count :: Variable -> ConnectionPoint -> (Int, ConnectionPoint)
count var point = (length $ findIndices (var `elem`) lVars, point)
-- copyPointInNet :: (InfoKind n g,InfoKind e g) =>
-- Network g n e -> Variable -> (Int, ConnectionPoint)
-- -> (Network g n e, [ConnectionPoint])
copyPointInNet net _ (0, point) = error "Internal Error in copyPointInNet"
copyPointInNet net _ (1, point) = (net, [point])
copyPointInNet net v (n, point) =
let (nNr, net1) = addNode "copy" palette net
m = n `div` 2
net2 = moveNode nNr (-1.5,1) point
$ connectNodes palette point (nNr,"copy","src") net1
(netL, pointsL) = copyPointInNet net2 v (m , (nNr,"copy","fst_target"))
(netR, pointsR) = copyPointInNet netL v (n-m, (nNr,"copy","snd_target"))
in (netR, pointsL ++ pointsR)
subTermCtx :: RichCtx -> [Variable] -> (RichCtx, Context)
subTermCtx richctx = (id >< Map.fromList) . mapAccumL variableCtx richctx
variableCtx :: RichCtx -> Variable -> (RichCtx, (Variable,ConnectionPoint))
variableCtx richctx var = (Map.adjust tail var richctx, (var, head $ richctx Map.! var))
-- | Connect unused variables to erase agents.
closeEpsilon ::(InfoKind n g, InfoKind e g) => Palette n -> Context -> Network g n e -> Network g n e
closeEpsilon pal ctx net = Map.fold aux net ctx
where
-- aux :: ConnectionPoint -> Network g n e -> Network g n e
aux point nt = let (node_nr, n_nt) = addNode "Erase" pal nt
in connectNodes pal point (node_nr,"Erase","down")
. moveNode node_nr (0,-1) point
$ n_nt
createIterSymbol :: AgentType -> (FuncLang, String) -> (String, (Shape, Ports, Maybe a))
createIterSymbol at (term, name) = (name2, (shape, ports, Nothing))
where
(x,y) = (1.0, 1.0)
topPosition = DoublePoint 0.0 (-y)
name2 = case at of
Syntactical -> name
Computational -> '^':name
shape =
case at of
Syntactical -> -- triangle with text
Composite { shapeSegments =
[ Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1
, styleStrokeColour = licorice
, styleFill = lightRed }
, shapePerimeter = [topPosition, DoublePoint (-x) 0.3, DoublePoint x 0.3] }
, Text { shapeStyle = defaultShapeStyle
, shapeText = name }
] }
Computational -> -- circle
TextInEllipse { shapeStyle = ShapeStyle { styleStrokeWidth = 1
, styleStrokeColour = licorice
, styleFill = lightRed }
, shapeText = name }
(resP,argP) = case at of
Syntactical -> (("res", topPosition),("arg", DoublePoint 0.0 0.3))
Computational -> (("arg", DoublePoint 0.0 0.3),("res", topPosition))
ports =
case term of
IterBool v f (Var "") -> resP: portsFrom (-x) 'v' v ++ argP: portsFrom x 'f' f
IterNat a s z (Var "") -> resP: portsFrom (-x) 's' (Abst a s) ++ argP: portsFrom x 'z' z
IterList a b c n (Var "") -> resP: portsFrom (-x) 'c' (Abst a $ Abst b c) ++ argP: portsFrom x 'n' n
_ -> error "unexpected case"
portsFrom :: Double -> Char -> FuncLang -> [Port]
portsFrom pos char term = snd . mapAccumL (createPort char desc) pos $ freeVars term
where desc = (signum pos) * (-0.3)
createPort :: Char -> Double -> Double -> String -> (Double, Port)
createPort c desc x str = (x + desc, (c:'_':str, DoublePoint x 0.3))
createIterTokenRule :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> (FuncLang, String) -> IO (INRule g n e)
createIterTokenRule g n e palette (_, agent) =
do
(rule,nNr1,nNr2) <- createRuleWizard g n e palette "evaluation" agent
portsEval <- getSymbolPorts "evaluation" palette
return . updateRHS (f (map fst portsEval) ('^':agent) nNr1 nNr2) $ copyLHS2RHS rule
where
-- f :: (InfoKind e g) => [PortName] -> ShapeName -> NodeNr -> NodeNr -> Network g n e -> Network g n e
f ["arg","res"] shape2 nNr1 nNr2 net =
let pos1 = getNodePosition net nNr1
pos2 = getNodePosition net nNr2
mid = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr1 "arg"
top = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr1 "res"
bot = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr2 "arg"
arc1 = fromJust $ edgeConnectedOnPort net nNr1 "arg"
arc2 = fromJust $ edgeConnectedOnPort net nNr1 "res"
arc3 = fromJust $ edgeConnectedOnPort net nNr2 "arg"
in addEdges palette
[ ((nNr2,"arg"),(nNr1,"res")) -- (iter,arg) |-> (token,res)
, (top,(nNr2,"res")) -- top interface |-> (iter,res)
, ((nNr1,"arg"), bot) -- (token,arg) |-> bottom interface
]
. removeEdge arc1 . removeEdge arc2 . removeEdge arc3
. setNodeShape nNr2 shape2 -- change symbol iter to ^iter
. setNodePosition nNr1 pos2 . setNodePosition nNr2 pos1 -- swap positions
$ net
f _ _ _ _ _ = error $ "Internal Error: creating rule for token and " ++ agent
createIterConstructorRules :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> [(FuncLang, String)] -> (FuncLang, String) -> IO (INRules g n e)
createIterConstructorRules g n e palette names (term, agent) =
mapM (createIterConstructorRule g n e palette names (term, agent) ) constructorAgents
where constructorAgents = case term of
IterBool _ _ (Var "") -> ["True","False"]
IterNat _ _ _ (Var "") -> ["Zero","Succ"]
IterList _ _ _ _ (Var "") -> ["Nil","Cons"]
-- new Iterators
_ -> error "Internal Error: iterator term expected and something different found."
data InterfaceID =
RES ConnectionPoint
| SuccArg ConnectionPoint
| ConsHead ConnectionPoint
| ConsTail ConnectionPoint
| IterBoolV Context
| IterBoolF Context
| IterNatS Context
| IterNatZ Context
| IterListC Context
| IterListN Context
deriving(Eq,Ord,Show)
equalIID :: InterfaceID -> InterfaceID -> Bool
equalIID (RES _) (RES _) = True
equalIID (SuccArg _) (SuccArg _) = True
equalIID (ConsHead _) (ConsHead _) = True
equalIID (ConsTail _) (ConsTail _) = True
equalIID (IterBoolV _) (IterBoolV _) = True
equalIID (IterBoolF _) (IterBoolF _) = True
equalIID (IterNatS _) (IterNatS _) = True
equalIID (IterNatZ _) (IterNatZ _) = True
equalIID (IterListC _) (IterListC _) = True
equalIID (IterListN _) (IterListN _) = True
equalIID _ _ = False
createIterConstructorRule :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> [(FuncLang, String)] -> (FuncLang, String) -> String -> IO (INRule g n e)
createIterConstructorRule g n e palette names (term, agent) agent2 =
do
(rule,nNr1,nNr2) <- createRuleWizard g n e palette ('^':agent) agent2
let lhs = getLHS rule
(_:lPorts1) = map fst . maybe (error "Internal Error: unexpected Nothing") id $ getPorts palette lhs nNr1
(_:lPorts2) = map fst . maybe (error "Internal Error: unexpected Nothing") id $ getPorts palette lhs nNr2
groupedInterfaces = groupInterfaces lhs (nNr1, lPorts1) (nNr2, lPorts2)
return . updateRHS (makeRHS term agent agent2 groupedInterfaces) $ copyLHSInterface2RHS rule
where
groupInterfaces :: Network g n e -> (NodeNr, [PortName]) -> (NodeNr, [PortName])
-> [InterfaceID]
groupInterfaces lhs (nNr1, auxPorts1) (nNr2, auxPorts2) =
sort (f4 nNr1 auxPorts1) ++ f4 nNr2 auxPorts2
where
f4 :: NodeNr -> [PortName] -> [InterfaceID]
f4 nNr = map (f3 lhs nNr) . groupBy aux
f3 :: Network g n e -> NodeNr -> [PortName] -> InterfaceID
f3 net nNr = aux3
where
aux3 [p@"res" ] = RES $ f2 p
aux3 [p@"head"] = ConsHead $ f2 p
aux3 [p@"tail"] = ConsTail $ f2 p
aux3 [p@"arg" ] = SuccArg $ f2 p
aux3 l@(('v':'_':_):_) = IterBoolV . f6 $ l
aux3 l@(('f':'_':_):_) = IterBoolF . f6 $ l
aux3 l@(('s':'_':_):_) = IterNatS . f6 $ l
aux3 l@(('z':'_':_):_) = IterNatZ . f6 $ l
aux3 l@(('c':'_':_):_) = IterListC . f6 $ l
aux3 l@(('n':'_':_):_) = IterListN . f6 $ l
aux3 _ = error "Internal Error in aux3"
f2 :: PortName -> ConnectionPoint
f2 = f4 . maybe (error "Internal Error: unexpected Nothing") id . otherExtremeOfEdgeConnectedOnPort net nNr
f4 (nNr,"interface") = (nNr,"interface","interface")
f4 _ = error "Internal Error: unexpected agent"
f5 (_:'_':portName) = portName
f5 _ = error "Internal Error: unexpected port name"
f6 = Map.fromList . map (f5 /\ f2)
-- makeRHS :: FuncLang -> String -> String -> [InterfaceID] -> Network g n e -> Network g n e
makeRHS term iterAgent consAgent (RES interfacePoint:lInters) net =
let (conE,net1) = connectToken palette interfacePoint net
in reallyMakeRHS palette names term iterAgent consAgent lInters conE net1
makeRHS _ _ _ _ _ = error "Internal Error making RHS."
-- | Add a token agent and connect its auxiliar port to the given point.
connectToken :: (InfoKind n g, InfoKind e g) => Palette n -> ConnectionPoint -> Network g n e -> (ConnectionPoint, Network g n e)
connectToken palette topPoint net =
let (nNrE, net1) = addNode "evaluation" palette net -- add token agent
in ( (nNrE,"evaluation","arg")
, connectNodes palette (nNrE, "evaluation", "res") topPoint -- (token, res) |-> topPoint
. moveNode nNrE (0,1) topPoint
$ net1 )
aux :: PortName -> PortName -> Bool
aux (c1:'_':_) (c2:'_':_) = c1 == c2
aux _ _ = False
-- | Creates the network that is the RHS of rule for given symbols.
-- See interaction rules for iterators in paper
-- "Encoding Iterators in Interaction Nets" for more details.
reallyMakeRHS :: (InfoKind n g, InfoKind e g)
=> Palette n
-> [(FuncLang, String)]
-> FuncLang -- Iter_TYPE args (Var "")
-> String -- iter agent name
-> String -- constructor agent name
-> [InterfaceID] -> ConnectionPoint
-> Network g n e -> Network g n e
reallyMakeRHS palette names term iterAgent const l point =
case (term, const) of
(IterBool v _ (Var ""), "True") ->
case emptyfy l [IterBoolV emp, IterBoolF emp] of
[IterBoolV ctxV, IterBoolF ctxF] -> simpleRHS palette names point ctxV ctxF v
_ -> error "Internal Error: unexpected [InterfaceID]"
(IterBool _ f (Var ""), "False") ->
case emptyfy l [IterBoolV emp, IterBoolF emp] of
[IterBoolV ctxV, IterBoolF ctxF] -> simpleRHS palette names point ctxF ctxV f
_ -> error "Internal Error: unexpected [InterfaceID]"
(IterNat _ _ z (Var ""), "Zero") ->
case emptyfy l [IterNatS emp, IterNatZ emp] of
[IterNatS ctxS, IterNatZ ctxZ] -> simpleRHS palette names point ctxZ ctxS z
_ -> error "Internal Error: unexpected [InterfaceID]"
(IterNat x s _ (Var ""), "Succ") ->
case emptyfy l [IterNatS emp, IterNatZ emp, SuccArg undef] of
[IterNatS ctxS, IterNatZ ctxZ, SuccArg pSucArg] ->
oneRecursiveCallRHS palette names point ctxS emp ctxZ pSucArg x s iterAgent 'z' 's'
_ -> error "Internal Error: unexpected [InterfaceID]"
(IterList _ _ _ n (Var ""), "Nil") ->
case emptyfy l [IterListC emp, IterListN emp] of
[IterListC ctxC, IterListN ctxN] -> simpleRHS palette names point ctxN ctxC n
_ -> error "Internal Error: unexpected [InterfaceID]"
(IterList x y c _ (Var ""), "Cons") ->
case emptyfy l [IterListC emp, IterListN emp, ConsHead undef, ConsTail undef] of
[IterListC ctxC, IterListN ctxN, ConsHead pConsHead, ConsTail pConsTail] ->
oneRecursiveCallRHS palette names point ctxC (Map.singleton x pConsHead) ctxN pConsTail y c iterAgent 'n' 'c'
_ -> error "Internal Error: unexpected [InterfaceID]"
_ -> error "Undefined case making RHS."
where emp = Map.empty
undef = (0,"INVALID NODE","")
emptyfy :: [InterfaceID] -> [InterfaceID] -> [InterfaceID]
emptyfy given needed = map (\e -> maybe e id $ find (equalIID e) given ) needed
-- | Defines a simple RHS that evaluates the translation of term t
-- connecting its free variables to the corresponding interface agents
-- and connects the remaing interface agents to erase agents.
-- For example RHS for rule IterBool |X| TT that is
-- \TOKEN(T(V))
simpleRHS :: (InfoKind n g, InfoKind e g)
=> Palette n
-> [(FuncLang, String)]
-> ConnectionPoint
-> Context -- context to connect
-> Context -- context to erase
-> FuncLang -- term to translate
-> Network g n e -> Network g n e
simpleRHS palette names point goodCtx eraCtx term = -- trace ("simpleRHS: POINT: " ++ show point ++ " GOODCTX" ++ show (Map.keys goodCtx) ++ " ERACTX: " ++ show (Map.keys eraCtx) ++" TERM: " ++ show term ) $
iso palette names point (2,0) term goodCtx
. closeEpsilon palette eraCtx
-- | Defines a RHS with one recursive call.
-- Like IterNat |X| suc or IterList |X| cons
oneRecursiveCallRHS :: (InfoKind n g, InfoKind e g)
=> Palette n
-> [(FuncLang, String)]
-> ConnectionPoint -- (token, arg) port to connect generated net
-> Context -- context to connect to copy
-> Context -- context to pass to translate function; refers to arguments of constructor
-> Context -- context to connect to iterator
-> ConnectionPoint -- interface for place to apply recursion
-> Variable -- variable that represents result of recursive call
-> FuncLang -- term to translate
-> String -- Iterator agent name
-> Char -- port prefix for final elements
-> Char -- port prefix for cont elements
-> Network g n e -> Network g n e
oneRecursiveCallRHS palette names topPoint copyCtx argCtx stopCtx argPoint var term iterAgent pF pC net =
let (newNet, newCtx) =
if var `elem` lFreeVars
then
let
(iterNr,net1) = addNode iterAgent palette net -- add iter agent
(net2, ctxNew) = Map.mapAccumWithKey (connectCopies iterNr) net1 copyCtx -- (Iter, FV(S)) |-> (copy, snd_target)
-- (copy, src) |-> copyCtx
in ( connectNodes palette (iterNr,iterAgent,"arg") argPoint -- (Iter, arg) |-> argInterface
. connectPorts palette pF iterNr iterAgent stopCtx -- (Iter, FV(Z)) |-> stopCtx
. moveNode iterNr (0,-1) argPoint
$ net2, Map.insert var (iterNr,iterAgent,"res") ctxNew )
else (closeEpsilon palette (Map.insert "" argPoint stopCtx) net, copyCtx)
(frees, dontExist) = Map.partitionWithKey aux argCtx
in iso palette names topPoint (2,0.7) term (frees `Map.union` newCtx)
. closeEpsilon palette dontExist
$ newNet
where
lFreeVars = freeVars term
-- connectCopies :: NodeNr -> Network g n e -> Variable -> ConnectionPoint -> (Network g n e, ConnectionPoint)
connectCopies iterNr net var point =
let (copyNr,net1) = addNode "copy" palette net
in (connectNodes palette (iterNr,iterAgent,pC:'_':var) (copyNr,"copy","snd_target")
. connectNodes palette (copyNr,"copy","src") point
. moveNode copyNr (0,-0.8) point
$ net1, (copyNr,"copy","fst_target") )
aux var _ = var `elem` lFreeVars
type ConnectionPoint = ( NodeNr
, ShapeName
, PortName
)
-- | Connect a port in a node to another.
connectNodes :: (InfoKind e g) => Palette n -> ConnectionPoint -> ConnectionPoint -> Network g n e -> Network g n e
connectNodes palette (nrFrom, shapeFrom, portFrom) (nrTo, shapeTo, portTo) net =
case (getNodeShape net nrFrom, getNodeShape net nrTo) of
(str1, str2) | str1 == shapeFrom && str2 == shapeTo ->
case (getPorts palette net nrFrom, getPorts palette net nrTo) of
(Just portsFrom, Just portsTo) ->
case (Data.List.lookup portFrom portsFrom, Data.List.lookup portTo portsTo) of
(Just _, Just _) ->
addEdge palette nrFrom portFrom nrTo portTo net
(Nothing,_) -> error $ "Port \"" ++ portFrom ++ "\" do not exist in symbol \"" ++ shapeFrom ++ "\"."
(_,Nothing) -> error $ "Port \"" ++ portTo ++ "\" do not exist in symbol \"" ++ shapeTo ++ "\"."
_ -> error "No ports."
_ -> error "Shapes do not coincide."
-- | Move first node to position @(dx,dy)@ relatively to reference point position.
moveNode :: NodeNr -> (Double,Double) -> ConnectionPoint -> Network g n e -> Network g n e
moveNode node (dx,dy) refPoint net =
setNodePosition node ( translate (DoublePoint dx dy)
$ getNodePosition net $ fst3 refPoint)
net