diff --git a/MetaBrush.cabal b/MetaBrush.cabal index d330c3a..c1cc4f8 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 7c972ce..86cb113 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index d6bb235..1d61d39 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index 6e442f3..b0c8e41 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/lib/Math/Bezier/Cubic.hs @@ -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 ) diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/lib/Math/Bezier/Cubic/Fit.hs index 62a10a3..d66599a 100644 --- a/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/src/lib/Math/Bezier/Cubic/Fit.hs @@ -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' ) diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index 39fee30..9adb36e 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/lib/Math/Bezier/Quadratic.hs @@ -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 diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index 4d3b93d..02eaa61 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -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 diff --git a/src/lib/Math/Module.hs b/src/lib/Math/Module.hs index 9c537cb..5e9bc1f 100644 --- a/src/lib/Math/Module.hs +++ b/src/lib/Math/Module.hs @@ -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