wxSimpleCanvas-0.0.0.0: src/Graphics/UI/WX/Canvas.hs
module Graphics.UI.WX.Canvas
(CanvasElements(..), CanvasElement(..),
CanvasHandle(..), HandleStyle(..), HandleShape(..),
makeCanvas) where
import Graphics.UI.WX hiding (when)
import Graphics.UI.WXCore hiding (when)
import Control.Monad
import Text.Printf
import Geom2D.CubicBezier hiding (Point)
import qualified Geom2D.CubicBezier as CB
import Data.List
import Data.Foldable (for_, traverse_)
data CanvasElements = CanvasElements [CanvasElement] [CanvasHandle]
deriving Show
data CanvasState = CanvasState {
-- logical bounds
canvasLeft :: !Double,
canvasBottom :: !Double,
canvasWidth :: !Double,
canvasHeight :: !Double,
canvasZoom :: !Double,
canvasRulerUnit :: !Double,
-- logical point of middle of screen
canvasMidX :: Double,
canvasMidY :: Double,
canvasDragPoint :: Maybe (Double, Double),
canvasMousePoint :: Var (Maybe Point),
canvasOverHandle :: Maybe CanvasHandle,
canvasElements :: Var CanvasElements}
data CanvasElement =
CanvasDrawPath (ClosedPath Double) Color Bool Double |
CanvasStrokeOpenPath (OpenPath Double) Color |
CanvasStrokeClosedPath (ClosedPath Double) Color |
CanvasDrawHRule Double Color |
CanvasDrawVRule Double Color |
CanvasDrawSegment CB.DPoint CB.DPoint Color
deriving Show
-- | a handle, with callbacks embedded
data CanvasHandle = CanvasHandle {
handlePos :: CB.DPoint,
handleStyle :: HandleStyle,
handleHoverStyle :: HandleStyle,
handleOnMouseDown :: CB.DPoint -> Modifiers -> IO (),
handleOnMouseMove :: CB.DPoint -> Modifiers -> IO (),
handleOnMouseRelease :: CB.DPoint -> Modifiers -> IO () }
instance Show CanvasHandle where
show (CanvasHandle (CB.Point x y) stile hstyle _ _ _) =
printf "(%f, %f, %s, %s)" x y (show stile) (show hstyle)
-- | style of handles: width, shape, foreground and background color
-- (transparent if Nothing).
data HandleStyle = HandleStyle Int HandleShape Color (Maybe Color)
deriving Show
-- | shape of the handle
data HandleShape = RectangleHandle | TiltedHandle | RoundHandle | CrossHandle
deriving Show
-- this should be defined in WXCore...
wxALWAYS_SHOW_SB :: Int
wxALWAYS_SHOW_SB = 0x00800000
fromInt :: Num a => Int -> a
fromInt = fromIntegral
-- | @makeCanvas parent viewport zoom elements@: Create a new canvas
-- window with the given elements. To /draw/ something, simply change
-- the variable with the elements, and refresh the window.
makeCanvas :: Window a -> Rect2D Double -> Double -> Var CanvasElements -> IO (Window ())
makeCanvas wd (Rect l b w h) zoom elements = do
canvas <- window wd [style := bits [wxVSCROLL, wxHSCROLL, wxALWAYS_SHOW_SB]]
mp <- varCreate Nothing
let state = CanvasState l b w h zoom (calcRulerUnit zoom)
(l+w/2) (b+h/2) Nothing mp Nothing elements
stateVar <- varCreate state
set canvas [on mouse := canvasMouse stateVar canvas,
on paintGc := canvasPaint stateVar canvas,
on resize := canvasResize stateVar canvas]
void $ windowSetBackgroundColour canvas white
setCanvasScrollBars canvas state True
windowOnScroll canvas (canvasScroll stateVar canvas)
return canvas
setCanvasScrollBars :: Window a -> CanvasState -> Bool -> IO ()
setCanvasScrollBars canvas state draw = do
Size winWidth winHeight <- windowGetClientSize canvas
let hSR = hScrollRange state
vSR = vScrollRange state
hSS = min (winWidth - rulerThickness) hSR
vSS = min (winHeight - rulerThickness) vSR
hSP = max 0 $ min (hSR-hSS) $ hScrollPos state winWidth
vSP = max 0 $ min (vSR-vSS) $ vScrollPos state winHeight
windowSetScrollbar canvas wxHORIZONTAL hSP hSS hSR draw
windowSetScrollbar canvas wxVERTICAL vSP vSS vSR draw
updateScrollState :: Int -> Int -> Int -> Int -> CanvasState -> CanvasState
updateScrollState winWidth winHeight hSP vSP state =
let midX = fromInt (hSP + (winWidth-rulerThickness)`div`2) /
canvasZoom state + canvasLeft state
midY = canvasHeight state + canvasBottom state -
fromInt (vSP + (winHeight-rulerThickness)`div`2) /
canvasZoom state
in state {canvasMidX = midX, canvasMidY = midY}
scrollDir :: Int -> Int -> Var CanvasState -> Window a -> IO ()
scrollDir hShift vShift stateVar canvas = do
Size winWidth winHeight <- windowGetClientSize canvas
hSP <- windowGetScrollPos canvas wxHORIZONTAL
vSP <- windowGetScrollPos canvas wxVERTICAL
hSR <- windowGetScrollRange canvas wxHORIZONTAL
vSR <- windowGetScrollRange canvas wxVERTICAL
hSS <- windowGetScrollThumb canvas wxHORIZONTAL
vSS <- windowGetScrollThumb canvas wxVERTICAL
let hSP' = if hShift >= 0
then min (hSP+hShift) (max 0 (hSR-hSS))
else max 0 (hSP + hShift)
vSP' = if vShift >= 0
then min (vSP+vShift) (max 0 (vSR-vSS))
else max 0 (vSP+vShift)
void $ varUpdate stateVar $ updateScrollState winWidth winHeight hSP' vSP'
state <- varGet stateVar
setCanvasScrollBars canvas state True
repaint canvas
moveCanvasTo :: Window a -> Var CanvasState -> Double -> Double
-> Int -> Int -> Int -> Int -> IO ()
moveCanvasTo canvas stateVar lx ly rx ry winWidth winHeight = do
state <- varGet stateVar
let newX = realX lx state winWidth
newY = realY ly state winHeight
scrollDir (newX-rx) (newY-ry) stateVar canvas
sqrt2 :: Double
sqrt2 = sqrt 2
zoomCanvas :: Bool -> Window a -> Var CanvasState -> Point -> IO ()
zoomCanvas down canvas stateVar (Point x y) = do
Size winWidth winHeight <- windowGetClientSize canvas
state <- varGet stateVar
let mouseX = logicalX x state winWidth
mouseY = logicalY y state winHeight
newZoom = min 500 $
(if down then (/sqrt2) else (*sqrt2)) $
canvasZoom state
newState = state {canvasZoom = newZoom,
canvasRulerUnit = calcRulerUnit newZoom}
varSet stateVar newState
setCanvasScrollBars canvas newState False
moveCanvasTo canvas stateVar mouseX mouseY x y winWidth winHeight
canvasMouse :: Var CanvasState -> Window a -> EventMouse -> IO ()
canvasMouse stateVar canvas mouseEv = do
Size winWidth winHeight <- windowGetClientSize canvas
state <- varGet stateVar
let h = canvasOverHandle state
case mouseEv of
MouseWheel down p modifiers
| shiftDown modifiers ->
scrollDir (if down then 40 else -40) 0 stateVar canvas
| controlDown modifiers -> zoomCanvas down canvas stateVar p
| otherwise ->
scrollDir 0 (if down then 40 else -40) stateVar canvas
MouseMiddleDown (Point x y) _ ->
varSet stateVar (state {canvasDragPoint = Just (logicalX x state winWidth,
logicalY y state winHeight)})
MouseMiddleUp _ _ ->
varSet stateVar (state {canvasDragPoint = Nothing})
MouseLeftDrag (Point x y) modifiers -> do
resetMousePointer state canvas (Point x y)
for_ h $ \handle ->
handleOnMouseMove handle
(CB.Point (logicalX x state winWidth )
(logicalY y state winHeight)) modifiers
MouseMiddleDrag (Point x y) _ -> do
resetMousePointer state canvas (Point x y)
for_ (canvasDragPoint state) $ \(lx, ly) ->
moveCanvasTo canvas stateVar lx ly x y winWidth winHeight
MouseLeftUp (Point x y) modifiers ->
for_ h $ \handle ->
handleOnMouseRelease handle
(CB.Point (logicalX x state winWidth)
(logicalY y state winHeight)) modifiers
MouseLeftDown (Point x y) modifiers ->
for_ h $ \handle ->
handleOnMouseDown handle
(CB.Point (logicalX x state winWidth)
(logicalY y state winHeight)) modifiers
MouseMotion p _ -> do
resetMousePointer state canvas p
-- unset pointOverHandle when leaving handle
for_ h $ \handle ->
unless (pointOverHandle p state winWidth winHeight handle) $ do
void $ varUpdate stateVar $ \s ->
s {canvasOverHandle = Nothing}
windowRefreshRect canvas True (handleRect state winWidth winHeight handle)
h' <- canvasOverHandle <$> varGet stateVar
-- set pointOverHandle when entering handle
case h' of
Nothing -> do
CanvasElements _ handles <- varGet $ canvasElements state
for_ (handleAtPoint p state winWidth winHeight handles) $ \handle -> do
void $ varUpdate stateVar $ \s ->
s {canvasOverHandle = Just handle}
windowRefreshRect canvas True (handleRect state winWidth winHeight handle)
_ -> return ()
repaint canvas
_ -> return ()
resetMousePointer :: CanvasState -> Window a -> Point -> IO ()
resetMousePointer state canvas (Point x y) = do
prevPoint <- varGet $ canvasMousePoint state
varSet (canvasMousePoint state) (Just $ Point x y)
for_ prevPoint $ \(Point x' y') -> do
windowRefreshRect canvas True
(Rect (x'-rulerSmall) (rulerThickness-rulerSmall)
(rulerThickness*2+1) rulerSmall)
windowRefreshRect canvas True
(Rect (rulerThickness-rulerSmall) (y'-rulerSmall)
rulerSmall (rulerThickness*2+1))
canvasResize :: Var CanvasState -> Window a -> IO ()
canvasResize stateVar canvas = do
state <- varGet stateVar
setCanvasScrollBars canvas state False
repaint canvas
canvasTransform :: CanvasState -> Int -> Int -> Transform Double
canvasTransform state winWidth winHeight =
translate (CB.Point (fromInt $ (winWidth+rulerThickness)`div`2)
(fromInt $ (winHeight+rulerThickness)`div`2)) $*
Transform (canvasZoom state) 0 0 0 (negate $ canvasZoom state) 0 $*
translate (CB.Point (negate $ canvasMidX state) (negate $ canvasMidY state))
canvasPaint :: Var CanvasState -> Window a -> GCDC b -> Rect -> IO ()
canvasPaint stateVar canvas dc view = do
state <- varGet stateVar
set dc [font := rulerFont]
(Size _ ht, descend, _) <- getFullTextExtent dc "1"
let textHt = ht - descend
Size winWidth winHeight <- windowGetClientSize canvas
drawHorizRuler state dc view winWidth
drawVertRuler state dc view textHt winHeight
drawMousePointers state dc
CanvasElements elements handles <- varGet $ canvasElements state
let tf = canvasTransform state winWidth winHeight
gc <- gcdcGetGraphicsContext dc
graphicsContextClipByRectangle gc
(Rect (fromInt rulerThickness) (fromInt rulerThickness)
(fromInt $ winWidth-rulerThickness) (fromInt $ winHeight-rulerThickness))
traverse_ (drawElement gc tf state winWidth winHeight) elements
mp <- varGet $ canvasMousePoint state
traverse_ (drawHandle dc tf mp state winWidth winHeight) handles
drawMousePointers :: CanvasState -> DC a -> IO ()
drawMousePointers state dc = do
mp <- varGet $ canvasMousePoint state
for_ mp $ \(Point x y) -> do
set dc [brush := BrushStyle BrushSolid black]
polygon dc [Point (x-rulerSmall+2) (rulerThickness-rulerSmall),
Point (x+rulerSmall-2) (rulerThickness-rulerSmall),
Point x (rulerThickness-2)] []
polygon dc [Point (rulerThickness-rulerSmall) (y-rulerSmall+2),
Point (rulerThickness-rulerSmall) (y+rulerSmall-2),
Point (rulerThickness-2) y] []
canvasScroll :: Var CanvasState -> Window a -> EventScroll -> IO ()
canvasScroll stateVar canvas evScroll = do
hSP <- windowGetScrollPos canvas wxHORIZONTAL
vSP <- windowGetScrollPos canvas wxVERTICAL
hSR <- windowGetScrollRange canvas wxHORIZONTAL
vSR <- windowGetScrollRange canvas wxVERTICAL
hSS <- windowGetScrollThumb canvas wxHORIZONTAL
vSS <- windowGetScrollThumb canvas wxVERTICAL
Size winWidth winHeight <- windowGetClientSize canvas
let hMax = hSR - hSS
vMax = vSR - vSS
(hSP', vSP') = case evScroll of
ScrollLineUp Horizontal _ -> (min hMax (hSP+1-hSS`div`10), vSP)
ScrollLineUp Vertical _ -> (hSP, min vMax (vSP+1-vSS`div`10))
ScrollLineDown Horizontal _ -> (max 0 (hSP-1+hSS`div`10), vSP)
ScrollLineDown Vertical _ -> (hSP, max 0 (vSP-1+vSS`div`10))
_ -> (hSP, vSP)
windowSetScrollbar canvas wxHORIZONTAL hSP' hSS hSR (hSP' /= hSP)
windowSetScrollbar canvas wxVERTICAL vSP' vSS vSR (vSP' /= vSP)
void $ varUpdate stateVar (updateScrollState winWidth winHeight hSP' vSP')
repaint canvas
rulerThickness, rulerLarge, rulerSmall, rulerTiny, rulerMinUnit :: Int
rulerThickness = 16 -- ruler thickness in pixels
rulerLarge = 14
rulerSmall = 6 -- minimum length of a ruler unit in pixels
rulerTiny = 3
rulerMinUnit = 70
calcRulerUnit :: Double -> Double
calcRulerUnit zoom = result
where
result | minUnit <= scale_ = scale_
| scale_ < 10 && minUnit <= 2 = 2
| scale_ >= 10 && minUnit <= 2.5*scale_ = 2.5*scale_
| minUnit <= 5*scale_ = 5*scale_
| otherwise = 10*scale_
minUnit = fromInt rulerMinUnit/zoom
scale_ = max 1 $ 10**(fromInt $ floor $ logBase 10.0 minUnit)
rulerColor :: Color
rulerColor = lightgrey
rulerFont :: FontStyle
rulerFont = FontStyle 7 FontSwiss ShapeNormal WeightNormal False "" wxFONTENCODING_DEFAULT
logicalX, logicalY :: Int -> CanvasState -> Int -> Double
logicalX x state winWidth =
fromInt (x - (winWidth+rulerThickness) `div` 2) / canvasZoom state +
canvasMidX state
logicalY y state winHeight =
fromInt ((winHeight+rulerThickness) `div` 2 - y) / canvasZoom state +
canvasMidY state
realX, realY :: Double -> CanvasState -> Int -> Int
realX x state winWidth =
round ((x - canvasMidX state) * canvasZoom state) + (winWidth+rulerThickness)`div`2
realY y state winHeight =
round ((canvasMidY state - y) * canvasZoom state) + (winHeight+rulerThickness)`div`2
hScrollPos, vScrollPos :: CanvasState -> Int -> Int
hScrollPos state winWidth =
round ((canvasMidX state - canvasLeft state) * canvasZoom state) -
(winWidth - rulerThickness)`div`2
vScrollPos state winHeight =
round ((canvasHeight state + canvasBottom state - canvasMidY state) * canvasZoom state) -
(winHeight - rulerThickness)`div`2
hScrollRange, vScrollRange :: CanvasState -> Int
hScrollRange state =
round $ canvasWidth state * canvasZoom state
vScrollRange state =
round $ canvasHeight state * canvasZoom state
unitToStr :: Double -> Double -> String
unitToStr unit x
| x == 0 = "0"
| unit >= 10000 = show (round $ x/1000 :: Int) ++ "k"
| otherwise = show (round x :: Int)
drawHorizRuler :: CanvasState -> DC a -> Rect -> Int -> IO ()
drawHorizRuler state dc (Rect l t w _) winWidth
| t >= rulerThickness = return ()
| otherwise = do
dcSetClippingRegion dc (Rect 0 0 winWidth rulerThickness)
set dc [penKind := PenTransparent,
brush := BrushStyle BrushSolid rulerColor]
drawRect dc (Rect l 0 w rulerThickness) []
dcSetClippingRegion dc (Rect rulerThickness 0 (winWidth-rulerThickness) rulerThickness)
let unit = canvasRulerUnit state
unitPix = unit * canvasZoom state
unitStart = (fromInt $ floor $ logicalX l state winWidth/unit) * unit
startX = fromInt $ realX unitStart state winWidth
n = fromInt $ ceiling $ (fromInt (w+l)-startX)/unitPix :: Double
set dc [brush := BrushStyle BrushSolid black,
penKind := PenSolid,
penColor := black]
traverse_ (\x -> drawRect dc (Rect (round x) (rulerThickness - rulerLarge) 1 rulerLarge) [])
[startX, startX+unitPix..startX+unitPix*n]
traverse_ (\x -> drawRect dc (Rect (round x) (rulerThickness - rulerSmall) 1 rulerSmall) [])
[startX, startX+unitPix/5..startX+unitPix*n]
traverse_ (\x -> drawRect dc (Rect (round x) (rulerThickness - rulerTiny) 1 rulerTiny) [])
[startX+unitPix/10, startX+unitPix/5..startX+unitPix*n]
traverse_ (\i -> drawText dc (unitToStr unit (unitStart + unit*i))
(Point (round $ startX+unitPix*i+2) 0) [])
[0..n]
dcDestroyClippingRegion dc
drawVertRuler
:: CanvasState -> DC a -> Rect2D Int -> Int -> Int -> IO ()
drawVertRuler state dc (Rect l t _ h) textHt winHeight
| l >= rulerThickness = return ()
| otherwise = do
dcSetClippingRegion dc (Rect 0 rulerThickness rulerThickness h)
set dc [penKind := PenTransparent,
brush := BrushStyle BrushSolid rulerColor]
drawRect dc (Rect 0 t rulerThickness h) []
let unit = canvasRulerUnit state
unitPix = unit * canvasZoom state
unitStart = (fromInt $ ceiling $ logicalY t state winHeight / unit) * unit
startY = fromInt $ realY unitStart state winHeight
n = fromInt $ ceiling $ (fromInt (t+h)-startY)/unitPix
set dc [brush := BrushStyle BrushSolid black,
penKind := PenSolid,
penColor := black,
font := rulerFont]
traverse_ (\y -> drawRect dc (Rect (rulerThickness - rulerLarge) (round y) rulerLarge 1) [])
[startY, startY+unitPix..startY+unitPix*n]
traverse_ (\y -> drawRect dc (Rect (rulerThickness - rulerSmall) (round y) rulerSmall 1) [])
[startY, startY+unitPix/5..startY+unitPix*n]
traverse_ (\y -> drawRect dc (Rect (rulerThickness - rulerTiny) (round y) rulerTiny 1) [])
[startY+unitPix/10, startY+unitPix/5..startY+unitPix*n]
traverse_ (\i -> drawTextVert dc (unitToStr unit (unitStart - unit*i)) (Point 2 (round (startY+unitPix*i+2))) textHt)
[0..n]
dcDestroyClippingRegion dc
drawTextVert :: DC a -> String -> Point -> Int -> IO ()
drawTextVert dc txt (Point x y) textHt = traverse_ drawTextOne $
zip (map (:[]) txt) [y, y+textHt ..]
where drawTextOne (t, y') = drawText dc t (Point x y') []
pointToWx :: CB.DPoint -> Point2 Double
pointToWx (CB.Point x y) = Point x y
drawPathRest :: GraphicsPath a -> [(CB.DPoint, PathJoin Double)] -> CB.DPoint -> IO ()
drawPathRest _ [] _ = return ()
drawPathRest gp [(_, JoinCurve p q)] r =
graphicsPathAddCurveToPoint gp (pointToWx p) (pointToWx q) (pointToWx r)
drawPathRest gp ((_, JoinCurve p q):rest@((r, _):_)) s = do
graphicsPathAddCurveToPoint gp (pointToWx p) (pointToWx q) (pointToWx r)
drawPathRest gp rest s
drawPathRest gp [(_, JoinLine)] r =
graphicsPathAddLineToPoint gp (pointToWx r)
drawPathRest gp ((_, JoinLine):rest@((r, _):_)) s = do
graphicsPathAddLineToPoint gp (pointToWx r)
drawPathRest gp rest s
closedToGraphicsPath :: ClosedPath Double -> Transform Double -> GraphicsContext a -> IO (GraphicsPath ())
closedToGraphicsPath path tf gc = do
gp <- graphicsContextCreatePath gc
case transform tf path of
ClosedPath [] -> return ()
ClosedPath p@((q,_):_) -> do
graphicsPathMoveToPoint gp (pointToWx q)
drawPathRest gp p q
graphicsPathCloseSubpath gp
return gp
openToGraphicsPath :: OpenPath Double -> Transform Double -> GraphicsContext a -> IO (GraphicsPath ())
openToGraphicsPath path tf gc = do
gp <- graphicsContextCreatePath gc
case transform tf path of
OpenPath [] _ -> return ()
OpenPath p@((q,_):_) r -> do
graphicsPathMoveToPoint gp (pointToWx q)
drawPathRest gp p r
return gp
drawElement :: GraphicsContext a -> Transform Double -> CanvasState ->
Int -> Int -> CanvasElement -> IO ()
drawElement gc tf state _ _ (CanvasDrawPath path fillColor fillp lineWidth) = do
gp <- closedToGraphicsPath path tf gc
when fillp $
withBrushStyle (BrushStyle BrushSolid fillColor) $
\brush_ -> do
graphicsContextSetBrush gc brush_
graphicsContextFillPath gc gp wxWINDING_RULE
when (lineWidth > 0) $
withPenStyle (penColored fillColor (round $ min 10000 $ lineWidth*canvasZoom state)) $
\pen_ -> do
graphicsContextSetPen gc pen_
graphicsContextStrokePath gc gp
graphicsPathDelete gp
drawElement gc tf _ _ _ (CanvasStrokeOpenPath path strokeColor) = do
gp <- openToGraphicsPath path tf gc
withPenStyle (penColored strokeColor 1) $
\pen_ -> do
graphicsContextSetPen gc pen_
graphicsContextStrokePath gc gp
graphicsPathDelete gp
drawElement gc tf _ _ _ (CanvasStrokeClosedPath path strokeColor) = do
gp <- closedToGraphicsPath path tf gc
withPenStyle (penColored strokeColor 1) $
\pen_ -> do
graphicsContextSetPen gc pen_
graphicsContextStrokePath gc gp
graphicsPathDelete gp
--intersectRect (line p q) r s = undefined
drawElement gc _ state w h (CanvasDrawVRule x color_) =
withBrushStyle (BrushStyle BrushSolid color_) $ \brush_ ->
withPenStyle penTransparent $ \pen_ -> do
graphicsContextSetBrush gc brush_
graphicsContextSetPen gc pen_
graphicsContextDrawRectangle gc
(Rect (fromInt $ realX x state w) (fromInt rulerThickness)
1 (fromInt h))
drawElement gc _ state w h (CanvasDrawHRule y color_) =
withBrushStyle (BrushStyle BrushSolid color_) $ \brush_ ->
withPenStyle penTransparent $ \pen_ -> do
graphicsContextSetBrush gc brush_
graphicsContextSetPen gc pen_
graphicsContextDrawRectangle gc
(Rect (fromInt rulerThickness) (fromInt $ realY y state h)
(fromInt w) 1)
drawElement gc tf _ _ _ (CanvasDrawSegment from to color_) =
withPenStyle (penColored color_ 1) $
\pen_ -> do
graphicsContextSetPen gc pen_
graphicsContextStrokeLine gc (pointToWx $ transform tf from)
(pointToWx $ transform tf to)
drawHandle :: DC a -> Transform Double -> Maybe Point -> CanvasState
-> Int -> Int -> CanvasHandle -> IO ()
drawHandle dc tf p state w h handle =
drawHandleStyle dc tf (handlePos handle) $
case p of
Just p' | pointOverHandle p' state w h handle ->
handleHoverStyle handle
_ -> handleStyle handle
drawHandleStyle :: DC a -> Transform Double -> CB.DPoint -> HandleStyle -> IO ()
drawHandleStyle dc tf pos (HandleStyle width' RectangleHandle stroke fill_) =
let CB.Point x y = transform tf pos
width = width' + if even width' then 1 else 0
in drawRect dc (Rect (round x-width`div`2) (round y-width`div`2) width width)
[brush := case fill_ of
Nothing -> brushTransparent
Just f -> BrushStyle BrushSolid f,
pen := penColored stroke 1]
drawHandleStyle dc tf pos (HandleStyle width RoundHandle stroke fill_) =
let CB.Point x y = transform tf pos
in circle dc (Point (round x) (round y)) (width`div`2)
[brush := case fill_ of
Nothing -> brushTransparent
Just f -> BrushStyle BrushSolid f,
pen := penColored stroke 1]
drawHandleStyle dc tf pos (HandleStyle width' TiltedHandle stroke fill_) =
let CB.Point x' y' = transform tf pos
x = round x'
y = round y'
width = width' + if even width' then 1 else 0
halfW = width`div`2
in polygon dc [Point (x - halfW) y, Point x (y - halfW),
Point (x + halfW) y, Point x (y + halfW)]
[brush := case fill_ of
Nothing -> brushTransparent
Just f -> BrushStyle BrushSolid f,
pen := penColored stroke 1]
drawHandleStyle dc tf pos (HandleStyle width' CrossHandle stroke fill_) = do
let CB.Point x' y' = transform tf pos
x = round x'
y = round y'
width = width' + if even width' then 1 else 0
halfW = width`div`2
for_ fill_ $ \f ->
drawRect dc (Rect (x-halfW) (y-halfW) width width)
[brush := BrushStyle BrushSolid f]
set dc [pen := penColored stroke 1]
line dc (Point (x-halfW) (y-halfW)) (Point (x+halfW) (y+halfW)) []
line dc (Point (x-halfW) (y+halfW)) (Point (x+halfW) (y-halfW)) []
handleAtPoint :: Point -> CanvasState -> Int -> Int
-> [CanvasHandle] -> Maybe CanvasHandle
handleAtPoint p state w h handles =
find (pointOverHandle p state w h) handles
pointOverHandle :: Point -> CanvasState -> Int -> Int -> CanvasHandle -> Bool
pointOverHandle (Point x y) state w h handle =
let CB.Point cx cy = handlePos handle
rx = realX cx state w
ry = realY cy state h
HandleStyle radius _ _ _ = handleStyle handle
in x >= rx - radius`div`2 && x <= rx + radius`div`2 &&
y >= ry - radius`div`2 && y <= ry + radius`div`2
handleRect :: CanvasState -> Int -> Int -> CanvasHandle -> Rect2D Int
handleRect state w h handle =
let (CB.Point cx cy) = handlePos handle
rx = realX cx state w
ry = realY cy state h
HandleStyle radius _ _ _ = handleStyle handle
in Rect (rx - radius`div`2) (ry - radius`div`2)
(radius+1) (radius+1)