diff --git a/.gitignore b/.gitignore index 00d359b..8905ede 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,7 @@ cabal.project.local assets/*.svg assets/*/ refs/ +img/examples *.txt *.md diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 50e0e21..f341997 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -61,6 +61,7 @@ library , Math.Bezier.Quadratic , Math.Bezier.Stroke , Math.Bezier.Subdivision + , Math.Epsilon , Math.Module , Math.RealRoots , Math.Vector2D diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 8f1433a..3664982 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 3d1e12c..9058d8d 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 diff --git a/src/lib/Math/Epsilon.hs b/src/lib/Math/Epsilon.hs new file mode 100644 index 0000000..1194a9d --- /dev/null +++ b/src/lib/Math/Epsilon.hs @@ -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 ) ) diff --git a/src/lib/Math/RealRoots.hs b/src/lib/Math/RealRoots.hs index 5205cbd..9fe326e 100644 --- a/src/lib/Math/RealRoots.hs +++ b/src/lib/Math/RealRoots.hs @@ -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. -- diff --git a/src/lib/Math/Vector2D.hs b/src/lib/Math/Vector2D.hs index 1f2accc..f35c355 100644 --- a/src/lib/Math/Vector2D.hs +++ b/src/lib/Math/Vector2D.hs @@ -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