darcs - INblobs

1 module NetworkControl

2 ( createNode, selectNode

3 , createEdge, selectEdge

4 , createVia, selectVia

5 , selectPort

6 , createMapping

7 , selectNothing, selectMultiple

8 , pickupNode, dragNode, dropNode

9 , pickupVia, dragVia, dropVia

10 , pickupMultiple, dragMultiple, dropMultiple

11 , pickupArea, dragArea, dropArea

12 , deleteSelection

13 , changeNamePosition

14 , changeNodeShape

15 , renameNode, reinfoNodeOrEdge

16 , changeGlobalInfo

17 ) where

19 {- pickupX functions with X belonging to {Node, Edge, Via, Area, Multiple} do

20 1 - setDragging on

21 2 - selects X

22 -}

25 import State

26 import StateUtil

27 import Network

28 import NetworkView (edgeContains)

29 import Document

30 import INRule

31 import INRules

32 import Common

33 import CommonIO

34 import Math

35 import Shape

36 import Ports

37 import qualified PersistentDocument as PD

38 import InfoKind

39 import Text.Parse as Parse

40 import Data.Char (isSpace)

42 import Graphics.UI.WX hiding (Selection)

43 import Graphics.UI.WXCore

47 changeNamePosition :: Bool -> State g n e -> IO ()

48 changeNamePosition above state =

49 do{ pDoc <- getDocument state

50 ; doc <- PD.getDocument pDoc

51 ; canvas <- getActiveCanvas state

52 ; case getSelection doc of

53 NodeSelection canv nodeNr _ | canv == canvas ->

54 do{ PD.updateDocument "move label"

55 (updateSelNetwork

56 (updateNode nodeNr

57 (setNameAbove above)) canvas) pDoc

58 ; repaintAll state

59 }

60 _ -> return ()

61 }

63 changeNodeShape :: InfoKind n g => String -> n -> State g n e -> IO ()

64 changeNodeShape shapename info state =

65 do{ pDoc <- getDocument state

66 ; doc <- PD.getDocument pDoc

67 ; canvas <- getActiveCanvas state

68 ; case getSelection doc of

69 NodeSelection canv nodeNr _ | canv == canvas ->

70 do{ PD.updateDocument "change shape"

71 (updateSelNetwork

72 (updateNode nodeNr

73 (setInfo info . setShape shapename)) canvas) pDoc

74 ; repaintAll state

75 }

76 _ -> return ()

77 }

79 deleteSelection :: State g n e -> IO ()

80 deleteSelection state =

81 do{ pDoc <- getDocument state

82 ; doc <- PD.getDocument pDoc

83 ; canvas <- getActiveCanvas state

84 ; case getSelection doc of

85 NodeSelection canv nodeNr _ | canv == canvas ->

86 do{ PD.updateDocument "delete node"

87 ( setSelection NoSelection

88 . removeMappingElemWithNode canv nodeNr

89 . updateSelNetwork (removeNode nodeNr) canvas

90 ) pDoc

91 ; repaintAll state

92 }

93 EdgeSelection canv edgeNr | canv == canvas ->

94 do{ PD.updateDocument "delete edge"

95 ( setSelection NoSelection

96 . updateSelNetwork (removeEdge edgeNr) canvas

97 ) pDoc

98 ; repaintAll state

99 }

100 ViaSelection canv edgeNr viaNr | canv == canvas ->

101 do{ PD.updateDocument "delete control point"

102 ( setSelection NoSelection

103 . updateSelNetwork (removeVia edgeNr viaNr) canvas

104 ) pDoc

105 ; repaintAll state

106 }

107 MultipleSelection canv area nodeNrs viaNrs | canv == canvas ->

108 do{ PD.updateDocument "delete multiple selection"

109 ( setSelection NoSelection

110 . updateSelNetwork (foldr (\edgeNr r -> removeNode edgeNr . r) id nodeNrs) canvas

111 ) pDoc

112 ; repaintAll state

113 }

114 _ -> return ()

115 }

116

117 createNode :: InfoKind n g => DoublePoint -> State g n e -> IO ()

118 createNode mousePoint state =

