mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
compute and render brush stroke outlines
This commit is contained in:
sheaf
parent
b3941a2834
commit
3916fe2656
|
|
@ -34,6 +34,8 @@ common common
|
|||
>= 0.6.0.1 && < 0.6.4
|
||||
, generic-data
|
||||
>= 0.8.0.0 && < 0.8.4.0
|
||||
, generic-lens
|
||||
>= 1.2.0.1 && < 2.0
|
||||
, groups
|
||||
^>= 0.4.1.0
|
||||
, transformers
|
||||
|
|
@ -43,7 +45,7 @@ common common
|
|||
Haskell2010
|
||||
|
||||
ghc-options:
|
||||
-O1
|
||||
-O2
|
||||
-fexpose-all-unfoldings
|
||||
-fspecialise-aggressively
|
||||
-Wall
|
||||
|
|
@ -133,8 +135,6 @@ executable MetaBrush
|
|||
>= 1.3.4.0 && < 1.4
|
||||
--, fingertree
|
||||
-- >= 0.1.4.2 && < 0.2
|
||||
, generic-lens
|
||||
>= 1.2.0.1 && < 2.0
|
||||
, gi-gdk
|
||||
>= 3.0.22 && < 3.1
|
||||
, gi-gio
|
||||
|
|
|
|||
16
app/Main.hs
16
app/Main.hs
|
|
@ -119,7 +119,7 @@ testDocuments = IntMap.fromList
|
|||
}
|
||||
]
|
||||
|
||||
circle :: forall a. a -> Seq ( StrokePoint a)
|
||||
circle :: forall a. a -> Seq ( StrokePoint a )
|
||||
circle d = Seq.fromList
|
||||
[ pp ( Point2D 0 1 )
|
||||
, cp ( Point2D a 1 )
|
||||
|
|
@ -144,13 +144,13 @@ circle d = Seq.fromList
|
|||
|
||||
razor :: forall a. a -> Seq ( StrokePoint a )
|
||||
razor d = Seq.fromList
|
||||
[ pp ( Point2D 10 0 )
|
||||
, cp ( Point2D 10 -3 )
|
||||
, cp ( Point2D -10 -3 )
|
||||
, pp ( Point2D -10 0 )
|
||||
, cp ( Point2D -10 3 )
|
||||
, cp ( Point2D 10 3 )
|
||||
, pp ( Point2D 10 0 )
|
||||
[ pp ( Point2D 30 0 )
|
||||
, cp ( Point2D 30 -6 )
|
||||
, cp ( Point2D -30 -6 )
|
||||
, pp ( Point2D -30 0 )
|
||||
, cp ( Point2D -30 3 )
|
||||
, cp ( Point2D 30 3 )
|
||||
, pp ( Point2D 30 0 )
|
||||
]
|
||||
where
|
||||
pp, cp :: Point2D Double -> StrokePoint a
|
||||
|
|
|
|||
|
|
@ -52,9 +52,6 @@ import Data.Generics.Product.Typed
|
|||
-- gi-cairo-render
|
||||
import qualified GI.Cairo.Render as Cairo
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
|
|
@ -65,7 +62,7 @@ import qualified Math.Bezier.Cubic as Cubic
|
|||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..) )
|
||||
import Math.Bezier.Stroke
|
||||
( StrokePoint(..) )
|
||||
( StrokePoint(..), stroke )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
|
|
@ -136,7 +133,7 @@ renderDocument
|
|||
renderSelectionRect
|
||||
| Just ( SelectionHold p0 ) <- mbHoldEvent
|
||||
, Just p1 <- mbMousePos
|
||||
= renderSelectionRectangle cols zoomFactor p0 p1
|
||||
= drawSelectionRectangle cols zoomFactor p0 p1
|
||||
| otherwise
|
||||
= pure ()
|
||||
|
||||
|
|
@ -183,44 +180,35 @@ renderDocument
|
|||
pure ()
|
||||
|
||||
renderStroke :: Colours -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
|
||||
renderStroke cols mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
|
||||
renderStroke cols@( Colours { brush } ) mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
|
||||
| strokeVisible
|
||||
= renderContent Path cols mode zoom pts
|
||||
= renderStrokePoints cols mode zoom
|
||||
( whenBrush mode . renderBrushShape ( cols { path = brush } ) ( 2 * zoom ) )
|
||||
pts
|
||||
*> Compose blank { renderStrokes = drawStroke cols ( stroke pts ) }
|
||||
| otherwise
|
||||
= pure ()
|
||||
|
||||
class RenderableContent d where
|
||||
renderContent :: Mode -> Colours -> Mode -> Double -> d -> Compose Renders Cairo.Render ()
|
||||
|
||||
instance RenderableContent ( StrokePoint PointData ) where
|
||||
renderContent _ cols _ zoom pt =
|
||||
let
|
||||
x, y :: Double
|
||||
Point2D x y = coords pt
|
||||
brushPts :: Seq ( StrokePoint BrushPointData )
|
||||
brushPts = brushShape ( pointData pt )
|
||||
in
|
||||
toAll do
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
*> renderContent Brush cols Path zoom brushPts
|
||||
*> Compose blank { renderPPts = drawCross cols zoom }
|
||||
*> toAll Cairo.restore
|
||||
|
||||
instance RenderableContent ( StrokePoint BrushPointData ) where
|
||||
renderContent _ _ _ _ _ = pure ()
|
||||
|
||||
instance ( Show d, RenderableContent ( StrokePoint d ), HasType FocusState d ) => RenderableContent ( Seq ( StrokePoint d ) ) where
|
||||
renderContent _ _ _ _ Empty = pure ()
|
||||
renderContent tp cols mode zoom ( pt0 :<| pts ) =
|
||||
Compose blank
|
||||
{ renderPPts = whenPath mode $ drawPoint cols zoom pt0 }
|
||||
*> whenBrush mode ( renderContent Brush cols mode zoom pt0 )
|
||||
*> go pt0 pts
|
||||
-- | Render a sequence of stroke points.
|
||||
--
|
||||
-- Accepts a sub-function for additional rendering of each stroke point
|
||||
-- (e.g. overlay a brush shape over each stroke point).
|
||||
renderStrokePoints
|
||||
:: forall d
|
||||
. ( Show d, HasType FocusState d )
|
||||
=> Colours -> Mode -> Double
|
||||
-> ( StrokePoint d -> Compose Renders Cairo.Render () )
|
||||
-> Seq ( StrokePoint d )
|
||||
-> Compose Renders Cairo.Render ()
|
||||
renderStrokePoints _ _ _ _ Empty = pure ()
|
||||
renderStrokePoints cols mode zoom renderSubcontent ( pt0 :<| pts ) =
|
||||
Compose blank { renderPPts = whenPath mode $ drawPoint cols zoom pt0 }
|
||||
*> renderSubcontent pt0
|
||||
*> go pt0 pts
|
||||
where
|
||||
go :: StrokePoint d -> Seq ( StrokePoint d ) -> Compose Renders Cairo.Render ()
|
||||
go _ Empty = pure ()
|
||||
go ( ControlPoint {} ) _ = error "renderContent: path starts with a control point"
|
||||
go ( ControlPoint {} ) _ = error "renderStrokePoints: path starts with a control point"
|
||||
-- Line.
|
||||
go p0 ( p1 :<| ps )
|
||||
| PathPoint {} <- p1
|
||||
|
|
@ -228,9 +216,9 @@ instance ( Show d, RenderableContent ( StrokePoint d ), HasType FocusState d ) =
|
|||
{ renderPPts
|
||||
= whenPath mode $ drawPoint cols zoom p1
|
||||
, renderPath
|
||||
= drawLine cols tp zoom p0 p1
|
||||
= drawLine cols zoom p0 p1
|
||||
}
|
||||
*> ( whenBrush mode $ renderContent Brush cols mode zoom p1 )
|
||||
*> renderSubcontent p1
|
||||
*> go p1 ps
|
||||
-- Quadratic Bézier curve.
|
||||
go p0 ( p1 :<| p2 :<| ps )
|
||||
|
|
@ -239,19 +227,17 @@ instance ( Show d, RenderableContent ( StrokePoint d ), HasType FocusState d ) =
|
|||
= Compose blank
|
||||
{ renderCLines
|
||||
= whenPath mode do
|
||||
drawLine cols tp zoom p0 p1
|
||||
drawLine cols tp zoom p1 p2
|
||||
drawLine cols zoom p0 p1
|
||||
drawLine cols zoom p1 p2
|
||||
, renderCPts
|
||||
= whenPath mode $ drawPoint cols zoom p1
|
||||
, renderPPts
|
||||
= whenPath mode $ drawPoint cols zoom p2
|
||||
, renderPath
|
||||
= drawQuadraticBezier cols tp zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } )
|
||||
= drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } )
|
||||
}
|
||||
*> whenBrush mode
|
||||
( renderContent Brush cols mode zoom p1
|
||||
*> renderContent Brush cols mode zoom p2
|
||||
)
|
||||
*> renderSubcontent p1
|
||||
*> renderSubcontent p2
|
||||
*> go p2 ps
|
||||
-- Cubic Bézier curve.
|
||||
go p0 ( p1 :<| p2 :<| p3 :<| ps )
|
||||
|
|
@ -261,8 +247,8 @@ instance ( Show d, RenderableContent ( StrokePoint d ), HasType FocusState d ) =
|
|||
= Compose blank
|
||||
{ renderCLines
|
||||
= whenPath mode do
|
||||
drawLine cols tp zoom p0 p1
|
||||
drawLine cols tp zoom p2 p3
|
||||
drawLine cols zoom p0 p1
|
||||
drawLine cols zoom p2 p3
|
||||
, renderCPts
|
||||
= whenPath mode do
|
||||
drawPoint cols zoom p1
|
||||
|
|
@ -270,16 +256,29 @@ instance ( Show d, RenderableContent ( StrokePoint d ), HasType FocusState d ) =
|
|||
, renderPPts
|
||||
= whenPath mode $ drawPoint cols zoom p3
|
||||
, renderPath
|
||||
= drawCubicBezier cols tp zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } )
|
||||
= drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } )
|
||||
}
|
||||
*> whenBrush mode
|
||||
( renderContent Brush cols mode zoom p1
|
||||
*> renderContent Brush cols mode zoom p2
|
||||
*> renderContent Brush cols mode zoom p3
|
||||
)
|
||||
*> renderSubcontent p1
|
||||
*> renderSubcontent p2
|
||||
*> renderSubcontent p3
|
||||
*> go p3 ps
|
||||
go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
|
||||
|
||||
renderBrushShape :: Colours -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render ()
|
||||
renderBrushShape cols zoom pt =
|
||||
let
|
||||
x, y :: Double
|
||||
Point2D x y = coords pt
|
||||
brushPts :: Seq ( StrokePoint BrushPointData )
|
||||
brushPts = brushShape ( pointData pt )
|
||||
in
|
||||
toAll do
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
*> renderStrokePoints cols Brush zoom ( const $ pure () ) brushPts
|
||||
*> Compose blank { renderPPts = drawCross cols zoom }
|
||||
*> toAll Cairo.restore
|
||||
|
||||
drawPoint :: HasType FocusState d => Colours -> Double -> StrokePoint d -> Cairo.Render ()
|
||||
drawPoint ( Colours { .. } ) zoom pt@( PathPoint { coords = Point2D x y } )
|
||||
= do
|
||||
|
|
@ -344,19 +343,12 @@ drawPoint ( Colours { .. } ) zoom pt@( ControlPoint { coords = Point2D x y } )
|
|||
|
||||
Cairo.restore
|
||||
|
||||
drawLine :: Colours -> Mode -> Double -> StrokePoint d -> StrokePoint d -> Cairo.Render ()
|
||||
drawLine ( Colours { path, brush, controlPoint } ) mode zoom p1 p2 = do
|
||||
drawLine :: Colours -> Double -> StrokePoint d -> StrokePoint d -> Cairo.Render ()
|
||||
drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
|
||||
let
|
||||
x1, y1, x2, y2 :: Double
|
||||
Point2D x1 y1 = coords p1
|
||||
Point2D x2 y2 = coords p2
|
||||
col :: GDK.RGBA
|
||||
sz :: Double
|
||||
( col, sz )
|
||||
| Brush <- mode
|
||||
= ( brush, 3 )
|
||||
| otherwise
|
||||
= ( path, 6 )
|
||||
|
||||
Cairo.save
|
||||
Cairo.moveTo x1 y1
|
||||
|
|
@ -364,8 +356,8 @@ drawLine ( Colours { path, brush, controlPoint } ) mode zoom p1 p2 = do
|
|||
|
||||
case ( p1, p2 ) of
|
||||
( PathPoint {}, PathPoint {} ) -> do
|
||||
Cairo.setLineWidth ( sz / zoom )
|
||||
withRGBA col Cairo.setSourceRGBA
|
||||
Cairo.setLineWidth ( 5 / zoom )
|
||||
withRGBA path Cairo.setSourceRGBA
|
||||
_ -> do
|
||||
Cairo.setLineWidth ( 3 / zoom )
|
||||
withRGBA controlPoint Cairo.setSourceRGBA
|
||||
|
|
@ -373,8 +365,8 @@ drawLine ( Colours { path, brush, controlPoint } ) mode zoom p1 p2 = do
|
|||
|
||||
Cairo.restore
|
||||
|
||||
drawQuadraticBezier :: Colours -> Mode -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
|
||||
drawQuadraticBezier ( Colours { path, brush } ) mode zoom
|
||||
drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
|
||||
drawQuadraticBezier ( Colours { path } ) zoom
|
||||
( Quadratic.Bezier
|
||||
{ p0 = Point2D x0 y0
|
||||
, p1 = Point2D x1 y1
|
||||
|
|
@ -382,14 +374,6 @@ drawQuadraticBezier ( Colours { path, brush } ) mode zoom
|
|||
}
|
||||
)
|
||||
= do
|
||||
let
|
||||
col :: GDK.RGBA
|
||||
sz :: Double
|
||||
( col, sz )
|
||||
| Brush <- mode
|
||||
= ( brush, 3 )
|
||||
| otherwise
|
||||
= ( path, 6 )
|
||||
|
||||
Cairo.save
|
||||
|
||||
|
|
@ -399,14 +383,14 @@ drawQuadraticBezier ( Colours { path, brush } ) mode zoom
|
|||
( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
|
||||
x2 y2
|
||||
|
||||
Cairo.setLineWidth ( sz / zoom )
|
||||
withRGBA col Cairo.setSourceRGBA
|
||||
Cairo.setLineWidth ( 6 / zoom )
|
||||
withRGBA path Cairo.setSourceRGBA
|
||||
Cairo.stroke
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawCubicBezier :: Colours -> Mode -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
|
||||
drawCubicBezier ( Colours { path, brush } ) mode zoom
|
||||
drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
|
||||
drawCubicBezier ( Colours { path } ) zoom
|
||||
( Cubic.Bezier
|
||||
{ p0 = Point2D x0 y0
|
||||
, p1 = Point2D x1 y1
|
||||
|
|
@ -415,29 +399,61 @@ drawCubicBezier ( Colours { path, brush } ) mode zoom
|
|||
}
|
||||
)
|
||||
= do
|
||||
let
|
||||
col :: GDK.RGBA
|
||||
sz :: Double
|
||||
( col, sz )
|
||||
| Brush <- mode
|
||||
= ( brush, 3 )
|
||||
| otherwise
|
||||
= ( path, 6 )
|
||||
|
||||
Cairo.save
|
||||
|
||||
Cairo.moveTo x0 y0
|
||||
Cairo.curveTo x1 y1 x2 y2 x3 y3
|
||||
|
||||
Cairo.setLineWidth ( sz / zoom )
|
||||
withRGBA col Cairo.setSourceRGBA
|
||||
Cairo.setLineWidth ( 6 / zoom )
|
||||
withRGBA path Cairo.setSourceRGBA
|
||||
Cairo.stroke
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawStroke :: Colours -> Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) -> Cairo.Render ()
|
||||
drawStroke ( Colours { brushStroke } ) strokeData = do
|
||||
Cairo.save
|
||||
withRGBA brushStroke Cairo.setSourceRGBA
|
||||
Cairo.setLineWidth 3
|
||||
case strokeData of
|
||||
Left outline -> do
|
||||
go outline
|
||||
Right ( fwd, bwd ) -> do
|
||||
go fwd
|
||||
go bwd
|
||||
Cairo.fill
|
||||
Cairo.restore
|
||||
|
||||
renderSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
|
||||
renderSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
|
||||
where
|
||||
go :: Seq ( StrokePoint () ) -> Cairo.Render ()
|
||||
go ( p@( PP ( Point2D x y ) ) :<| ps ) = Cairo.moveTo x y *> go' p ps
|
||||
go _ = pure ()
|
||||
|
||||
go' :: StrokePoint () -> Seq ( StrokePoint () ) -> Cairo.Render ()
|
||||
go' _ Empty = pure ()
|
||||
-- Line.
|
||||
go' _ ( p1@( PP ( Point2D x1 y1 ) ) :<| ps ) =
|
||||
do
|
||||
Cairo.lineTo x1 y1
|
||||
go' p1 ps
|
||||
-- Quadratic Bézier curve.
|
||||
go' ( PP ( Point2D x0 y0 ) ) ( CP ( Point2D x1 y1 ) :<| p2@( PP ( Point2D x2 y2 ) ) :<| ps ) =
|
||||
do
|
||||
Cairo.curveTo
|
||||
( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 )
|
||||
( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
|
||||
x2 y2
|
||||
go' p2 ps
|
||||
-- Cubic Bézier curve.
|
||||
go' _ ( CP ( Point2D x1 y1 ) :<| CP ( Point2D x2 y2 ) :<| p3@( PP ( Point2D x3 y3 ) ) :<| ps ) =
|
||||
do
|
||||
Cairo.curveTo x1 y1 x2 y2 x3 y3
|
||||
go' p3 ps
|
||||
go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
|
||||
|
||||
drawSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
|
||||
drawSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
|
||||
|
||||
Cairo.save
|
||||
|
||||
|
|
@ -463,7 +479,7 @@ drawCross ( Colours { .. } ) zoom = do
|
|||
Cairo.setLineWidth 2
|
||||
withRGBA brushCenter Cairo.setSourceRGBA
|
||||
|
||||
Cairo.scale ( 1 / zoom ) ( 1 / zoom )
|
||||
Cairo.scale ( 2 / zoom ) ( 2 / zoom )
|
||||
|
||||
Cairo.moveTo -3 -3
|
||||
Cairo.lineTo 3 3
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
|
|
@ -20,17 +21,32 @@ module Math.Bezier.Cubic
|
|||
-- base
|
||||
import Data.List.NonEmpty
|
||||
( NonEmpty(..) )
|
||||
import Data.Monoid
|
||||
( Ap(..) )
|
||||
import Data.Semigroup
|
||||
( ArgMin, Min(..), Arg(..) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
( Generic, Generic1 )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Torsor
|
||||
( Act(..)
|
||||
, Torsor
|
||||
( (-->) )
|
||||
)
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( GenericProduct(..), Generically1(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group )
|
||||
|
||||
-- groups-generic
|
||||
import Data.Group.Generics
|
||||
()
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(Bezier), bezier )
|
||||
|
|
@ -50,7 +66,14 @@ import Math.Roots
|
|||
data Bezier p
|
||||
= Bezier
|
||||
{ p0, p1, p2, p3 :: !p }
|
||||
deriving stock ( Show, Generic, Functor, Foldable, Traversable )
|
||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via GenericProduct ( Bezier p )
|
||||
deriving Applicative
|
||||
via Generically1 Bezier
|
||||
|
||||
deriving via Ap Bezier p
|
||||
instance Act v p => Act v ( Bezier p )
|
||||
|
||||
-- | Cubic Bézier curve.
|
||||
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
|
||||
|
|
@ -59,6 +82,7 @@ bezier ( Bezier { .. } ) t =
|
|||
( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t )
|
||||
( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t )
|
||||
|
||||
|
||||
-- | Derivative of cubic Bézier curve.
|
||||
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
|
||||
bezier' ( Bezier { .. } ) t
|
||||
|
|
@ -99,7 +123,7 @@ ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3, a4, a5 ]
|
|||
|
||||
-- | Finds the closest point to a given point on a cubic Bézier curve.
|
||||
closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p )
|
||||
closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
|
||||
closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists
|
||||
where
|
||||
roots :: [ r ]
|
||||
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c )
|
||||
|
|
|
|||
|
|
@ -101,6 +101,7 @@ fitPiece
|
|||
-> ( Bezier ( Point2D Double ), ArgMax Double Double )
|
||||
fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
||||
runST do
|
||||
-- Initialise the parameter values to a uniform subdivision.
|
||||
ts <- Unboxed.Vector.unsafeThaw ( Unboxed.Vector.generate n uniform )
|
||||
loop ts 0
|
||||
where
|
||||
|
|
@ -141,6 +142,7 @@ fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
|||
Vector2D s1 s2 <- hermiteParameters ( Mat22 0 0 0 0 ) ( Vector2D 0 0 ) 0 qs
|
||||
|
||||
let
|
||||
-- Convert from Hermite form to Bézier form.
|
||||
cp1, cp2 :: Point2D Double
|
||||
cp1 = ( ( s1 / 3 ) *^ tp ) • p
|
||||
cp2 = ( ( (-s2) / 3 ) *^ tr ) • r
|
||||
|
|
@ -158,18 +160,17 @@ fitPiece t_tol dist_tol maxIters p tp qs r tr =
|
|||
poly = map (:+ 0) $ ddist @( Vector2D Double ) bez q
|
||||
ti' <- case laguerre epsilon 1 poly ( ti :+ 0 ) of
|
||||
x :+ y
|
||||
| abs y > epsilon
|
||||
|| isNaN x
|
||||
| isNaN x
|
||||
|| isNaN y
|
||||
|| abs y > epsilon
|
||||
-> modify' ( first ( const True ) ) $> ti
|
||||
| otherwise
|
||||
-> pure x
|
||||
-> when ( abs ( x - ti ) > t_tol )
|
||||
( modify' ( first ( const True ) ) )
|
||||
$> x
|
||||
let
|
||||
dt, sq_dist :: Double
|
||||
dt = abs ( ti' - ti )
|
||||
sq_dist :: Double
|
||||
sq_dist = quadrance @( Vector2D Double ) q ( bezier @( Vector2D Double ) bez ti' )
|
||||
when ( dt > t_tol )
|
||||
( modify' ( first ( const True ) ) )
|
||||
modify' ( second ( <> Max ( Arg ti' sq_dist ) ) )
|
||||
lift ( Unboxed.MVector.unsafeWrite ts i ti' )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
|
|
@ -20,17 +21,32 @@ module Math.Bezier.Quadratic
|
|||
-- base
|
||||
import Data.List.NonEmpty
|
||||
( NonEmpty(..) )
|
||||
import Data.Monoid
|
||||
( Ap(..) )
|
||||
import Data.Semigroup
|
||||
( ArgMin, Min(..), Arg(..) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
( Generic, Generic1 )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Torsor
|
||||
( Act(..)
|
||||
, Torsor
|
||||
( (-->) )
|
||||
)
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( GenericProduct(..), Generically1(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group )
|
||||
|
||||
-- groups-generic
|
||||
import Data.Group.Generics
|
||||
()
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( Module (..)
|
||||
|
|
@ -48,7 +64,14 @@ import Math.Roots
|
|||
data Bezier p
|
||||
= Bezier
|
||||
{ p0, p1, p2 :: !p }
|
||||
deriving stock ( Show, Generic, Functor, Foldable, Traversable )
|
||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via GenericProduct ( Bezier p )
|
||||
deriving Applicative
|
||||
via Generically1 Bezier
|
||||
|
||||
deriving via Ap Bezier p
|
||||
instance Act v p => Act v ( Bezier p )
|
||||
|
||||
-- | Quadratic Bézier curve.
|
||||
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
|
||||
|
|
|
|||
|
|
@ -1,44 +1,69 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Math.Bezier.Stroke
|
||||
( StrokePoint(..)
|
||||
( StrokePoint(PP, CP, ..)
|
||||
, Offset(..)
|
||||
, stroke, joinWithBrush
|
||||
, withTangent
|
||||
, between, parallel
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( first )
|
||||
import Control.Monad
|
||||
( guard )
|
||||
import Data.Maybe
|
||||
( mapMaybe )
|
||||
( fromMaybe, mapMaybe )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Torsor
|
||||
( Act
|
||||
( (•) )
|
||||
, Torsor
|
||||
( (-->) )
|
||||
)
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Sequence as Seq
|
||||
( splitAt, drop, dropWhileL
|
||||
, zipWith3, zipWith4
|
||||
)
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field, field' )
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
import Data.GenericLens.Internal
|
||||
( set, over, view )
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
import Math.Bezier.Cubic.Fit
|
||||
( fitPiece )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
import Math.Epsilon
|
||||
( epsilon )
|
||||
import Math.Module
|
||||
( Module((^-^)), Inner((^.^)), lerp )
|
||||
( Module((^-^), (*^)), Inner((^.^)), lerp )
|
||||
import Math.Roots
|
||||
( realRoots )
|
||||
import Math.Vector2D
|
||||
|
|
@ -57,15 +82,347 @@ data StrokePoint d
|
|||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
instance Act ( Vector2D Double ) ( StrokePoint d ) where
|
||||
(•) v = over ( field' @"coords" ) ( v • )
|
||||
instance Act ( Vector2D Double ) ( Seq ( StrokePoint d ) ) where
|
||||
(•) v = fmap ( v • )
|
||||
|
||||
pattern PP, CP :: Point2D Double -> StrokePoint ()
|
||||
pattern PP p = PathPoint p ()
|
||||
pattern CP p = ControlPoint p ()
|
||||
|
||||
data Offset
|
||||
= Offset
|
||||
{ offsetIndex :: !Int
|
||||
, offsetParameter :: !( Maybe Double )
|
||||
, offset :: !( Point2D Double )
|
||||
, offset :: !( Vector2D Double )
|
||||
--, curvature :: !Double
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
stroke
|
||||
:: forall x d
|
||||
. ( Show x, Show d
|
||||
, HasType ( Seq ( StrokePoint x ) ) d
|
||||
)
|
||||
=> Seq ( StrokePoint d )
|
||||
-> Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
|
||||
stroke Empty = Left Empty
|
||||
stroke ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0
|
||||
stroke allPts@( spt0 :<| spt1 :<| spts )
|
||||
| isClosed
|
||||
= Right ( fwd, bwd )
|
||||
| otherwise
|
||||
= Left ( fwd <> bwd )
|
||||
where
|
||||
|
||||
startOffset, endOffset :: Vector2D Double
|
||||
tgt_start, tgt_end :: Vector2D Double
|
||||
startOffset = Point2D 0 0 --> coords spt0
|
||||
tgt_start = coords spt0 --> coords spt1
|
||||
( tgt_end, endOffset ) = case allPts of
|
||||
_ :|> sptnm1 :|> sptn -> ( coords sptnm1 --> coords sptn, Point2D 0 0 --> coords sptn )
|
||||
_ -> error "impossible"
|
||||
|
||||
brush_start :: Seq ( StrokePoint x )
|
||||
brush_start = brushShape spt0
|
||||
|
||||
isClosed :: Bool
|
||||
isClosed = case ( spt1 :<| spts ) of
|
||||
( _ :|> PathPoint { coords = lpt } )
|
||||
| lpt == coords spt0
|
||||
-> True
|
||||
_ -> False
|
||||
|
||||
fwd, bwd :: Seq ( StrokePoint () )
|
||||
( fwd, bwd ) = go tgt_start spt0 ( spt1 :<| spts )
|
||||
|
||||
(<~>)
|
||||
:: ( Monoid a, Monoid b )
|
||||
=> ( a, b )
|
||||
-> ( a, b )
|
||||
-> ( a, b )
|
||||
(a1, b1) <~> (a2, b2) = ( a1 <> a2, b2 <> b1 )
|
||||
|
||||
-- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
|
||||
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
|
||||
joinAndContinue :: Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
|
||||
joinAndContinue _ _ Empty
|
||||
-- Closed curve.
|
||||
| isClosed
|
||||
= if parallel tgt_start tgt_end
|
||||
then ( Empty, Empty )
|
||||
else ( startOffset • joinWithBrush ( withTangent tgt_start brush_start ) ( withTangent tgt_end brush_start ) brush_start
|
||||
, startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start
|
||||
)
|
||||
-- Open curve.
|
||||
| otherwise
|
||||
= ( endOffset • joinWithBrush ( withTangent tgt_end brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start
|
||||
, startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start
|
||||
)
|
||||
joinAndContinue tgt sp0 ( sp1 :<| sps )
|
||||
| tgt' `parallel` tgt
|
||||
= go tgt sp0 ( sp1 :<| sps )
|
||||
| let
|
||||
ptOffset :: Vector2D Double
|
||||
ptOffset = Point2D 0 0 --> coords sp0
|
||||
= ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0
|
||||
, ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0
|
||||
)
|
||||
<~> go tgt sp0 ( sp1 :<| sps )
|
||||
where
|
||||
tgt' :: Vector2D Double
|
||||
tgt' = coords sp0 --> coords sp1
|
||||
brush0 :: Seq ( StrokePoint () )
|
||||
brush0 = removePointData $ brushShape @x sp0
|
||||
|
||||
go :: Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
|
||||
go _ _ Empty = ( Empty, Empty )
|
||||
-- Line.
|
||||
go tgt0 sp0 ( sp1 :<| sps )
|
||||
| PathPoint {} <- sp1
|
||||
, let
|
||||
p0, p1, fop0, fop1, bop0, bop1 :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
fop0 = offset ( withTangent tgt0 ( brushShape @x sp0 ) ) • p0
|
||||
fop1 = offset ( withTangent tgt0 ( brushShape @x sp1 ) ) • p1
|
||||
bop0 = offset ( withTangent ( (-1) *^ tgt0 ) ( brushShape @x sp0 ) ) • p0
|
||||
bop1 = offset ( withTangent ( (-1) *^ tgt0 ) ( brushShape @x sp1 ) ) • p1
|
||||
tgt1 :: Vector2D Double
|
||||
tgt1 = p0 --> p1
|
||||
brush :: Double -> Seq ( StrokePoint () )
|
||||
brush t = lerpBrush t ( brushShape @x sp0 ) ( brushShape @x sp1 )
|
||||
fwdPts, bwdPts :: [ Point2D Double ]
|
||||
fwdPts
|
||||
= [ ( offset $ withTangent tgt0 $ brush t )
|
||||
• ( lerp @( Vector2D Double ) t p0 p1 )
|
||||
| t <- [0.1,0.2..0.9]
|
||||
]
|
||||
bwdPts
|
||||
= [ ( offset $ withTangent ( (-1) *^ tgt0 ) $ brush t ) •
|
||||
( lerp @( Vector2D Double ) t p0 p1 )
|
||||
| t <- [0.9,0.8..0.1]
|
||||
]
|
||||
= ( fitCurve fop0 tgt0 fwdPts fop1 tgt0, fitCurve bop1 ( (-1) *^ tgt1 ) bwdPts bop0 ( (-1) *^ tgt0 ) )
|
||||
<~> joinAndContinue tgt1 sp1 sps
|
||||
-- Quadratic Bézier curve.
|
||||
go tgt0 sp0 ( sp1 :<| sp2 :<| sps )
|
||||
| ControlPoint {} <- sp1
|
||||
, PathPoint {} <- sp2
|
||||
, let
|
||||
p0, p1, p2, fop0, fop2, bop0, bop2 :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
fop0 = offset ( withTangent tgt0 ( brushShape @x sp0 ) ) • p0
|
||||
fop2 = offset ( withTangent tgt2 ( brushShape @x sp2 ) ) • p2
|
||||
bop0 = offset ( withTangent ( (-1) *^ tgt0 ) ( brushShape @x sp0 ) ) • p0
|
||||
bop2 = offset ( withTangent ( (-1) *^ tgt2 ) ( brushShape @x sp2 ) ) • p2
|
||||
tgt2 :: Vector2D Double
|
||||
tgt2 = p1 --> p2
|
||||
bez :: Quadratic.Bezier ( Point2D Double )
|
||||
bez = Quadratic.Bezier { .. }
|
||||
brush :: Double -> Seq ( StrokePoint () )
|
||||
brush t = quadraticBezierBrush t
|
||||
( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) )
|
||||
fwdPts, bwdPts :: [ Point2D Double ]
|
||||
fwdPts
|
||||
= [ ( offset $ withTangent ( Quadratic.bezier' bez t ) $ brush t ) •
|
||||
( Quadratic.bezier @( Vector2D Double ) bez t )
|
||||
| t <- [0.1,0.2..0.9]
|
||||
]
|
||||
bwdPts
|
||||
= [ ( offset $ withTangent ( (-1) *^ Quadratic.bezier' bez t ) $ brush t ) •
|
||||
( Quadratic.bezier @( Vector2D Double ) bez t )
|
||||
| t <- [0.9,0.8..0.1]
|
||||
]
|
||||
= ( fitCurve fop0 tgt0 fwdPts fop2 tgt2, fitCurve bop2 ( (-1) *^ tgt2 ) bwdPts bop0 ( (-1) *^ tgt0 ) )
|
||||
<~> joinAndContinue tgt2 sp2 sps
|
||||
-- Cubic Bézier curve.
|
||||
go tgt0 sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
|
||||
| ControlPoint {} <- sp1
|
||||
, ControlPoint {} <- sp2
|
||||
, PathPoint {} <- sp3
|
||||
, let
|
||||
p0, p1, p2, p3, fop0, fop3, bop0, bop3 :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
p3 = coords sp3
|
||||
fop0 = offset ( withTangent tgt0 ( brushShape @x sp0 ) ) • p0
|
||||
fop3 = offset ( withTangent tgt3 ( brushShape @x sp3 ) ) • p3
|
||||
bop0 = offset ( withTangent ( (-1) *^ tgt0 ) ( brushShape @x sp0 ) ) • p0
|
||||
bop3 = offset ( withTangent ( (-1) *^ tgt3 ) ( brushShape @x sp3 ) ) • p3
|
||||
tgt3 :: Vector2D Double
|
||||
tgt3 = p2 --> p3
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez = Cubic.Bezier { .. }
|
||||
brush :: Double -> Seq ( StrokePoint () )
|
||||
brush t = cubicBezierBrush t
|
||||
( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) )
|
||||
fwdPts, bwdPts :: [ Point2D Double ]
|
||||
fwdPts
|
||||
= [ ( offset $ withTangent ( Cubic.bezier' bez t ) $ brush t ) •
|
||||
( Cubic.bezier @( Vector2D Double ) bez t )
|
||||
| t <- [0.1,0.2..0.9]
|
||||
]
|
||||
bwdPts
|
||||
= [ ( offset $ withTangent ( (-1) *^ Cubic.bezier' bez t ) $ brush t ) •
|
||||
( Cubic.bezier @( Vector2D Double ) bez t )
|
||||
| t <- [0.9,0.8..0.1]
|
||||
]
|
||||
= ( fitCurve fop0 tgt0 fwdPts fop3 tgt3, fitCurve bop3 ( (-1) *^ tgt3 ) bwdPts bop0 ( (-1) *^ tgt0 ) )
|
||||
<~> joinAndContinue tgt3 sp3 sps
|
||||
go _ p0 ps = error $ "stroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
|
||||
|
||||
-----------------------------------
|
||||
-- Various utility functions
|
||||
-- used in the "stroke" function.
|
||||
-----
|
||||
|
||||
brushShape :: forall x d. HasType ( Seq ( StrokePoint x ) ) d => StrokePoint d -> Seq ( StrokePoint x )
|
||||
brushShape = view typed . pointData
|
||||
|
||||
removePointData :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
||||
removePointData = fmap ( set ( field @"pointData" ) () )
|
||||
|
||||
lerpBrush :: forall d. Double -> Seq ( StrokePoint d ) -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
||||
lerpBrush t p0s p1s = f <$> p0s <*> p1s
|
||||
where
|
||||
f :: StrokePoint d -> StrokePoint d -> StrokePoint ()
|
||||
f ( PathPoint { coords = p0 } )
|
||||
( PathPoint { coords = p1 } )
|
||||
= PP $ lerp @( Vector2D Double ) t p0 p1
|
||||
f ( ControlPoint { coords = p0 } )
|
||||
( ControlPoint { coords = p1 } )
|
||||
= CP $ lerp @( Vector2D Double ) t p0 p1
|
||||
f _ _ = error "stroke: incompatible brushes"
|
||||
|
||||
quadraticBezierBrush :: forall d. Double -> Quadratic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
|
||||
quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s p2s
|
||||
where
|
||||
f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
|
||||
f ( PathPoint { coords = p0 } )
|
||||
( PathPoint { coords = p1 } )
|
||||
( PathPoint { coords = p2 } )
|
||||
= PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
|
||||
f ( ControlPoint { coords = p0 } )
|
||||
( ControlPoint { coords = p1 } )
|
||||
( ControlPoint { coords = p2 } )
|
||||
= CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
|
||||
f _ _ _ = error "stroke: incompatible brushes"
|
||||
|
||||
cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
|
||||
cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s p3s
|
||||
where
|
||||
f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
|
||||
f ( PathPoint { coords = p0 } )
|
||||
( PathPoint { coords = p1 } )
|
||||
( PathPoint { coords = p2 } )
|
||||
( PathPoint { coords = p3 } )
|
||||
= PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier { .. } ) t
|
||||
f ( ControlPoint { coords = p0 } )
|
||||
( ControlPoint { coords = p1 } )
|
||||
( ControlPoint { coords = p2 } )
|
||||
( ControlPoint { coords = p3 } )
|
||||
= CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier { .. } ) t
|
||||
f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ]
|
||||
|
||||
fitCurve
|
||||
:: Point2D Double -> Vector2D Double -> [ Point2D Double ] -> Point2D Double -> Vector2D Double
|
||||
-> Seq ( StrokePoint () )
|
||||
fitCurve p tp qs r tr = case fitPiece 1e-4 1e-3 100 p tp qs r tr of
|
||||
( Cubic.Bezier p0 p1 p2 p3, _ ) ->
|
||||
-- TODO: don't duplicate endpoints
|
||||
PP p0 :<| CP p1 :<| CP p2 :<| PP p3 :<| Empty
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Compute the join at a point of discontinuity of the tangent vector direction (G1 discontinuity).
|
||||
joinWithBrush :: forall d. Show d => Offset -> Offset -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
||||
joinWithBrush
|
||||
( Offset { offsetIndex = i1, offsetParameter = mb_t1 } )
|
||||
( Offset { offsetIndex = i2, offsetParameter = mb_t2 } )
|
||||
pts
|
||||
| i2 > i1
|
||||
= let
|
||||
pcs, lastAndRest :: Seq ( StrokePoint d )
|
||||
( pcs, lastAndRest ) = Seq.splitAt ( i2 - i1 ) $ Seq.drop i1 pts
|
||||
in
|
||||
snd ( splitFirstPiece t1 pcs ) <> dropFirstPiece pcs <> fst ( splitFirstPiece t2 lastAndRest )
|
||||
| i2 == i1 && mb_t2 >= mb_t1
|
||||
= let
|
||||
pcs :: Seq ( StrokePoint d )
|
||||
pcs = Seq.drop i1 pts
|
||||
in
|
||||
fst ( splitFirstPiece t2 $ snd ( splitFirstPiece t1 pcs ) )
|
||||
| otherwise
|
||||
= let
|
||||
start, middle, end :: Seq ( StrokePoint d )
|
||||
( ( middle, end ), start ) = first ( Seq.splitAt i2 ) $ Seq.splitAt i1 pts
|
||||
in
|
||||
snd ( splitFirstPiece t1 start ) <> removePointData middle <> fst ( splitFirstPiece t2 end )
|
||||
where
|
||||
t1, t2 :: Double
|
||||
t1 = fromMaybe 0.5 mb_t1
|
||||
t2 = fromMaybe 0.5 mb_t2
|
||||
|
||||
-- | Drop the first piece in a sequence of Bézier pieces.
|
||||
dropFirstPiece :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
|
||||
dropFirstPiece
|
||||
= removePointData
|
||||
. Seq.dropWhileL ( \case { ControlPoint {} -> True; _ -> False } )
|
||||
. Seq.drop 1
|
||||
|
||||
-- | Subdivide the first piece at the given parameter, discarding the subsequent pieces.
|
||||
splitFirstPiece :: Show d => Double -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
|
||||
-- Line.
|
||||
splitFirstPiece t ( sp0 :<| sp1 :<| _ )
|
||||
| PathPoint { coords = p0 } <- sp0
|
||||
, PathPoint { coords = p1 } <- sp1
|
||||
, let
|
||||
p :: Point2D Double
|
||||
p = lerp @( Vector2D Double ) t p0 p1
|
||||
= ( PP p0 :<| PP p :<| Empty
|
||||
, PP p :<| PP p1 :<| Empty
|
||||
)
|
||||
-- Quadratic Bézier curve.
|
||||
splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| _ )
|
||||
| PathPoint { coords = p0 } <- sp0
|
||||
, ControlPoint { coords = p1 } <- sp1
|
||||
, PathPoint { coords = p2 } <- sp2
|
||||
, let
|
||||
q1, p, r1 :: Point2D Double
|
||||
( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ )
|
||||
= Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t
|
||||
= ( PP p0 :<| CP q1 :<| PP p :<| Empty
|
||||
, PP p :<| CP r1 :<| PP p2 :<| Empty
|
||||
)
|
||||
-- Cubic Bézier curve.
|
||||
splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| _ )
|
||||
| PathPoint { coords = p0 } <- sp0
|
||||
, ControlPoint { coords = p1 } <- sp1
|
||||
, ControlPoint { coords = p2 } <- sp2
|
||||
, PathPoint { coords = p3 } <- sp3
|
||||
, let
|
||||
q1, q2, p, r1, r2 :: Point2D Double
|
||||
( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ )
|
||||
= Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier { .. } ) t
|
||||
= ( PP p0 :<| CP q1 :<| CP q2 :<| PP p :<| Empty
|
||||
, PP p :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty
|
||||
)
|
||||
-- Anything else.
|
||||
splitFirstPiece _ _ = ( Empty, Empty ) -- error ( "splitFirstPiece: unexpected stroke point data" <> show pcs )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Finds the point at which a convex nib (given by a piecewise Bézier curve) has the given tangent vector.
|
||||
--
|
||||
-- Does /not/ check that the provided nib shape is convex.
|
||||
withTangent :: forall d. Vector2D Double -> Seq ( StrokePoint d ) -> Offset
|
||||
withTangent tgt ( spt0 :<| spt1 :<| spts ) =
|
||||
let
|
||||
|
|
@ -73,7 +430,7 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
|
|||
tgt0 = coords spt0 --> coords spt1
|
||||
in
|
||||
if parallel tgt tgt0
|
||||
then Offset 0 ( Just 0 ) ( coords spt0 )
|
||||
then Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 )
|
||||
else go 0 tgt0 spt0 spt1 spts
|
||||
|
||||
where
|
||||
|
|
@ -85,64 +442,65 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
|
|||
( sp1@( PathPoint { coords = p1 } ) )
|
||||
ps
|
||||
| parallel tgt tgt0
|
||||
= Offset i Nothing ( lerp @( Vector2D Double ) 0.5 p0 p1 )
|
||||
= Offset i Nothing ( MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1 )
|
||||
| otherwise
|
||||
= continue ( i + 1 ) tgt0 sp1 ps
|
||||
-- Quadratic Bézier curve.
|
||||
go i tgt0
|
||||
( PathPoint { coords = p0 } )
|
||||
( PathPoint { coords = p0 } )
|
||||
( ControlPoint { coords = p1 } )
|
||||
( sp2@( PathPoint { coords = p2 } ) :<| ps ) =
|
||||
let
|
||||
tgt1 :: Vector2D Double
|
||||
tgt1 = p1 --> p2
|
||||
in case between tgt tgt0 tgt1 of
|
||||
Just t -> Offset i ( Just t ) ( Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t )
|
||||
Just t -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t )
|
||||
Nothing -> continue ( i + 2 ) tgt1 sp2 ps
|
||||
-- Cubic Bézier curve.
|
||||
go i tgt0
|
||||
( PathPoint { coords = p0 } )
|
||||
( PathPoint { coords = p1 } )
|
||||
( PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) =
|
||||
( PathPoint { coords = p0 } )
|
||||
( ControlPoint { coords = p1 } )
|
||||
( ControlPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) =
|
||||
let
|
||||
tgt1, tgt2 :: Vector2D Double
|
||||
tgt1 = p1 --> p2
|
||||
tgt2 = p2 --> p3
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez = Cubic.Bezier { .. }
|
||||
in 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.
|
||||
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
|
||||
in
|
||||
case mapMaybe correctTangentParam $ realRoots [ c01, 2 * ( c12 - c01 ), c01 + c23 - 2 * c12 ] of
|
||||
( t : _ )
|
||||
-> Offset i ( Just t ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t )
|
||||
-- Fallback in case we couldn't solve the quadratic for some reason.
|
||||
_
|
||||
| Just s <- between tgt tgt0 tgt2
|
||||
-> Offset i ( Just s ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez s )
|
||||
-- Otherwise: go to next piece of the curve.
|
||||
| otherwise
|
||||
-> Offset i ( Just s ) ( Cubic.bezier @( Vector2D Double ) bez s )
|
||||
-- Go to next piece of the curve.
|
||||
_ -> continue ( i + 3 ) tgt2 sp3 ps
|
||||
-> continue ( i + 3 ) tgt2 sp3 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 d -> Seq ( StrokePoint d ) -> Offset
|
||||
continue _ _ _ Empty = Offset 0 ( Just 0 ) ( coords spt0 )
|
||||
continue _ _ _ Empty = Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 )
|
||||
continue i ptgt p0 ( p1 :<| ps ) =
|
||||
let
|
||||
tgt0 :: Vector2D Double
|
||||
tgt0 = coords p0 --> coords p1
|
||||
in case between tgt ptgt tgt0 of
|
||||
Just _ -> Offset i ( Just 0 ) ( coords p0 )
|
||||
Just _ -> Offset i ( Just 0 ) ( MkVector2D $ coords p0 )
|
||||
Nothing -> go i tgt0 p0 p1 ps
|
||||
|
||||
withTangent _ _ = error $ "withTangent: invalid path (fewer than 2 points)"
|
||||
|
|
@ -178,6 +536,8 @@ between u v0 v1
|
|||
|
||||
-- | Compute whether two vectors point in the same direction,
|
||||
-- that is, whether each vector is a (strictly) positive multiple of the other.
|
||||
--
|
||||
-- Returns @False@ if either of the vectors is zero.
|
||||
parallel :: Vector2D Double -> Vector2D Double -> Bool
|
||||
parallel u v
|
||||
= abs ( u `cross` v ) < epsilon -- vectors are collinear
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@
|
|||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
|
||||
module Math.Module
|
||||
( Module(..), lerp
|
||||
|
|
@ -12,6 +14,12 @@ module Math.Module
|
|||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Applicative
|
||||
( liftA2 )
|
||||
import Data.Monoid
|
||||
( Ap(..) )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act
|
||||
|
|
@ -38,6 +46,11 @@ class Num r => Module r m | m -> r where
|
|||
(^*) = flip (*^)
|
||||
m ^-^ n = m ^+^ (-1) *^ n
|
||||
|
||||
instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where
|
||||
(^+^) = liftA2 (^+^)
|
||||
(^-^) = liftA2 (^-^)
|
||||
(*^) r = fmap ( r *^ )
|
||||
|
||||
lerp :: forall v r p. ( Module r v, Torsor v p ) => r -> p -> p -> p
|
||||
lerp t p0 p1 = ( t *^ ( p0 --> p1 :: v ) ) • p0
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue