darcs - INblobs

37 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)

38 compile g n e callBy term names doc

39 | callBy `elem` [Name,Value] =

40 -- add iter symbols

41 let symbs = foldr (\h r-> createIterSymbol Syntactical h : createIterSymbol Computational h :r) [] names

42 repeated = map fst symbs `intersect` (shapesNames $ getPalette doc)

43 in if null repeated

44 then

45 do

46 let doc1 = joinPalette (Palette symbs) doc

47 palette = getPalette doc1

48 tokenRules <- mapM (createIterTokenRule g n e palette) names

49 lrules <- mapM (createIterConstructorRules g n e palette names) names

50 return $ setNetwork (draw term names palette $ Network.empty g n e)

51 $ updateRules (++ tokenRules ++ concat lrules) doc1

52 else fail $ "Give different names to iter symbols. This ones are already in use:\n"

53 ++ commasAnd repeated

54

55 | otherwise = fail "unknown strategy"

56

57

58 -- | Create the main net.

59 draw ::(InfoKind n g, InfoKind e g) => FuncLang -> [(FuncLang, String)] -> Palette n -> Network g n e -> Network g n e

60 draw t names p network = let (x,net) = addNode "interface" p network

61 (n,net1) = addNode "evaluation" p net

62 net2 = setNodePosition n (DoublePoint 15 1.03)

63 . setNodePosition x (DoublePoint 15 0.01)

64 . connectNodes p (x,"interface","interface") (n,"evaluation","res") $ net1

65 in iso p names (n,"evaluation","arg") (0,1.6) t Map.empty net2

66

67 -- | The \cal{T} function of the paper.

68 iso :: (InfoKind n g, InfoKind e g) => Palette n

69 -> [(FuncLang, String)] -- ^ list of names for Iter_TYPE symbols

70 -> ConnectionPoint -- point to connect the root of the IN term

71 -> (Double,Double) -- translation from connection node

72 -> FuncLang -- term to translate to INs

73 -> Context -- free variables and their respective connection points

74 -> Network g n e -- already constructed net

75 -> Network g n e -- resulting net

76 iso palette names point trans term ctx net = -- trace ("ISO: TERM: " ++ show term ++ " CTX: " ++ show (Map.keys ctx)) $

77 case term of

78 Var v -> case Map.lookup v ctx of

79 Just pointVar -> connectNodes palette point pointVar net

80 Nothing -> error $ "Internal Error: variable \"" ++ v ++ "\" is not in context " ++ show (Map.keys ctx)

81

82 Abst v t -> let (abstNr, net1) = addNode "lambda" palette net

83 net2 = connectNodes palette point (abstNr,"lambda","res")

84 . moveNode abstNr trans point

85 $ net1

86 abstPoint = translate (getNodePosition net2 abstNr) (DoublePoint (-1) 1)

87 (net3, ctx1) = if v `elem` (freeVars t)

88 then (net2, Map.insert v (abstNr,"lambda","var") ctx)

89 else let (eraseNr,net4) = addNode "Erase" palette net2

90 in (connectNodes palette (eraseNr,"Erase","down") (abstNr,"lambda","var")

91 $ setNodePosition eraseNr abstPoint net4, ctx)

92 in iso palette names (abstNr,"lambda","body") (1,1.2) t ctx1 net3

93

94 Appl t u -> createNet2 "beforeApplication" t "func" u "arg"

95 TT -> createNet0 "True"

96 FF -> createNet0 "False"

97 Zero -> createNet0 "Zero"

98 Succ t -> createNet1 "Succ" t "arg"

99 Nil -> createNet0 "Nil"

100 Cons t u -> createNet2 "Cons" t "head" u "tail"

101 iter@(IterBool v f b) -> createNetIter iter [(v, 'v'),(f, 'f')] b "arg"

102 iter@(IterNat x s z n) -> createNetIter iter [(Abst x s, 's'),(z, 'z')] n "arg"

103 iter@(IterList x y c n l) -> createNetIter iter [(Abst x $ Abst y c, 'c'),(n, 'n')] l "arg"

104 _ -> error "Internal Error: none exaustive patterns in function iso."

