wxSimpleCanvas (empty) → 0.0.0.0

raw patch · 4 files changed

+652/−0 lines, 4 filesdep +basedep +cubicbezierdep +wxsetup-changed

Dependencies added: base, cubicbezier, wx, wxcore

Files

• LICENSE +28/−0
• Setup.hs +2/−0
• src/Graphics/UI/WX/Canvas.hs +597/−0
• wxSimpleCanvas.cabal +25/−0

@@ -0,0 +1,28 @@+Copyright (c) 2016, Kristof Bastiaensen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+    Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.  Neither the name of the organisation nor the+    names of its contributors may be used to endorse or promote+    products derived from this software without specific prior written+    permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,597 @@+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)+

@@ -0,0 +1,25 @@+Name:		wxSimpleCanvas+Version: 	0.0.0.0+Synopsis:	Simple zoomable canvas for wxHaskell+Category: 	Graphics, +Copyright: 	Kristof Bastiaensen (2016)+Stability:	Unstable+License:	BSD3+License-file:	LICENSE+Author:		Kristof Bastiaensen+Maintainer:	Kristof Bastiaensen+Bug-Reports: 	https://github.com/kuribas/wxSimpleCanvas/issues+Build-type:	Simple+Cabal-version:	>=1.8+Description:	A simple zoomable canvas for wxHaskell+ +source-repository head+  type:		git+  location:	https://github.com/kuribas/wxSimpleCanvas++Library+  Ghc-options: -Wall+  Build-depends: cubicbezier >= 0.5.0, base >= 3 && < 5, wx > 0.92.3, wxcore >= 0.92.3+  hs-source-dirs: src+  Exposed-Modules:+    Graphics.UI.WX.Canvas