darcs - INblobs

1 module Shape where

2

3 import CommonIO

4 import Graphics.UI.WX as WX

5 import Graphics.UI.WXCore hiding (Colour)

6 import Graphics.UI.WXCore.Draw

7 import Math

8 import Text.Parse

9 --import Text.XML.HaXml.XmlContent

10 --import NetworkFile

11

12 import Colors

13 import Constants

14 import Common (removeQuotes)

15

16 data Shape =

17 Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double }

18 | Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }

19 -- centred on (0,0)

20 | Lines { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }

21 -- no fill for open shape

22 | Points { shapeStyle :: ShapeStyle, shapePoints :: [DoublePoint] }

23 | Rectangle { shapeStyle :: ShapeStyle

24 , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }

25 | Arc { shapeStyle :: ShapeStyle, shapeRadius :: Double

26 , shapeStart :: Double, shapeEnd :: Double

27 , shapeCenter :: DoublePoint }

28 | Ellipse { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint

29 , shapeHRadius :: Double, shapeVRadius :: Double }

30 | EllipticArc { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint

31 , shapeHRadius :: Double, shapeVRadius :: Double

32 , shapeStart :: Double, shapeEnd :: Double }

33 | RoundRec { shapeStyle :: ShapeStyle, shapeRadius :: Double

34 , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }

35 | Text { shapeStyle :: ShapeStyle, shapeText :: String }

36 | Composite { shapeSegments :: [Shape] } -- drawn in given order

37 | TextInEllipse { shapeStyle :: ShapeStyle, shapeText :: String }

38 deriving (Eq, Show, Read)

39

40 data ShapeStyle = ShapeStyle

41 { styleStrokeWidth :: Int

42 , styleStrokeColour :: Colour

43 , styleFill :: Colour

44 }

45 deriving (Eq, Show, Read)

46

47 instance Parse Shape where

48 parse = oneOf

49 [ do{ isWord "Circle"

50 ; return Circle

51 `discard` isWord "{" `apply` field "shapeStyle"

52 `discard` isWord "," `apply` field "shapeRadius"

53 `discard` isWord "}"

54 }

55 , do{ isWord "Polygon"

56 ; return Polygon

57 `discard` isWord "{" `apply` field "shapeStyle"

58 `discard` isWord "," `apply` field "shapePerimeter"

59 `discard` isWord "}"

60 }

61 , do{ isWord "Lines"

62 ; return Lines

63 `discard` isWord "{" `apply` field "shapeStyle"

64 `discard` isWord "," `apply` field "shapePerimeter"

65 `discard` isWord "}"

66 }

67 , do{ isWord "Points"

68 ; return Points

69 `discard` isWord "{" `apply` field "shapeStyle"

70 `discard` isWord "," `apply` field "shapePoints"

71 `discard` isWord "}"

72 }

73 , do{ isWord "Rectangle"

74 ; return Rectangle

75 `discard` isWord "{" `apply` field "shapeStyle"

76 `discard` isWord "," `apply` field "shapeUpperLeft"

77 `discard` isWord "," `apply` field "shapeLowerRight"

78 `discard` isWord "}"

79 }

80 , do{ isWord "Arc"

81 ; return Arc

82 `discard` isWord "{" `apply` field "shapeStyle"

83 `discard` isWord "," `apply` field "shapeRadius"

84 `discard` isWord "," `apply` field "shapeStart"

85 `discard` isWord "," `apply` field "shapeEnd"

86 `discard` isWord "," `apply` field "shapeCenter"

87 `discard` isWord "}"

88 }

89 , do{ isWord "Ellipse"

90 ; return Ellipse

91 `discard` isWord "{" `apply` field "shapeStyle"

92 `discard` isWord "," `apply` field "shapeCenter"

93 `discard` isWord "," `apply` field "shapeHRadius"

94 `discard` isWord "," `apply` field "shapeVRadius"

95 `discard` isWord "}"

96 }

97 , do{ isWord "EllipticArc"

98 ; return EllipticArc

99 `discard` isWord "{" `apply` field "shapeStyle"

100 `discard` isWord "," `apply` field "shapeCenter"

101 `discard` isWord "," `apply` field "shapeHRadius"

102 `discard` isWord "," `apply` field "shapeVRadius"

103 `discard` isWord "," `apply` field "shapeStart"

104 `discard` isWord "," `apply` field "shapeEnd"

105 `discard` isWord "}"

106 }

107 , do{ isWord "RoundRec"

108 ; return RoundRec

109 `discard` isWord "{" `apply` field "shapeStyle"

110 `discard` isWord "," `apply` field "shapeRadius"

111 `discard` isWord "," `apply` field "shapeUpperLeft"

112 `discard` isWord "," `apply` field "shapeLowerRight"

113 `discard` isWord "}"

114 }

115 , do{ isWord "Text"

116 ; return Text

117 `discard` isWord "{" `apply` field "shapeStyle"

118 `discard` isWord "," `apply` field "shapeText"

119 `discard` isWord "}"

120 }

121 , do{ isWord "Composite"

122 ; return Composite

123 `discard` isWord "{" `apply` field "shapeSegments"

124 `discard` isWord "}"

125 }

126 , do{ isWord "TextInEllipse"

127 ; return TextInEllipse

128 `discard` isWord "{" `apply` field "shapeStyle"

129 `discard` isWord "," `apply` field "shapeText"

130 `discard` isWord "}"

131 }

132 ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Points,Rectangle,Arc,Ellipse,EllipticArc,RoundRec,Text,Composite,TextInEllipse)")