105 where

106 -- | Create a net with the agent of arity 0 and connect it to the given point.

107 -- createNet0 :: String -> Network g n e

108 createNet0 agentName = let (nr, net1) = addNode agentName palette net

109 in connectNodes palette point (nr,agentName,"res")

110 $ moveNode nr trans point net1

111

112 -- | Create a net with the agent of arity 1 and connect

113 -- it to the given point and to the translation of the subterm.

114 -- createNet1 :: String -> FuncLang -> PortName -> Network g n e

115 createNet1 agentName term portName =

116 let (nr, net1) = addNode agentName palette net

117 in iso palette names (nr,agentName,portName) (0,1) term ctx

118 . connectNodes palette point (nr,agentName,"res")

119 . moveNode nr trans point

120 $ net1

121

122 -- | Create a net with the agent of arity 2 and connect it to the given

123 -- point and to the subterms, taking care of shared variables.

124 -- createNet2 :: String -> FuncLang -> PortName -> FuncLang -> PortName -> Network g n e

125 createNet2 agentName tLeft portLeft tRight portRight =

126 let (nr, net1) = addNode agentName palette net

127 net2 = connectNodes palette point (nr,agentName,"res")

128 . moveNode nr trans point

129 $ net1

130 (net3, [ctxL,ctxR]) = shareCommonVariables palette [tLeft, tRight] ctx net2

131 in iso palette names (nr,agentName,portLeft) (-5,1) tLeft ctxL

132 . iso palette names (nr,agentName,portRight) (5,1) tRight ctxR

133 $ net3

134

135 -- | Create a net with the iter agent and connect it to the given

136 -- point and to the subterms, taking care of shared variables.

137 -- createNetIter :: FuncLang -- iter_TYPE term

138 -- -> [(FuncLang, Char)] -- list of sub terms and respective port prefixs

139 -- -> FuncLang -- middle (arg) sub term

140 -- -> PortName -- middle (arg) port name

141 -- -> Network g n e

142 createNetIter term l tMiddle portMiddle =

143 case lookupIterName term names of

144 Just agentName ->

145 let (nr, net1) = addNode agentName palette net

146 net2 = connectNodes palette point (nr,agentName,"res")

147 . moveNode nr trans point

148 $ net1

149 (terms,portPrefixs) = unzip l

150 (net3, ctxM:ctxs) = shareCommonVariables palette (tMiddle:terms) ctx net2

151 in iso palette names (nr,agentName,portMiddle) (0,1.5) tMiddle ctxM

152 . foldlCont (connect2Iter nr agentName) (zip portPrefixs ctxs)

153 $ net3

154 Nothing -> error $ "Internal Error: symbol " ++ show term ++ "not found in list of symbol's names."

155

156 -- connect2Iter :: (InfoKind e g) => NodeNr -> String -> Network g n e -> (Char,Context) -> Network g n e

157 connect2Iter nr agentName net (portPrefix, ctx) =

158 connectPorts palette portPrefix nr agentName ctx net

159

160 -- | Connect the set of ports with prefix 'pF' from given agent to the context.

161 connectPorts :: (InfoKind e g) => Palette n ->

162 Char -- port prefix

163 -> NodeNr -- iter agent

164 -> String -- iter agent

165 -> Context

166 -> Network g n e -> Network g n e

167 connectPorts palette pF iterNr iterAgent ctx net = Map.foldWithKey (connectIterZs iterNr) net ctx

168 where -- connectIterZs :: (InfoKind e g) => NodeNr

169 -- -> Variable -> ConnectionPoint -> Network g n e

170 -- -> Network g n e

171 connectIterZs iterNr var point net =

172 connectNodes palette (iterNr,iterAgent,pF:'_':var) point net

173

174

175 type RichCtx = Map.Map Variable [ConnectionPoint]

176

177 -- | Add as many copy agents as necessary for variables that are shared between sub-terms.

178 shareCommonVariables :: (InfoKind n g,InfoKind e g) =>

179 Palette n

180 -> [FuncLang] -- list of n subterms

181 -> Context

182 -> Network g n e

183 -> (Network g n e, [Context]) -- new net with necessary copy agents

