darcs - INblobs

1 module NetworkView

2 ( drawCanvas

3 , clickedNode

4 , clickedNodePort

5 , clickedEdge

6 , clickedVia

7 , edgeContains

8 ) where

10 import Constants

11 import CommonIO

12 import Network

13 import Document

14 import Colors

15 import Common

16 import Palette

17 import Ports

18 import Math

19 import Graphics.UI.WX as WX hiding (Vector, Selection)

20 import Graphics.UI.WXCore hiding (Document, screenPPI, Colour, Palette)

21 import Graphics.UI.WXCore.Draw

22 import Data.Maybe

23 import Shape

24 import DisplayOptions

25 import InfoKind

27 import Prelude hiding (catch)

28 import Control.Exception

29 import qualified Data.IntMap as IntMap

30 import Data.List

32 drawCanvas :: (InfoKind n g, InfoKind e g) =>

33 Network g n e -> Palette n -> Selection -> [NodeNr] -- interface nodes mapped

34 -> DC () -> DisplayOptions -> IO ()

35 drawCanvas net palette selec p dc opt =

36 do{

38 -- Scale if the DC we are drawing to has a different PPI from the screen

39 -- Printing, nudge, nudge

40 ; dcPPI <- dcGetPPI dc

41 ; screenPPI <- getScreenPPI

42 ; when (dcPPI /= screenPPI) $

43 dcSetUserScale dc

44 (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI ))

45 (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI ))

47 -- Set font

48 ; set dc [ fontFamily := FontDefault, fontSize := 10 ]

50 ; catch (reallyDrawCanvas net palette selec p screenPPI dc opt)

51 (\e -> logicalText dcPPI dc (DoublePoint 50 50)

52 ("Exception while drawing: "++show e)

53 (Justify LeftJ TopJ) [] )

54 }

56 reallyDrawCanvas :: (InfoKind n g, InfoKind e g) =>

57 Network g n e -> Palette n -> Selection -> [NodeNr]

58 -> Size -> DC () -> DisplayOptions -> IO ()

59 reallyDrawCanvas network palette theSelection mapp ppi dc opt =

60 do{

61 -- draw edges, highlight the selected ones (if any)

62 ; mapM_ (\edge -> drawEdge edge []) (getEdgeAssocs network)

63 ; case theSelection of

64 EdgeSelection _ edgeNr -> do

65 drawEdge (edgeNr, getEdge edgeNr network) kSELECTED_OPTIONS

66 ViaSelection _ edgeNr viaNr -> do

67 drawVia (getEdge edgeNr network) viaNr kSELECTED_OPTIONS

68 MultipleSelection _ _ _ viaNrs -> do

69 mapM_ (\ (e,v)-> drawVia (getEdge e network) v kSELECTED_OPTIONS)

70 viaNrs

71 _ -> return ()

73 -- draw nodes, highlight the selected ones (if any)

74 ; mapM_ (\(nodeNr, _) -> drawNode nodeNr [ ]) (getNodeAssocs network)

75 ; case theSelection of

76 NodeSelection _ nodeNr mPort ->

77 do drawNode nodeNr (kSELECTED_OPTIONS

78 ++ [ penColor := wxcolor activeSelectionColor ])

79 case mPort of

80 Nothing -> return ()

81 Just str -> drawPort ppi dc

82 (getPosition $ getNode nodeNr network)

83 [brushKind := BrushSolid

84 , brushColor := kPortSelectedColor]

85 $ snd $ takeJust "inexistent port" $ getPort palette network (nodeNr, str)

86 MultipleSelection _ _ nodeNrs _ ->

87 mapM_ (\n-> drawNode n (kSELECTED_OPTIONS

88 ++ [ penColor := wxcolor activeSelectionColor ]))

89 nodeNrs

90 _ -> return ()

92 -- multiple selection drag area rectangle

93 ; case theSelection of

94 MultipleSelection _ (Just (p,q)) _ _ ->

95 logicalRect ppi dc (doublePointX p) (doublePointY p)

96 (doublePointX q - doublePointX p)

97 (doublePointY q - doublePointY p)

98 [ penColor := wxcolor lightGrey

99 , brushKind := BrushTransparent]

100 _ -> return ()

101

102 -- canvas size rectangle

103 -- ; let (width, height) = Network.getCanvasSize (getNetwork doc)

104 -- ; logicalRect ppi dc 0 0 width height [brushKind := BrushTransparent]

105 }

106 where

107 drawNode :: Int -> [Prop (DC ())] -> IO ()

108 drawNode nodeNr options =

