{-# LANGUAGE OverloadedStrings #-} module UserInterface where import qualified GI.Gtk as G import qualified GI.Gdk as Gdk import qualified GI.Cairo.Render as R import qualified GI.Cairo.Render.Connector as C import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Maybe (fromJust) import Data.IORef import Control.Monad (when) import Queries data DrawingContext = DC { path :: Path Double , lastPos :: Maybe (Point Double) , isErasing :: Bool } emptyDC :: DrawingContext emptyDC = DC { path = [] , lastPos = Nothing , isErasing = False } -- Radius of the circle representing the eraser circleRadius :: Double circleRadius = 50 setLastPos :: Maybe (Point Double) -> DrawingContext -> DrawingContext setLastPos p (DC path _ e) = DC path p e isMouseDown :: DrawingContext -> Bool isMouseDown (DC _ Nothing _) = False isMouseDown (DC _ _ _) = True setErasing :: Bool -> DrawingContext -> DrawingContext setErasing e (DC p l _) = DC p l e addPoint :: Point Double -> DrawingContext -> DrawingContext addPoint _ (DC path Nothing e) = DC path Nothing e addPoint p (DC path (Just lastPos) e) = let newLine = Line lastPos p in DC (newLine : path) (Just p) e erase :: OpenCircle Double -> DrawingContext -> DrawingContext erase c (DC path _ e) = DC (removeCircleFromPath c path) (Just (center c)) e -- ^ Change last mouse pos to the circle center drawPath :: Path Double -> R.Render () drawPath [] = return () drawPath (line:lines) = do R.moveTo (xCoord (p1 line)) (yCoord (p1 line)) R.lineTo (xCoord (p2 line)) (yCoord (p2 line)) drawPath lines drawAll :: DrawingContext -> Gdk.Rectangle -> R.Render () drawAll (DC path lastPos isErasing) rect = do x <- fromIntegral <$> Gdk.getRectangleX rect y <- fromIntegral <$> Gdk.getRectangleY rect width <- fromIntegral <$> Gdk.getRectangleWidth rect height <- fromIntegral <$> Gdk.getRectangleHeight rect R.setSourceRGB 0 0 0 R.rectangle x y width height R.fill -- Path color R.setSourceRGB 255 255 255 drawPath (reverse path) R.stroke when isErasing $ case lastPos of Nothing -> return () Just (Point mouseX mouseY) -> do -- Eraser color R.setSourceRGB 0 0 255 R.arc mouseX mouseY circleRadius 0 (2 * pi) R.stroke doDraw :: G.DrawingArea -> IORef DrawingContext -> Point Double -> IO () doDraw drawingArea ctx pos = do mouseDown <- isMouseDown <$> readIORef ctx -- Only add points if we are drawing when mouseDown $ do modifyIORef' ctx (addPoint pos) G.widgetQueueDraw drawingArea doErase :: G.DrawingArea -> IORef DrawingContext -> Point Double -> IO () doErase drawingArea ctx pos = do mouseDown <- isMouseDown <$> readIORef ctx -- Only erase when ouse down when mouseDown $ do let circle = OpenCircle pos circleRadius modifyIORef' ctx (erase circle) G.widgetQueueDraw drawingArea mainGUI :: IORef DrawingContext -> IO () mainGUI ctx = do G.init Nothing builder <- G.builderNew G.builderAddFromFile builder "geometry.ui" window <- G.builderGetObject builder "window" >>= unsafeCastTo G.Window . fromJust eraseSwitch <- G.builderGetObject builder "eraseSwitch" >>= unsafeCastTo G.Switch . fromJust drawingArea <- G.builderGetObject builder "drawingArea" >>= unsafeCastTo G.DrawingArea . fromJust -- receive mouse events G.widgetAddEvents drawingArea [Gdk.EventMaskPointerMotionMask, Gdk.EventMaskButtonPressMask, Gdk.EventMaskButtonReleaseMask] -- When we press on the button we calculate the convex hull -- G.onButtonClicked button $ do -- points <- paths <$> readIORef ctx -- let convexHullPath = convexHull (concat points) -- modifyIORef' ctx (setConvexHull convexHullPath) -- G.widgetQueueDraw drawingArea G.onSwitchStateSet eraseSwitch $ \newState -> do modifyIORef' ctx (setErasing newState) return True G.onWidgetDraw drawingArea $ \cairoCtx -> do rect <- G.widgetGetAllocation drawingArea dc <- readIORef ctx C.renderWithContext (drawAll dc rect) cairoCtx return True G.onWidgetMotionNotifyEvent drawingArea $ \e -> do x <- Gdk.getEventMotionX e y <- Gdk.getEventMotionY e let pos = Point x y isErasing <- isErasing <$> readIORef ctx if isErasing then doErase drawingArea ctx pos else doDraw drawingArea ctx pos return True G.onWidgetButtonPressEvent drawingArea $ \e -> do x <- Gdk.getEventButtonX e y <- Gdk.getEventButtonY e let pos = Point x y modifyIORef' ctx (setLastPos (Just pos)) return True G.onWidgetButtonReleaseEvent drawingArea $ \_ -> do modifyIORef' ctx (setLastPos Nothing) return False G.onWidgetDestroy window G.mainQuit G.widgetShowAll window G.main