184 -- and n contexts: respectively for each subterm

185 shareCommonVariables palette l ctx net =

186 let

187 lVars = map freeVars l

188 (net1, richCtx) =

189 Map.mapAccumWithKey copyPointInNet net . Map.mapWithKey count $ ctx

190 in (net1, snd $ mapAccumL subTermCtx richCtx lVars)

191 where

192 lVars = map freeVars l

193

194 count :: Variable -> ConnectionPoint -> (Int, ConnectionPoint)

195 count var point = (length $ findIndices (var `elem`) lVars, point)

196

197 -- copyPointInNet :: (InfoKind n g,InfoKind e g) =>

198 -- Network g n e -> Variable -> (Int, ConnectionPoint)

199 -- -> (Network g n e, [ConnectionPoint])

200 copyPointInNet net _ (0, point) = error "Internal Error in copyPointInNet"

201 copyPointInNet net _ (1, point) = (net, [point])

202 copyPointInNet net v (n, point) =

203 let (nNr, net1) = addNode "copy" palette net

204 m = n `div` 2

205 net2 = moveNode nNr (-1.5,1) point

206 $ connectNodes palette point (nNr,"copy","src") net1

207 (netL, pointsL) = copyPointInNet net2 v (m , (nNr,"copy","fst_target"))

208 (netR, pointsR) = copyPointInNet netL v (n-m, (nNr,"copy","snd_target"))

209 in (netR, pointsL ++ pointsR)

210

211

212

213 subTermCtx :: RichCtx -> [Variable] -> (RichCtx, Context)

214 subTermCtx richctx = (id >< Map.fromList) . mapAccumL variableCtx richctx

215

216 variableCtx :: RichCtx -> Variable -> (RichCtx, (Variable,ConnectionPoint))

217 variableCtx richctx var = (Map.adjust tail var richctx, (var, head $ richctx Map.! var))

218

219 -- | Connect unused variables to erase agents.

220 closeEpsilon ::(InfoKind n g, InfoKind e g) => Palette n -> Context -> Network g n e -> Network g n e

221 closeEpsilon pal ctx net = Map.fold aux net ctx

222 where

223 -- aux :: ConnectionPoint -> Network g n e -> Network g n e

224 aux point nt = let (node_nr, n_nt) = addNode "Erase" pal nt

225 in connectNodes pal point (node_nr,"Erase","down")

226 . moveNode node_nr (0,-1) point

227 $ n_nt

228

229 createIterSymbol :: AgentType -> (FuncLang, String) -> (String, (Shape, Ports, Maybe a))

230 createIterSymbol at (term, name) = (name2, (shape, ports, Nothing))

231 where

232 (x,y) = (1.0, 1.0)

233 topPosition = DoublePoint 0.0 (-y)

234 name2 = case at of

235 Syntactical -> name

236 Computational -> '^':name

237 shape =

238 case at of

239 Syntactical -> -- triangle with text

240 Composite { shapeSegments =

241 [ Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1

242 , styleStrokeColour = licorice

243 , styleFill = lightRed }

244 , shapePerimeter = [topPosition, DoublePoint (-x) 0.3, DoublePoint x 0.3] }

245 , Text { shapeStyle = defaultShapeStyle

246 , shapeText = name }

247 ] }

248 Computational -> -- circle

249 TextInEllipse { shapeStyle = ShapeStyle { styleStrokeWidth = 1

250 , styleStrokeColour = licorice

251 , styleFill = lightRed }

252 , shapeText = name }

253 (resP,argP) = case at of

254 Syntactical -> (("res", topPosition),("arg", DoublePoint 0.0 0.3))

255 Computational -> (("arg", DoublePoint 0.0 0.3),("res", topPosition))

256

257 ports =

258 case term of

259 IterBool v f (Var "") -> resP: portsFrom (-x) 'v' v ++ argP: portsFrom x 'f' f

260 IterNat a s z (Var "") -> resP: portsFrom (-x) 's' (Abst a s) ++ argP: portsFrom x 'z' z

261 IterList a b c n (Var "") -> resP: portsFrom (-x) 'c' (Abst a $ Abst b c) ++ argP: portsFrom x 'n' n

