geometry/UserInterface.hs

{-# 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