Fri Feb 17 14:44:40 WET 2006 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Operations on Document and Rules for full IN system
Operations were performed in a Network and now are performed in the Document.
Since the document contains several networks, the operation can change just one network or many at the same time.
The automatic generation of Interaction Nets textual description now covers the all system, this means that automatic generation of textual description for rules had been added.
It also fixes display of edge names.
{
hunk ./src/AuxNet.hs 1
-module AuxNet [_$_]
- (
- Net (..)
- , printNetEquations
- , printSimplifiedNetEquations
- , saveNetEquations
- , saveSimplifiedNetEquations
- )where
-
-import Operations
-import Network
-import Constants
-import SafetyNet
-import qualified IntMap as IM
-import Data.Maybe
-import Data.Char
-import Data.List
-import Graphics.UI.WXCore
-
-
-
-type Edge' = EdgeNr
-type AgentName = String
-type Agent = (AgentName -- ^
- , Int -- ^ the agent arity, this is, the number of ports
- -- excludind the principal one
- )
-type Interface = [EqSide]
-
-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 Rule = (NodeApl, NodeApl)
-type EqSide = Either Edge' NodeApl
-type Equation = (EqSide, EqSide)
-type NodeApl = (AgentName, [NodeApl'])
-data NodeApl' = End Edge' | Nested NodeApl deriving (Show, Eq, Ord)
-
-
-
-instance Show Net where
- show = jspRepresentation
-
-{-
-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 "(" ++ showNodeApl' (head edges) [_$_]
- ++ showTail (tail edges)
- ++ ")"
- showEdge edge = [toEnum (edge + fromEnum 'a' -1)] [_$_]
- showNode node = filter (not . isSpace) node
- showNodeApl' (End edge) = showEdge edge
- showNodeApl' (Nested nodeApl) = showNodeApl nodeApl
- showTail = concatMap (\a -> ", " ++ showNodeApl' a)
--}
-
--- | Creates the string with the representation of a 'Net' [_$_]
--- in the format of JSP IN transformation tool
-jspRepresentation :: Net -> String
-jspRepresentation net =
- unlines ( [_$_]
- [ "/* Automatically generated by " ++ toolName ++ " */"
- , ""
- , "agents"
- , "" [_$_]
- ] ++ map showAgent (agents net) ++ [_$_]
- [ ""
- , "rules"
- , ""
- -- ] ++ map showRule (rules net) ++ [[_^I_][_$_]
- , ""
- , "net"
- , ""
- ] ++ map showEquation (equations net) ++
- [ ""
- , "interface"
- , ""
- ] ++ map showEdge2 (interface net) ++ [_$_]
- [ ""
- , ""
- , "end"
- ])
- where showAgent :: Agent -> String
- showAgent (name, arity) = sl name "\t" $ show arity
-
- showEquation :: Equation -> String
- showEquation (lhs, rhs) = sl (showEqSide lhs) " = " $ showEqSide rhs
- [_$_]
- showEqSide = either showEdge showNodeApl
- showNodeApl (node, edges) = [_$_]
- showNode node ++ if null edges
- then ""
- else "(" ++ showNodeApl' (head edges) [_$_]
- ++ showTail (tail edges)
- ++ ")" [_$_]
- showNode node = filter (not . isSpace) node
- showNodeApl' (End edge) = showEdge edge
- showNodeApl' (Nested nodeApl) = showNodeApl nodeApl
- showTail = concatMap (\a -> ", " ++ showNodeApl' a)
-
- showEdge :: Edge' -> String
- showEdge edge = [toEnum (edge + fromEnum 'a' -1)]
- [_$_]
- showEdge2 = either (\e -> showEdge e ++ ";") showNodeApl
-
- sl arg1 sep arg2 = '\t' : arg1 ++ sep ++ arg2 ++ [';']
- [_$_]
-
-
-
-
-
-network2net :: IM.IntMap (Node n) -> IM.IntMap (Edge e) -> Net
-network2net nodeMap edgeMap = [_$_]
- Net { agents = delete ("interface",0) . nub [_$_]
- . map getAgent . IM.elems $ nodeMap
- , equations = sort eqs'
- , interface = map fst inter
- , rules = [] [_$_]
- }
- where [_$_]
- net = Net { agents = delete ("interface",0) . nub [_$_]
- . map getAgent . IM.elems $ nodeMap
- , equations = sort eqs'
- , interface = map fst inter
- , rules = [] [_$_]
- }
- 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 node
- pEdge <- edgeConnectedOnPort edgeMap nr pPort
- let otherEdges = catMaybes $ map (edgeConnectedOnPort edgeMap nr) otherPorts
- return (Left pEdge, Right (getName' node, map End otherEdges))
- test :: Equation -> Bool
- test (Left x, Right ("interface", [])) = False
- test _ = True
- getAgent :: Node n -> (AgentName, Int)
- getAgent node = (getName' node, agentArity node)
- agentArity :: Node n -> Int
- agentArity node = length (maybe []id $ getPorts node) - 1
- getName' :: Node n -> AgentName
- getName' = either id undefined . getShape
-
-
-
-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@(Right x, a) : eqsA) = simp (eqsB ++ [eq]) eqsA
- simp eqsB (eq@(Left x , a) : eqsA) [_$_]
- | Left x `elem` inter = simp (eqsB ++ [eq]) eqsA
- | otherwise = simp eqsBS eqsAS
- where (eqsBS, eqsAS) = subst2 (Left 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) eq@(Left x , a)
- | Left x `elem` i = (eqsB, a : delete (Left 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 all tree and replaces in the right place.
- subst2 :: EqSide -> EqSide -> [Equation] -> [Equation] [_$_]
- -> ([Equation], [Equation])
- subst2 (Right x) z y a = error "unexpected case"
- subst2 (Left x) rhs eqsB eqsA = (subst eqsB, subst eqsA)
- where subst :: [Equation] -> [Equation]
- subst = map substEq
- substEq (lhs, rhs) = (substEqS lhs, substEqS rhs)
- [_$_]
- substEqS = either f4 (Right . substNA)
- f4 a | a == x = rhs
- | otherwise = Left a
- [_$_]
- substNA (agent, args) = (agent, map substNA' args)
- substNA' (End e) | e == x = Nested . either undefined id $ rhs
- | otherwise = End e
- substNA' (Nested args) = Nested $ substNA args
-
------------------------------------------------------------------------------
-
-printNetEquations, printSimplifiedNetEquations :: IOOp g n e
-printNetEquations = auxPrintNet False
-printSimplifiedNetEquations = auxPrintNet True
-
-auxPrintNet :: Bool -> IOOp g n e
-auxPrintNet b (g, nodeMap, edgeMap) _ = [_$_]
- do logMessage "printing Net"
- logMessage (show net)
- print net
- where net = simp $ network2net nodeMap edgeMap
- simp = if b then simplify else id
-
-
-saveNetEquations, saveSimplifiedNetEquations :: IOOp g n e
-saveNetEquations = auxSaveNetEquations False
-saveSimplifiedNetEquations = auxSaveNetEquations True
-
-auxSaveNetEquations :: Bool -> IOOp g n e
-auxSaveNetEquations b (g, nodeMap, edgeMap) w = [_$_]
- safetyNet w $
- do mf <- fileSaveDialog w [_$_]
- rememberCurrentDir overwritePrompt [_$_]
- "Save net equations"
- [("Any file", ["*"])] [_$_]
- directory filename
- case mf of
- Nothing -> return ()
- Just fn -> writeFile fn . show . simp $ network2net nodeMap edgeMap
- where rememberCurrentDir = True
- overwritePrompt = True
- directory = "" [_$_]
- filename = "" [_$_]
- simp = if b then simplify else id
-
rmfile ./src/AuxNet.hs
hunk ./src/Common.hs 172
+int2name :: Int -> String
+int2name n | n<=0 = error "Unexpected number; a positive number was expected." [_$_]
+ | otherwise = aux (n-1)
+ where aux m = (if q == 0 then [] else int2name q) ++ [toEnum (r + fromEnum 'a')]
+ where (q, r) = m `divMod` 26
+
+takeJust :: String -> Maybe a -> a
+takeJust erro (Just res) = res
+takeJust erro Nothing = error erro
+
hunk ./src/INRule.hs 9
+ , Mapping[_^M_][_$_]
+ , MappingElement [_^M_][_$_]
hunk ./src/INRule.hs 26
+ , isInterfaceNode[_^M_][_$_]
hunk ./src/INRules.hs 18
+[_^M_][_$_]
+ , mapRules[_^M_][_$_]
hunk ./src/INRules.hs 68
+mapRules :: (INRule g n e -> x) -> INRules g n e -> [x][_^M_][_$_]
+mapRules = map[_^M_][_$_]
addfile ./src/INTextual.hs
hunk ./src/INTextual.hs 1
+module INTextual [_$_]
+ (
+ Net (..)
+ , printNetEquations
+ , printSimplifiedNetEquations
+ , saveNetEquations
+ , saveSimplifiedNetEquations
+ )where
+
+import Operations
+import Document hiding (ActiveCanvas(..))
+import Network
+import Constants
+import SafetyNet
+import qualified IntMap as IM
+import Data.Maybe
+import Data.Char
+import Data.List
+import Graphics.UI.WXCore hiding (Document)
+import Common
+import State
+import INRules
+import INRule
+import InfoKind
+
+
+type Edge' = EdgeNr
+type AgentName = String
+type Agent = (AgentName -- ^
+ , 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 = (NodeApl, NodeApl)
+
+
+instance Show Net where
+ show = jspRepresentation
+
+{-
+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)
+-}
+
+-- | Creates the string with the representation of a 'Net' [_$_]
+-- in the format of JSP IN transformation tool
+jspRepresentation :: Net -> String
+jspRepresentation net =
+ unlines ( [_$_]
+ [ "/* Automatically generated by " ++ toolName ++ " */"
+ , ""
+ , "agents"
+ , "" [_$_]
+ ] ++ map showAgent (agents net) ++ [_$_]
+ [ ""
+ , "rules"
+ , ""
+ ] ++ map showRule (rules net) ++ [_$_]
+ [ ""
+ , "net"
+ , ""
+ ] ++ map showEquation (equations net) ++
+ [ ""
+ , "interface"
+ , ""
+ ] ++ map showEdge2 (interface net) ++ [_$_]
+ [ ""
+ , ""
+ , "end"
+ ])
+ where showAgent :: Agent -> String
+ showAgent (name, arity) = sl name "\t" $ show arity
+
+ showEquation :: Equation -> String
+ showEquation (lhs, rhs) = sl (showTerm lhs) " = " $ 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 = filter (not . isSpace) node
+ showTail = concatMap (\a -> ", " ++ showTerm a)
+
+ showEdge :: Edge' -> String
+ showEdge = int2name
+ [_$_]
+ showEdge2 term = showTerm term ++ ";"
+
+ sl arg1 sep arg2 = '\t' : arg1 ++ sep ++ arg2 ++ [';']
+
+ showRule (lhs, rhs) = sl (showNodeApl lhs) " >< " (showNodeApl rhs)
+ [_$_]
+
+doc2net :: (InfoKind n g, InfoKind e g) => Document g n e -> Net
+doc2net doc = nubAgents $ (network2net $ getNetwork doc) [_$_]
+ `join` [_$_]
+ (foldr1 join . mapRules textualRule $ getRules 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 :: Network g n e -> Net
+network2net network =
+ Net { agents = delete ("interface",0) . nub [_$_]
+ . map getAgent . IM.elems $ 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 node
+ pEdge <- edgeConnectedOnPort network nr pPort
+ let otherEdges = catMaybes $ map (edgeConnectedOnPort network nr) otherPorts
+ return (Simple pEdge, Compound (getName' node, map Simple otherEdges))
+ test :: Equation -> Bool
+ test (Simple _, Compound ("interface", [])) = False
+ test _ = True
+ getAgent :: Node n -> (AgentName, Int)
+ getAgent node = (getName' node, agentArity node)
+ agentArity :: Node n -> Int
+ agentArity node = length (maybe [] id $ getPorts node) - 1
+ getName' :: Node n -> AgentName
+ getName' = either id undefined . getShape
+
+-- | Generates the textual representation of a rule.
+textualRule :: (InfoKind n g, InfoKind e g) => INRule g n e -> Net
+textualRule 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, Just p), (nir,_)) = [_$_]
+ let redge = takeJust ("One interface agent in rhs of rule " [_$_]
+ ++ ruleName ++ " is disconnected.")
+ $ edgeConnectedOnPort oldnet nir p [_$_]
+ (nl, pl) = takeJust ("One interface agent in lhs of rule " [_$_]
+ ++ ruleName ++ " is disconnected.")
+ $ otherExtremeOfEdgeConnectedOnPort lhs nil p [_$_]
+
+ in removeNode nir . updateEdge redge (substBy (nir, p) (new nl, pl)) $ oldnet [_$_]
+ f _ _ _ = error "unknow error"
+
+ substBy (oldNode, oldPort) (newNode, newPort) edge = [_$_]
+ case getPortFrom edge of
+ Just (node, port) | node == oldNode && port == oldPort [_$_]
+ -> setPortFrom newNode newPort edge
+ _ -> case getPortTo edge of [_$_]
+ Just (node, port) | node == oldNode && port == oldPort [_$_]
+ -> setPortTo newNode newPort edge
+ _ -> error "unexpected"
+ [_$_]
+ in case others of [_$_]
+ [x1@(n1, a), x2@(n2, b)] | hasActivePair x1 x2 lhs -> [_$_]
+ let aPrincipalPort = head . fromJust $ getPorts a
+ bPrincipalPort = head . fromJust $ getPorts b
+ (na, rhs1) = addExistingNode a rhs [_$_]
+ (nb, rhs2) = addExistingNode b rhs1
+ rhs3 = addEdge na (Just aPrincipalPort) nb (Just 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 $ 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, Node n) -> (NodeNr, Node n) -> Network g n e -> Bool
+hasActivePair (n1,a) (n2,b) net = [_$_]
+ case (getPorts a, getPorts b) of
+ (Just (ap:_), Just (bp:_) ) -> [_$_]
+ isJust ( findEdge n1 (Just ap) n2 (Just bp) net ) || [_$_]
+ isJust ( findEdge n2 (Just bp) n1 (Just 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 = [(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 all 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)
+
+-----------------------------------------------------------------------------
+
+printNetEquations, printSimplifiedNetEquations :: (InfoKind n g, InfoKind e g) => IOOp g n e
+printNetEquations = auxPrintNet False
+printSimplifiedNetEquations = auxPrintNet True
+
+auxPrintNet :: (InfoKind n g, InfoKind e g) => Bool -> IOOp g n e
+auxPrintNet b doc _ = [_$_]
+ do logMessage "printing Net"
+ logMessage (show net)
+ print net
+ where net = simp $ doc2net doc
+ simp = if b then simplify else id
+
+
+saveNetEquations, saveSimplifiedNetEquations :: (InfoKind n g, InfoKind e g) => IOOp g n e
+saveNetEquations = auxSaveNetEquations False
+saveSimplifiedNetEquations = auxSaveNetEquations True
+
+auxSaveNetEquations :: (InfoKind n g, InfoKind e g) => Bool -> IOOp g n e
+auxSaveNetEquations b doc state = [_$_]
+ do w <- getNetworkFrame state
+ safetyNet w $
+ do [_$_]
+ mf <- fileSaveDialog w [_$_]
+ rememberCurrentDir overwritePrompt [_$_]
+ "Save net equations"
+ [("Any file", ["*"])] [_$_]
+ directory filename
+ case mf of
+ Nothing -> return ()
+ Just fn -> writeFile fn . show . simp $ doc2net doc
+ where rememberCurrentDir = True
+ overwritePrompt = True
+ directory = "" [_$_]
+ filename = "" [_$_]
+ simp = if b then simplify else id
+
hunk ./src/Main.hs 15
-import AuxNet
+import INTextual
hunk ./src/Main.hs 34
-graphOps = GraphOps { pureOps = [ ("push numbers one step", onePush)
- , ("clear all numbers", revert) ]
+graphOps = GraphOps { pureOps = [ ]
hunk ./src/Main.hs 44
- where
- onePush (g, nodemap, edgemap) =
- (g, IntMap.mapWithKey (\k v-> (edgemap `accumulateIn` k) v) nodemap
- , IntMap.map (\e-> nodemap `pushAlongEdge` e) edgemap)
- revert (g, nodemap, edgemap) =
- (g, IntMap.map (setInfo blank) nodemap
- , IntMap.map (setEdgeInfo blank) edgemap)
hunk ./src/Network.hs 31
+ , otherExtremeOfEdgeConnectedOnPort
hunk ./src/Network.hs 39
- , addNode, addNodes, removeNode, addNodeEx
+ , addNode, addNodes, removeNode, addNodeEx, addExistingNode
hunk ./src/Network.hs 446
+addExistingNode :: InfoKind n g => Node n -> Network g n e -> (NodeNr, Network g n e)
+addExistingNode node network = [_$_]
+ ( nodeNr
+ , network { networkNodes = insert nodeNr node' (networkNodes network) }
+ )
+ where
+ nodeNr = getUnusedNodeNr network
+ node' = setName ("Node " ++ show nodeNr) node
+
hunk ./src/Network.hs 589
-edgeConnectedOnPort :: IntMap (Edge e) -> NodeNr -> Port -> Maybe EdgeNr [_$_]
-edgeConnectedOnPort edgeMap nodeNr port = [_$_]
- case IntMap.keys (IntMap.filter f edgeMap) of
+edgeConnectedOnPort :: Network g n e -> NodeNr -> Port -> Maybe EdgeNr [_$_]
+edgeConnectedOnPort network nodeNr port = [_$_]
+ case IntMap.keys (IntMap.filter f (networkEdges network) ) of
hunk ./src/Network.hs 599
+otherExtremeOfEdgeConnectedOnPort :: Network g n e -> NodeNr -> Port [_$_]
+ -> Maybe (NodeNr, Port)
+otherExtremeOfEdgeConnectedOnPort network nodeNr port [_$_]
+ | getPortFrom edge == Just (nodeNr, port) = getPortTo edge
+ | getPortTo edge == Just (nodeNr, port) = getPortFrom edge
+ | otherwise = Nothing
+ where edge = getEdge (takeJust "disconnected agent" [_$_]
+ $ edgeConnectedOnPort network nodeNr port)
+ network
hunk ./src/NetworkView.hs 176
- drawLabel 0 False [toEnum (edgeNr + fromEnum 'a' -1)] [_$_]
+ drawLabel 0 False (int2name edgeNr) [_$_]
hunk ./src/Operations.hs 3
-import InfoKind
hunk ./src/Operations.hs 8
-import Graphics.UI.WX
-
hunk ./src/Operations.hs 11
--- on the graph network. The operations are classified into pure and
--- IO variants. A pure operation takes a graph and returns a new
--- graph, which is stored into the current document (can be reverted
--- with the standard 'undo' menu item), and displayed immediately. An
--- IO operation is simply executed taking the graph as argument - it
--- is up to the IO action to do any state updates it wants to.
+-- on the document. The operations are classified into pure and
+-- IO variants. A pure operation takes a document and returns a new
+-- document and displayed immediately. An IO operation is simply
+-- executed taking the document as argument and the state.
hunk ./src/Operations.hs 20
+ Document g n e -> Document g n e
+type IOOp g n e = -- (InfoKind n g, InfoKind e g) =>
+ Document g n e -> State g n e -> IO ()
+
+type PureNetworkOp g n e = -- (InfoKind n g, InfoKind e g)
hunk ./src/Operations.hs 27
-type IOOp g n e = -- (InfoKind n g, InfoKind e g) =>
+type IONetworkOp g n e = -- (InfoKind n g, InfoKind e g) =>
hunk ./src/Operations.hs 29
- -> Frame ()
+ -> State g n e
hunk ./src/Operations.hs 35
- ; doc <- PD.getDocument pDoc
- ; let network = getNetwork doc
- g = getGlobalInfo network
- n = networkNodes network
- e = networkEdges network
- operation = maybe id id (Prelude.lookup opName (pureOps allGraphOps))
- (g',n',e') = operation (g,n,e)
- network' = setNodeAssocs (assocs n')
- $ setEdgeAssocs (assocs e')
- $ setGlobalInfo g'
- $ network
- ; PD.updateDocument opName (setNetwork network') pDoc
+ ; let operation = maybe id id (Prelude.lookup opName (pureOps allGraphOps))
+ ; PD.updateDocument opName operation pDoc
hunk ./src/Operations.hs 43
- ; let network = getNetwork doc
+ ; maybe (return ()) (\op-> op doc state)
+ (Prelude.lookup opName (ioOps allGraphOps))
+ }
+
+
+globalizePure :: PureNetworkOp g n e -> PureOp g n e
+globalizePure netOperation = updateNetwork aux
+ where aux network = [_$_]
+ let g = getGlobalInfo network
+ n = networkNodes network
+ e = networkEdges network
+ (g',n',e') = netOperation (g,n,e)
+ in setNodeAssocs (assocs n')
+ . setEdgeAssocs (assocs e')
+ . setGlobalInfo g'
+ $ network
+
+globalizeIO :: IONetworkOp g n e -> IOOp g n e
+globalizeIO netOperation doc state = [_$_]
+ do{ let network = getNetwork doc
hunk ./src/Operations.hs 66
- ; w <- getNetworkFrame state
- ; maybe (return ()) (\op->op (g,n,e) w)
- (Prelude.lookup opName (ioOps allGraphOps))
+ ; netOperation (g, n, e) state
}