262 _ -> error "unexpected case"

263 portsFrom :: Double -> Char -> FuncLang -> [Port]

264 portsFrom pos char term = snd . mapAccumL (createPort char desc) pos $ freeVars term

265 where desc = (signum pos) * (-0.3)

266

267 createPort :: Char -> Double -> Double -> String -> (Double, Port)

268 createPort c desc x str = (x + desc, (c:'_':str, DoublePoint x 0.3))

269

270 createIterTokenRule :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> (FuncLang, String) -> IO (INRule g n e)

271 createIterTokenRule g n e palette (_, agent) =

272 do

273 (rule,nNr1,nNr2) <- createRuleWizard g n e palette "evaluation" agent

274 portsEval <- getSymbolPorts "evaluation" palette

275 return . updateRHS (f (map fst portsEval) ('^':agent) nNr1 nNr2) $ copyLHS2RHS rule

276 where

277 -- f :: (InfoKind e g) => [PortName] -> ShapeName -> NodeNr -> NodeNr -> Network g n e -> Network g n e

278 f ["arg","res"] shape2 nNr1 nNr2 net =

279 let pos1 = getNodePosition net nNr1

280 pos2 = getNodePosition net nNr2

281 mid = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr1 "arg"

282 top = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr1 "res"

283 bot = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr2 "arg"

284 arc1 = fromJust $ edgeConnectedOnPort net nNr1 "arg"

285 arc2 = fromJust $ edgeConnectedOnPort net nNr1 "res"

286 arc3 = fromJust $ edgeConnectedOnPort net nNr2 "arg"

287

288 in addEdges palette

289 [ ((nNr2,"arg"),(nNr1,"res")) -- (iter,arg) |-> (token,res)

290 , (top,(nNr2,"res")) -- top interface |-> (iter,res)

291 , ((nNr1,"arg"), bot) -- (token,arg) |-> bottom interface

292 ]

293 . removeEdge arc1 . removeEdge arc2 . removeEdge arc3

294 . setNodeShape nNr2 shape2 -- change symbol iter to ^iter

295 . setNodePosition nNr1 pos2 . setNodePosition nNr2 pos1 -- swap positions

296 $ net

297 f _ _ _ _ _ = error $ "Internal Error: creating rule for token and " ++ agent

298

299 createIterConstructorRules :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> [(FuncLang, String)] -> (FuncLang, String) -> IO (INRules g n e)

300 createIterConstructorRules g n e palette names (term, agent) =

301 mapM (createIterConstructorRule g n e palette names (term, agent) ) constructorAgents

302 where constructorAgents = case term of

303 IterBool _ _ (Var "") -> ["True","False"]

304 IterNat _ _ _ (Var "") -> ["Zero","Succ"]

305 IterList _ _ _ _ (Var "") -> ["Nil","Cons"]

306 -- new Iterators

307 _ -> error "Internal Error: iterator term expected and something different found."

308

309

310 data InterfaceID =

311 RES ConnectionPoint

312 | SuccArg ConnectionPoint

313 | ConsHead ConnectionPoint

314 | ConsTail ConnectionPoint

315 | IterBoolV Context

316 | IterBoolF Context

317 | IterNatS Context

318 | IterNatZ Context

319 | IterListC Context

320 | IterListN Context

321 deriving(Eq,Ord,Show)

322

323 equalIID :: InterfaceID -> InterfaceID -> Bool

324 equalIID (RES _) (RES _) = True

325 equalIID (SuccArg _) (SuccArg _) = True

326 equalIID (ConsHead _) (ConsHead _) = True

327 equalIID (ConsTail _) (ConsTail _) = True

328 equalIID (IterBoolV _) (IterBoolV _) = True

329 equalIID (IterBoolF _) (IterBoolF _) = True

330 equalIID (IterNatS _) (IterNatS _) = True

331 equalIID (IterNatZ _) (IterNatZ _) = True

332 equalIID (IterListC _) (IterListC _) = True

333 equalIID (IterListN _) (IterListN _) = True

334 equalIID _ _ = False

335

336 createIterConstructorRule :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> [(FuncLang, String)] -> (FuncLang, String) -> String -> IO (INRule g n e)

337 createIterConstructorRule g n e palette names (term, agent) agent2 =

338 do

339 (rule,nNr1,nNr2) <- createRuleWizard g n e palette ('^':agent) agent2

340 let lhs = getLHS rule

341 (_:lPorts1) = map fst . maybe (error "Internal Error: unexpected Nothing") id $ getPorts palette lhs nNr1

342 (_:lPorts2) = map fst . maybe (error "Internal Error: unexpected Nothing") id $ getPorts palette lhs nNr2

343 groupedInterfaces = groupInterfaces lhs (nNr1, lPorts1) (nNr2, lPorts2)

344

345 return . updateRHS (makeRHS term agent agent2 groupedInterfaces) $ copyLHSInterface2RHS rule

346 where

347 groupInterfaces :: Network g n e -> (NodeNr, [PortName]) -> (NodeNr, [PortName])

348 -> [InterfaceID]

349 groupInterfaces lhs (nNr1, auxPorts1) (nNr2, auxPorts2) =

350 sort (f4 nNr1 auxPorts1) ++ f4 nNr2 auxPorts2

351 where

352 f4 :: NodeNr -> [PortName] -> [InterfaceID]

353 f4 nNr = map (f3 lhs nNr) . groupBy aux

354

355 f3 :: Network g n e -> NodeNr -> [PortName] -> InterfaceID

356 f3 net nNr = aux3

357 where

358 aux3 [p@"res" ] = RES $ f2 p

359 aux3 [p@"head"] = ConsHead $ f2 p

360 aux3 [p@"tail"] = ConsTail $ f2 p

361 aux3 [p@"arg" ] = SuccArg $ f2 p

362 aux3 l@(('v':'_':_):_) = IterBoolV . f6 $ l

363 aux3 l@(('f':'_':_):_) = IterBoolF . f6 $ l

364 aux3 l@(('s':'_':_):_) = IterNatS . f6 $ l

365 aux3 l@(('z':'_':_):_) = IterNatZ . f6 $ l

366 aux3 l@(('c':'_':_):_) = IterListC . f6 $ l

367 aux3 l@(('n':'_':_):_) = IterListN . f6 $ l

368 aux3 _ = error "Internal Error in aux3"

369

370 f2 :: PortName -> ConnectionPoint

371 f2 = f4 . maybe (error "Internal Error: unexpected Nothing") id . otherExtremeOfEdgeConnectedOnPort net nNr

372

373 f4 (nNr,"interface") = (nNr,"interface","interface")

374 f4 _ = error "Internal Error: unexpected agent"

375

376 f5 (_:'_':portName) = portName

377 f5 _ = error "Internal Error: unexpected port name"

378

379 f6 = Map.fromList . map (f5 /\ f2)

380

381 -- makeRHS :: FuncLang -> String -> String -> [InterfaceID] -> Network g n e -> Network g n e

382 makeRHS term iterAgent consAgent (RES interfacePoint:lInters) net =

383 let (conE,net1) = connectToken palette interfacePoint net

384 in reallyMakeRHS palette names term iterAgent consAgent lInters conE net1

385 makeRHS _ _ _ _ _ = error "Internal Error making RHS."

386

387 -- | Add a token agent and connect its auxiliar port to the given point.

388 connectToken :: (InfoKind n g, InfoKind e g) => Palette n -> ConnectionPoint -> Network g n e -> (ConnectionPoint, Network g n e)

389 connectToken palette topPoint net =

390 let (nNrE, net1) = addNode "evaluation" palette net -- add token agent

391 in ( (nNrE,"evaluation","arg")

392 , connectNodes palette (nNrE, "evaluation", "res") topPoint -- (token, res) |-> topPoint

393 . moveNode nNrE (0,1) topPoint

394 $ net1 )

395

396 aux :: PortName -> PortName -> Bool

397 aux (c1:'_':_) (c2:'_':_) = c1 == c2

398 aux _ _ = False

399

400 -- | Creates the network that is the RHS of rule for given symbols.

