From e044b1b06cced471df61688a22c6382129a3d6b6 Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 19 Aug 2020 17:23:20 +0200 Subject: [PATCH] stroking: compute offset given tangent vector --- MetaBrush.cabal | 5 +- app/Main.hs | 33 ++++- src/app/MetaBrush/Bezier/Stroke.hs | 164 ++++++++++++++++++++++++ src/app/MetaBrush/Document/Selection.hs | 26 +++- src/app/MetaBrush/Render/Document.hs | 2 +- src/app/MetaBrush/UI/Coordinates.hs | 2 +- src/app/MetaBrush/Unique.hs | 17 ++- src/lib/Math/Bezier/Stroke.hs | 3 - src/lib/Math/RealRoots.hs | 3 + 9 files changed, 237 insertions(+), 18 deletions(-) create mode 100644 src/app/MetaBrush/Bezier/Stroke.hs delete mode 100644 src/lib/Math/Bezier/Stroke.hs diff --git a/MetaBrush.cabal b/MetaBrush.cabal index f341997..413c700 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -59,7 +59,7 @@ library exposed-modules: Math.Bezier.Cubic , Math.Bezier.Quadratic - , Math.Bezier.Stroke + --, Math.Bezier.Stroke , Math.Bezier.Subdivision , Math.Epsilon , Math.Module @@ -92,6 +92,9 @@ executable MetaBrush , MetaBrush.Asset.TickBox , MetaBrush.Asset.Tools , MetaBrush.Asset.WindowIcons + -- temporarily here + , MetaBrush.Bezier.Stroke + -- , MetaBrush.Document , MetaBrush.Document.Draw , MetaBrush.Document.Selection diff --git a/app/Main.hs b/app/Main.hs index 52b00f8..3cf52ad 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,6 +24,10 @@ import Data.IntMap.Strict ( IntMap ) import qualified Data.IntMap.Strict as IntMap ( fromList ) +import Data.Sequence + ( Seq ) +import qualified Data.Sequence as Seq + ( fromList ) -- directory import qualified System.Directory as Directory @@ -56,6 +60,8 @@ import MetaBrush.Asset.Logo ( drawLogo ) import MetaBrush.Document ( Document(..), AABB(..) + , Stroke(..), StrokePoint(..) + , PointType(..), FocusState(..) , currentDocument ) import MetaBrush.Event @@ -79,7 +85,7 @@ import MetaBrush.UI.ToolBar import MetaBrush.UI.Viewport ( Viewport(..), createViewport ) import MetaBrush.Unique - ( newUniqueSupply ) + ( newUniqueSupply, unsafeUnique ) import qualified Paths_MetaBrush as Cabal ( getDataFileName ) @@ -92,7 +98,7 @@ testDocuments = IntMap.fromList { displayName = "Document 1" , filePath = Nothing , unsavedChanges = False - , strokes = [ ] + , strokes = [ Stroke circle "Circle" True ( unsafeUnique 0 ) ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , viewportCenter = Point2D 50 50 , zoomFactor = 1 @@ -108,6 +114,29 @@ testDocuments = IntMap.fromList } ] +circle :: Seq StrokePoint +circle = Seq.fromList + [ pp ( Point2D 0 1 ) + , cp ( Point2D a 1 ) + , cp ( Point2D 1 a ) + , pp ( Point2D 1 0 ) + , cp ( Point2D 1 (-a) ) + , cp ( Point2D a (-1) ) + , pp ( Point2D 0 (-1) ) + , cp ( Point2D (-a) (-1) ) + , cp ( Point2D (-1) (-a) ) + , pp ( Point2D (-1) 0 ) + , cp ( Point2D (-1) a ) + , cp ( Point2D (-a) 1 ) + , pp ( Point2D 0 1 ) + ] + where + a :: Double + a = 0.551915024494 + pp, cp :: Point2D Double -> StrokePoint + pp p = StrokePoint ( fmap ( * 100 ) p ) PathPoint Normal + cp p = StrokePoint ( fmap ( * 100 ) p ) ControlPoint Normal + -------------------------------------------------------------------------------- main :: IO () diff --git a/src/app/MetaBrush/Bezier/Stroke.hs b/src/app/MetaBrush/Bezier/Stroke.hs new file mode 100644 index 0000000..3b513be --- /dev/null +++ b/src/app/MetaBrush/Bezier/Stroke.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +-- TODO: refactor and move this module to the library component. +module MetaBrush.Bezier.Stroke + ( Offset(..), withTangent + , between, parallel + ) + where + +-- base +import Control.Monad + ( guard ) +import Data.Maybe + ( mapMaybe ) + +-- acts +import Data.Act + ( Torsor + ( (-->) ) + ) + +-- containers +import Data.Sequence + ( Seq(..) ) + +-- MetaBrush +import qualified Math.Bezier.Cubic as Cubic +import qualified Math.Bezier.Quadratic as Quadratic +import Math.Epsilon + ( epsilon ) +import Math.Module + ( Module((^-^)), Inner((^.^)), lerp ) +import Math.RealRoots + ( realRoots ) +import Math.Vector2D + ( Point2D(..), Vector2D(..), cross ) +import MetaBrush.Document + ( StrokePoint(..), PointType(..) ) + +-------------------------------------------------------------------------------- + +data Offset + = Offset + { offsetIndex :: !Int + , offsetParameter :: !( Maybe Double ) + , offset :: !( Point2D Double ) +--, curvature :: !Double + } + deriving stock Show + +withTangent :: Vector2D Double -> Seq StrokePoint -> Offset +withTangent tgt ( spt0 :<| spt1 :<| spts ) = + let + tgt0 :: Vector2D Double + tgt0 = strokePoint spt0 --> strokePoint spt1 + in + if parallel tgt tgt0 + then Offset 0 ( Just 0 ) ( strokePoint spt0 ) + else go 0 tgt0 spt0 spt1 spts + + where + go :: Int -> Vector2D Double -> StrokePoint -> StrokePoint -> Seq StrokePoint -> Offset + -- Line. + go i tgt0 p0 p1 ps + | PathPoint <- pointType p1 + = if parallel tgt tgt0 + then Offset i Nothing ( lerp @( Vector2D Double ) 0.5 ( strokePoint p0 ) ( strokePoint p1 ) ) + else continue ( i + 1 ) tgt0 p1 ps + -- Quadratic Bézier curve. + go i tgt0 p0 p1 ( p2 :<| ps ) + | ControlPoint <- pointType p1 + , PathPoint <- pointType p2 + , let + tgt1 :: Vector2D Double + tgt1 = strokePoint p1 --> strokePoint p2 + = case between tgt tgt0 tgt1 of + Just t -> Offset i ( Just t ) ( Quadratic.bezier @( Vector2D Double ) ( strokePoint <$> Quadratic.Bezier { .. } ) t ) + Nothing -> continue ( i + 2 ) tgt1 p2 ps + -- Cubic Bézier curve. + go i tgt0 p0 p1 ( p2 :<| p3 :<| ps ) + | ControlPoint <- pointType p1 + , ControlPoint <- pointType p2 + , PathPoint <- pointType p3 + , let + tgt1, tgt2 :: Vector2D Double + tgt1 = strokePoint p1 --> strokePoint p2 + tgt2 = strokePoint p2 --> strokePoint p3 + bez :: Cubic.Bezier ( Point2D Double ) + bez = strokePoint <$> Cubic.Bezier { .. } + = case between tgt tgt0 tgt2 of + Just s + | let + c01, c12, c23 :: Double + c01 = tgt `cross` tgt0 + c12 = tgt `cross` tgt1 + c23 = tgt `cross` tgt2 + correctTangentParam :: Double -> Maybe Double + correctTangentParam t + | t > -epsilon && t < 1 + epsilon + , tgt ^.^ Cubic.bezier' bez t > epsilon + = Just ( max 0 ( min 1 t ) ) + | otherwise + = Nothing + , ( t : _ ) <- mapMaybe correctTangentParam $ realRoots [ c01, 2 * ( c12 - c01 ), c01 + c23 - 2 * c12 ] + -> Offset i ( Just t ) ( Cubic.bezier @( Vector2D Double ) bez t ) + -- Fallback in case we couldn't solve the quadratic for some reason. + | otherwise + -> Offset i ( Just s ) ( Cubic.bezier @( Vector2D Double ) bez s ) + -- Go to next piece of the curve. + _ -> continue ( i + 3 ) tgt2 p3 ps + go _ _ _ _ _ + = error "withTangent: unrecognised path type (more than two consecutive control points)" + + -- Handles corners in the Bézier curve. + continue :: Int -> Vector2D Double -> StrokePoint -> Seq StrokePoint -> Offset + continue _ _ _ Empty = Offset 0 ( Just 0 ) ( strokePoint spt0 ) + continue i ptgt p0 ( p1 :<| ps ) = + let + tgt0 :: Vector2D Double + tgt0 = strokePoint p0 --> strokePoint p1 + in case between tgt ptgt tgt0 of + Just _ -> Offset i ( Just 0 ) ( strokePoint p0 ) + Nothing -> go i tgt0 p0 p1 ps + +withTangent _ _ = error $ "withTangent: invalid path (fewer than 2 points)" + +-- | Finds whether the query vector @ u @ lies between the two provided vectors @ v0 @, @ v1 @. +-- +-- If so, returns @ t @ in @ [ 0, 1 ] @ such that @ ( 1 - t ) v0 + t v1 @ is a positive multiple of @ u @. +between + :: Vector2D Double -- ^ query vector + -> Vector2D Double -- ^ first vector + -> Vector2D Double -- ^ second vector + -> Maybe Double +between u v0 v1 + | abs c10 < epsilon + = if parallel u v0 + then Just 0 + else if parallel u v1 + then Just 1 + else Nothing + | otherwise + = do + let + t :: Double + t = c0 / c10 + guard ( t > - epsilon && t < 1 + epsilon ) + guard ( epsilon < u ^.^ ( lerp @( Vector2D Double ) t v0 v1 ) ) + Just $ min 1 ( max 0 t ) + + where + c0, c10 :: Double + c0 = v0 `cross` u + c10 = ( v0 ^-^ v1 ) `cross` u + +-- | Compute whether two vectors point in the same direction, +-- that is, whether each vector is a (strictly) positive multiple of the other. +parallel :: Vector2D Double -> Vector2D Double -> Bool +parallel u v + = abs ( u `cross` v ) < epsilon -- vectors are collinear + && u ^.^ v > epsilon -- vectors point in the same direction (parallel and not anti-parallel) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 9058d8d..b6097c7 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -97,9 +97,10 @@ selectAt mode c doc@( Document { zoomFactor } ) = where updateStroke :: Stroke -> State Bool Stroke updateStroke stroke@( Stroke { strokeVisible } ) = - field' @"strokePoints" - ( traverse ( updatePoint strokeVisible ) ) - stroke + over ( field' @"strokePoints" ) matchEndpoints <$> + field' @"strokePoints" + ( traverse ( updatePoint strokeVisible ) ) + stroke updatePoint :: Bool -> StrokePoint -> State Bool StrokePoint updatePoint isVisible pt@( StrokePoint { strokePoint = p } ) = do anotherPointHasAlreadyBeenSelected <- get @@ -115,6 +116,12 @@ selectAt mode c doc@( Document { zoomFactor } ) = selected | not isVisible = False | otherwise = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) + -- Ensure consistency of selection at endpoints for closed loops. + matchEndpoints :: Seq StrokePoint -> Seq StrokePoint + matchEndpoints ( p0 :<| ( ps :|> pn ) ) + | strokePoint p0 == strokePoint pn + = p0 :<| ( ps :|> pn { pointState = pointState p0 } ) + matchEndpoints ps = ps -- | Type of a drag move selection: -- @@ -142,9 +149,10 @@ dragMoveSelect c doc@( Document { zoomFactor } ) = where updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke updateStroke stroke@( Stroke { strokeVisible } ) = - field' @"strokePoints" - ( traverse ( updatePoint strokeVisible ) ) - stroke + over ( field' @"strokePoints" ) matchEndpoints <$> + field' @"strokePoints" + ( traverse ( updatePoint strokeVisible ) ) + stroke updatePoint :: Bool -> StrokePoint -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) StrokePoint updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } ) | selected @@ -179,6 +187,12 @@ dragMoveSelect c doc@( Document { zoomFactor } ) = selected | not isVisible = False | otherwise = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) + -- Ensure consistency of selection at endpoints for closed loops. + matchEndpoints :: Seq StrokePoint -> Seq StrokePoint + matchEndpoints ( p0 :<| ( ps :|> pn ) ) + | strokePoint p0 == strokePoint pn + = p0 :<| ( ps :|> pn { pointState = pointState p0 } ) + matchEndpoints ps = ps -- | Updates the selected objects on a rectangular selection event. selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 029c623..7a74d34 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -175,7 +175,7 @@ renderStroke cols zoom ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = Tr -- Cubic Bézier curve. go p0 ( p1 :<| p2 :<| p3 :<| ps ) | ControlPoint <- pointType p1 - , ControlPoint <- pointType p1 + , ControlPoint <- pointType p2 , PathPoint <- pointType p3 = Renders { renderPoints diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index a764f3c..daa721f 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -64,7 +64,7 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) = -- Cubic Bézier curve. go p0 ( p1 :<| p2 :<| p3 :<| ps ) | ControlPoint <- pointType p1 - , ControlPoint <- pointType p1 + , ControlPoint <- pointType p2 , PathPoint <- pointType p3 = fmap ( fmap ( Just . snd ) ) ( Cubic.closestPoint @( Vector2D Double ) ( strokePoint <$> Cubic.Bezier { .. } ) c ) diff --git a/src/app/MetaBrush/Unique.hs b/src/app/MetaBrush/Unique.hs index c69a78c..6617bc3 100644 --- a/src/app/MetaBrush/Unique.hs +++ b/src/app/MetaBrush/Unique.hs @@ -4,15 +4,17 @@ {-# LANGUAGE OverloadedStrings #-} module MetaBrush.Unique - ( Unique + ( Unique, unsafeUnique , freshUnique, uniqueText , UniqueSupply, newUniqueSupply ) where -- base +import Data.Int + ( Int64 ) import Data.Word - ( Word64 ) + ( Word32 ) -- stm import Control.Concurrent.STM @@ -28,12 +30,19 @@ import qualified Data.Text as Text -------------------------------------------------------------------------------- -newtype Unique = Unique { unique :: Word64 } +newtype Unique = Unique { unique :: Int64 } deriving stock Show deriving newtype ( Eq, Ord ) +unsafeUnique :: Word32 -> Unique +unsafeUnique i = Unique ( - fromIntegral i - 1 ) + uniqueText :: Unique -> Text -uniqueText ( Unique i ) = "%" <> Text.pack ( show i ) +uniqueText ( Unique i ) + | i >= 0 + = "%" <> Text.pack ( show i ) + | otherwise + = "§" <> Text.pack ( show $ -i - 1 ) newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique } diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs deleted file mode 100644 index 4b746fe..0000000 --- a/src/lib/Math/Bezier/Stroke.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Math.Bezier.Stroke where - --------------------------------------------------------------------------------- \ No newline at end of file diff --git a/src/lib/Math/RealRoots.hs b/src/lib/Math/RealRoots.hs index 9fe326e..401d6eb 100644 --- a/src/lib/Math/RealRoots.hs +++ b/src/lib/Math/RealRoots.hs @@ -19,6 +19,9 @@ import Math.Epsilon -------------------------------------------------------------------------------- -- | Find real roots of a polynomial. + +-- Coefficients are given in order of increasing degree, e.g.: +-- x² + 7 is given by [ 7, 0, 1 ]. realRoots :: forall r. RealFloat r => [ r ] -> [ r ] realRoots p = mapMaybe isReal ( roots epsilon 10000 ( map (:+ 0) p ) ) where