mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
start reworking brush stroking
This commit is contained in:
parent
f8b0ec2ab1
commit
b46dc2a140
|
@ -61,6 +61,8 @@ common common
|
||||||
-fspecialise-aggressively
|
-fspecialise-aggressively
|
||||||
-optc-O3
|
-optc-O3
|
||||||
-optc-ffast-math
|
-optc-ffast-math
|
||||||
|
-- work around a laziness bug involving runRW# in GHC 9.0.1
|
||||||
|
-fno-full-laziness
|
||||||
-Wall
|
-Wall
|
||||||
-Wcompat
|
-Wcompat
|
||||||
-fwarn-missing-local-signatures
|
-fwarn-missing-local-signatures
|
||||||
|
|
|
@ -181,7 +181,7 @@ instance HandleAction () where
|
||||||
-- New file --
|
-- New file --
|
||||||
--------------
|
--------------
|
||||||
|
|
||||||
data NewFile = NewFile TabLocation
|
data NewFile = NewFile !TabLocation
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction NewFile where
|
instance HandleAction NewFile where
|
||||||
|
@ -192,7 +192,7 @@ instance HandleAction NewFile where
|
||||||
-- Open file --
|
-- Open file --
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
data OpenFile = OpenFile TabLocation
|
data OpenFile = OpenFile !TabLocation
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction OpenFile where
|
instance HandleAction OpenFile where
|
||||||
|
@ -252,7 +252,7 @@ warningDialog window filePath errMess = do
|
||||||
-- Open folder --
|
-- Open folder --
|
||||||
-----------------
|
-----------------
|
||||||
|
|
||||||
data OpenFolder = OpenFolder TabLocation
|
data OpenFolder = OpenFolder !TabLocation
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction OpenFolder where
|
instance HandleAction OpenFolder where
|
||||||
|
@ -671,7 +671,7 @@ instance HandleAction About where
|
||||||
-- Mouse movement --
|
-- Mouse movement --
|
||||||
--------------------
|
--------------------
|
||||||
|
|
||||||
data MouseMove = MouseMove ( Point2D Double )
|
data MouseMove = MouseMove !( Point2D Double )
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction MouseMove where
|
instance HandleAction MouseMove where
|
||||||
|
@ -714,7 +714,7 @@ instance HandleAction MouseMove where
|
||||||
|
|
||||||
data ActionOrigin
|
data ActionOrigin
|
||||||
= ViewportOrigin
|
= ViewportOrigin
|
||||||
| RulerOrigin Ruler
|
| RulerOrigin !Ruler
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
data MouseClickType
|
data MouseClickType
|
||||||
|
@ -722,7 +722,7 @@ data MouseClickType
|
||||||
| DoubleClick
|
| DoubleClick
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
|
data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double )
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction MouseClick where
|
instance HandleAction MouseClick where
|
||||||
|
@ -860,7 +860,7 @@ instance HandleAction MouseClick where
|
||||||
-- Mouse release --
|
-- Mouse release --
|
||||||
-------------------
|
-------------------
|
||||||
|
|
||||||
data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
data MouseRelease = MouseRelease !Word32 !( Point2D Double )
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction MouseRelease where
|
instance HandleAction MouseRelease where
|
||||||
|
@ -1053,7 +1053,7 @@ instance HandleAction MouseRelease where
|
||||||
-- Scrolling --
|
-- Scrolling --
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
|
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction Scroll where
|
instance HandleAction Scroll where
|
||||||
|
@ -1108,7 +1108,7 @@ instance HandleAction Scroll where
|
||||||
-- Keyboard press --
|
-- Keyboard press --
|
||||||
--------------------
|
--------------------
|
||||||
|
|
||||||
data KeyboardPress = KeyboardPress Word32
|
data KeyboardPress = KeyboardPress !Word32
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction KeyboardPress where
|
instance HandleAction KeyboardPress where
|
||||||
|
@ -1153,7 +1153,7 @@ instance HandleAction KeyboardPress where
|
||||||
-- Keyboard release --
|
-- Keyboard release --
|
||||||
----------------------
|
----------------------
|
||||||
|
|
||||||
data KeyboardRelease = KeyboardRelease Word32
|
data KeyboardRelease = KeyboardRelease !Word32
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction KeyboardRelease where
|
instance HandleAction KeyboardRelease where
|
||||||
|
|
|
@ -45,13 +45,13 @@ class HandleAction action where
|
||||||
|
|
||||||
instance HandleAction ()
|
instance HandleAction ()
|
||||||
|
|
||||||
data NewFile = NewFile TabLocation
|
data NewFile = NewFile !TabLocation
|
||||||
instance HandleAction NewFile
|
instance HandleAction NewFile
|
||||||
|
|
||||||
data OpenFile = OpenFile TabLocation
|
data OpenFile = OpenFile !TabLocation
|
||||||
instance HandleAction OpenFile
|
instance HandleAction OpenFile
|
||||||
|
|
||||||
data OpenFolder = OpenFolder TabLocation
|
data OpenFolder = OpenFolder !TabLocation
|
||||||
instance HandleAction OpenFolder
|
instance HandleAction OpenFolder
|
||||||
|
|
||||||
data Save = Save
|
data Save = Save
|
||||||
|
@ -107,26 +107,26 @@ instance HandleAction Confirm
|
||||||
data About = About
|
data About = About
|
||||||
instance HandleAction About
|
instance HandleAction About
|
||||||
|
|
||||||
data MouseMove = MouseMove ( Point2D Double )
|
data MouseMove = MouseMove !( Point2D Double )
|
||||||
instance HandleAction MouseMove
|
instance HandleAction MouseMove
|
||||||
|
|
||||||
data ActionOrigin
|
data ActionOrigin
|
||||||
= ViewportOrigin
|
= ViewportOrigin
|
||||||
| RulerOrigin Ruler
|
| RulerOrigin !Ruler
|
||||||
data MouseClickType
|
data MouseClickType
|
||||||
= SingleClick
|
= SingleClick
|
||||||
| DoubleClick
|
| DoubleClick
|
||||||
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
|
data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double )
|
||||||
instance HandleAction MouseClick
|
instance HandleAction MouseClick
|
||||||
|
|
||||||
data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
data MouseRelease = MouseRelease !Word32 !( Point2D Double )
|
||||||
instance HandleAction MouseRelease
|
instance HandleAction MouseRelease
|
||||||
|
|
||||||
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
|
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
|
||||||
instance HandleAction Scroll
|
instance HandleAction Scroll
|
||||||
|
|
||||||
data KeyboardPress = KeyboardPress Word32
|
data KeyboardPress = KeyboardPress !Word32
|
||||||
instance HandleAction KeyboardPress
|
instance HandleAction KeyboardPress
|
||||||
|
|
||||||
data KeyboardRelease = KeyboardRelease Word32
|
data KeyboardRelease = KeyboardRelease !Word32
|
||||||
instance HandleAction KeyboardRelease
|
instance HandleAction KeyboardRelease
|
||||||
|
|
|
@ -184,9 +184,9 @@ runApplication application = do
|
||||||
Spline
|
Spline
|
||||||
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
||||||
, splineCurves = OpenCurves $ Seq.fromList
|
, splineCurves = OpenCurves $ Seq.fromList
|
||||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined }
|
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 10 ), curveData = invalidateCache undefined }
|
||||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
|
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined }
|
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 15 ), curveData = invalidateCache undefined }
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -81,7 +81,7 @@ import Math.Module
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
( Point2D )
|
( Point2D )
|
||||||
import {-# SOURCE #-} MetaBrush.Document.Serialise
|
import {-# SOURCE #-} MetaBrush.Document.Serialise
|
||||||
( Serialisable, Workaround(..) )
|
( Serialisable, Workaround(..), workaround )
|
||||||
import MetaBrush.MetaParameter.AST
|
import MetaBrush.MetaParameter.AST
|
||||||
( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes
|
( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes
|
||||||
, Adapted, BrushFunction
|
, Adapted, BrushFunction
|
||||||
|
@ -93,7 +93,7 @@ import MetaBrush.MetaParameter.Interpolation
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
whatever :: Int
|
whatever :: Int
|
||||||
whatever = case Workaround of
|
whatever = case workaround Workaround of
|
||||||
Workaround -> 0
|
Workaround -> 0
|
||||||
|
|
||||||
data Brush brushFields where
|
data Brush brushFields where
|
||||||
|
|
|
@ -14,7 +14,8 @@
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module MetaBrush.Document.Serialise
|
module MetaBrush.Document.Serialise
|
||||||
( Workaround(..), Serialisable(..)
|
( Workaround(..), workaround
|
||||||
|
, Serialisable(..)
|
||||||
, documentToJSON, documentFromJSON
|
, documentToJSON, documentFromJSON
|
||||||
, saveDocument, loadDocument
|
, saveDocument, loadDocument
|
||||||
)
|
)
|
||||||
|
@ -201,6 +202,8 @@ import qualified Paths_MetaBrush as Cabal
|
||||||
|
|
||||||
-- | Dummy data-type that helps workaround a GHC bug with hs-boot files.
|
-- | Dummy data-type that helps workaround a GHC bug with hs-boot files.
|
||||||
data Workaround = Workaround
|
data Workaround = Workaround
|
||||||
|
workaround :: Workaround -> Workaround
|
||||||
|
workaround Workaround = Workaround
|
||||||
|
|
||||||
-- | Serialise a document to JSON (in the form of a lazy bytestring).
|
-- | Serialise a document to JSON (in the form of a lazy bytestring).
|
||||||
documentToJSON :: Document -> Lazy.ByteString
|
documentToJSON :: Document -> Lazy.ByteString
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module MetaBrush.Document.Serialise
|
module MetaBrush.Document.Serialise
|
||||||
( Workaround(..), Serialisable(..) )
|
( Workaround(..), workaround, Serialisable(..) )
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
@ -31,6 +31,8 @@ import Math.Vector2D
|
||||||
|
|
||||||
data Workaround = Workaround
|
data Workaround = Workaround
|
||||||
|
|
||||||
|
workaround :: Workaround -> Workaround
|
||||||
|
|
||||||
class Serialisable a where
|
class Serialisable a where
|
||||||
encoder :: Monad f => JSON.Encoder f a
|
encoder :: Monad f => JSON.Encoder f a
|
||||||
decoder :: Monad m => JSON.Decoder m a
|
decoder :: Monad m => JSON.Decoder m a
|
||||||
|
|
|
@ -516,7 +516,10 @@ type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Close
|
||||||
newtype AdaptableFunction brushFields a
|
newtype AdaptableFunction brushFields a
|
||||||
= AdaptableFunction
|
= AdaptableFunction
|
||||||
( forall givenFields usedFields
|
( forall givenFields usedFields
|
||||||
. Adapted brushFields givenFields usedFields
|
. ( Adapted brushFields givenFields usedFields
|
||||||
|
-- Debugging.
|
||||||
|
, Show ( Super.Rec givenFields )
|
||||||
|
)
|
||||||
=> ( Super.Rec givenFields -> Super.Rec usedFields
|
=> ( Super.Rec givenFields -> Super.Rec usedFields
|
||||||
, Super.Rec usedFields -> a
|
, Super.Rec usedFields -> a
|
||||||
)
|
)
|
||||||
|
|
|
@ -303,12 +303,12 @@ strokeRenderData fitParams
|
||||||
= Just $ case strokeBrush of
|
= Just $ case strokeBrush of
|
||||||
Just ( AdaptedBrush ( brush :: Brush brushFields ) )
|
Just ( AdaptedBrush ( brush :: Brush brushFields ) )
|
||||||
| ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
|
| ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
|
||||||
|
-- Get the adaptable brush shape (function),
|
||||||
|
-- specialising it to the type we are using.
|
||||||
, let
|
, let
|
||||||
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
|
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
|
||||||
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
|
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
|
||||||
AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush
|
AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush
|
||||||
-- Get the adaptable brush shape (function),
|
|
||||||
-- specialising it to the type we are using.
|
|
||||||
-> do
|
-> do
|
||||||
-- Compute the outline using the brush function.
|
-- Compute the outline using the brush function.
|
||||||
( outline, fitPts ) <-
|
( outline, fitPts ) <-
|
||||||
|
|
|
@ -101,10 +101,9 @@ import Math.Bezier.Spline
|
||||||
, ssplineType, adjustSplineType
|
, ssplineType, adjustSplineType
|
||||||
, NextPoint(..), fromNextPoint
|
, NextPoint(..), fromNextPoint
|
||||||
, KnownSplineType
|
, KnownSplineType
|
||||||
( bifoldSpline, ibifoldSpline, bimapSpline )
|
( bifoldSpline, ibifoldSpline )
|
||||||
, Spline(..), SplinePts, Curves(..), Curve(..)
|
, Spline(..), SplinePts, Curves(..), Curve(..)
|
||||||
, openCurveStart, openCurveEnd
|
, openCurveEnd, splitSplineAt, dropCurves
|
||||||
, splitSplineAt, dropCurves
|
|
||||||
)
|
)
|
||||||
import qualified Math.Bezier.Quadratic as Quadratic
|
import qualified Math.Bezier.Quadratic as Quadratic
|
||||||
import Math.Epsilon
|
import Math.Epsilon
|
||||||
|
@ -180,6 +179,8 @@ computeStrokeOutline ::
|
||||||
, HasType ( Point2D Double ) ptData
|
, HasType ( Point2D Double ) ptData
|
||||||
, HasType ( CachedStroke s ) crvData
|
, HasType ( CachedStroke s ) crvData
|
||||||
, NFData ptData, NFData crvData
|
, NFData ptData, NFData crvData
|
||||||
|
-- Debugging.
|
||||||
|
, Show ptData
|
||||||
)
|
)
|
||||||
=> FitParameters
|
=> FitParameters
|
||||||
-> ( ptData -> brushParams )
|
-> ( ptData -> brushParams )
|
||||||
|
@ -189,53 +190,54 @@ computeStrokeOutline ::
|
||||||
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
||||||
, Seq FitPoint
|
, Seq FitPoint
|
||||||
)
|
)
|
||||||
computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of
|
computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
|
||||||
-- Open brush path with at least one segment.
|
-- Open brush path with at least one segment.
|
||||||
|
-- Need to add caps at both ends of the path.
|
||||||
SOpen
|
SOpen
|
||||||
| OpenCurves curves <- splineCurves
|
| ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
|
||||||
, firstCurve :<| _ <- curves
|
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
|
||||||
, prevCurves :|> lastCurve <- curves
|
, _ :|> lastCurve <- openCurves $ splineCurves spline
|
||||||
, let
|
, let
|
||||||
endPt :: ptData
|
endPt :: ptData
|
||||||
endPt = openCurveEnd lastCurve
|
endPt = openCurveEnd lastCurve
|
||||||
startTgt, endTgt :: Vector2D Double
|
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
|
||||||
startTgt = coords spt0 --> coords ( openCurveStart firstCurve )
|
startTgtFwd = snd $ firstOutlineFwd 0
|
||||||
endTgt = case prevCurves of
|
startTgtBwd = snd $ firstOutlineBwd 1
|
||||||
Empty -> endTangent spt0 spt0 lastCurve
|
endTgtFwd = snd $ lastOutlineFwd 1
|
||||||
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
endTgtBwd = snd $ lastOutlineBwd 0
|
||||||
startBrush, endBrush :: SplinePts Closed
|
startBrush, endBrush :: SplinePts Closed
|
||||||
startBrush = brushShape spt0
|
startBrush = brushShape spt0
|
||||||
endBrush = brushShape endPt
|
endBrush = brushShape endPt
|
||||||
startCap, endCap :: SplinePts Open
|
startCap, endCap :: SplinePts Open
|
||||||
startCap
|
startCap
|
||||||
= fmap ( MkVector2D ( coords spt0 ) • )
|
= fmap ( MkVector2D ( coords spt0 ) • )
|
||||||
$ joinWithBrush ( withTangent ( (-1) *^ startTgt ) startBrush ) ( withTangent startTgt startBrush ) startBrush
|
$ joinWithBrush ( withTangent ( (-1) *^ startTgtBwd ) startBrush ) ( withTangent startTgtFwd startBrush ) startBrush
|
||||||
endCap
|
endCap
|
||||||
= fmap ( MkVector2D ( coords endPt ) • )
|
= fmap ( MkVector2D ( coords endPt ) • )
|
||||||
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
|
$ joinWithBrush ( withTangent endTgtFwd endBrush ) ( withTangent ( (-1) *^ endTgtBwd ) endBrush ) endBrush
|
||||||
-> do
|
-> do
|
||||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline startTgt
|
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( startTgtFwd, startTgtBwd )
|
||||||
pure
|
pure
|
||||||
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
|
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
|
||||||
, fwdFits <> bwdFits
|
, fwdFits <> bwdFits
|
||||||
)
|
)
|
||||||
-- Closed brush path with at least one segment.
|
-- Closed brush path with at least one segment.
|
||||||
|
-- Add forward and backward caps at the start.
|
||||||
SClosed
|
SClosed
|
||||||
| ClosedCurves prevCurves lastCurve <- splineCurves
|
| ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
|
||||||
|
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
|
||||||
, let
|
, let
|
||||||
startTgt, endTgt :: Vector2D Double
|
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
|
||||||
startTgt = case prevCurves of
|
startTgtFwd = snd $ firstOutlineFwd 0
|
||||||
Empty -> startTangent spt0 spt0 lastCurve
|
startTgtBwd = snd $ firstOutlineBwd 1
|
||||||
firstCrv :<| _ -> startTangent spt0 spt0 firstCrv
|
endTgtFwd = snd $ lastOutlineFwd 1
|
||||||
endTgt = case prevCurves of
|
endTgtBwd = snd $ lastOutlineBwd 0
|
||||||
Empty -> endTangent spt0 spt0 lastCurve
|
|
||||||
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
|
||||||
fwdStartCap, bwdStartCap :: SplinePts Open
|
fwdStartCap, bwdStartCap :: SplinePts Open
|
||||||
TwoSided fwdStartCap bwdStartCap
|
TwoSided fwdStartCap bwdStartCap
|
||||||
= fmap fst . snd . runWriter
|
= fmap fst . snd . runWriter
|
||||||
$ tellBrushJoin endTgt spt0 startTgt
|
$ tellBrushJoin ( endTgtFwd, endTgtBwd ) spt0 ( startTgtFwd, startTgtBwd )
|
||||||
-> do
|
-> do
|
||||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline endTgt
|
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( endTgtFwd, endTgtBwd )
|
||||||
pure
|
pure
|
||||||
( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
|
( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
|
||||||
, fwdFits <> bwdFits
|
, fwdFits <> bwdFits
|
||||||
|
@ -243,160 +245,54 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
-- Single point.
|
-- Single point.
|
||||||
_ ->
|
_ ->
|
||||||
pure
|
pure
|
||||||
( Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
|
( Left $ fmap ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
|
||||||
, Empty
|
, Empty
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
outlineFns
|
||||||
|
:: Seq
|
||||||
|
( Double -> ( Point2D Double, Vector2D Double )
|
||||||
|
, Double -> ( Point2D Double, Vector2D Double )
|
||||||
|
)
|
||||||
|
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
|
||||||
|
where
|
||||||
|
go
|
||||||
|
:: ptData
|
||||||
|
-> Seq ( Curve Open crvData ptData )
|
||||||
|
-> Seq
|
||||||
|
( Double -> ( Point2D Double, Vector2D Double )
|
||||||
|
, Double -> ( Point2D Double, Vector2D Double )
|
||||||
|
)
|
||||||
|
go _ Empty = Empty
|
||||||
|
go p0 ( crv :<| crvs ) =
|
||||||
|
outlineFunctions @diffParams ptParams brushFn p0 crv :<| go ( openCurveEnd crv ) crvs
|
||||||
|
|
||||||
brushShape :: ptData -> SplinePts Closed
|
brushShape :: ptData -> SplinePts Closed
|
||||||
brushShape pt = brushFn ( ptParams pt )
|
brushShape pt = brushFn ( ptParams pt )
|
||||||
|
|
||||||
updateSpline :: Vector2D Double -> ST s OutlineData
|
updateSpline :: ( Vector2D Double, Vector2D Double ) -> ST s OutlineData
|
||||||
updateSpline lastTgt
|
updateSpline ( lastTgtFwd, lastTgtBwd )
|
||||||
= execWriterT
|
= execWriterT
|
||||||
. ( `evalStateT` lastTgt )
|
. ( `evalStateT` ( lastTgtFwd, lastTgtBwd ) )
|
||||||
$ bifoldSpline
|
$ bifoldSpline
|
||||||
( \ ptData curve -> do
|
( \ ptData curve -> do
|
||||||
prev_tgt <- get
|
( prev_tgtFwd, prev_tgtBwd ) <- get
|
||||||
let
|
let
|
||||||
tgt :: Vector2D Double
|
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||||
tgt = startTangent spt0 ptData curve
|
( fwd, bwd ) = outlineFunctions @diffParams ptParams brushFn ptData curve
|
||||||
lift $ tellBrushJoin prev_tgt ptData tgt
|
tgtFwd, tgtBwd, next_tgtFwd, next_tgtBwd :: Vector2D Double
|
||||||
lift $ strokeOutline ptData curve
|
tgtFwd = snd ( fwd 0 )
|
||||||
put ( endTangent spt0 ptData curve )
|
tgtBwd = snd ( bwd 1 )
|
||||||
|
next_tgtFwd = snd ( fwd 1 )
|
||||||
|
next_tgtBwd = snd ( bwd 0 )
|
||||||
|
lift $ tellBrushJoin ( prev_tgtFwd, prev_tgtBwd ) ptData ( tgtFwd, tgtBwd )
|
||||||
|
lift $ updateCurveData ( curveData curve ) fwd bwd
|
||||||
|
put ( next_tgtFwd, next_tgtBwd )
|
||||||
)
|
)
|
||||||
( const ( pure () ) )
|
( const ( pure () ) )
|
||||||
( adjustSplineType @Open spline )
|
( adjustSplineType @Open spline )
|
||||||
|
|
||||||
strokeOutline
|
|
||||||
:: ptData -> Curve Open crvData ptData
|
|
||||||
-> WriterT OutlineData ( ST s ) ()
|
|
||||||
strokeOutline sp0 ( LineTo { curveEnd = NextPoint sp1, curveData } ) =
|
|
||||||
let
|
|
||||||
p0, p1 :: Point2D Double
|
|
||||||
p0 = coords sp0
|
|
||||||
p1 = coords sp1
|
|
||||||
tgt :: Vector2D Double
|
|
||||||
tgt = p0 --> p1
|
|
||||||
brush :: Double -> SplinePts Closed
|
|
||||||
brush t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) )
|
|
||||||
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
|
||||||
fwd t
|
|
||||||
= ( off t
|
|
||||||
, if squaredNorm offTgt < epsilon then tgt else offTgt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
off :: Double -> Point2D Double
|
|
||||||
off x = offset ( withTangent tgt ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1
|
|
||||||
offTgt :: Vector2D Double
|
|
||||||
offTgt
|
|
||||||
| t < 0.5
|
|
||||||
= 1e9 *^ ( off t --> off (t + 1e-9) )
|
|
||||||
| otherwise
|
|
||||||
= 1e9 *^ ( off (t - 1e-9) --> off t )
|
|
||||||
bwd t
|
|
||||||
= ( off s
|
|
||||||
, if squaredNorm offTgt < epsilon then (-1) *^ tgt else offTgt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
s :: Double
|
|
||||||
s = 1 - t
|
|
||||||
off :: Double -> Point2D Double
|
|
||||||
off x = offset ( withTangent ( (-1) *^ tgt ) ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1
|
|
||||||
offTgt :: Vector2D Double
|
|
||||||
offTgt
|
|
||||||
| s < 0.5
|
|
||||||
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
|
||||||
| otherwise
|
|
||||||
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
|
||||||
in
|
|
||||||
updateCurveData curveData fwd bwd
|
|
||||||
strokeOutline sp0 ( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
|
|
||||||
let
|
|
||||||
p0, p1, p2 :: Point2D Double
|
|
||||||
p0 = coords sp0
|
|
||||||
p1 = coords sp1
|
|
||||||
p2 = coords sp2
|
|
||||||
bez :: Quadratic.Bezier ( Point2D Double )
|
|
||||||
bez = Quadratic.Bezier {..}
|
|
||||||
brush :: Double -> SplinePts Closed
|
|
||||||
brush t = brushFn
|
|
||||||
$ Quadratic.bezier @diffParams
|
|
||||||
( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t
|
|
||||||
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
|
||||||
fwd t
|
|
||||||
= ( off t
|
|
||||||
, if squaredNorm offTgt < epsilon then Quadratic.bezier' bez t else offTgt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
off :: Double -> Point2D Double
|
|
||||||
off x = offset ( withTangent ( Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x
|
|
||||||
offTgt :: Vector2D Double
|
|
||||||
offTgt
|
|
||||||
| t < 0.5
|
|
||||||
= 1e9 *^ ( off t --> off (t + 1e-9) )
|
|
||||||
| otherwise
|
|
||||||
= 1e9 *^ ( off (t - 1e-9) --> off t )
|
|
||||||
bwd t
|
|
||||||
= ( off s
|
|
||||||
, if squaredNorm offTgt < epsilon then (-1) *^ Quadratic.bezier' bez s else offTgt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
s :: Double
|
|
||||||
s = 1 - t
|
|
||||||
off :: Double -> Point2D Double
|
|
||||||
off x = offset ( withTangent ( (-1) *^ Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x
|
|
||||||
offTgt :: Vector2D Double
|
|
||||||
offTgt
|
|
||||||
| s < 0.5
|
|
||||||
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
|
||||||
| otherwise
|
|
||||||
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
|
||||||
in updateCurveData curveData fwd bwd
|
|
||||||
strokeOutline sp0 ( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) =
|
|
||||||
let
|
|
||||||
p0, p1, p2, p3 :: Point2D Double
|
|
||||||
p0 = coords sp0
|
|
||||||
p1 = coords sp1
|
|
||||||
p2 = coords sp2
|
|
||||||
p3 = coords sp3
|
|
||||||
bez :: Cubic.Bezier ( Point2D Double )
|
|
||||||
bez = Cubic.Bezier {..}
|
|
||||||
brush :: Double -> SplinePts Closed
|
|
||||||
brush t = brushFn
|
|
||||||
$ Cubic.bezier @diffParams
|
|
||||||
( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
|
|
||||||
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
|
||||||
fwd t
|
|
||||||
= ( off t
|
|
||||||
, if squaredNorm offTgt < epsilon then Cubic.bezier' bez t else offTgt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
off :: Double -> Point2D Double
|
|
||||||
off x = offset ( withTangent ( Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x
|
|
||||||
offTgt :: Vector2D Double
|
|
||||||
offTgt
|
|
||||||
| t < 0.5
|
|
||||||
= 1e9 *^ ( off t --> off (t + 1e-9) )
|
|
||||||
| otherwise
|
|
||||||
= 1e9 *^ ( off (t - 1e-9) --> off t )
|
|
||||||
bwd t
|
|
||||||
= ( off s
|
|
||||||
, if squaredNorm offTgt < epsilon then (-1) *^ Cubic.bezier' bez s else offTgt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
s :: Double
|
|
||||||
s = 1 - t
|
|
||||||
off :: Double -> Point2D Double
|
|
||||||
off x = offset ( withTangent ( (-1) *^ Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x
|
|
||||||
offTgt :: Vector2D Double
|
|
||||||
offTgt
|
|
||||||
| s < 0.5
|
|
||||||
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
|
||||||
| otherwise
|
|
||||||
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
|
||||||
in updateCurveData curveData fwd bwd
|
|
||||||
|
|
||||||
updateCurveData
|
updateCurveData
|
||||||
:: crvData
|
:: crvData
|
||||||
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||||
|
@ -426,15 +322,11 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
|
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
|
||||||
tellBrushJoin
|
tellBrushJoin
|
||||||
:: Monad m
|
:: Monad m
|
||||||
=> Vector2D Double
|
=> ( Vector2D Double, Vector2D Double )
|
||||||
-> ptData
|
-> ptData
|
||||||
-> Vector2D Double
|
-> ( Vector2D Double, Vector2D Double )
|
||||||
-> WriterT OutlineData m ()
|
-> WriterT OutlineData m ()
|
||||||
tellBrushJoin prevTgt sp0 tgt
|
tellBrushJoin ( prevTgtFwd, prevTgtBwd ) sp0 ( tgtFwd, tgtBwd ) = tell brushJoin
|
||||||
| tgt `parallel` prevTgt
|
|
||||||
= pure ()
|
|
||||||
| otherwise
|
|
||||||
= tell brushJoin
|
|
||||||
where
|
where
|
||||||
ptOffset :: Vector2D Double
|
ptOffset :: Vector2D Double
|
||||||
ptOffset = Point2D 0 0 --> coords sp0
|
ptOffset = Point2D 0 0 --> coords sp0
|
||||||
|
@ -442,14 +334,111 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
brush0 = brushShape sp0
|
brush0 = brushShape sp0
|
||||||
fwdJoin, bwdJoin :: SplinePts Open
|
fwdJoin, bwdJoin :: SplinePts Open
|
||||||
fwdJoin
|
fwdJoin
|
||||||
|
| tgtFwd `parallel` prevTgtFwd
|
||||||
|
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
|
||||||
|
| otherwise
|
||||||
= fmap ( ptOffset • )
|
= fmap ( ptOffset • )
|
||||||
$ joinWithBrush ( withTangent prevTgt brush0 ) ( withTangent tgt brush0 ) brush0
|
$ joinWithBrush ( withTangent prevTgtFwd brush0 ) ( withTangent tgtFwd brush0 ) brush0
|
||||||
bwdJoin
|
bwdJoin
|
||||||
|
| tgtBwd `parallel` prevTgtBwd
|
||||||
|
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
|
||||||
|
| otherwise
|
||||||
= fmap ( ptOffset • )
|
= fmap ( ptOffset • )
|
||||||
$ joinWithBrush ( withTangent ( (-1) *^ tgt ) brush0 ) ( withTangent ( (-1) *^ prevTgt ) brush0 ) brush0
|
$ joinWithBrush ( withTangent ( (-1) *^ tgtBwd ) brush0 ) ( withTangent ( (-1) *^ prevTgtBwd ) brush0 ) brush0
|
||||||
brushJoin :: OutlineData
|
brushJoin :: OutlineData
|
||||||
brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
|
brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
|
||||||
|
|
||||||
|
-- | Computes the forward and backward stroke outline functions for a single curve.
|
||||||
|
outlineFunctions
|
||||||
|
:: forall diffParams brushParams crvData ptData
|
||||||
|
. ( Group diffParams, Module Double diffParams
|
||||||
|
, Torsor diffParams brushParams
|
||||||
|
, HasType ( Point2D Double ) ptData
|
||||||
|
-- Debugging.
|
||||||
|
, Show ptData
|
||||||
|
)
|
||||||
|
=> ( ptData -> brushParams )
|
||||||
|
-> ( brushParams -> SplinePts Closed )
|
||||||
|
-> ptData
|
||||||
|
-> Curve Open crvData ptData
|
||||||
|
-> ( Double -> ( Point2D Double, Vector2D Double )
|
||||||
|
, Double -> ( Point2D Double, Vector2D Double )
|
||||||
|
)
|
||||||
|
outlineFunctions ptParams brushFn sp0 crv =
|
||||||
|
let
|
||||||
|
p0 :: Point2D Double
|
||||||
|
p0 = coords sp0
|
||||||
|
brush :: Double -> SplinePts Closed
|
||||||
|
f :: Double -> Point2D Double
|
||||||
|
f' :: Double -> Vector2D Double
|
||||||
|
( brush, f, f' ) = case crv of
|
||||||
|
LineTo { curveEnd = NextPoint sp1 }
|
||||||
|
| let
|
||||||
|
p1 :: Point2D Double
|
||||||
|
p1 = coords sp1
|
||||||
|
tgt :: Vector2D Double
|
||||||
|
tgt = p0 --> p1
|
||||||
|
brush1 :: Double -> SplinePts Closed
|
||||||
|
brush1 t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) )
|
||||||
|
-> ( brush1, \ t -> lerp @( Vector2D Double ) t p0 p1, const tgt )
|
||||||
|
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
|
||||||
|
| let
|
||||||
|
p1, p2 :: Point2D Double
|
||||||
|
p1 = coords sp1
|
||||||
|
p2 = coords sp2
|
||||||
|
bez :: Quadratic.Bezier ( Point2D Double )
|
||||||
|
bez = Quadratic.Bezier {..}
|
||||||
|
brush2 :: Double -> SplinePts Closed
|
||||||
|
brush2 t =
|
||||||
|
brushFn $
|
||||||
|
Quadratic.bezier @diffParams
|
||||||
|
( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t
|
||||||
|
-> ( brush2, Quadratic.bezier @( Vector2D Double ) bez, Quadratic.bezier' bez )
|
||||||
|
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
|
||||||
|
| let
|
||||||
|
p1, p2, p3 :: Point2D Double
|
||||||
|
p1 = coords sp1
|
||||||
|
p2 = coords sp2
|
||||||
|
p3 = coords sp3
|
||||||
|
bez :: Cubic.Bezier ( Point2D Double )
|
||||||
|
bez = Cubic.Bezier {..}
|
||||||
|
brush3 :: Double -> SplinePts Closed
|
||||||
|
brush3 t =
|
||||||
|
brushFn $
|
||||||
|
Cubic.bezier @diffParams
|
||||||
|
( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
|
||||||
|
-> ( brush3, Cubic.bezier @( Vector2D Double ) bez, Cubic.bezier' bez )
|
||||||
|
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||||
|
fwd t
|
||||||
|
= ( off t
|
||||||
|
, if squaredNorm offTgt < epsilon then f' t else offTgt
|
||||||
|
)
|
||||||
|
where
|
||||||
|
off :: Double -> Point2D Double
|
||||||
|
off u = offset ( withTangent ( f' u ) ( brush u ) ) • f u
|
||||||
|
offTgt :: Vector2D Double
|
||||||
|
offTgt
|
||||||
|
| t < 0.5
|
||||||
|
= 1e9 *^ ( off t --> off (t + 1e-9) )
|
||||||
|
| otherwise
|
||||||
|
= 1e9 *^ ( off (t - 1e-9) --> off t )
|
||||||
|
bwd t
|
||||||
|
= ( off s
|
||||||
|
, if squaredNorm offTgt < epsilon then (-1) *^ f' s else offTgt
|
||||||
|
)
|
||||||
|
where
|
||||||
|
s :: Double
|
||||||
|
s = 1 - t
|
||||||
|
off :: Double -> Point2D Double
|
||||||
|
off u = offset ( withTangent ( (-1) *^ f' u ) ( brush u ) ) • f u
|
||||||
|
offTgt :: Vector2D Double
|
||||||
|
offTgt
|
||||||
|
| s < 0.5
|
||||||
|
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
||||||
|
| otherwise
|
||||||
|
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
||||||
|
in ( fwd, bwd )
|
||||||
|
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
-- Various utility functions
|
-- Various utility functions
|
||||||
-- used in the "stroke" function.
|
-- used in the "stroke" function.
|
||||||
|
|
Loading…
Reference in a new issue