401 -- See interaction rules for iterators in paper

402 -- "Encoding Iterators in Interaction Nets" for more details.

403 reallyMakeRHS :: (InfoKind n g, InfoKind e g)

404 => Palette n

405 -> [(FuncLang, String)]

406 -> FuncLang -- Iter_TYPE args (Var "")

407 -> String -- iter agent name

408 -> String -- constructor agent name

409 -> [InterfaceID] -> ConnectionPoint

410 -> Network g n e -> Network g n e

411 reallyMakeRHS palette names term iterAgent const l point =

412 case (term, const) of

413 (IterBool v _ (Var ""), "True") ->

414 case emptyfy l [IterBoolV emp, IterBoolF emp] of

415 [IterBoolV ctxV, IterBoolF ctxF] -> simpleRHS palette names point ctxV ctxF v

416 _ -> error "Internal Error: unexpected [InterfaceID]"

417 (IterBool _ f (Var ""), "False") ->

418 case emptyfy l [IterBoolV emp, IterBoolF emp] of

419 [IterBoolV ctxV, IterBoolF ctxF] -> simpleRHS palette names point ctxF ctxV f

420 _ -> error "Internal Error: unexpected [InterfaceID]"

421 (IterNat _ _ z (Var ""), "Zero") ->

422 case emptyfy l [IterNatS emp, IterNatZ emp] of

423 [IterNatS ctxS, IterNatZ ctxZ] -> simpleRHS palette names point ctxZ ctxS z

424 _ -> error "Internal Error: unexpected [InterfaceID]"

425 (IterNat x s _ (Var ""), "Succ") ->

426 case emptyfy l [IterNatS emp, IterNatZ emp, SuccArg undef] of

427 [IterNatS ctxS, IterNatZ ctxZ, SuccArg pSucArg] ->

428 oneRecursiveCallRHS palette names point ctxS emp ctxZ pSucArg x s iterAgent 'z' 's'

429 _ -> error "Internal Error: unexpected [InterfaceID]"

430 (IterList _ _ _ n (Var ""), "Nil") ->

431 case emptyfy l [IterListC emp, IterListN emp] of

432 [IterListC ctxC, IterListN ctxN] -> simpleRHS palette names point ctxN ctxC n

433 _ -> error "Internal Error: unexpected [InterfaceID]"

434 (IterList x y c _ (Var ""), "Cons") ->

435 case emptyfy l [IterListC emp, IterListN emp, ConsHead undef, ConsTail undef] of

436 [IterListC ctxC, IterListN ctxN, ConsHead pConsHead, ConsTail pConsTail] ->

437 oneRecursiveCallRHS palette names point ctxC (Map.singleton x pConsHead) ctxN pConsTail y c iterAgent 'n' 'c'

438 _ -> error "Internal Error: unexpected [InterfaceID]"

439 _ -> error "Undefined case making RHS."

440 where emp = Map.empty

441 undef = (0,"INVALID NODE","")

442

443 emptyfy :: [InterfaceID] -> [InterfaceID] -> [InterfaceID]

444 emptyfy given needed = map (\e -> maybe e id $ find (equalIID e) given ) needed

445

446

447 -- | Defines a simple RHS that evaluates the translation of term t

448 -- connecting its free variables to the corresponding interface agents

449 -- and connects the remaing interface agents to erase agents.

450 -- For example RHS for rule IterBool |X| TT that is

451 -- \TOKEN(T(V))

452 simpleRHS :: (InfoKind n g, InfoKind e g)

453 => Palette n

454 -> [(FuncLang, String)]

455 -> ConnectionPoint

456 -> Context -- context to connect

457 -> Context -- context to erase

458 -> FuncLang -- term to translate

459 -> Network g n e -> Network g n e

460 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 ) $

461 iso palette names point (2,0) term goodCtx

462 . closeEpsilon palette eraCtx

463

464

465 -- | Defines a RHS with one recursive call.

466 -- Like IterNat |X| suc or IterList |X| cons

467 oneRecursiveCallRHS :: (InfoKind n g, InfoKind e g)

468 => Palette n

469 -> [(FuncLang, String)]

