implement deletion of selection

This commit is contained in:
sheaf 2020-08-19 05:28:47 +02:00
parent 0f2eddab80
commit 107b27ebca
7 changed files with 68 additions and 11 deletions

1
.gitignore vendored
View file

@ -4,6 +4,7 @@ cabal.project.local
assets/*.svg
assets/*/
refs/
img/examples
*.txt
*.md

View file

@ -61,6 +61,7 @@ library
, Math.Bezier.Quadratic
, Math.Bezier.Stroke
, Math.Bezier.Subdivision
, Math.Epsilon
, Math.Module
, Math.RealRoots
, Math.Vector2D

View file

@ -78,13 +78,13 @@ data StrokePoint
data PointType
= PathPoint
| ControlPoint
deriving stock Show
deriving stock ( Show, Eq )
data FocusState
= Normal
| Hover
| Selected
deriving stock Show
deriving stock ( Show, Eq )
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do

View file

@ -28,6 +28,10 @@ import Data.Word
import Data.Act
( Act(()), Torsor((-->)) )
-- containers
import Data.Sequence
( Seq(..) )
-- generic-lens
import Data.GenericLens.Internal
( over )
@ -53,7 +57,7 @@ import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Stroke(..), StrokePoint(..)
, FocusState(..)
, PointType(..), FocusState(..)
)
import MetaBrush.Event.KeyCodes
( pattern Alt_L , pattern Alt_R
@ -215,6 +219,37 @@ translateSelection t = over ( field' @"strokes" ) ( fmap updateStroke )
| otherwise
= pt
-- | Delete the selected points
-- | Delete the selected points.
deleteSelected :: Document -> Document
deleteSelected doc = doc -- TODO
deleteSelected doc
= fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) )
$ field' @"strokes"
( traverse $ field' @"strokePoints" updateStroke )
doc
where
updateStroke :: Seq StrokePoint -> Tardis Bool Bool ( Seq StrokePoint )
updateStroke Empty = pure Empty
updateStroke ( StrokePoint { pointType = PathPoint, pointState = Selected } :<| ps ) = do
Tardis.sendPast True
Tardis.sendFuture True
updateStroke ps
updateStroke ( p@( StrokePoint { pointType = PathPoint } ) :<| ps ) = do
Tardis.sendPast False
Tardis.sendFuture False
( p :<| ) <$> updateStroke ps
updateStroke ( p@( StrokePoint { pointType = ControlPoint, pointState } ) :<| ps ) = do
prevPathPointDeleted <- Tardis.getPast
nextPathPointDeleted <- Tardis.getFuture
rest <- updateStroke ps
let
-- Control point must be deleted:
-- - if it is selected,
-- - if the previous path point was deleted,
-- - if the next path point is going to be deleted.
--
-- Need to be lazy in "nextPathPointDeleted" to avoid looping.
res :: Seq StrokePoint
res = if pointState == Selected || prevPathPointDeleted || nextPathPointDeleted
then rest
else p :<| rest
pure res

12
src/lib/Math/Epsilon.hs Normal file
View file

@ -0,0 +1,12 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Math.Epsilon
( epsilon )
where
--------------------------------------------------------------------------------
{-# SPECIALISE epsilon :: Float #-}
{-# SPECIALISE epsilon :: Double #-}
epsilon :: forall r. RealFloat r => r
epsilon = encodeFloat 1 ( 5 - floatDigits ( 0 :: r ) )

View file

@ -12,18 +12,20 @@ import Data.List.NonEmpty
import Data.Maybe
( mapMaybe )
-- MetaBrush
import Math.Epsilon
( epsilon )
--------------------------------------------------------------------------------
-- | Find real roots of a polynomial.
realRoots :: forall r. RealFloat r => [ r ] -> [ r ]
realRoots p = mapMaybe isReal ( roots eps 10000 ( map (:+ 0) p ) )
realRoots p = mapMaybe isReal ( roots epsilon 10000 ( map (:+ 0) p ) )
where
isReal :: Complex r -> Maybe r
isReal ( a :+ b )
| abs b < eps = Just a
| otherwise = Nothing
eps :: r
eps = encodeFloat 1 ( 5 - floatDigits ( 0 :: r ) )
| abs b < epsilon = Just a
| otherwise = Nothing
-- | Compute all roots of a polynomial using Laguerre's method and (forward) deflation.
--

View file

@ -5,7 +5,9 @@
{-# LANGUAGE MultiParamTypeClasses #-}
module Math.Vector2D
( Point2D(..), Vector2D(..) )
( Point2D(..), Vector2D(..)
, cross
)
where
-- base
@ -56,3 +58,7 @@ instance Num a => Module a ( Vector2D a ) where
instance Num a => Inner a ( Vector2D a ) where
( Vector2D ( Point2D x1 y1 ) ) ^.^ ( Vector2D ( Point2D x2 y2 ) )
= x1 * x2 + y1 * y2
cross :: Num a => Vector2D a -> Vector2D a -> a
cross ( Vector2D ( Point2D x1 y1 ) ) ( Vector2D ( Point2D x2 y2 ) )
= x1 * y2 - x2 * y1