119 do{ pDoc <- getDocument state

120 ; shapeName <- getCurrentShape state

121 ; canvas <- getActiveCanvas state

122 ; doc1 <- PD.getDocument pDoc

123

124 ; let palette = getPalette doc1

125 (nodeNr, doc2) = updateSelNetworkEx

126 (setNewPosition . addNode shapeName palette)

127 canvas doc1

128 doc3 = setSelection (NodeSelection canvas nodeNr Nothing) doc2

129 ; PD.setDocument ("add node on " ++ show' canvas) doc3 pDoc

130 ; repaintAll state

131 }

132 where setNewPosition (nodeNr, newNet) =

133 (nodeNr, updateNode nodeNr ( setPosition mousePoint) newNet )

134

135 selectNothing :: State g n e -> IO ()

136 selectNothing state =

137 do{ pDoc <- getDocument state

138 ; PD.superficialUpdateDocument (setSelection NoSelection) pDoc

139 ; repaintAll state

140 }

141

142 selectEdge :: Int -> State g n e -> IO ()

143 selectEdge edgeNr state =

144 do{ pDoc <- getDocument state

145 ; canvas <- getActiveCanvas state

146 ; PD.superficialUpdateDocument (setSelection (EdgeSelection canvas edgeNr)) pDoc

147 ; repaintAll state

148 }

149

150 createEdge :: (InfoKind e g) => NodeNr -> PortName -> NodeNr -> PortName -> State g n e -> IO ()

151 createEdge fromNodeNr fromPort toNodeNr toPort state =

152 do{ pDoc <- getDocument state

153 ; canvas <- getActiveCanvas state

154 ; doc <- PD.getDocument pDoc

155 ; PD.updateDocument "add edge"

156 ( setSelection (NodeSelection canvas fromNodeNr $ Just fromPort)

157 . updateSelNetwork (addEdge (getPalette doc) fromNodeNr fromPort toNodeNr toPort)

158 canvas ) pDoc

159 ; repaintAll state

160 }

161

162 createMapping :: RuleName -- ^ rule to add the mapping to

163 -> NodeNr -- ^ LHS node number

164 -> NodeNr -- ^ RHS node number

165 -> State g n e -> IO ()

166 createMapping rule nNrL nNrR state =

167 do{ pDoc <- getDocument state

168 ; PD.updateDocument ("add mapping to rule " ++ rule)

169 (updateRules

170 $ updateRule rule

171 $ updateMapping

172 $ addMapping (nNrL, nNrR)

173 ) pDoc

174 ; repaintAll state

175 }

176

177 createVia :: DoublePoint -> State g n e -> IO ()

178 createVia mousepoint state =

179 do{ pDoc <- getDocument state

180 ; doc <- PD.getDocument pDoc

181 ; canvas <- getActiveCanvas state

182 ; let network = selectNetwork doc canvas

183 ; case getSelection doc of

184 EdgeSelection canv edgeNr | canv == canvas ->

185 do{ ifJust (edgeContains (getEdge edgeNr network) mousepoint network)

186 $ \viaNr->

187 do{ PD.updateDocument "add control point to edge"

188 ( setSelection (ViaSelection canvas edgeNr viaNr)

189 . updateSelNetwork (newViaEdge edgeNr viaNr mousepoint) canvas

190 ) pDoc

191 ; repaintAll state

192 }

193 }

194 _ -> return ()

195 }

196

197 selectVia :: Int -> Int -> State g n e -> IO ()

198 selectVia edgeNr viaNr state =

199 do{ pDoc <- getDocument state

200 ; canvas <- getActiveCanvas state

201 ; PD.superficialUpdateDocument (setSelection (ViaSelection canvas edgeNr viaNr))

202 pDoc

203 ; repaintAll state

204 }

205

206 pickupVia :: Int -> Int -> DoublePoint -> State g n e -> IO ()

207 pickupVia edgeNr viaNr mousePoint state =

208 do{ pDoc <- getDocument state

209 ; doc <- PD.getDocument pDoc

210 ; canvas <- getActiveCanvas state

211 ; let network = selectNetwork doc canvas

212 viaPos = (getEdgeVia (getEdge edgeNr network))!!viaNr

213 ; setDragging (Just (False, mousePoint `subtractDoublePoint` viaPos)) state

214 ; selectVia edgeNr viaNr state

215 }

216

217 selectNode :: Int -> State g n e -> IO ()

218 selectNode nodeNr state = selectPort nodeNr Nothing state

219

220 selectPort :: Int -> Maybe PortName -> State g n e -> IO ()

221 selectPort nodeNr mPort state =

222 do{ pDoc <- getDocument state

223 ; canvas <- getActiveCanvas state

224 ; PD.superficialUpdateDocument (setSelection $ NodeSelection canvas nodeNr mPort) pDoc

225 ; repaintAll state

226 }

227

228 pickupNode :: Int -> Maybe PortName -> DoublePoint -> State g n e -> IO ()

229 pickupNode nodeNr mPort mousePoint state =

230 do{ pDoc <- getDocument state

231 ; doc <- PD.getDocument pDoc

232 ; canvas <- getActiveCanvas state

233 ; let network = selectNetwork doc canvas

234 nodePos = getNodePosition network nodeNr

235 ; setDragging (Just (False, mousePoint `subtractDoublePoint` nodePos)) state

236 ; selectPort nodeNr mPort state

237 }

238

239 dragNode :: Int -> DoublePoint -> State g n e -> IO ()

240 dragNode nodeNr mousePoint state =

241 do{ pDoc <- getDocument state

242 ; doc <- PD.getDocument pDoc

243 ; canvas <- getActiveCanvas state

244 ; Just (hasMoved, offset) <- getDragging state

245 ; let newPosition = mousePoint `subtractDoublePoint` offset

246 oldPosition = getNodePosition (selectNetwork doc canvas) nodeNr

247 ; when (newPosition /= oldPosition) $

248 do{ -- The first time the node is moved we have to remember

249 -- the document in the undo history

250 ; (if not hasMoved then PD.updateDocument "move node"

251 else PD.superficialUpdateDocument)

252 (updateSelNetwork (updateNode nodeNr

253 (setPosition newPosition)) canvas )

254 pDoc

255 ; repaintAll state

256 ; setDragging (Just (True, offset)) state

257 -- yes, the node has really moved

258 }

259 }

260

261 dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()

262 dropNode hasMoved nodeNr offset mousePoint state =

263 do{ when hasMoved $

264 do{ let newPosition = mousePoint `subtractDoublePoint` offset

265 ; pDoc <- getDocument state

266 ; canvas <- getActiveCanvas state

267 ; PD.superficialUpdateDocument

268 (updateSelNetwork (updateNode nodeNr

269 (setPosition newPosition)) canvas) pDoc

270 }

271 ; repaintAll state

272 ; setDragging Nothing state

273 }

274

275 dragVia :: Int -> Int -> DoublePoint -> State g n e -> IO ()

276 dragVia edgeNr viaNr mousePoint state =

277 do{ pDoc <- getDocument state

278 ; doc <- PD.getDocument pDoc

279 ; canvas <- getActiveCanvas state

280 ; Just (hasMoved, offset) <- getDragging state

281 ; let newPosition = mousePoint `subtractDoublePoint` offset

282 oldPosition = (getEdgeVia (getEdge edgeNr (selectNetwork doc canvas)))!!viaNr

283 ; when (newPosition /= oldPosition) $

284 do{ -- The first time the point is moved we have to remember

285 -- the document in the undo history

286 ; (if not hasMoved then PD.updateDocument "move control point"

287 else PD.superficialUpdateDocument)

288 (updateSelNetwork (updateVia edgeNr viaNr newPosition) canvas)

289 pDoc

290 ; repaintAll state

291 ; setDragging (Just (True, offset)) state

292 -- yes, the point has really moved

293 }

294 }

295

296 dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()

297 dropVia hasMoved edgeNr viaNr offset mousePoint state =

298 do{ when hasMoved $

299 do{ let newPosition = mousePoint `subtractDoublePoint` offset

300 ; pDoc <- getDocument state

301 ; canvas <- getActiveCanvas state

302 ; PD.superficialUpdateDocument

303 (updateSelNetwork (updateVia edgeNr viaNr newPosition) canvas)

304 pDoc

305 }

306 ; repaintAll state

307 ; setDragging Nothing state

308 }

309

310 selectMultiple :: Maybe (DoublePoint,DoublePoint) -> [Int] -> [(Int,Int)]

311 -> State g n e -> IO ()

312 selectMultiple area nodeNrs viaNrs state =

313 do{ pDoc <- getDocument state

314 ; canvas <- getActiveCanvas state

315 ; PD.superficialUpdateDocument

316 (setSelection (MultipleSelection canvas area nodeNrs viaNrs))

317 pDoc

318 ; repaintAll state

319 }

320

321 pickupMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO ()

322 pickupMultiple _nodeNrs _viaNrs mousePoint state =

323 do{ setDragging (Just (False, mousePoint)) state

324 -- ; selectMultiple Nothing nodeNrs viaNrs state -- already selected

325 }

326

327 dragMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO ()

328 dragMultiple nodeNrs viaNrs mousePoint state =

329 do{ pDoc <- getDocument state

330 ; canvas <- getActiveCanvas state

331 -- ; doc <- PD.getDocument pDoc

332 ; Just (hasMoved, origin) <- getDragging state

333 ; let offset = mousePoint `subtractDoublePoint` origin

334 ; when (mousePoint /= origin) $

335 do{ -- The first time the point is moved we have to remember

336 -- the document in the undo history

337 ; (if not hasMoved then PD.updateDocument "move control point"

338 else PD.superficialUpdateDocument)

339 (updateSelNetwork (updateMultiple nodeNrs viaNrs offset) canvas)

340 pDoc

341 ; repaintAll state

342 ; setDragging (Just (True, mousePoint)) state

343 -- yes, the point has really moved

344 }

345 }

346

347 updateMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> Network g n e

348 -> Network g n e

349 updateMultiple ns vs o network =

350 ( foldr (\n z-> updateNode n (offsetNode o) . z) id ns

351 . foldr (\ (e,v) z-> updateVia e v (offsetVia o e v) . z) id vs

352 ) network

353 where

354 offsetNode off node = setPosition (getPosition node `translate` off) node

355 offsetVia off edgeNr via = ((getEdgeVia (getEdge edgeNr network))!!via)

356 `translate` off

357

358 dropMultiple :: Bool -> [Int] -> [(Int,Int)] -> DoublePoint -> DoublePoint

359 -> State g n e -> IO ()

360 dropMultiple hasMoved nodeNrs viaNrs origin mousePoint state =

361 do{ when hasMoved $

362 do{ pDoc <- getDocument state

363 ; canvas <- getActiveCanvas state

364 ; PD.superficialUpdateDocument

365 (updateSelNetwork

366 (updateMultiple nodeNrs viaNrs

367 (mousePoint`subtractDoublePoint`origin)) canvas)

368 pDoc

369 }

370 ; repaintAll state

371 ; setDragging Nothing state

372 }

373

374 pickupArea :: DoublePoint -> State g n e -> IO ()

375 pickupArea mousePoint state =

376 do{ setDragging (Just (False, mousePoint)) state

377 ; selectMultiple (Just (mousePoint,mousePoint)) [] [] state

378 }

379

380 -- dragArea is not like dragging a selection. It does not move anything.

381 -- It only adds items into a multiple selection.

382 dragArea :: DoublePoint -> State g n e -> IO ()

383 dragArea mousePoint state =

384 do{ pDoc <- getDocument state

385 ; doc <- PD.getDocument pDoc

386 ; canvas <- getActiveCanvas state

387 ; Just (_, origin) <- getDragging state

388 ; let (ns,vs) = itemsEnclosedWithin mousePoint origin (selectNetwork doc canvas)

389 ; selectMultiple (Just (origin,mousePoint)) ns vs state

390 }

391 where

392 itemsEnclosedWithin p0 p1 network =

393 ( ( Prelude.map fst

394 . Prelude.filter (\ (_,n)-> enclosedInRectangle (getPosition n) p0 p1)

395 . getNodeAssocs ) network

396 , ( Prelude.concatMap (\ (i,e)-> map (\ (j,_)-> (i,j))

397 (Prelude.filter

398 (\ (_,v)-> enclosedInRectangle

399 v p0 p1)

400 (zip [0..] (getEdgeVia e))))

401 . getEdgeAssocs ) network

402 )

403

404 dropArea :: DoublePoint -> DoublePoint -> State g n e -> IO ()

405 dropArea _origin mousePoint state =

406 do{ dragArea mousePoint state -- calculate enclosure area

407 ; pDoc <- getDocument state

408 ; doc <- PD.getDocument pDoc

409 ; canvas <- getActiveCanvas state

410 ; case getSelection doc of

411 MultipleSelection _ _ [] [] ->

412 PD.superficialUpdateDocument (setSelection NoSelection) pDoc

413 MultipleSelection canv _ ns vs | canvas == canv ->

414 PD.superficialUpdateDocument

415 (setSelection (MultipleSelection canvas Nothing ns vs)) pDoc

416 | otherwise ->

417 PD.superficialUpdateDocument (setSelection NoSelection) pDoc

418 _ -> return ()

419 ; setDragging Nothing state

420 ; repaintAll state

421 }

422

423

424 renameNode :: Frame () -> State g n e -> IO ()

425 renameNode theFrame state =

426 do{ pDoc <- getDocument state

427 ; doc <- PD.getDocument pDoc

428 ; canvas <- getActiveCanvas state

429 ; let network = selectNetwork doc canvas

430 ; case getSelection doc of

431 NodeSelection canv nodeNr _ | canv == canvas ->

432 do{ let oldName = getNodeName network nodeNr

433 ; result <- myTextDialog theFrame SingleLine

434 "Rename node" oldName True

435 ; ifJust result $ \newName ->

436 do{ PD.updateDocument "rename node"

437 (updateSelNetwork

438 (updateNode nodeNr (Network.setName newName)) canvas) pDoc

439 ; repaintAll state

440 }

441 }

442 _ -> return ()

443 }

444

445 reinfoNodeOrEdge :: (InfoKind n g, InfoKind e g) =>

446 Frame () -> State g n e -> IO ()

447 reinfoNodeOrEdge theFrame state =

448 do{ pDoc <- getDocument state

449 ; doc <- PD.getDocument pDoc

450 ; canvas <- getActiveCanvas state

451 ; let network = selectNetwork doc canvas

452 ; case getSelection doc of

453 NodeSelection canv nodeNr _ | canv == canvas ->

454 do{ let oldInfo = getNodeInfo network nodeNr

455 ; result <- myTextDialog theFrame MultiLine

456 "Edit node info" (show oldInfo) True

457 ; ifJust result $ \newInfo ->

458 case Parse.runParser Parse.parse newInfo of

459 (Right x, s) ->

460 do{ when (not (null s || all isSpace s)) $

461 errorDialog theFrame "Edit warning"

462 ("Excess text after parsed value."

463 ++"\nRemaining text: "++s)

464 ; case check (getNodeName network nodeNr)

465 (getGlobalInfo network) x of

466 [] -> return ()

467 e -> errorDialog theFrame "Validity warning"

468 ("Validity check fails:\n"

469 ++unlines e)

470 ; PD.updateDocument "edit node info"

471 (updateSelNetwork

472 (updateNode nodeNr (setInfo x)) canvas) pDoc

473 ; repaintAll state

474 }

475 (Left err, s) -> errorDialog theFrame "Edit warning"

476 ("Cannot parse entered text."

477 ++"\nReason: "++err

478 ++"\nRemaining text: "++s)

479 }

480 EdgeSelection canv edgeNr | canv == canvas ->

481 do{ let oldInfo = getEdgeInfo (getEdge edgeNr network)

482 ; result <- myTextDialog theFrame MultiLine

483 "Edit edge info" (show oldInfo) True

484 ; ifJust result $ \newInfo ->

485 case Parse.runParser Parse.parse newInfo of

486 (Right x, s) ->

487 do{ when (not (null s || all isSpace s)) $

488 errorDialog theFrame "Edit warning"

489 ("Excess text after parsed value."

490 ++"\nRemaining text: "++s)

491 -- ; case check (getNodeName network nodeNr)

492 -- (getGlobalInfo network) x of

493 -- [] -> return ()

494 -- e -> errorDialog theFrame "Validity warning"

495 -- ("Validity check fails:\n"

496 -- ++unlines e)

497 ; PD.updateDocument "edit edge info"

498 (updateSelNetwork

499 (updateEdge edgeNr (setEdgeInfo x)) canvas) pDoc

500 ; repaintAll state

501 }

502 (Left err, s) -> errorDialog theFrame "Edit warning"

503 ("Cannot parse entered text."

504 ++"\nReason: "++err

505 ++"\nRemaining text: "++s)

506 }

507 _ -> return ()

508 }

509

510 changeGlobalInfo :: (Show g, Parse g) => Frame () -> State g n e -> IO ()

511 changeGlobalInfo theFrame state =

512 do{ pDoc <- getDocument state

513 ; doc <- PD.getDocument pDoc

514 ; canvas <- getActiveCanvas state

515 ; let network = selectNetwork doc canvas

516 ; let info = show (getGlobalInfo network)

517 ; result <- myTextDialog theFrame MultiLine "Edit global info" info True

518 ; ifJust result $ \newInfo->

519 case Parse.runParser Parse.parse newInfo of

520 (Right x, s) ->

521 do{ when (not (null s || all isSpace s)) $

522 errorDialog theFrame "Edit warning"

523 ("Excess text after parsed value."

524 ++"\nRemaining text: "++s)

525 ; PD.updateDocument "edit global info"

526 (updateSelNetwork (setGlobalInfo x) canvas) pDoc

527 ; repaintAll state -- no visible change?

528 }

529 (Left err, s) -> errorDialog theFrame "Edit warning"

530 ("Cannot parse entered text."

531 ++"\nReason: "++err

532 ++"\nRemaining text: "++s)

533 }

534