3 import Data.List (nub,(\\))
4 import NetworkView(clickedNode, clickedNodePort, clickedEdge, clickedVia)
11 import qualified ContextMenu
12 import qualified PersistentDocument as PD
16 import INReductionStrategies
19 import Graphics.UI.WXCore
21 mouseDown :: (InfoKind n g, InfoKind e g, Show g, Parse g) =>
22 Bool -> Point -> Frame () -> State g n e -> IO ()
23 mouseDown leftButton mousePoint theFrame state =
24 do{ pDoc <- getDocument state
25 ; canvas <- getActiveCanvas state
26 ; doc <- PD.getDocument pDoc
28 ; let network = selectNetwork doc canvas
29 doubleMousePoint = screenToLogicalPoint ppi mousePoint
33 ; case clickedNodePort doubleMousePoint doc canvas of
35 case clickedVia doubleMousePoint network of
37 case clickedEdge doubleMousePoint network of
38 Nothing -> -- click in empty area
40 pickupArea doubleMousePoint state
41 else ContextMenu.canvas theFrame state
42 Just edgeNr -> -- click over the edge edgeNr
44 do let toReduce = canvas == Net && isActivePair edgeNr (getPalette doc) network
46 do button <- getReduceButton state
47 set button [enabled := True]
50 selectEdge edgeNr state
52 do{ selectEdge edgeNr state
53 ; ContextMenu.edge theFrame doubleMousePoint state toReduce
55 Just (edgeNr,viaNr) -> -- click over the via viaNr on edge edgeNr
57 case getSelection doc of
58 MultipleSelection canv _ ns vs
59 | (edgeNr,viaNr) `elem` vs && canv == canvas ->
60 pickupMultiple ns vs doubleMousePoint state
61 _ -> pickupVia edgeNr viaNr doubleMousePoint state
63 do{ selectVia edgeNr viaNr state
64 ; ContextMenu.via theFrame state
66 Just (nodeNr, mPort) -> -- click over node nodeNr and
67 -- if also click on a port of that node mPort will be
69 -- Nothing if click over a node but none of its ports
71 case getSelection doc of
72 MultipleSelection canv _ ns vs
73 | nodeNr `elem` ns && canv == canvas ->
74 pickupMultiple ns vs doubleMousePoint state
75 _ -> pickupNode nodeNr mPort doubleMousePoint state
77 do{ selectPort nodeNr mPort state
78 ; ContextMenu.node nodeNr theFrame state
82 leftMouseDownWithShift :: (InfoKind n g, InfoKind e g) =>
83 Point -> State g n e -> IO ()
84 leftMouseDownWithShift mousePoint state =
85 do{ pDoc <- getDocument state
86 ; canvas <- getActiveCanvas state
87 ; doc <- PD.getDocument pDoc
89 ; let network = selectNetwork doc canvas
90 doubleMousePoint = screenToLogicalPoint ppi mousePoint
94 ; case clickedNodePort doubleMousePoint doc canvas of
96 case clickedEdge doubleMousePoint network of
98 -- shift click in empty area = create new node
99 createNode doubleMousePoint state -- change shape of new node
101 selectEdge i state -- shift click on edge = select
102 Just (j,mP) -> do -- shift click on node = create edge (if possible)
103 case (getSelection doc, mP, canvas) of
104 (NodeSelection canv i (Just p), Just p', canvas)
105 | canv==canvas -> createEdge i p j p' state
106 (NodeSelection (LHS rL) i (Just p), Just p', RHS rR)
107 | rL==rR && p == p' && isInterfacePort p
108 -> createMapping rL i j state
109 -- print ("CREATING MAP: ", rL, (i, mPL), (nNrR, mPR))
112 (NodeSelection canv i Nothing, Nothing, canvas) | i /= j -- no edges from one node to it self
113 -> if hasPorts then logMessage "Only allow connections between ports." else ?? -- createEdge i j state
114 (NodeSelection canv i Nothing, Just p') -> logMessage "Repeat it selecting a source port."
115 (NodeSelection canv i (Just p),Nothing) -> logMessage "Select a destination port."
116 (NodeSelection canv i (Just p), Just p') | i /= j -> createEdgePorts i p j p' state
118 _ -> selectPort j mP state
122 leftMouseDownWithMeta :: (InfoKind n g, InfoKind e g) =>
123 Point -> State g n e -> IO ()
124 leftMouseDownWithMeta mousePoint state =
125 do{ pDoc <- getDocument state
126 ; canvas <- getActiveCanvas state
127 ; doc <- PD.getDocument pDoc
128 ; ppi <- getScreenPPI
129 ; let network = selectNetwork doc canvas
130 doubleMousePoint = screenToLogicalPoint ppi mousePoint
132 ; disableReduce state
134 ; case clickedNode doubleMousePoint doc canvas of
136 Just j -> do -- meta click on node = toggle whether node in selection
137 case getSelection doc of
138 NodeSelection _ i _ {-??-}
139 | i == j -> selectNothing state
140 | i /= j -> selectMultiple Nothing (nub [i,j]) [] state
141 ViaSelection _ e v -> selectMultiple Nothing [j] [(e,v)] state
142 MultipleSelection _ _ ns vs
143 | j `elem` ns -> selectMultiple Nothing (ns\\[j]) vs state
144 | otherwise -> selectMultiple Nothing (j:ns) vs state
145 _ -> selectNode j state
147 case clickedVia doubleMousePoint network of
148 Just via@(e,v) -> -- meta click on via point = toggle inclusion
149 case getSelection doc of
150 NodeSelection _ i _ {-??-} -> selectMultiple Nothing [i] [(e,v)] state
152 | e==e' && v==v' -> selectNothing state
153 | otherwise -> selectMultiple Nothing [] [via,(e',v')]
155 MultipleSelection _ _ ns vs
156 | via `elem` vs -> selectMultiple Nothing ns (vs\\[via])
158 | otherwise -> selectMultiple Nothing ns (via:vs) state
159 _ -> selectVia e v state
163 leftMouseDrag :: Point -> ScrolledWindow () -> State g n e -> IO ()
164 leftMouseDrag mousePoint _ state =
165 do{ dragging <- getDragging state
166 ; ppi <- getScreenPPI
167 ; ifJust dragging $ \_ ->
168 do{ pDoc <- getDocument state
169 ; doc <- PD.getDocument pDoc
170 ; canvas <- getActiveCanvas state
171 ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint
172 ; case getSelection doc of
173 NodeSelection canv nodeNr _ | canv == canvas ->
174 dragNode nodeNr doubleMousePoint state
175 ViaSelection canv edgeNr viaNr | canv == canvas ->
176 dragVia edgeNr viaNr doubleMousePoint state
177 MultipleSelection canv Nothing ns vs | canv == canvas ->
178 dragMultiple ns vs doubleMousePoint state
179 MultipleSelection canv _ _ _ | canv == canvas ->
180 dragArea doubleMousePoint state
181 _ -> do selectNothing state
182 -- setDragging Nothing state
186 leftMouseUp :: Point -> State g n e -> IO ()
187 leftMouseUp mousePoint state =
188 do{ dragging <- getDragging state
189 ; ppi <- getScreenPPI
190 ; ifJust dragging $ \(hasMoved, offset) ->
191 do{ pDoc <- getDocument state
192 ; doc <- PD.getDocument pDoc
193 ; canvas <- getActiveCanvas state
194 ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint
195 ; case getSelection doc of
196 NodeSelection canv nodeNr _ | canv == canvas ->
197 dropNode hasMoved nodeNr offset doubleMousePoint state
198 ViaSelection canv edgeNr viaNr | canv == canvas ->
199 dropVia hasMoved edgeNr viaNr offset doubleMousePoint state
200 MultipleSelection canv Nothing ns vs | canv == canvas ->
201 dropMultiple hasMoved ns vs offset doubleMousePoint state
202 MultipleSelection canv _ _ _ | canv == canvas->
203 dropArea offset doubleMousePoint state
204 _ -> do selectNothing state
205 -- setDragging Nothing state
210 deleteKey :: State g n e -> IO ()
212 do disableReduce state
213 deleteSelection state
215 backspaceKey :: State g n e -> IO ()
217 do disableReduce state
218 deleteSelection state
220 f2Key :: Frame () -> State g n e -> IO () -- due for demolition
221 f2Key theFrame state =
222 do disableReduce state
223 renameNode theFrame state
225 pressRKey :: Frame () -> State g n e -> IO ()
226 pressRKey theFrame state =
227 do disableReduce state
228 renameNode theFrame state
230 pressIKey :: (InfoKind n g, InfoKind e g) => Frame () -> State g n e -> IO ()
231 pressIKey theFrame state =
232 do disableReduce state
233 reinfoNodeOrEdge theFrame state
235 upKey :: State g n e -> IO ()
237 do disableReduce state
238 changeNamePosition True state
240 downKey :: State g n e -> IO ()
242 do disableReduce state
243 changeNamePosition False state