470 -> ConnectionPoint -- (token, arg) port to connect generated net

471 -> Context -- context to connect to copy

472 -> Context -- context to pass to translate function; refers to arguments of constructor

473 -> Context -- context to connect to iterator

474 -> ConnectionPoint -- interface for place to apply recursion

475 -> Variable -- variable that represents result of recursive call

476 -> FuncLang -- term to translate

477 -> String -- Iterator agent name

478 -> Char -- port prefix for final elements

479 -> Char -- port prefix for cont elements

480 -> Network g n e -> Network g n e

481 oneRecursiveCallRHS palette names topPoint copyCtx argCtx stopCtx argPoint var term iterAgent pF pC net =

482 let (newNet, newCtx) =

483 if var `elem` lFreeVars

484 then

485 let

486 (iterNr,net1) = addNode iterAgent palette net -- add iter agent

487 (net2, ctxNew) = Map.mapAccumWithKey (connectCopies iterNr) net1 copyCtx -- (Iter, FV(S)) |-> (copy, snd_target)

488 -- (copy, src) |-> copyCtx

489 in ( connectNodes palette (iterNr,iterAgent,"arg") argPoint -- (Iter, arg) |-> argInterface

490 . connectPorts palette pF iterNr iterAgent stopCtx -- (Iter, FV(Z)) |-> stopCtx

491 . moveNode iterNr (0,-1) argPoint

492 $ net2, Map.insert var (iterNr,iterAgent,"res") ctxNew )

493

494 else (closeEpsilon palette (Map.insert "" argPoint stopCtx) net, copyCtx)

495 (frees, dontExist) = Map.partitionWithKey aux argCtx

496

497 in iso palette names topPoint (2,0.7) term (frees `Map.union` newCtx)

498 . closeEpsilon palette dontExist

499 $ newNet

500 where

501 lFreeVars = freeVars term

502

503 -- connectCopies :: NodeNr -> Network g n e -> Variable -> ConnectionPoint -> (Network g n e, ConnectionPoint)

504 connectCopies iterNr net var point =

505 let (copyNr,net1) = addNode "copy" palette net

506 in (connectNodes palette (iterNr,iterAgent,pC:'_':var) (copyNr,"copy","snd_target")

507 . connectNodes palette (copyNr,"copy","src") point

508 . moveNode copyNr (0,-0.8) point

509 $ net1, (copyNr,"copy","fst_target") )

510

511 aux var _ = var `elem` lFreeVars

512

513 type ConnectionPoint = ( NodeNr

514 , ShapeName

515 , PortName

516 )

517

518 -- | Connect a port in a node to another.

519 connectNodes :: (InfoKind e g) => Palette n -> ConnectionPoint -> ConnectionPoint -> Network g n e -> Network g n e

520 connectNodes palette (nrFrom, shapeFrom, portFrom) (nrTo, shapeTo, portTo) net =

521 case (getNodeShape net nrFrom, getNodeShape net nrTo) of

522 (str1, str2) | str1 == shapeFrom && str2 == shapeTo ->

523 case (getPorts palette net nrFrom, getPorts palette net nrTo) of

524 (Just portsFrom, Just portsTo) ->

525 case (Data.List.lookup portFrom portsFrom, Data.List.lookup portTo portsTo) of

526 (Just _, Just _) ->

527 addEdge palette nrFrom portFrom nrTo portTo net

528 (Nothing,_) -> error $ "Port \"" ++ portFrom ++ "\" do not exist in symbol \"" ++ shapeFrom ++ "\"."

529 (_,Nothing) -> error $ "Port \"" ++ portTo ++ "\" do not exist in symbol \"" ++ shapeTo ++ "\"."

530 _ -> error "No ports."

531 _ -> error "Shapes do not coincide."

532

533 -- | Move first node to position @(dx,dy)@ relatively to reference point position.

534 moveNode :: NodeNr -> (Double,Double) -> ConnectionPoint -> Network g n e -> Network g n e

535 moveNode node (dx,dy) refPoint net =

536 setNodePosition node ( translate (DoublePoint dx dy)

537 $ getNodePosition net $ fst3 refPoint)

538 net

539