109 do{

110 -- draw node

111 ; logicalDraw ppi dc center shape options

112 -- ; logicalCircle ppi dc center kNODE_RADIUS options

113 ; drawPorts ppi dc center ports options

114

115 -- draw label

116 ; when (NodeLabel `elem` dpShowInfo opt) $

117 drawLabel (offset above) False (getName node) center

118 (justif above) [ textColor := wxcolor kNodeLabelColour ]

119 -- draw info

120 ; when (NodeInfo `elem` dpShowInfo opt) $

121 drawLabel (offset (not above)) False (show (getInfo node))

122 center (justif (not above))

123 [ textColor := wxcolor kNodeInfoColour ]

124

125 -- draw mapping numbering when needed

126 ; maybe ( return () )

127 showInterfaceMap

128 $ findIndex (nodeNr ==) mapp

129

130 }

131 where

132 node = getNode nodeNr network

133 above = getNameAbove node

134 center = getPosition node

135 symbol = takeJust "No symbol definition"

136 $ getSymbol (getShape node) palette

137 shape = fst3 symbol

138 ports = snd3 symbol

139

140 offset b = (if b then negate else id) kNODE_RADIUS

141 justif b = Justify CentreJ (if b then BottomJ else TopJ)

142

143 showInterfaceMap n =

144 drawLabel 0.15 True (show $ succ n) center

145 (justif above) [ textColor := wxcolor kNodeMapColour ]

146

147 drawLabel :: Double -> Bool -> String -> DoublePoint -> Justify

148 -> [Prop (DC ())] -> IO ()

149 drawLabel voffset boxed text (DoublePoint x y) justify opts =

150 do{ -- draw background

151 when boxed $ do

152 { (textWidth, textHeight) <- logicalGetTextExtent ppi dc text

153 ; let horizontalMargin = 0.2 -- centimeters

154 verticalMargin = 0.01 -- centimeters

155 topleftY = y+voffset - case justify of

156 Justify _ TopJ -> 0

157 Justify _ MiddleJ -> textHeight/2

158 Justify _ BottomJ -> textHeight

159

160 ; logicalRect ppi dc

161 (x - textWidth/2 - horizontalMargin) (topleftY)

162 (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin)

163 (solidFill labelBackgroundColor)

164 }

165 -- draw text

166 ; logicalText ppi dc (DoublePoint x (y+voffset)) text justify opts

167 }

168

169 isPrincipalPort' (nodeNr, port) =

170 isPrincipalPort palette network nodeNr port && not (isInterfacePort port)

171 isPrincipalPort' _ = False

172

173 drawEdge :: InfoKind e g => (EdgeNr, Edge e) -> [Prop (DC ())] -> IO ()

174 drawEdge (edgeNr, edge) options =

175 do{ logicalLineSegments ppi dc (pt1:via++[pt2]) options

176 -- arrow on the end

177 -- ; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill licorice)

178

179 -- arrow(s) on principal ports

180 ; when hasPrincipalPorts

181 $ do when (isPrincipalPort' fromPort)

182 $ logicalLine ppi dc [tw1, pw1, tw2] options

183 when (isPrincipalPort' toPort)

184 $ logicalLine ppi dc [tw3, pw2, tw4] options

185

186 -- draw label

187 ; when (EdgeLabel `elem` dpShowInfo opt) $

188 drawLabel 0 False (int2name edgeNr)

189 (translate (DoublePoint 0.2 0.1 )$ middle via)

190 (Justify LeftJ TopJ)

191 [ textColor := wxcolor kEdgeLabelColour ]

192

193 -- draw info

194 ; when (EdgeInfo `elem` dpShowInfo opt) $

195 -- logicalTextRotated ppi dc (middle via) (show info) 45

196 -- [ textColor := wxcolor kEdgeInfoColour ]

197 drawLabel 0 False (show (getEdgeInfo edge)) (middle via)

198 (Justify CentreJ BottomJ)

199 [ textColor := wxcolor kEdgeInfoColour ]

200 }

201 where

202 fromNode = getNode (getEdgeFrom edge) network

203 toNode = getNode (getEdgeTo edge) network

204

205 fromPort = getFullPortFrom edge

206 toPort = getFullPortTo edge

207

208 radius = kPortRadius

209 fromNodePoint = getPosition fromNode

210 toNodePoint = getPosition toNode

211

212 fromPortPosition = snd . takeJust "Inexistent port" $ getPort palette network fromPort

213 toPortPosition = snd . takeJust "Inexistent port" $ getPort palette network toPort

214

215 fromPoint = translate fromNodePoint fromPortPosition

216 toPoint = translate toNodePoint toPortPosition

217 via = getEdgeVia edge

218

219 fstEdgeVector = (head (via++[toPoint]))

220 `subtractDoublePointVector` fromPoint

221 fstTotalLen = vectorLength fstEdgeVector

222 fstAngle = vectorAngle fstEdgeVector

223

224 penultimatePt = head (reverse (fromPoint:via))

225 endEdgeVector = toPoint `subtractDoublePointVector` penultimatePt

226 endTotalLen = vectorLength endEdgeVector

227 endAngle = vectorAngle endEdgeVector

228

229 middle [] = DoublePoint ((doublePointX pt1 + doublePointX pt2)/2)

230 ((doublePointY pt1 + doublePointY pt2)/2)

231 middle [p] = p

232 middle ps = middle (tail (reverse ps))

233

234 pt1 = translatePolar fstAngle radius fromPoint

235 pt2 = translatePolar endAngle (endTotalLen - radius) penultimatePt

236

237 tr1 = translatePolar (endAngle + pi + pi / 6) kARROW_SIZE pt2

238 tr2 = translatePolar (endAngle + pi - pi / 6) kARROW_SIZE pt2

239

240 pw1 = translatePolar fstAngle (radius + kARROW_SIZE) fromPoint

241 pw2 = translatePolar endAngle (endTotalLen - radius - kARROW_SIZE) penultimatePt

242

243 tw1 = translatePolar (fstAngle + pi + pi / 6) kARROW_SIZE pw1

244 tw2 = translatePolar (fstAngle + pi - pi / 6) kARROW_SIZE pw1

245

246 tw3 = translatePolar (endAngle + pi / 6) kARROW_SIZE pw2

247 tw4 = translatePolar (endAngle - pi / 6) kARROW_SIZE pw2

248

249 drawVia :: Edge e -> ViaNr -> [Prop (DC ())] -> IO ()

250 drawVia e n options =

251 let pt = (getEdgeVia e)!!n in

252 do logicalCircle ppi dc pt kEDGE_CLICK_RANGE

253 (options ++ solidFill violet)

254

255 solidFill :: Colour -> [Prop (DC ())]

256 solidFill colour = [ brushKind := BrushSolid, brushColor := wxcolor colour ]

257

258 -- | Finds which node of the network is clicked by the mouse, if any

259 clickedNode :: DoublePoint -> Document g n e -> ActiveCanvas -> Maybe Int

260 clickedNode clickedPoint doc canvas =

261 let network = selectNetwork doc canvas

262 nodeAssocs = case getSelection doc of

263 NodeSelection canv nodeNr _

264 | canv == canvas -> [(nodeNr, getNode nodeNr network)]

265 | otherwise -> []

266 _ -> []

267 ++ reverse (getNodeAssocs network)

268 in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of

269 [] -> Nothing

270 ((i, _):_) -> Just i

271

272 -- | Finds which node and port of the network is clicked by the mouse, if any

273 clickedNodePort :: DoublePoint -> Document g n e -> ActiveCanvas

274 -> Maybe (NodeNr, Maybe PortName)

275 clickedNodePort clickedPoint doc canvas =

276 let network = selectNetwork doc canvas

277 nodeAssocs = case getSelection doc of

278 NodeSelection canv nodeNr _

279 | canv == canvas -> [(nodeNr, getNode nodeNr network)]

280 | otherwise -> []

281 _ -> []

282 ++ reverse (getNodeAssocs network)

283 in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of

284 [] -> Nothing

285 ((i, n):_) -> case getPorts (getPalette doc) network i of

286 Nothing -> Nothing -- no symbol definition. Shouldn't occur

287 Just ps ->

288 case filter (\p -> portContains n p clickedPoint) ps of

289 [] -> Just (i, Nothing) -- if the mouse is over a node

290 -- with ports but not over any

291 -- of its ports the node is selected

292 (port:_) -> Just (i, Just $ fst port)

293

294 nodeContains :: Node n -> DoublePoint -> Bool

295 nodeContains node clickedPoint =

296 distancePointPoint (getPosition node) clickedPoint

297 < kNODE_RADIUS

298

299 portContains :: Node n -> Port -> DoublePoint -> Bool

300 portContains node (_, portP) clickedPoint =

301 distancePointPoint portCenter clickedPoint

302 < kPortSelectionRadius

303 where portCenter = translate (getPosition node) portP

304

305 -- | Finds which edge of the network is clicked by the mouse, if any

306 clickedEdge :: DoublePoint -> Network g n e -> Maybe Int

307 clickedEdge clickedPoint network =

308 let assocs = getEdgeAssocs network

309 in case filter (\(_, edge) -> isJust (edgeContains edge clickedPoint network)) assocs of

310 [] -> Nothing

311 ((i, _):_) -> Just i

312

313 edgeContains :: Edge e -> DoublePoint -> Network g n e -> Maybe Int

314 edgeContains edge clickedPoint network =

315 let p0 = getNodePosition network (getEdgeFrom edge)

316 p1 = getNodePosition network (getEdgeTo edge)

317 via= getEdgeVia edge

318 p = clickedPoint

319 numberedDistancesToSegments = zip [0..] $

320 zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p)

321 (p0:via) (via++[p1])

322 in case [ nr | (nr,dist) <- numberedDistancesToSegments

323 , dist < kEDGE_CLICK_RANGE ] of

324 [] -> Nothing

325 nrs -> Just (head nrs)

326

327 -- | Finds which 'via' control point is clicked by the mouse, if any

328 clickedVia :: DoublePoint -> Network g n e -> Maybe (Int,Int)

329 clickedVia clickedPoint network =

330 let allVia = concatMap (\ (k,e)-> zipWith (\n v->((k,n),v))

331 [0..] (getEdgeVia e))

332 (IntMap.toList (networkEdges network))

333 in case filter (\ (_,v)-> distancePointPoint v clickedPoint

334 < kEDGE_CLICK_RANGE) allVia of

335 [] -> Nothing

336 ((kn,_):_) -> Just kn

337

338 -- Drawing operations in logical coordinates

339

340 logicalCircle :: Size -> DC () -> DoublePoint -> Double -> [Prop (DC ())] -> IO ()

341 logicalCircle ppi dc center radius options =

342 WX.circle dc (logicalToScreenPoint ppi center) (logicalToScreenX ppi radius) options

343

344 logicalRect :: Size -> DC () -> Double -> Double -> Double -> Double -> [Prop (DC ())] -> IO ()

345 logicalRect ppi dc x y width height options =

346 drawRect dc

347 (rect

348 (pt (logicalToScreenX ppi x) (logicalToScreenY ppi y))

349 (sz (logicalToScreenX ppi width) (logicalToScreenY ppi height)))

350 options

351

352 data Justify = Justify Horizontal Vertical deriving Eq

353 data Horizontal = LeftJ | CentreJ | RightJ deriving Eq

354 data Vertical = TopJ | MiddleJ | BottomJ deriving Eq

355

356 -- can deal with multi-line text

357 logicalText :: Size -> DC () -> DoublePoint -> String -> Justify

358 -> [Prop (DC ())] -> IO ()

359 logicalText ppi dc (DoublePoint x y) txt (Justify horiz vert) options =

360 do{ (width,height) <- logicalGetTextExtent ppi dc txt

361 ; eachLine width (startPos height) (lines txt)

362 }

363 where

364 startPos height = case vert of TopJ -> (x, y)

365 MiddleJ -> (x, y-height/2)

366 BottomJ -> (x, y-height)

367 eachLine _ _ [] = return ()

368 eachLine maxwidth (x,y) (txt:txts) =

369 do{ (w,h) <- logicalGetTextExtent ppi dc txt

370 ; let thisX = case horiz of LeftJ -> x-maxwidth/2

371 CentreJ -> x-w/2

372 RightJ -> x+(maxwidth/2)-w

373 ; drawText dc txt (logicalToScreenPoint ppi (DoublePoint thisX y))

374 options

375 ; eachLine maxwidth (x,y+h) txts

376 }

377

378 -- currently assumes only single line of text

379 logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double

380 -> [Prop (DC ())] -> IO ()

381 logicalTextRotated ppi dc pos txt angle options =

382 draw dc txt (logicalToScreenPoint ppi pos) options

383 where

384 draw = if angle<1 && angle>(-1) then drawText

385 else (\a b c e -> rotatedText a b c angle e)

386

387

388 {-

389 logicalLine :: Size -> DC () -> DoublePoint -> DoublePoint -> [Prop (DC ())] -> IO ()

390 logicalLine ppi dc fromPoint toPoint options =

391 line dc (logicalToScreenPoint ppi fromPoint)

392 (logicalToScreenPoint ppi toPoint) options

393

394 logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()

395 logicalLineSegments _ _ [p] options = return ()

396 logicalLineSegments ppi dc (fromPoint:toPoint:ps) options =

397 do{ line dc (logicalToScreenPoint ppi fromPoint)

398 (logicalToScreenPoint ppi toPoint) options

399 ; logicalLineSegments ppi dc (toPoint:ps) options

400 }

401 -}

402

403 logicalPoly :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()

404 logicalPoly ppi dc points options =

405 polygon dc (map (logicalToScreenPoint ppi) points) options

406

407 logicalLine :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()

408 logicalLine ppi dc points options =

409 polyline dc (map (logicalToScreenPoint ppi) points) options

410

411 logicalGetTextExtent :: Size -> DC () -> String -> IO (Double, Double)

412 logicalGetTextExtent ppi dc txt =

413 do{ textSizes <- mapM (getTextExtent dc) (lines txt)

414 ; return

415 ( screenToLogicalX ppi (maximum (map sizeW textSizes))

416 , screenToLogicalY ppi (sum (map sizeH textSizes))

417 )

418 }