stroking: compute offset given tangent vector

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

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 ()

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)

src/app/MetaBrush/Document/Selection.hs

@@ -97,6 +97,7 @@ selectAt mode c doc@( Document { zoomFactor } ) =
     where
       updateStroke :: Stroke -> State Bool Stroke
       updateStroke stroke@( Stroke { strokeVisible } ) =
+        over ( field' @"strokePoints" ) matchEndpoints <$>
           field' @"strokePoints"
             ( traverse ( updatePoint strokeVisible ) )
             stroke
@@ -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,6 +149,7 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
   where
     updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke
     updateStroke stroke@( Stroke { strokeVisible } ) =
+      over ( field' @"strokePoints" ) matchEndpoints <$>
         field' @"strokePoints"
           ( traverse ( updatePoint strokeVisible ) )
           stroke
@@ -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

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

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 )

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 }
 

src/lib/Math/Bezier/Stroke.hs

@@ -1,3 +0,0 @@
-module Math.Bezier.Stroke where
-
---------------------------------------------------------------------------------

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