Mon Feb 20 19:04:04 WET 2006 Miguel Vilaca <jmvilaca@di.uminho.pt>
* More shapes for nodes
Adds new shapes: arc, ellipse, elliptic arc, list of points, rectangle, rounded rectangle, text, and ellipse with text inside it.
{
hunk ./src/Common.hs 182
+removeQuotes :: String -> String
+removeQuotes = init . tail
+
hunk ./src/Math.hs 16
+ , scale
hunk ./src/Math.hs 112
+
+scale :: Double -> DoublePoint -> DoublePoint
+scale f (DoublePoint x y) = DoublePoint (f * x) (f * y)
hunk ./src/NetworkFile.hs 236
- toHType v = Defined "Shape" []
- [Constr "Circle" [] [toHType aa,toHType ab]
- ,Constr "Polygon" [] [toHType ac,toHType ad]
- ,Constr "Lines" [] [toHType ae,toHType af]
- ,Constr "Composite" [] [toHType ag]]
+ toHType v =
+ Defined "Shape" []
+ [Constr "Circle" [] [toHType aa,toHType ab],
+ Constr "Polygon" [] [toHType ac,toHType ad],
+ Constr "Lines" [] [toHType ae,toHType af],
+ Constr "Points" [] [toHType ag,toHType ah],
+ Constr "Rectangle" [] [toHType ai,toHType aj,toHType ak],
+ Constr "Arc" []
+ [toHType al,toHType am,toHType an,toHType ao,toHType ap]
+ ,Constr "Ellipse" [] [toHType aq,toHType ar,toHType as,toHType at],
+ Constr "EllipticArc" []
+ [toHType au,toHType av,toHType aw,toHType ax,toHType ay,toHType az]
+ ,Constr "RoundRec" [] [toHType aA,toHType aB,toHType aC,toHType aD]
+ ,Constr "Text" [] [toHType aE,toHType aF],
+ Constr "Composite" [] [toHType aG],
+ Constr "TextInEllipse" [] [toHType aH,toHType aI]]
hunk ./src/NetworkFile.hs 253
- (Circle aa ab) = v
- (Polygon ac ad) = v
- (Lines ae af) = v
- (Composite ag) = v
+ (Circle aa ab) = v
+ (Polygon ac ad) = v
+ (Lines ae af) = v
+ (Points ag ah) = v
+ (Rectangle ai aj ak) = v
+ (Arc al am an ao ap) = v
+ (Ellipse aq ar as at) = v
+ (EllipticArc au av aw ax ay az) = v
+ (RoundRec aA aB aC aD) = v
+ (Text aE aF) = v
+ (Composite aG) = v
+ (TextInEllipse aH aI) = v
+
hunk ./src/NetworkFile.hs 268
- { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]
- ; case t of
- _ | "Polygon" `isPrefixOf` t -> interior e $
- do { ac <- parseContents
- ; ad <- parseContents
- ; return (Polygon ac ad)
- }
- | "Lines" `isPrefixOf` t -> interior e $
- do { ae <- parseContents
- ; af <- parseContents
- ; return (Lines ae af)
- }
- | "Composite" `isPrefixOf` t -> interior e $
- fmap Composite parseContents
- | "Circle" `isPrefixOf` t -> interior e $
- do { aa <- parseContents
- ; ab <- parseContents
- ; return (Circle aa ab)
- }
- }
+ { e@(Elem t _ _) <- elementWith (flip isPrefixOf) ["TextInEllipse","Text","RoundRec","Rectangle","Polygon","Points","Lines","EllipticArc","Ellipse","Composite","Circle","Arc"]
+ ; case t of
+ _ | "TextInEllipse" `isPrefixOf` t -> interior e $
+ return TextInEllipse `apply` parseContents `apply` parseContents
+ | "Text" `isPrefixOf` t -> interior e $
+ return Text `apply` parseContents `apply` parseContents
+ | "RoundRec" `isPrefixOf` t -> interior e $
+ return RoundRec `apply` parseContents `apply` parseContents
+ `apply` parseContents `apply` parseContents
+ | "Rectangle" `isPrefixOf` t -> interior e $
+ return Rectangle `apply` parseContents `apply` parseContents
+ `apply` parseContents
+ | "Polygon" `isPrefixOf` t -> interior e $
+ return Polygon `apply` parseContents `apply` parseContents
+ | "Points" `isPrefixOf` t -> interior e $
+ return Points `apply` parseContents `apply` parseContents
+ | "Lines" `isPrefixOf` t -> interior e $
+ return Lines `apply` parseContents `apply` parseContents
+ | "EllipticArc" `isPrefixOf` t -> interior e $
+ return EllipticArc `apply` parseContents `apply` parseContents
+ `apply` parseContents `apply` parseContents
+ `apply` parseContents `apply` parseContents
+ | "Ellipse" `isPrefixOf` t -> interior e $
+ return Ellipse `apply` parseContents `apply` parseContents
+ `apply` parseContents `apply` parseContents
+ | "Composite" `isPrefixOf` t -> interior e $ fmap Composite parseContents
+ | "Circle" `isPrefixOf` t -> interior e $
+ return Circle `apply` parseContents `apply` parseContents
+ | "Arc" `isPrefixOf` t -> interior e $
+ return Arc `apply` parseContents `apply` parseContents
+ `apply` parseContents `apply` parseContents `apply` parseContents
+ }
hunk ./src/NetworkFile.hs 301
- [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,
- toContents ab])]
+ [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,
+ toContents ab])]
hunk ./src/NetworkFile.hs 304
- [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac,
- toContents ad])]
+ [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac,
+ toContents ad])]
hunk ./src/NetworkFile.hs 307
- [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae,
- toContents af])]
- toContents v@(Composite ag) =
- [mkElemC (showConstr 3 (toHType v)) (toContents ag)]
+ [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae,
+ toContents af])]
+ toContents v@(Points ag ah) =
+ [mkElemC (showConstr 3 (toHType v)) (concat [toContents ag,
+ toContents ah])]
+ toContents v@(Rectangle ai aj ak) =
+ [mkElemC (showConstr 4 (toHType v)) (concat [toContents ai,
+ toContents aj,toContents ak])]
+ toContents v@(Arc al am an ao ap) =
+ [mkElemC (showConstr 5 (toHType v)) (concat [toContents al,
+ toContents am,toContents an,toContents ao,
+ toContents ap])]
+ toContents v@(Ellipse aq ar as at) =
+ [mkElemC (showConstr 6 (toHType v)) (concat [toContents aq,
+ toContents ar,toContents as,toContents at])]
+ toContents v@(EllipticArc au av aw ax ay az) =
+ [mkElemC (showConstr 7 (toHType v)) (concat [toContents au,
+ toContents av,toContents aw,toContents ax,
+ toContents ay,toContents az])]
+ toContents v@(RoundRec aA aB aC aD) =
+ [mkElemC (showConstr 8 (toHType v)) (concat [toContents aA,
+ toContents aB,toContents aC,toContents aD])]
+ toContents v@(Text aE aF) =
+ [mkElemC (showConstr 9 (toHType v)) (concat [toContents aE,
+ toContents aF])]
+ toContents v@(Composite aG) =
+ [mkElemC (showConstr 10 (toHType v)) (toContents aG)]
+ toContents v@(TextInEllipse aH aI) =
+ [mkElemC (showConstr 11 (toHType v)) (concat [toContents aH,
+ toContents aI])]
hunk ./src/Shape.hs 14
+import Common (removeQuotes) [_$_]
hunk ./src/Shape.hs 22
+ | Points { shapeStyle :: ShapeStyle, shapePoints :: [DoublePoint] }
+ | Rectangle { shapeStyle :: ShapeStyle
+ , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }
+ | Arc { shapeStyle :: ShapeStyle, shapeRadius :: Double
+ , shapeStart :: Double, shapeEnd :: Double
+ , shapeCenter :: DoublePoint }
+ | Ellipse { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint
+ , shapeHRadius :: Double, shapeVRadius :: Double }
+ | EllipticArc { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint
+ , shapeHRadius :: Double, shapeVRadius :: Double [_$_]
+ , shapeStart :: Double, shapeEnd :: Double }
+ | RoundRec { shapeStyle :: ShapeStyle, shapeRadius :: Double
+ , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }
+ | Text { shapeStyle :: ShapeStyle, shapeText :: String }
hunk ./src/Shape.hs 37
+ | TextInEllipse { shapeStyle :: ShapeStyle, shapeText :: String }
hunk ./src/Shape.hs 67
+ , do{ isWord "Points"
+ ; return Points
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapePoints"
+ `discard` isWord "}"
+ }
+ , do{ isWord "Rectangle"
+ ; return Rectangle
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeUpperLeft"
+ `discard` isWord "," `apply` field "shapeLowerRight"
+ `discard` isWord "}"
+ }
+ , do{ isWord "Arc"
+ ; return Arc
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeRadius"
+ `discard` isWord "," `apply` field "shapeStart"
+ `discard` isWord "," `apply` field "shapeEnd"
+ `discard` isWord "," `apply` field "shapeCenter"
+ `discard` isWord "}"
+ }
+ , do{ isWord "Ellipse"
+ ; return Ellipse
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeCenter"
+ `discard` isWord "," `apply` field "shapeHRadius"
+ `discard` isWord "," `apply` field "shapeVRadius"
+ `discard` isWord "}"
+ }
+ , do{ isWord "EllipticArc"
+ ; return EllipticArc
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeCenter"
+ `discard` isWord "," `apply` field "shapeHRadius"
+ `discard` isWord "," `apply` field "shapeVRadius"
+ `discard` isWord "," `apply` field "shapeStart"
+ `discard` isWord "," `apply` field "shapeEnd"
+ `discard` isWord "}"
+ }
+ , do{ isWord "RoundRec"
+ ; return RoundRec
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeRadius"
+ `discard` isWord "," `apply` field "shapeUpperLeft"
+ `discard` isWord "," `apply` field "shapeLowerRight"
+ `discard` isWord "}"
+ }
+ , do{ isWord "Text"
+ ; return Text
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeText"
+ `discard` isWord "}"
+ }
hunk ./src/Shape.hs 126
- ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Composite)")
+ , do{ isWord "TextInEllipse"
+ ; return TextInEllipse
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeText"
+ `discard` isWord "}"
+ }
+ ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Points,Rectangle,Arc,Ellipse,EllipticArc,RoundRec,Text,Composite,TextInEllipse)")
hunk ./src/Shape.hs 212
+
hunk ./src/Shape.hs 217
+
hunk ./src/Shape.hs 221
- Composite {}-> mapM_ (\s-> logicalDraw ppi dc centre s options)
+
+ Points {} -> mapM_ (\p -> WX.drawPoint dc [_$_]
+ (logicalToScreenPoint ppi $ translate centre p)
+ (style2options (shapeStyle shape)++options)
+ ) [_$_]
+ $ shapePoints shape
+
+ Rectangle {} -> WX.drawRect dc [_$_]
+ (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )
+ (style2options (shapeStyle shape)++options)
+
+ Arc {} -> WX.arc dc (logicalToScreenPoint ppi . translate centre $ shapeCenter shape)
+ (logicalToScreenX ppi (shapeRadius shape))
+ (shapeStart shape)
+ (shapeEnd shape)
+ (style2options (shapeStyle shape)++options)
+
+ Ellipse {} -> WX.ellipse dc
+ (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))
+ (style2options (shapeStyle shape)++options)
+
+ EllipticArc {} -> WX.ellipticArc [_$_]
+ dc
+ (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))
+ (shapeStart shape)
+ (shapeEnd shape)
+ (style2options (shapeStyle shape)++options)
+
+ RoundRec {} -> WX.roundedRect dc [_$_]
+ (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )
+ (shapeRadius shape)
+ (style2options (shapeStyle shape)++options)
+
+ Text {} -> do textSize <- getTextExtent dc (shapeText shape)
+ let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre
+ . scale 0.5 [_$_]
+ . screenToLogicalPoint ppi $ pointFromSize textSize
+ WX.drawText dc (removeQuotes $ shapeText shape) [_$_]
+ upperCorner
+ (style2options (shapeStyle shape)++options)
+
+ Composite {} -> mapM_ (\s-> logicalDraw ppi dc centre s options)
hunk ./src/Shape.hs 264
+
+ TextInEllipse {} -> [_$_]
+ do let txt = removeQuotes (shapeText shape) [_$_]
+ textSize <- getTextExtent dc (shapeText shape)
+ let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre
+ . scale 0.5 [_$_]
+ . screenToLogicalPoint ppi $ pointFromSize textSize
+ WX.ellipse dc
+ (rect (pointSub upperCorner $ Point 5 5) [_$_]
+ $ Size (sizeW textSize + 10) (sizeH textSize + 10) )
+ (style2options (shapeStyle shape)++options)
+ WX.drawText dc txt upperCorner [_$_]
+ (style2options (shapeStyle shape)++options)
+
+ where rectFrom :: DoublePoint -> DoublePoint -> Rect
+ rectFrom upperLeftCorner lowerRightCorner = [_$_]
+ rectBetween (logicalToScreenPoint ppi $ translate centre upperLeftCorner)
+ (logicalToScreenPoint ppi $ translate centre lowerRightCorner)
+ doRect :: DoublePoint -> Double -> Double -> Rect
+ doRect ellipseCenter hRadius vRadius = [_$_]
+ rectBetween (logicalToScreenPoint ppi . translate centre [_$_]
+ $ subtractDoublePoint ellipseCenter $ DoublePoint hRadius vRadius)
+ (logicalToScreenPoint ppi . translate centre [_$_]
+ $ translate ellipseCenter $ DoublePoint hRadius vRadius)
}