From 5a76b3b7aa37a919a65f556a39d0b394ead3ee9b Mon Sep 17 00:00:00 2001 From: Francesco Magliocca Date: Tue, 27 Oct 2020 11:18:25 +0100 Subject: [PATCH] Implement naive eraser --- ConvexHull.hs | 69 ++++++++------------- Main.hs | 11 +++- Queries.hs | 57 +++++++++++++++++ UserInterface.hs | 157 +++++++++++++++++++++++++++++++++++++++++++++++ geometry.cabal | 8 ++- geometry.ui | 43 +++++++++++++ 6 files changed, 297 insertions(+), 48 deletions(-) create mode 100644 Queries.hs create mode 100644 geometry.ui diff --git a/ConvexHull.hs b/ConvexHull.hs index a21cdf3..c0a2043 100644 --- a/ConvexHull.hs +++ b/ConvexHull.hs @@ -1,53 +1,32 @@ module ConvexHull where -import qualified Data.Set as S (fromList, toAscList) -import qualified Data.List as L (init, foldl') - -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 +import Data.List (foldl', sort) +import Queries -removeNonConvexAngles :: (Ord a, Num a) => [Point a] -> [Point a] -removeNonConvexAngles ps@(p1:p2:p3:rest) - | convexAngle p3 p2 p1 = ps - | otherwise = removeNonConvexAngles (p1:p3:rest) +addNewPoint :: (Ord a, Num a) => [Point a] -> Point a -> [Point a] +addNewPoint (p2:p1:rest) p = if (makesRightTurn p1 p2 p) + then p : p2 : p1 : rest + else addNewPoint (p1 : rest) p +addNewPoint ps p = p:ps --- if there are less than three points, there is nothing to do -removeNonConvexAngles ps = ps - -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 :: (Ord a, Show a, Num a) => [Point a] -> [Point a] +convexHull [] = [] convexHull points = - let orderedPoints = S.toAscList (S.fromList points) - upperConvexHull = L.foldl' convexHullHelper [] orderedPoints - lowerConvexHull = foldr (flip convexHullHelper) [] orderedPoints - -- Remove first and last element from the lower convex hull, because they are duplicates - lowerConvexHull' = tail (L.init lowerConvexHull) + let sortedPoints = sort points + upperHull = foldl' addNewPoint [] sortedPoints + lowerHull = foldr (flip addNewPoint) [] 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 - 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 diff --git a/Main.hs b/Main.hs index 2372b5b..e7cf2e1 100644 --- a/Main.hs +++ b/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 diff --git a/Queries.hs b/Queries.hs new file mode 100644 index 0000000..cb6d53c --- /dev/null +++ b/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 + diff --git a/UserInterface.hs b/UserInterface.hs index 34f722c..5d56c1c 100644 --- a/UserInterface.hs +++ b/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 diff --git a/geometry.cabal b/geometry.cabal index 561c3f1..a52d681 100644 --- a/geometry.cabal +++ b/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 diff --git a/geometry.ui b/geometry.ui new file mode 100644 index 0000000..acafe50 --- /dev/null +++ b/geometry.ui @@ -0,0 +1,43 @@ + + + + + + False + + + + + + True + False + vertical + + + True + True + + + False + True + 0 + + + + + True + False + True + True + True + + + False + True + 1 + + + + + +