INblobs-0.1.1: src/Shape.hs
module Shape where
import CommonIO
import Graphics.UI.WX as WX
import Graphics.UI.WXCore hiding (Colour)
import Graphics.UI.WXCore.Draw
import Math
import Text.Parse
--import Text.XML.HaXml.XmlContent
--import NetworkFile
import Colors
import Constants
import Common (removeQuotes)
data Shape =
Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double }
| Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }
-- centred on (0,0)
| Lines { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }
-- no fill for open shape
| 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 }
| Composite { shapeSegments :: [Shape] } -- drawn in given order
| TextInEllipse { shapeStyle :: ShapeStyle, shapeText :: String }
deriving (Eq, Show, Read)
data ShapeStyle = ShapeStyle
{ styleStrokeWidth :: Int
, styleStrokeColour :: Colour
, styleFill :: Colour
}
deriving (Eq, Show, Read)
instance Parse Shape where
parse = oneOf
[ do{ isWord "Circle"
; return Circle
`discard` isWord "{" `apply` field "shapeStyle"
`discard` isWord "," `apply` field "shapeRadius"
`discard` isWord "}"
}
, do{ isWord "Polygon"
; return Polygon
`discard` isWord "{" `apply` field "shapeStyle"
`discard` isWord "," `apply` field "shapePerimeter"
`discard` isWord "}"
}
, do{ isWord "Lines"
; return Lines
`discard` isWord "{" `apply` field "shapeStyle"
`discard` isWord "," `apply` field "shapePerimeter"
`discard` isWord "}"
}
, 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 "}"
}
, do{ isWord "Composite"
; return Composite
`discard` isWord "{" `apply` field "shapeSegments"
`discard` isWord "}"
}
, 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)")
instance Parse ShapeStyle where
parse = do{ isWord "ShapeStyle"
; return ShapeStyle
`discard` isWord "{" `apply` field "styleStrokeWidth"
`discard` isWord "," `apply` field "styleStrokeColour"
`discard` isWord "," `apply` field "styleFill"
`discard` isWord "}"
}
{-
instance HTypeable Shape where
toHType s = Defined "Shape" [] [ Constr "Circle" [] []
, Constr "Polygon" [] []
, Constr "Lines" [] []
, Constr "Composite" [] []
]
instance XmlContent Shape where
toContents s@(Circle{}) =
[ mkElemC "Circle" (toContents (shapeStyle s)
++ [mkElemC "radius" (toContents (shapeRadius s))]) ]
toContents s@(Polygon{}) =
[ mkElemC "Polygon" (toContents (shapeStyle s)
++ [mkElemC "perimeter" (concatMap toContents
(shapePerimeter s))]) ]
toContents s@(Lines{}) =
[ mkElemC "Lines" (toContents (shapeStyle s)
++ [mkElemC "perimeter" (concatMap toContents
(shapePerimeter s))]) ]
toContents s@(Composite{}) =
[ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ]
parseContents = do
{ e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]
; case t of
"Circle" -> interior e $
do{ style <- parseContents
; r <- inElement "radius" parseContents
; return (Circle {shapeStyle=style, shapeRadius=r})
}
"Polygon" -> interior e $
do{ style <- parseContents
; p <- inElement "perimeter" $ many1 parseContents
; return (Polygon {shapeStyle=style, shapePerimeter=p})
}
"Lines" -> interior e $
do{ style <- parseContents
; p <- inElement "perimeter" $ many1 parseContents
; return (Lines {shapeStyle=style, shapePerimeter=p})
}
"Composite" -> interior e $ do{ ss <- many1 parseContents
; return (Composite {shapeSegments=ss})
}
}
instance HTypeable ShapeStyle where
toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []]
instance XmlContent ShapeStyle where
toContents s =
[ mkElemC "ShapeStyle"
[ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s))
, mkElemC "StrokeColour" (toContents (styleStrokeColour s))
, mkElemC "Fill" (toContents (styleFill s))
]
]
parseContents = inElement "ShapeStyle" $ do
{ w <- inElement "StrokeWidth" parseContents
; c <- inElement "StrokeColour" parseContents
; f <- inElement "Fill" parseContents
; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c
, styleFill=f })
}
-}
logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [Prop (DC ())] -> IO ()
logicalDraw ppi dc centre shape options =
case shape of
Circle {} -> WX.circle dc (logicalToScreenPoint ppi centre)
(logicalToScreenX ppi (shapeRadius shape))
(style2options (shapeStyle shape)++options)
Polygon {} -> WX.polygon dc (map (logicalToScreenPoint ppi
. translate centre)
(shapePerimeter shape))
(style2options (shapeStyle shape)++options)
Lines {} -> logicalLineSegments ppi dc (map (translate centre)
(shapePerimeter shape))
(style2options (shapeStyle shape)++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)
(shapeSegments shape)
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)
logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()
logicalLineSegments _ _ [_p] _options = return ()
logicalLineSegments ppi dc (fromPoint:toPoint:ps) options =
do{ line dc (logicalToScreenPoint ppi fromPoint)
(logicalToScreenPoint ppi toPoint) options
; logicalLineSegments ppi dc (toPoint:ps) options
}
circle :: Shape
circle = Circle { shapeStyle = defaultShapeStyle
, shapeRadius = kNODE_RADIUS }
style2options :: ShapeStyle -> [Prop (DC ())]
style2options sty =
[ penWidth := styleStrokeWidth sty
, penColor := wxcolor (styleStrokeColour sty)
, brushKind := BrushSolid
, brushColor := wxcolor (styleFill sty)
]
defaultShapeStyle :: ShapeStyle
defaultShapeStyle =
ShapeStyle { styleStrokeWidth = 1
, styleStrokeColour = licorice
, styleFill = nodeColor }