/ src /
src/GUIEvents.hs
1 module GUIEvents where
2
3 import Data.List (nub,(\\))
4 import NetworkView(clickedNode, clickedNodePort, clickedEdge, clickedVia)
5 import NetworkControl
6 import State
7 import Ports
8 import Common
9 import CommonIO
10 import Document
11 import qualified ContextMenu
12 import qualified PersistentDocument as PD
13 import InfoKind
14 import Text.Parse
15 import INReduction
16 import INReductionStrategies
17
18 import Graphics.UI.WX
19 import Graphics.UI.WXCore
20
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
27 ; ppi <- getScreenPPI
28 ; let network = selectNetwork doc canvas
29 doubleMousePoint = screenToLogicalPoint ppi mousePoint
30
31 ; disableReduce state
32
33 ; case clickedNodePort doubleMousePoint doc canvas of
34 Nothing ->
35 case clickedVia doubleMousePoint network of
36 Nothing ->
37 case clickedEdge doubleMousePoint network of
38 Nothing -> -- click in empty area
39 if leftButton then
40 pickupArea doubleMousePoint state
41 else ContextMenu.canvas theFrame state
42 Just edgeNr -> -- click over the edge edgeNr
43
44 do let toReduce = canvas == Net && isActivePair edgeNr (getPalette doc) network
45 when toReduce $
46 do button <- getReduceButton state
47 set button [enabled := True]
48
49 if leftButton then
50 selectEdge edgeNr state
51 else
52 do{ selectEdge edgeNr state
53 ; ContextMenu.edge theFrame doubleMousePoint state toReduce
54 }
55 Just (edgeNr,viaNr) -> -- click over the via viaNr on edge edgeNr
56 if leftButton then
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
62 else
63 do{ selectVia edgeNr viaNr state
64 ; ContextMenu.via theFrame state
65 }
66 Just (nodeNr, mPort) -> -- click over node nodeNr and
67 -- if also click on a port of that node mPort will be
68 -- Just port or
69 -- Nothing if click over a node but none of its ports
70 if leftButton then
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
76 else
77 do{ selectPort nodeNr mPort state
78 ; ContextMenu.node nodeNr theFrame state
79 }
80 }
81
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
88 ; ppi <- getScreenPPI
89 ; let network = selectNetwork doc canvas
90 doubleMousePoint = screenToLogicalPoint ppi mousePoint
91
92 ; disableReduce state
93
94 ; case clickedNodePort doubleMousePoint doc canvas of
95 Nothing ->
96 case clickedEdge doubleMousePoint network of
97 Nothing ->
98 -- shift click in empty area = create new node
99 createNode doubleMousePoint state -- change shape of new node
100 Just i ->
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))
110
111 {-
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
117 -}
118 _ -> selectPort j mP state
119 }
120
121 -- para mudar
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
131
132 ; disableReduce state
133
134 ; case clickedNode doubleMousePoint doc canvas of
135
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
146 Nothing ->
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
151 ViaSelection _ e' v'
152 | e==e' && v==v' -> selectNothing state
153 | otherwise -> selectMultiple Nothing [] [via,(e',v')]
154 state
155 MultipleSelection _ _ ns vs
156 | via `elem` vs -> selectMultiple Nothing ns (vs\\[via])
157 state
158 | otherwise -> selectMultiple Nothing ns (via:vs) state
159 _ -> selectVia e v state
160 Nothing -> return ()
161 }
162
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
183 }
184 }
185
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
206 -- return ()
207 }
208 }
209
210 deleteKey :: State g n e -> IO ()
211 deleteKey state =
212 do disableReduce state
213 deleteSelection state
214
215 backspaceKey :: State g n e -> IO ()
216 backspaceKey state =
217 do disableReduce state
218 deleteSelection state
219
220 f2Key :: Frame () -> State g n e -> IO () -- due for demolition
221 f2Key theFrame state =
222 do disableReduce state
223 renameNode theFrame state
224
225 pressRKey :: Frame () -> State g n e -> IO ()
226 pressRKey theFrame state =
227 do disableReduce state
228 renameNode theFrame state
229
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
234
235 upKey :: State g n e -> IO ()
236 upKey state =
237 do disableReduce state
238 changeNamePosition True state
239
240 downKey :: State g n e -> IO ()
241 downKey state =
242 do disableReduce state
243 changeNamePosition False state