Implement naive eraser
This commit is contained in:
Francesco Magliocca
parent
9eadab57ca
commit
5a76b3b7aa
|
|
@ -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
|
||||
|
|
|
|||
11
Main.hs
11
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
157
UserInterface.hs
157
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
Loading…
Reference in New Issue