133

134 instance Parse ShapeStyle where

135 parse = do{ isWord "ShapeStyle"

136 ; return ShapeStyle

137 `discard` isWord "{" `apply` field "styleStrokeWidth"

138 `discard` isWord "," `apply` field "styleStrokeColour"

139 `discard` isWord "," `apply` field "styleFill"

140 `discard` isWord "}"

141 }

142

143 {-

144 instance HTypeable Shape where

145 toHType s = Defined "Shape" [] [ Constr "Circle" [] []

146 , Constr "Polygon" [] []

147 , Constr "Lines" [] []

148 , Constr "Composite" [] []

149 ]

150 instance XmlContent Shape where

151 toContents s@(Circle{}) =

152 [ mkElemC "Circle" (toContents (shapeStyle s)

153 ++ [mkElemC "radius" (toContents (shapeRadius s))]) ]

154 toContents s@(Polygon{}) =

155 [ mkElemC "Polygon" (toContents (shapeStyle s)

156 ++ [mkElemC "perimeter" (concatMap toContents

157 (shapePerimeter s))]) ]

158 toContents s@(Lines{}) =

159 [ mkElemC "Lines" (toContents (shapeStyle s)

160 ++ [mkElemC "perimeter" (concatMap toContents

161 (shapePerimeter s))]) ]

162 toContents s@(Composite{}) =

163 [ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ]

164 parseContents = do

165 { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]

166 ; case t of

167 "Circle" -> interior e $

168 do{ style <- parseContents

169 ; r <- inElement "radius" parseContents

170 ; return (Circle {shapeStyle=style, shapeRadius=r})

171 }

172 "Polygon" -> interior e $

173 do{ style <- parseContents

174 ; p <- inElement "perimeter" $ many1 parseContents

175 ; return (Polygon {shapeStyle=style, shapePerimeter=p})

176 }

177 "Lines" -> interior e $

178 do{ style <- parseContents

179 ; p <- inElement "perimeter" $ many1 parseContents

180 ; return (Lines {shapeStyle=style, shapePerimeter=p})

181 }

182 "Composite" -> interior e $ do{ ss <- many1 parseContents

183 ; return (Composite {shapeSegments=ss})

184 }

185 }

186

187 instance HTypeable ShapeStyle where

188 toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []]

189 instance XmlContent ShapeStyle where

190 toContents s =

191 [ mkElemC "ShapeStyle"

192 [ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s))

193 , mkElemC "StrokeColour" (toContents (styleStrokeColour s))

194 , mkElemC "Fill" (toContents (styleFill s))

195 ]

196 ]

197 parseContents = inElement "ShapeStyle" $ do

198 { w <- inElement "StrokeWidth" parseContents

199 ; c <- inElement "StrokeColour" parseContents

200 ; f <- inElement "Fill" parseContents

201 ; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c

202 , styleFill=f })

203 }

204 -}

205

206 logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [Prop (DC ())] -> IO ()

207 logicalDraw ppi dc centre shape options =

208 case shape of

209 Circle {} -> WX.circle dc (logicalToScreenPoint ppi centre)

210 (logicalToScreenX ppi (shapeRadius shape))

