INblobs-0.1.1: src/NetworkControl.hs
module NetworkControl
( createNode, selectNode
, createEdge, selectEdge
, createVia, selectVia
, selectPort
, createMapping
, selectNothing, selectMultiple
, pickupNode, dragNode, dropNode
, pickupVia, dragVia, dropVia
, pickupMultiple, dragMultiple, dropMultiple
, pickupArea, dragArea, dropArea
, deleteSelection
, changeNamePosition
, changeNodeShape
, renameNode, reinfoNodeOrEdge
, changeGlobalInfo
) where
{- pickupX functions with X belonging to {Node, Edge, Via, Area, Multiple} do
1 - setDragging on
2 - selects X
-}
import State
import StateUtil
import Network
import NetworkView (edgeContains)
import Document
import INRule
import INRules
import Common
import CommonIO
import Math
import Shape
import Ports
import qualified PersistentDocument as PD
import InfoKind
import Text.Parse as Parse
import Data.Char (isSpace)
import Graphics.UI.WX hiding (Selection)
import Graphics.UI.WXCore
changeNamePosition :: Bool -> State g n e -> IO ()
changeNamePosition above state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; case getSelection doc of
NodeSelection canv nodeNr _ | canv == canvas ->
do{ PD.updateDocument "move label"
(updateSelNetwork
(updateNode nodeNr
(setNameAbove above)) canvas) pDoc
; repaintAll state
}
_ -> return ()
}
changeNodeShape :: InfoKind n g => String -> n -> State g n e -> IO ()
changeNodeShape shapename info state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; case getSelection doc of
NodeSelection canv nodeNr _ | canv == canvas ->
do{ PD.updateDocument "change shape"
(updateSelNetwork
(updateNode nodeNr
(setInfo info . setShape shapename)) canvas) pDoc
; repaintAll state
}
_ -> return ()
}
deleteSelection :: State g n e -> IO ()
deleteSelection state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; case getSelection doc of
NodeSelection canv nodeNr _ | canv == canvas ->
do{ PD.updateDocument "delete node"
( setSelection NoSelection
. removeMappingElemWithNode canv nodeNr
. updateSelNetwork (removeNode nodeNr) canvas
) pDoc
; repaintAll state
}
EdgeSelection canv edgeNr | canv == canvas ->
do{ PD.updateDocument "delete edge"
( setSelection NoSelection
. updateSelNetwork (removeEdge edgeNr) canvas
) pDoc
; repaintAll state
}
ViaSelection canv edgeNr viaNr | canv == canvas ->
do{ PD.updateDocument "delete control point"
( setSelection NoSelection
. updateSelNetwork (removeVia edgeNr viaNr) canvas
) pDoc
; repaintAll state
}
MultipleSelection canv area nodeNrs viaNrs | canv == canvas ->
do{ PD.updateDocument "delete multiple selection"
( setSelection NoSelection
. updateSelNetwork (foldr (\edgeNr r -> removeNode edgeNr . r) id nodeNrs) canvas
) pDoc
; repaintAll state
}
_ -> return ()
}
createNode :: InfoKind n g => DoublePoint -> State g n e -> IO ()
createNode mousePoint state =
do{ pDoc <- getDocument state
; shapeName <- getCurrentShape state
; canvas <- getActiveCanvas state
; doc1 <- PD.getDocument pDoc
; let palette = getPalette doc1
(nodeNr, doc2) = updateSelNetworkEx
(setNewPosition . addNode shapeName palette)
canvas doc1
doc3 = setSelection (NodeSelection canvas nodeNr Nothing) doc2
; PD.setDocument ("add node on " ++ show' canvas) doc3 pDoc
; repaintAll state
}
where setNewPosition (nodeNr, newNet) =
(nodeNr, updateNode nodeNr ( setPosition mousePoint) newNet )
selectNothing :: State g n e -> IO ()
selectNothing state =
do{ pDoc <- getDocument state
; PD.superficialUpdateDocument (setSelection NoSelection) pDoc
; repaintAll state
}
selectEdge :: Int -> State g n e -> IO ()
selectEdge edgeNr state =
do{ pDoc <- getDocument state
; canvas <- getActiveCanvas state
; PD.superficialUpdateDocument (setSelection (EdgeSelection canvas edgeNr)) pDoc
; repaintAll state
}
createEdge :: (InfoKind e g) => NodeNr -> PortName -> NodeNr -> PortName -> State g n e -> IO ()
createEdge fromNodeNr fromPort toNodeNr toPort state =
do{ pDoc <- getDocument state
; canvas <- getActiveCanvas state
; doc <- PD.getDocument pDoc
; PD.updateDocument "add edge"
( setSelection (NodeSelection canvas fromNodeNr $ Just fromPort)
. updateSelNetwork (addEdge (getPalette doc) fromNodeNr fromPort toNodeNr toPort)
canvas ) pDoc
; repaintAll state
}
createMapping :: RuleName -- ^ rule to add the mapping to
-> NodeNr -- ^ LHS node number
-> NodeNr -- ^ RHS node number
-> State g n e -> IO ()
createMapping rule nNrL nNrR state =
do{ pDoc <- getDocument state
; PD.updateDocument ("add mapping to rule " ++ rule)
(updateRules
$ updateRule rule
$ updateMapping
$ addMapping (nNrL, nNrR)
) pDoc
; repaintAll state
}
createVia :: DoublePoint -> State g n e -> IO ()
createVia mousepoint state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; let network = selectNetwork doc canvas
; case getSelection doc of
EdgeSelection canv edgeNr | canv == canvas ->
do{ ifJust (edgeContains (getEdge edgeNr network) mousepoint network)
$ \viaNr->
do{ PD.updateDocument "add control point to edge"
( setSelection (ViaSelection canvas edgeNr viaNr)
. updateSelNetwork (newViaEdge edgeNr viaNr mousepoint) canvas
) pDoc
; repaintAll state
}
}
_ -> return ()
}
selectVia :: Int -> Int -> State g n e -> IO ()
selectVia edgeNr viaNr state =
do{ pDoc <- getDocument state
; canvas <- getActiveCanvas state
; PD.superficialUpdateDocument (setSelection (ViaSelection canvas edgeNr viaNr))
pDoc
; repaintAll state
}
pickupVia :: Int -> Int -> DoublePoint -> State g n e -> IO ()
pickupVia edgeNr viaNr mousePoint state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; let network = selectNetwork doc canvas
viaPos = (getEdgeVia (getEdge edgeNr network))!!viaNr
; setDragging (Just (False, mousePoint `subtractDoublePoint` viaPos)) state
; selectVia edgeNr viaNr state
}
selectNode :: Int -> State g n e -> IO ()
selectNode nodeNr state = selectPort nodeNr Nothing state
selectPort :: Int -> Maybe PortName -> State g n e -> IO ()
selectPort nodeNr mPort state =
do{ pDoc <- getDocument state
; canvas <- getActiveCanvas state
; PD.superficialUpdateDocument (setSelection $ NodeSelection canvas nodeNr mPort) pDoc
; repaintAll state
}
pickupNode :: Int -> Maybe PortName -> DoublePoint -> State g n e -> IO ()
pickupNode nodeNr mPort mousePoint state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; let network = selectNetwork doc canvas
nodePos = getNodePosition network nodeNr
; setDragging (Just (False, mousePoint `subtractDoublePoint` nodePos)) state
; selectPort nodeNr mPort state
}
dragNode :: Int -> DoublePoint -> State g n e -> IO ()
dragNode nodeNr mousePoint state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; Just (hasMoved, offset) <- getDragging state
; let newPosition = mousePoint `subtractDoublePoint` offset
oldPosition = getNodePosition (selectNetwork doc canvas) nodeNr
; when (newPosition /= oldPosition) $
do{ -- The first time the node is moved we have to remember
-- the document in the undo history
; (if not hasMoved then PD.updateDocument "move node"
else PD.superficialUpdateDocument)
(updateSelNetwork (updateNode nodeNr
(setPosition newPosition)) canvas )
pDoc
; repaintAll state
; setDragging (Just (True, offset)) state
-- yes, the node has really moved
}
}
dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()
dropNode hasMoved nodeNr offset mousePoint state =
do{ when hasMoved $
do{ let newPosition = mousePoint `subtractDoublePoint` offset
; pDoc <- getDocument state
; canvas <- getActiveCanvas state
; PD.superficialUpdateDocument
(updateSelNetwork (updateNode nodeNr
(setPosition newPosition)) canvas) pDoc
}
; repaintAll state
; setDragging Nothing state
}
dragVia :: Int -> Int -> DoublePoint -> State g n e -> IO ()
dragVia edgeNr viaNr mousePoint state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; Just (hasMoved, offset) <- getDragging state
; let newPosition = mousePoint `subtractDoublePoint` offset
oldPosition = (getEdgeVia (getEdge edgeNr (selectNetwork doc canvas)))!!viaNr
; when (newPosition /= oldPosition) $
do{ -- The first time the point is moved we have to remember
-- the document in the undo history
; (if not hasMoved then PD.updateDocument "move control point"
else PD.superficialUpdateDocument)
(updateSelNetwork (updateVia edgeNr viaNr newPosition) canvas)
pDoc
; repaintAll state
; setDragging (Just (True, offset)) state
-- yes, the point has really moved
}
}
dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()
dropVia hasMoved edgeNr viaNr offset mousePoint state =
do{ when hasMoved $
do{ let newPosition = mousePoint `subtractDoublePoint` offset
; pDoc <- getDocument state
; canvas <- getActiveCanvas state
; PD.superficialUpdateDocument
(updateSelNetwork (updateVia edgeNr viaNr newPosition) canvas)
pDoc
}
; repaintAll state
; setDragging Nothing state
}
selectMultiple :: Maybe (DoublePoint,DoublePoint) -> [Int] -> [(Int,Int)]
-> State g n e -> IO ()
selectMultiple area nodeNrs viaNrs state =
do{ pDoc <- getDocument state
; canvas <- getActiveCanvas state
; PD.superficialUpdateDocument
(setSelection (MultipleSelection canvas area nodeNrs viaNrs))
pDoc
; repaintAll state
}
pickupMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO ()
pickupMultiple _nodeNrs _viaNrs mousePoint state =
do{ setDragging (Just (False, mousePoint)) state
-- ; selectMultiple Nothing nodeNrs viaNrs state -- already selected
}
dragMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO ()
dragMultiple nodeNrs viaNrs mousePoint state =
do{ pDoc <- getDocument state
; canvas <- getActiveCanvas state
-- ; doc <- PD.getDocument pDoc
; Just (hasMoved, origin) <- getDragging state
; let offset = mousePoint `subtractDoublePoint` origin
; when (mousePoint /= origin) $
do{ -- The first time the point is moved we have to remember
-- the document in the undo history
; (if not hasMoved then PD.updateDocument "move control point"
else PD.superficialUpdateDocument)
(updateSelNetwork (updateMultiple nodeNrs viaNrs offset) canvas)
pDoc
; repaintAll state
; setDragging (Just (True, mousePoint)) state
-- yes, the point has really moved
}
}
updateMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> Network g n e
-> Network g n e
updateMultiple ns vs o network =
( foldr (\n z-> updateNode n (offsetNode o) . z) id ns
. foldr (\ (e,v) z-> updateVia e v (offsetVia o e v) . z) id vs
) network
where
offsetNode off node = setPosition (getPosition node `translate` off) node
offsetVia off edgeNr via = ((getEdgeVia (getEdge edgeNr network))!!via)
`translate` off
dropMultiple :: Bool -> [Int] -> [(Int,Int)] -> DoublePoint -> DoublePoint
-> State g n e -> IO ()
dropMultiple hasMoved nodeNrs viaNrs origin mousePoint state =
do{ when hasMoved $
do{ pDoc <- getDocument state
; canvas <- getActiveCanvas state
; PD.superficialUpdateDocument
(updateSelNetwork
(updateMultiple nodeNrs viaNrs
(mousePoint`subtractDoublePoint`origin)) canvas)
pDoc
}
; repaintAll state
; setDragging Nothing state
}
pickupArea :: DoublePoint -> State g n e -> IO ()
pickupArea mousePoint state =
do{ setDragging (Just (False, mousePoint)) state
; selectMultiple (Just (mousePoint,mousePoint)) [] [] state
}
-- dragArea is not like dragging a selection. It does not move anything.
-- It only adds items into a multiple selection.
dragArea :: DoublePoint -> State g n e -> IO ()
dragArea mousePoint state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; Just (_, origin) <- getDragging state
; let (ns,vs) = itemsEnclosedWithin mousePoint origin (selectNetwork doc canvas)
; selectMultiple (Just (origin,mousePoint)) ns vs state
}
where
itemsEnclosedWithin p0 p1 network =
( ( Prelude.map fst
. Prelude.filter (\ (_,n)-> enclosedInRectangle (getPosition n) p0 p1)
. getNodeAssocs ) network
, ( Prelude.concatMap (\ (i,e)-> map (\ (j,_)-> (i,j))
(Prelude.filter
(\ (_,v)-> enclosedInRectangle
v p0 p1)
(zip [0..] (getEdgeVia e))))
. getEdgeAssocs ) network
)
dropArea :: DoublePoint -> DoublePoint -> State g n e -> IO ()
dropArea _origin mousePoint state =
do{ dragArea mousePoint state -- calculate enclosure area
; pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; case getSelection doc of
MultipleSelection _ _ [] [] ->
PD.superficialUpdateDocument (setSelection NoSelection) pDoc
MultipleSelection canv _ ns vs | canvas == canv ->
PD.superficialUpdateDocument
(setSelection (MultipleSelection canvas Nothing ns vs)) pDoc
| otherwise ->
PD.superficialUpdateDocument (setSelection NoSelection) pDoc
_ -> return ()
; setDragging Nothing state
; repaintAll state
}
renameNode :: Frame () -> State g n e -> IO ()
renameNode theFrame state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; let network = selectNetwork doc canvas
; case getSelection doc of
NodeSelection canv nodeNr _ | canv == canvas ->
do{ let oldName = getNodeName network nodeNr
; result <- myTextDialog theFrame SingleLine
"Rename node" oldName True
; ifJust result $ \newName ->
do{ PD.updateDocument "rename node"
(updateSelNetwork
(updateNode nodeNr (Network.setName newName)) canvas) pDoc
; repaintAll state
}
}
_ -> return ()
}
reinfoNodeOrEdge :: (InfoKind n g, InfoKind e g) =>
Frame () -> State g n e -> IO ()
reinfoNodeOrEdge theFrame state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; let network = selectNetwork doc canvas
; case getSelection doc of
NodeSelection canv nodeNr _ | canv == canvas ->
do{ let oldInfo = getNodeInfo network nodeNr
; result <- myTextDialog theFrame MultiLine
"Edit node info" (show oldInfo) True
; ifJust result $ \newInfo ->
case Parse.runParser Parse.parse newInfo of
(Right x, s) ->
do{ when (not (null s || all isSpace s)) $
errorDialog theFrame "Edit warning"
("Excess text after parsed value."
++"\nRemaining text: "++s)
; case check (getNodeName network nodeNr)
(getGlobalInfo network) x of
[] -> return ()
e -> errorDialog theFrame "Validity warning"
("Validity check fails:\n"
++unlines e)
; PD.updateDocument "edit node info"
(updateSelNetwork
(updateNode nodeNr (setInfo x)) canvas) pDoc
; repaintAll state
}
(Left err, s) -> errorDialog theFrame "Edit warning"
("Cannot parse entered text."
++"\nReason: "++err
++"\nRemaining text: "++s)
}
EdgeSelection canv edgeNr | canv == canvas ->
do{ let oldInfo = getEdgeInfo (getEdge edgeNr network)
; result <- myTextDialog theFrame MultiLine
"Edit edge info" (show oldInfo) True
; ifJust result $ \newInfo ->
case Parse.runParser Parse.parse newInfo of
(Right x, s) ->
do{ when (not (null s || all isSpace s)) $
errorDialog theFrame "Edit warning"
("Excess text after parsed value."
++"\nRemaining text: "++s)
-- ; case check (getNodeName network nodeNr)
-- (getGlobalInfo network) x of
-- [] -> return ()
-- e -> errorDialog theFrame "Validity warning"
-- ("Validity check fails:\n"
-- ++unlines e)
; PD.updateDocument "edit edge info"
(updateSelNetwork
(updateEdge edgeNr (setEdgeInfo x)) canvas) pDoc
; repaintAll state
}
(Left err, s) -> errorDialog theFrame "Edit warning"
("Cannot parse entered text."
++"\nReason: "++err
++"\nRemaining text: "++s)
}
_ -> return ()
}
changeGlobalInfo :: (Show g, Parse g) => Frame () -> State g n e -> IO ()
changeGlobalInfo theFrame state =
do{ pDoc <- getDocument state
; doc <- PD.getDocument pDoc
; canvas <- getActiveCanvas state
; let network = selectNetwork doc canvas
; let info = show (getGlobalInfo network)
; result <- myTextDialog theFrame MultiLine "Edit global info" info True
; ifJust result $ \newInfo->
case Parse.runParser Parse.parse newInfo of
(Right x, s) ->
do{ when (not (null s || all isSpace s)) $
errorDialog theFrame "Edit warning"
("Excess text after parsed value."
++"\nRemaining text: "++s)
; PD.updateDocument "edit global info"
(updateSelNetwork (setGlobalInfo x) canvas) pDoc
; repaintAll state -- no visible change?
}
(Left err, s) -> errorDialog theFrame "Edit warning"
("Cannot parse entered text."
++"\nReason: "++err
++"\nRemaining text: "++s)
}