Implement naive eraser

ConvexHull.hs

@@ -1,53 +1,32 @@
 module ConvexHull where
 
-import qualified Data.Set as S (fromList, toAscList)
+import Data.List (foldl', sort)
-import qualified Data.List as L (init, foldl')
+import Queries
-
-data Point a = Point
-           { xCoord :: a
-           , yCoord :: a
-           }
-           deriving(Eq, Ord)
-
-data Vec a = Vec
-         { xComp :: a
-         , yComp :: a
-         }
-
-direction :: Num a => Point a -> Point a -> Vec a
-direction (Point x1 y1) (Point x2 y2) = Vec (x2 - x1) (y2 - y1)
-
-innerProd :: Num a => Vec a -> Vec a -> a
-innerProd (Vec x1 y1) (Vec x2 y2) = x1*x2 + y1*y2
-
--- Check whether the three points make a convex angle
-convexAngle :: (Ord a, Num a) => Point a -> Point a -> Point a -> Bool
-convexAngle p1 p2 p3 = let dir1 = p1 `direction` p2
-                           dir2 = p2 `direction` p3
-                       in (dir1 `innerProd` dir2) > 0
 
 
-removeNonConvexAngles :: (Ord a, Num a) => [Point a] -> [Point a]
+addNewPoint :: (Ord a, Num a) => [Point a] -> Point a -> [Point a]
-removeNonConvexAngles ps@(p1:p2:p3:rest)
+addNewPoint (p2:p1:rest) p = if (makesRightTurn p1 p2 p)
-    | convexAngle p3 p2 p1 = ps
+                                then p : p2 : p1 : rest
-    | otherwise            = removeNonConvexAngles (p1:p3:rest)
+                                else addNewPoint (p1 : rest) p
+addNewPoint ps p = p:ps
 
--- if there are less than three points, there is nothing to do
+convexHull :: (Ord a, Show a, Num a) => [Point a] -> [Point a]
-removeNonConvexAngles ps = ps
+convexHull [] = []
-
-convexHullHelper :: (Ord a, Num a) => [Point a] -> Point a -> [Point a]
-convexHullHelper ps newPoint = removeNonConvexAngles (newPoint : ps)
-
-
--- Given a set of points, return the list of points (ordered clockwisely)
--- that form the vertices of the convex hull
-convexHull :: (Ord a, Num a) => [Point a] -> [Point a]
 convexHull points =
-    let orderedPoints = S.toAscList (S.fromList points)
+    let sortedPoints  = sort points
-        upperConvexHull = L.foldl' convexHullHelper [] orderedPoints
+        upperHull = foldl' addNewPoint [] sortedPoints
-        lowerConvexHull = foldr (flip convexHullHelper) [] orderedPoints
+        lowerHull = foldr (flip addNewPoint) [] sortedPoints
-        -- Remove first and last element from the lower convex hull, because they are duplicates
+    -- Remove initial point from upperHull because it is the last point of lowerHull
-        lowerConvexHull' = tail (L.init lowerConvexHull)
+    -- Remove initial point from lowerHull because it is the last point of upperHull
+    in  tail upperHull ++ tail lowerHull
 
-    in upperConvexHull ++ lowerConvexHull'
 
+convexHull' :: (Ord a, Show a, Num a) => [Point a] -> [Point a]
+convexHull' [] = []
+convexHull' points =
+    let sortedPoints  = sort points
+        upperHull = foldl' addNewPoint [] sortedPoints
+        lowerHull = foldl' (addNewPoint) [] (reverse sortedPoints)
+    -- Remove initial point from upperHull because it is the last point of lowerHull
+    -- Remove initial point from lowerHull because it is the last point of upperHull
+    in  tail upperHull ++ tail lowerHull

Main.hs

@@ -1,7 +1,14 @@
 module Main where
 
-import ConvexHull
 import UserInterface
+import Data.IORef
+
+import Test.QuickCheck
+import Queries
 
 main :: IO ()
-main = putStrLn "Hello, Haskell!"
+main = do
+    putStrLn "Hello, Haskell!"
+    ctx <- newIORef emptyDC
+    mainGUI ctx
+    -- quickCheck prop

Queries.hs

@@ -0,0 +1,57 @@
+module Queries where
+
+import Test.QuickCheck.Arbitrary
+
+data Point a = Point
+           { xCoord :: a
+           , yCoord :: a
+           }
+           deriving(Eq, Ord, Show)
+
+instance Arbitrary a => Arbitrary (Point a) where
+    arbitrary = Point <$> arbitrary <*> arbitrary
+
+makesRightTurn :: (Ord a, Num a) => Point a -> Point a -> Point a -> Bool
+makesRightTurn (Point x1 y1) (Point x2 y2) (Point x3 y3) =
+    let crossProduct = (x2 - x1)*(y3-y1) - (x3 - x1)*(y2 - y1)
+    in crossProduct > 0
+
+
+squaredDistance :: Num a => Point a -> Point a -> a
+squaredDistance (Point x1 y1) (Point x2 y2) = (x2 - x1)*(x2 - x1) + (y2 - y1)*(y2 - y1)
+
+data Line a = Line
+            { p1 :: Point a
+            , p2 :: Point a
+            }
+            deriving(Eq, Show)
+
+data OpenCircle a = OpenCircle
+            { center :: Point a
+            , radius :: a
+            }
+            deriving(Eq, Show)
+
+pointInCircle :: (Ord a, Num a) => Point a -> OpenCircle a -> Bool
+pointInCircle p (OpenCircle c r) = (squaredDistance p c) < (r * r)
+
+lineCircleIntersect :: (Ord a, Num a) => OpenCircle a -> Line a -> Bool
+lineCircleIntersect c (Line p1 p2) =
+    pointInCircle p1 c || pointInCircle p2 c
+
+
+
+type Path a = [Line a]
+
+pathToLines :: [Point a] -> [Line a]
+pathToLines [] = []
+pathToLines [_] = []
+pathToLines (p1:p2:ps) = Line p1 p2 : pathToLines (p2:ps)
+
+pathFromPoints :: [Point a] -> Path a
+pathFromPoints = pathToLines
+
+
+removeCircleFromPath :: (Ord a, Num a) => OpenCircle a -> Path a -> Path a
+removeCircleFromPath c lines = filter (not . lineCircleIntersect c) lines
+

UserInterface.hs

@@ -1 +1,158 @@
+{-# 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

geometry.cabal

@@ -17,10 +17,16 @@ extra-source-files:  CHANGELOG.md
 
 executable geometry
   main-is:             Main.hs
-  other-modules:       ConvexHull, UserInterface
+  other-modules:       ConvexHull, UserInterface, Queries
   -- other-extensions:
   build-depends:       base ^>=4.13.0.0,
                        containers,
+                       haskell-gi-base,
+                       QuickCheck,
+                       gi-gdk,
+                       gi-cairo,
+                       gi-cairo-connector,
+                       gi-cairo-render,
                        gi-gtk ^>=3.0
   -- hs-source-dirs:
   default-language:    Haskell2010

geometry.ui

@@ -0,0 +1,43 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!-- Generated with glade 3.22.1 -->
+<interface>
+  <requires lib="gtk+" version="3.20"/>
+  <object class="GtkWindow" id="window">
+    <property name="can_focus">False</property>
+    <child>
+      <placeholder/>
+    </child>
+    <child>
+      <object class="GtkBox" id="box">
+        <property name="visible">True</property>
+        <property name="can_focus">False</property>
+        <property name="orientation">vertical</property>
+        <child>
+          <object class="GtkSwitch" id="eraseSwitch">
+            <property name="visible">True</property>
+            <property name="can_focus">True</property>
+          </object>
+          <packing>
+            <property name="expand">False</property>
+            <property name="fill">True</property>
+            <property name="position">0</property>
+          </packing>
+        </child>
+        <child>
+          <object class="GtkDrawingArea" id="drawingArea">
+            <property name="visible">True</property>
+            <property name="can_focus">False</property>
+            <property name="is_focus">True</property>
+            <property name="hexpand">True</property>
+            <property name="vexpand">True</property>
+          </object>
+          <packing>
+            <property name="expand">False</property>
+            <property name="fill">True</property>
+            <property name="position">1</property>
+          </packing>
+        </child>
+      </object>
+    </child>
+  </object>
+</interface>