211 (style2options (shapeStyle shape)++options)

212

213 Polygon {} -> WX.polygon dc (map (logicalToScreenPoint ppi

214 . translate centre)

215 (shapePerimeter shape))

216 (style2options (shapeStyle shape)++options)

217

218 Lines {} -> logicalLineSegments ppi dc (map (translate centre)

219 (shapePerimeter shape))

220 (style2options (shapeStyle shape)++options)

221

222 Points {} -> mapM_ (\p -> WX.drawPoint dc

223 (logicalToScreenPoint ppi $ translate centre p)

224 (style2options (shapeStyle shape)++options)

225 )

226 $ shapePoints shape

227

228 Rectangle {} -> WX.drawRect dc

229 (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )

230 (style2options (shapeStyle shape)++options)

231

232 Arc {} -> WX.arc dc (logicalToScreenPoint ppi . translate centre $ shapeCenter shape)

233 (logicalToScreenX ppi (shapeRadius shape))

234 (shapeStart shape)

235 (shapeEnd shape)

236 (style2options (shapeStyle shape)++options)

237

238 Ellipse {} -> WX.ellipse dc

239 (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))

240 (style2options (shapeStyle shape)++options)

241

242 EllipticArc {} -> WX.ellipticArc

243 dc

244 (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))

245 (shapeStart shape)

246 (shapeEnd shape)

247 (style2options (shapeStyle shape)++options)

248

249 RoundRec {} -> WX.roundedRect dc

250 (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )

251 (shapeRadius shape)

252 (style2options (shapeStyle shape)++options)

253

254 Text {} -> do textSize <- getTextExtent dc (shapeText shape)

255 let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre

256 . scale 0.5

257 . screenToLogicalPoint ppi $ pointFromSize textSize

258 WX.drawText dc (removeQuotes $ shapeText shape)

259 upperCorner

260 (style2options (shapeStyle shape)++options)

261

262 Composite {} -> mapM_ (\s-> logicalDraw ppi dc centre s options)

263 (shapeSegments shape)

264

265 TextInEllipse {} ->

266 do let txt = removeQuotes (shapeText shape)

267 textSize <- getTextExtent dc (shapeText shape)

268 let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre

269 . scale 0.5

270 . screenToLogicalPoint ppi $ pointFromSize textSize

271 WX.ellipse dc

272 (rect (pointSub upperCorner $ Point 5 5)

273 $ Size (sizeW textSize + 10) (sizeH textSize + 10) )

274 (style2options (shapeStyle shape)++options)

275 WX.drawText dc txt upperCorner

276 (style2options (shapeStyle shape)++options)

277

278 where rectFrom :: DoublePoint -> DoublePoint -> Rect

279 rectFrom upperLeftCorner lowerRightCorner =

280 rectBetween (logicalToScreenPoint ppi $ translate centre upperLeftCorner)

281 (logicalToScreenPoint ppi $ translate centre lowerRightCorner)

282 doRect :: DoublePoint -> Double -> Double -> Rect

283 doRect ellipseCenter hRadius vRadius =

284 rectBetween (logicalToScreenPoint ppi . translate centre

285 $ subtractDoublePoint ellipseCenter $ DoublePoint hRadius vRadius)

286 (logicalToScreenPoint ppi . translate centre

287 $ translate ellipseCenter $ DoublePoint hRadius vRadius)

288

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

290 logicalLineSegments _ _ [_p] _options = return ()

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

292 do{ line dc (logicalToScreenPoint ppi fromPoint)

293 (logicalToScreenPoint ppi toPoint) options

294 ; logicalLineSegments ppi dc (toPoint:ps) options

295 }

296

297 circle :: Shape

298 circle = Circle { shapeStyle = defaultShapeStyle

299 , shapeRadius = kNODE_RADIUS }

300

301 style2options :: ShapeStyle -> [Prop (DC ())]

302 style2options sty =

303 [ penWidth := styleStrokeWidth sty

304 , penColor := wxcolor (styleStrokeColour sty)

305 , brushKind := BrushSolid

306 , brushColor := wxcolor (styleFill sty)

307 ]

308

309 defaultShapeStyle :: ShapeStyle

310 defaultShapeStyle =

311 ShapeStyle { styleStrokeWidth = 1

312 , styleStrokeColour = licorice

313 , styleFill = nodeColor }