mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
implement deletion of selection
This commit is contained in:
parent
0f2eddab80
commit
107b27ebca
1
.gitignore
vendored
1
.gitignore
vendored
|
@ -4,6 +4,7 @@ cabal.project.local
|
|||
assets/*.svg
|
||||
assets/*/
|
||||
refs/
|
||||
img/examples
|
||||
|
||||
*.txt
|
||||
*.md
|
||||
|
|
|
@ -61,6 +61,7 @@ library
|
|||
, Math.Bezier.Quadratic
|
||||
, Math.Bezier.Stroke
|
||||
, Math.Bezier.Subdivision
|
||||
, Math.Epsilon
|
||||
, Math.Module
|
||||
, Math.RealRoots
|
||||
, Math.Vector2D
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
12
src/lib/Math/Epsilon.hs
Normal 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 ) )
|
|
@ -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.
|
||||
--
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue