mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 17:34:08 +00:00
draw cusps in debug mode
This commit is contained in:
parent
d2a485f71e
commit
dd503df126
|
@ -72,7 +72,7 @@ import Math.Bezier.Spline
|
||||||
, catMaybesSpline
|
, catMaybesSpline
|
||||||
)
|
)
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
( CachedStroke(..), invalidateCache
|
( Cusp(..), CachedStroke(..), invalidateCache
|
||||||
, computeStrokeOutline
|
, computeStrokeOutline
|
||||||
)
|
)
|
||||||
import Math.Interval
|
import Math.Interval
|
||||||
|
@ -120,7 +120,7 @@ import MetaBrush.GTK.Util
|
||||||
|
|
||||||
data Renders a
|
data Renders a
|
||||||
= Renders
|
= Renders
|
||||||
{ renderStrokes, renderPath, renderBrushes
|
{ renderStrokes, renderPath, renderDebug, renderBrushes
|
||||||
, renderCLines, renderCPts, renderPPts :: a
|
, renderCLines, renderCPts, renderPPts :: a
|
||||||
}
|
}
|
||||||
deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
|
deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
|
||||||
|
@ -256,6 +256,7 @@ data StrokeRenderData where
|
||||||
( SplinePts Closed )
|
( SplinePts Closed )
|
||||||
( SplinePts Closed, SplinePts Closed )
|
( SplinePts Closed, SplinePts Closed )
|
||||||
, Seq FitPoint
|
, Seq FitPoint
|
||||||
|
, [ Cusp ]
|
||||||
)
|
)
|
||||||
, strokeBrushFunction :: pointParams -> SplinePts Closed
|
, strokeBrushFunction :: pointParams -> SplinePts Closed
|
||||||
}
|
}
|
||||||
|
@ -299,14 +300,14 @@ strokeRenderData fitParams
|
||||||
let embedUsedParams = inject brush_defaults
|
let embedUsedParams = inject brush_defaults
|
||||||
|
|
||||||
-- Compute the outline using the brush function.
|
-- Compute the outline using the brush function.
|
||||||
( outline, fitPts ) <-
|
( outline, fitPts, cusps ) <-
|
||||||
computeStrokeOutline @clo fitParams
|
computeStrokeOutline @clo fitParams
|
||||||
( toUsedParams . brushParams ) embedUsedParams brushFn
|
( toUsedParams . brushParams ) embedUsedParams brushFn
|
||||||
spline
|
spline
|
||||||
pure $
|
pure $
|
||||||
StrokeWithOutlineRenderData
|
StrokeWithOutlineRenderData
|
||||||
{ strokeDataSpline = spline
|
{ strokeDataSpline = spline
|
||||||
, strokeOutlineData = ( outline, fitPts )
|
, strokeOutlineData = ( outline, fitPts, cusps )
|
||||||
, strokeBrushFunction = fun @Double ( brushFn @Point proxy# id )
|
, strokeBrushFunction = fun @Double ( brushFn @Point proxy# id )
|
||||||
. embedUsedParams
|
. embedUsedParams
|
||||||
. toUsedParams
|
. toUsedParams
|
||||||
|
@ -324,13 +325,17 @@ renderStroke
|
||||||
renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
|
renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
|
||||||
StrokeRenderData { strokeDataSpline } ->
|
StrokeRenderData { strokeDataSpline } ->
|
||||||
renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
|
renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
|
||||||
StrokeWithOutlineRenderData strokeDataSpline strokeOutlineData strokeBrushFunction ->
|
StrokeWithOutlineRenderData strokeDataSpline ( strokeOutlineData, fitPts, cusps ) strokeBrushFunction ->
|
||||||
renderStrokeSpline cols mode rdrMode mbHoverContext zoom
|
renderStrokeSpline cols mode rdrMode mbHoverContext zoom
|
||||||
( when ( mode == BrushMode )
|
( when ( mode == BrushMode )
|
||||||
. renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom ) strokeBrushFunction
|
. renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom ) strokeBrushFunction
|
||||||
)
|
)
|
||||||
strokeDataSpline
|
strokeDataSpline
|
||||||
*> Compose blank { renderStrokes = drawOutline cols debug zoom strokeOutlineData }
|
*> Compose blank
|
||||||
|
{ renderStrokes = drawOutline cols debug zoom strokeOutlineData
|
||||||
|
, renderDebug =
|
||||||
|
when debug $ drawDebugInfo cols zoom ( fitPts, cusps )
|
||||||
|
}
|
||||||
|
|
||||||
-- | Render a sequence of stroke points.
|
-- | Render a sequence of stroke points.
|
||||||
--
|
--
|
||||||
|
@ -550,13 +555,13 @@ drawCubicBezier ( Colours { path } ) zoom
|
||||||
|
|
||||||
drawOutline
|
drawOutline
|
||||||
:: Colours -> Bool -> Double
|
:: Colours -> Bool -> Double
|
||||||
-> ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint )
|
-> Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
||||||
-> Cairo.Render ()
|
-> Cairo.Render ()
|
||||||
drawOutline cols@( Colours {..} ) debug zoom strokeData = do
|
drawOutline ( Colours {..} ) debug zoom strokeData = do
|
||||||
Cairo.save
|
Cairo.save
|
||||||
withRGBA brushStroke Cairo.setSourceRGBA
|
withRGBA brushStroke Cairo.setSourceRGBA
|
||||||
case strokeData of
|
case strokeData of
|
||||||
( Left outline, fitPts ) -> do
|
Left outline -> do
|
||||||
makeOutline outline
|
makeOutline outline
|
||||||
case debug of
|
case debug of
|
||||||
False -> Cairo.fill
|
False -> Cairo.fill
|
||||||
|
@ -565,8 +570,7 @@ drawOutline cols@( Colours {..} ) debug zoom strokeData = do
|
||||||
Cairo.setSourceRGBA 0 0 0 0.75
|
Cairo.setSourceRGBA 0 0 0 0.75
|
||||||
Cairo.setLineWidth ( 2 / zoom )
|
Cairo.setLineWidth ( 2 / zoom )
|
||||||
Cairo.stroke
|
Cairo.stroke
|
||||||
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
Right ( fwd, bwd ) -> do
|
||||||
( Right ( fwd, bwd ), fitPts ) -> do
|
|
||||||
makeOutline fwd
|
makeOutline fwd
|
||||||
makeOutline bwd
|
makeOutline bwd
|
||||||
case debug of
|
case debug of
|
||||||
|
@ -576,7 +580,6 @@ drawOutline cols@( Colours {..} ) debug zoom strokeData = do
|
||||||
Cairo.setSourceRGBA 0 0 0 0.75
|
Cairo.setSourceRGBA 0 0 0 0.75
|
||||||
Cairo.setLineWidth ( 2 / zoom )
|
Cairo.setLineWidth ( 2 / zoom )
|
||||||
Cairo.stroke
|
Cairo.stroke
|
||||||
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
|
||||||
Cairo.restore
|
Cairo.restore
|
||||||
where
|
where
|
||||||
makeOutline :: SplinePts Closed -> Cairo.Render ()
|
makeOutline :: SplinePts Closed -> Cairo.Render ()
|
||||||
|
@ -600,6 +603,14 @@ drawOutline cols@( Colours {..} ) debug zoom strokeData = do
|
||||||
let ℝ2 x3 y3 = fromNextPoint start mp3
|
let ℝ2 x3 y3 = fromNextPoint start mp3
|
||||||
in Cairo.curveTo x1 y1 x2 y2 x3 y3
|
in Cairo.curveTo x1 y1 x2 y2 x3 y3
|
||||||
|
|
||||||
|
drawDebugInfo :: Colours -> Double
|
||||||
|
-> ( Seq FitPoint, [ Cusp ] )
|
||||||
|
-> Cairo.Render ()
|
||||||
|
drawDebugInfo cols zoom ( fitPts, cusps ) = do
|
||||||
|
Cairo.setLineWidth ( 2 / zoom )
|
||||||
|
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
||||||
|
for_ cusps ( drawCusp cols zoom )
|
||||||
|
|
||||||
drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
|
drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
|
||||||
drawFitPoint _ zoom ( FitPoint { fitPoint = ℝ2 x y } ) = do
|
drawFitPoint _ zoom ( FitPoint { fitPoint = ℝ2 x y } ) = do
|
||||||
|
|
||||||
|
@ -635,6 +646,27 @@ drawFitPoint _ zoom ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty }
|
||||||
Cairo.fill
|
Cairo.fill
|
||||||
Cairo.restore
|
Cairo.restore
|
||||||
|
|
||||||
|
drawCusp :: Colours -> Double -> Cusp -> Cairo.Render ()
|
||||||
|
drawCusp _ zoom
|
||||||
|
( Cusp { cuspPathCoords = ℝ2 px py
|
||||||
|
, cuspStrokeCoords = ℝ2 cx cy } ) = do
|
||||||
|
|
||||||
|
-- Draw a white circle on the path at the cusp point.
|
||||||
|
Cairo.save
|
||||||
|
Cairo.translate px py
|
||||||
|
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
|
||||||
|
Cairo.setSourceRGBA 1.0 1.0 1.0 1.0
|
||||||
|
Cairo.stroke
|
||||||
|
Cairo.restore
|
||||||
|
|
||||||
|
-- Draw a black circle on the outline at the cusp point.
|
||||||
|
Cairo.save
|
||||||
|
Cairo.translate cx cy
|
||||||
|
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
|
||||||
|
Cairo.setSourceRGBA 0 0 0 1.0
|
||||||
|
Cairo.stroke
|
||||||
|
Cairo.restore
|
||||||
|
|
||||||
drawSelectionRectangle :: Colours -> Double -> ℝ 2 -> ℝ 2 -> Cairo.Render ()
|
drawSelectionRectangle :: Colours -> Double -> ℝ 2 -> ℝ 2 -> Cairo.Render ()
|
||||||
drawSelectionRectangle ( Colours {..} ) zoom ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) = do
|
drawSelectionRectangle ( Colours {..} ) zoom ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) = do
|
||||||
|
|
||||||
|
|
|
@ -4,7 +4,7 @@
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Math.Bezier.Stroke
|
module Math.Bezier.Stroke
|
||||||
( Offset(..)
|
( Offset(..), Cusp(..)
|
||||||
, CachedStroke(..), discardCache, invalidateCache
|
, CachedStroke(..), discardCache, invalidateCache
|
||||||
, computeStrokeOutline, joinWithBrush
|
, computeStrokeOutline, joinWithBrush
|
||||||
, withTangent
|
, withTangent
|
||||||
|
@ -49,7 +49,7 @@ import GHC.Exts
|
||||||
import GHC.STRef
|
import GHC.STRef
|
||||||
( STRef(..), readSTRef, writeSTRef )
|
( STRef(..), readSTRef, writeSTRef )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic, Generic1 )
|
( Generic, Generic1, Generically(..) )
|
||||||
import GHC.TypeNats
|
import GHC.TypeNats
|
||||||
( type (-) )
|
( type (-) )
|
||||||
|
|
||||||
|
@ -158,13 +158,21 @@ data TwoSided a
|
||||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||||
deriving anyclass ( NFData, NFData1 )
|
deriving anyclass ( NFData, NFData1 )
|
||||||
|
|
||||||
type OutlineData = TwoSided ( SplinePts Open, Seq FitPoint )
|
data OutlineData =
|
||||||
instance Semigroup OutlineData where
|
OutlineData
|
||||||
|
{ outline :: !( TwoSided ( SplinePts Open, Seq FitPoint ) )
|
||||||
|
, cusps :: ![ Cusp ] }
|
||||||
|
deriving stock Generic
|
||||||
|
deriving ( Semigroup, Monoid )
|
||||||
|
via Generically OutlineData
|
||||||
|
deriving anyclass NFData
|
||||||
|
|
||||||
|
instance Semigroup ( TwoSided ( SplinePts Open, Seq FitPoint ) ) where
|
||||||
TwoSided ( fwdSpline1, fwdPts1 ) ( bwdSpline1, bwdPts1 ) <> TwoSided ( fwdSpline2, fwdPts2 ) ( bwdSpline2, bwdPts2 ) =
|
TwoSided ( fwdSpline1, fwdPts1 ) ( bwdSpline1, bwdPts1 ) <> TwoSided ( fwdSpline2, fwdPts2 ) ( bwdSpline2, bwdPts2 ) =
|
||||||
TwoSided
|
TwoSided
|
||||||
( fwdSpline1 <> fwdSpline2, fwdPts1 <> fwdPts2 )
|
( fwdSpline1 <> fwdSpline2, fwdPts1 <> fwdPts2 )
|
||||||
( bwdSpline2 <> bwdSpline1, bwdPts2 <> bwdPts1 )
|
( bwdSpline2 <> bwdSpline1, bwdPts2 <> bwdPts1 )
|
||||||
instance Monoid OutlineData where
|
instance Monoid ( TwoSided ( SplinePts Open, Seq FitPoint ) ) where
|
||||||
mempty = TwoSided empt empt
|
mempty = TwoSided empt empt
|
||||||
where
|
where
|
||||||
empt :: ( SplinePts Open, Seq FitPoint )
|
empt :: ( SplinePts Open, Seq FitPoint )
|
||||||
|
@ -193,8 +201,26 @@ coords = view typed
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Forward and backward outlines.
|
||||||
type OutlineFn = ℝ 1 -> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) )
|
type OutlineFn = ℝ 1 -> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) )
|
||||||
|
|
||||||
|
data Cusp
|
||||||
|
= Cusp
|
||||||
|
{ cuspParameters :: !( ℝ 2 )
|
||||||
|
-- ^ @(t,s)@ parameter values of the cusp
|
||||||
|
, cuspPathCoords :: !( ℝ 2 )
|
||||||
|
-- ^ path point coordinates
|
||||||
|
, cuspStrokeCoords :: !( ℝ 2 )
|
||||||
|
-- ^ brush stroke point coordinates
|
||||||
|
}
|
||||||
|
deriving stock Generic
|
||||||
|
deriving anyclass NFData
|
||||||
|
|
||||||
|
data OutlineInfo =
|
||||||
|
OutlineInfo
|
||||||
|
{ outlineFn :: OutlineFn
|
||||||
|
, outlineDefiniteCusps, outlinePotentialCusps :: [ Cusp ] }
|
||||||
|
|
||||||
computeStrokeOutline ::
|
computeStrokeOutline ::
|
||||||
forall ( clo :: SplineType ) usedParams brushParams crvData ptData s
|
forall ( clo :: SplineType ) usedParams brushParams crvData ptData s
|
||||||
. ( KnownSplineType clo
|
. ( KnownSplineType clo
|
||||||
|
@ -232,6 +258,7 @@ computeStrokeOutline ::
|
||||||
-> ST s
|
-> ST s
|
||||||
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
||||||
, Seq FitPoint
|
, Seq FitPoint
|
||||||
|
, [ Cusp ]
|
||||||
)
|
)
|
||||||
computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
|
computeStrokeOutline fitParams ptParams toBrushParams 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.
|
||||||
|
@ -245,8 +272,8 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
|
||||||
endPt :: ptData
|
endPt :: ptData
|
||||||
endPt = openCurveEnd lastCurve
|
endPt = openCurveEnd lastCurve
|
||||||
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( ℝ 2 )
|
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( ℝ 2 )
|
||||||
( ( _, startTgtFwd), ( _, startTgtBwd ) ) = firstOutlineFn $ ℝ1 0
|
( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 0
|
||||||
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = lastOutlineFn $ ℝ1 1
|
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 1
|
||||||
startBrush, endBrush :: SplinePts Closed
|
startBrush, endBrush :: SplinePts Closed
|
||||||
startBrush = brushShape spt0
|
startBrush = brushShape spt0
|
||||||
endBrush = brushShape endPt
|
endBrush = brushShape endPt
|
||||||
|
@ -286,10 +313,14 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
|
||||||
$ joinWithBrush endBrush endTgtBwd endTgtFwd
|
$ joinWithBrush endBrush endTgtBwd endTgtFwd
|
||||||
|
|
||||||
-> do
|
-> do
|
||||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( startTgt, startTgtFwd, startTgtBwd )
|
OutlineData
|
||||||
|
( TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
|
||||||
|
cusps
|
||||||
|
<- updateSpline ( startTgt, startTgtFwd, startTgtBwd )
|
||||||
pure
|
pure
|
||||||
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
|
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
|
||||||
, fwdFits <> bwdFits
|
, fwdFits <> bwdFits
|
||||||
|
, cusps
|
||||||
)
|
)
|
||||||
-- Closed brush path with at least one segment.
|
-- Closed brush path with at least one segment.
|
||||||
-- Add forward and backward caps at the start.
|
-- Add forward and backward caps at the start.
|
||||||
|
@ -305,33 +336,39 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
|
||||||
endTgt = case prevCurves of
|
endTgt = case prevCurves of
|
||||||
Empty -> endTangent spt0 spt0 lastCurve
|
Empty -> endTangent spt0 spt0 lastCurve
|
||||||
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
||||||
( ( _, startTgtFwd), ( _, startTgtBwd ) ) = firstOutlineFn $ ℝ1 0
|
( ( _, startTgtFwd), ( _, startTgtBwd ) ) = outlineFn firstOutlineFn $ ℝ1 0
|
||||||
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = lastOutlineFn $ ℝ1 1
|
( ( _, endTgtFwd ), ( _, endTgtBwd ) ) = outlineFn lastOutlineFn $ ℝ1 1
|
||||||
fwdStartCap, bwdStartCap :: SplinePts Open
|
fwdStartCap, bwdStartCap :: SplinePts Open
|
||||||
TwoSided fwdStartCap bwdStartCap
|
cusps :: [ Cusp ]
|
||||||
= fmap fst . snd . runWriter
|
OutlineData ( fmap fst -> TwoSided fwdStartCap bwdStartCap ) cusps
|
||||||
|
= snd . runWriter
|
||||||
$ tellBrushJoin ( endTgt, endTgtFwd, endTgtBwd ) spt0 ( startTgt, startTgtFwd, startTgtBwd )
|
$ tellBrushJoin ( endTgt, endTgtFwd, endTgtBwd ) spt0 ( startTgt, startTgtFwd, startTgtBwd )
|
||||||
-> do
|
-> do
|
||||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( endTgt, endTgtFwd, endTgtBwd )
|
OutlineData
|
||||||
|
( TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
|
||||||
|
cusps
|
||||||
|
<- updateSpline ( endTgt, 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
|
||||||
|
, cusps
|
||||||
)
|
)
|
||||||
-- Single point.
|
-- Single point.
|
||||||
_ ->
|
_ ->
|
||||||
pure
|
pure
|
||||||
( Left $ fmap ( T ( coords spt0 ) • ) ( brushShape spt0 )
|
( Left $ fmap ( T ( coords spt0 ) • ) ( brushShape spt0 )
|
||||||
, Empty
|
, Empty
|
||||||
|
, []
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
outlineFns :: Seq OutlineFn
|
outlineFns :: Seq OutlineInfo
|
||||||
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
|
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
|
||||||
where
|
where
|
||||||
go
|
go
|
||||||
:: ptData
|
:: ptData
|
||||||
-> Seq ( Curve Open crvData ptData )
|
-> Seq ( Curve Open crvData ptData )
|
||||||
-> Seq OutlineFn
|
-> Seq OutlineInfo
|
||||||
go _ Empty = Empty
|
go _ Empty = Empty
|
||||||
go p0 ( crv :<| crvs ) =
|
go p0 ( crv :<| crvs ) =
|
||||||
outlineFunction ptParams toBrushParams brushFn p0 crv :<| go ( openCurveEnd crv ) crvs
|
outlineFunction ptParams toBrushParams brushFn p0 crv :<| go ( openCurveEnd crv ) crvs
|
||||||
|
@ -347,13 +384,13 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
|
||||||
( \ ptData curve -> do
|
( \ ptData curve -> do
|
||||||
( prevTgt, prev_tgtFwd, prev_tgtBwd ) <- get
|
( prevTgt, prev_tgtFwd, prev_tgtBwd ) <- get
|
||||||
let
|
let
|
||||||
fwdBwd :: OutlineFn
|
fwdBwd :: OutlineInfo
|
||||||
fwdBwd = outlineFunction ptParams toBrushParams brushFn ptData curve
|
fwdBwd = outlineFunction ptParams toBrushParams brushFn ptData curve
|
||||||
tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: T ( ℝ 2 )
|
tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: T ( ℝ 2 )
|
||||||
tgt = startTangent spt0 ptData curve
|
tgt = startTangent spt0 ptData curve
|
||||||
next_tgt = endTangent spt0 ptData curve
|
next_tgt = endTangent spt0 ptData curve
|
||||||
( ( _, tgtFwd ), ( _, tgtBwd ) ) = fwdBwd $ ℝ1 0
|
( ( _, tgtFwd ), ( _, tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 0
|
||||||
( ( _, next_tgtFwd ), ( _, next_tgtBwd ) ) = fwdBwd $ ℝ1 1
|
( ( _, next_tgtFwd ), ( _, next_tgtBwd ) ) = outlineFn fwdBwd $ ℝ1 1
|
||||||
lift $ tellBrushJoin ( prevTgt, prev_tgtFwd, tgtBwd ) ptData ( tgt, tgtFwd, prev_tgtBwd )
|
lift $ tellBrushJoin ( prevTgt, prev_tgtFwd, tgtBwd ) ptData ( tgt, tgtFwd, prev_tgtBwd )
|
||||||
lift $ updateCurveData ( curveData curve ) fwdBwd
|
lift $ updateCurveData ( curveData curve ) fwdBwd
|
||||||
put ( next_tgt, next_tgtFwd, next_tgtBwd )
|
put ( next_tgt, next_tgtFwd, next_tgtBwd )
|
||||||
|
@ -363,7 +400,7 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
|
||||||
|
|
||||||
updateCurveData
|
updateCurveData
|
||||||
:: crvData
|
:: crvData
|
||||||
-> OutlineFn
|
-> OutlineInfo
|
||||||
-> WriterT OutlineData ( ST s ) ()
|
-> WriterT OutlineData ( ST s ) ()
|
||||||
updateCurveData ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) fwdBwd = do
|
updateCurveData ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) fwdBwd = do
|
||||||
mbOutline <- lift ( readSTRef cachedStrokeRef )
|
mbOutline <- lift ( readSTRef cachedStrokeRef )
|
||||||
|
@ -375,13 +412,21 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
|
||||||
-- No cached fit: compute the fit anew.
|
-- No cached fit: compute the fit anew.
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
let
|
let
|
||||||
|
cusps :: [ Cusp ]
|
||||||
|
cusps = outlineDefiniteCusps fwdBwd
|
||||||
|
++ outlinePotentialCusps fwdBwd
|
||||||
|
-- SLD TODO: here!!!
|
||||||
fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
|
fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
|
||||||
( fwdData, bwdData ) =
|
( fwdData, bwdData ) =
|
||||||
( fitSpline fitParams ( fst . fwdBwd ), fitSpline fitParams ( snd . fwdBwd ) )
|
( fitSpline fitParams ( fst . outlineFn fwdBwd )
|
||||||
|
, fitSpline fitParams ( snd . outlineFn fwdBwd ) )
|
||||||
`Strats.using`
|
`Strats.using`
|
||||||
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
|
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
|
||||||
outlineData :: OutlineData
|
outlineData :: OutlineData
|
||||||
outlineData = TwoSided fwdData ( bimap reverseSpline Seq.reverse bwdData )
|
outlineData =
|
||||||
|
OutlineData
|
||||||
|
( TwoSided fwdData ( bimap reverseSpline Seq.reverse bwdData ) )
|
||||||
|
cusps
|
||||||
outlineData `deepseq` tell outlineData
|
outlineData `deepseq` tell outlineData
|
||||||
lift $ writeSTRef cachedStrokeRef ( Just outlineData )
|
lift $ writeSTRef cachedStrokeRef ( Just outlineData )
|
||||||
|
|
||||||
|
@ -394,7 +439,9 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
|
||||||
-> ( T ( ℝ 2 ), T ( ℝ 2 ), T ( ℝ 2 ) )
|
-> ( T ( ℝ 2 ), T ( ℝ 2 ), T ( ℝ 2 ) )
|
||||||
-> WriterT OutlineData m ()
|
-> WriterT OutlineData m ()
|
||||||
tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) =
|
tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) =
|
||||||
tell $ TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
|
tell $ OutlineData
|
||||||
|
( TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty ) )
|
||||||
|
[]
|
||||||
where
|
where
|
||||||
ptOffset :: T ( ℝ 2 )
|
ptOffset :: T ( ℝ 2 )
|
||||||
ptOffset = ℝ2 0 0 --> coords sp0
|
ptOffset = ℝ2 0 0 --> coords sp0
|
||||||
|
@ -477,7 +524,7 @@ outlineFunction
|
||||||
)
|
)
|
||||||
-> ptData
|
-> ptData
|
||||||
-> Curve Open crvData ptData
|
-> Curve Open crvData ptData
|
||||||
-> OutlineFn
|
-> OutlineInfo
|
||||||
outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
||||||
let
|
let
|
||||||
pathAndUsedParams :: forall i k arr
|
pathAndUsedParams :: forall i k arr
|
||||||
|
@ -511,6 +558,16 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
||||||
path :: C ( ExtentOrder 'Point ) ( ℝ 1 ) ( ℝ 2 )
|
path :: C ( ExtentOrder 'Point ) ( ℝ 1 ) ( ℝ 2 )
|
||||||
( path, usedParams ) = pathAndUsedParams @Point id
|
( path, usedParams ) = pathAndUsedParams @Point id
|
||||||
|
|
||||||
|
curves :: ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum Point )
|
||||||
|
curves =
|
||||||
|
brushStrokeData @Point @( ExtentOrder 'Point ) @brushParams
|
||||||
|
path
|
||||||
|
( chainRule @Double @( ExtentOrder 'Point )
|
||||||
|
usedParams
|
||||||
|
( linear toBrushParams )
|
||||||
|
)
|
||||||
|
( brushFromParams @Point proxy# id )
|
||||||
|
|
||||||
curvesI :: 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 'Interval )
|
curvesI :: 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 'Interval )
|
||||||
curvesI = brushStrokeData @'Interval @( ExtentOrder 'Interval ) @brushParams
|
curvesI = brushStrokeData @'Interval @( ExtentOrder 'Interval ) @brushParams
|
||||||
pathI
|
pathI
|
||||||
|
@ -526,21 +583,10 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
||||||
|
|
||||||
fwdBwd :: OutlineFn
|
fwdBwd :: OutlineFn
|
||||||
fwdBwd t
|
fwdBwd t
|
||||||
= solveEnvelopeEquations t path_t path'_t ( fwdOffset, bwdOffset ) curves
|
= solveEnvelopeEquations t path_t path'_t ( fwdOffset, bwdOffset )
|
||||||
-- = ( ( offset fwdOffset • path_t, path'_t )
|
( curves t )
|
||||||
-- , ( offset bwdOffset • path_t, -1 *^ path'_t ) )
|
|
||||||
where
|
where
|
||||||
|
|
||||||
curves :: Seq ( ℝ 1 -> StrokeDatum Point )
|
|
||||||
curves = brushStrokeData @Point @( ExtentOrder 'Point ) @brushParams
|
|
||||||
path
|
|
||||||
( chainRule @Double @( ExtentOrder 'Point )
|
|
||||||
usedParams
|
|
||||||
( linear toBrushParams )
|
|
||||||
)
|
|
||||||
( brushFromParams @Point proxy# id )
|
|
||||||
t
|
|
||||||
|
|
||||||
fwdOffset = withTangent path'_t brush_t
|
fwdOffset = withTangent path'_t brush_t
|
||||||
bwdOffset = withTangent ( -1 *^ path'_t ) brush_t
|
bwdOffset = withTangent ( -1 *^ path'_t ) brush_t
|
||||||
|
|
||||||
|
@ -563,7 +609,10 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
||||||
-- , "unknown:"
|
-- , "unknown:"
|
||||||
-- , if null newtDunno then "[]" else unlines $ map show newtDunno ]
|
-- , if null newtDunno then "[]" else unlines $ map show newtDunno ]
|
||||||
-- ) $
|
-- ) $
|
||||||
fwdBwd
|
OutlineInfo
|
||||||
|
{ outlineFn = fwdBwd
|
||||||
|
, outlineDefiniteCusps = map ( cuspCoords curves ) newtSols
|
||||||
|
, outlinePotentialCusps = map ( cuspCoords curves ) newtDunno }
|
||||||
|
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
-- Various utility functions
|
-- Various utility functions
|
||||||
|
@ -1117,6 +1166,26 @@ extendedRecip x@( 𝕀 lo hi )
|
||||||
| otherwise
|
| otherwise
|
||||||
= [ recip ( 𝕀 lo 0 ), recip ( 𝕀 0 hi ) ]
|
= [ recip ( 𝕀 lo 0 ), recip ( 𝕀 0 hi ) ]
|
||||||
|
|
||||||
|
-- | Computes the brush stroke coordinates of a cusp from
|
||||||
|
-- the @(t,s)@ parameter values.
|
||||||
|
cuspCoords :: ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 'Point ) )
|
||||||
|
-> ( 𝕀ℝ 1, Int, 𝕀ℝ 1 )
|
||||||
|
-> Cusp
|
||||||
|
cuspCoords eqs ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ), i, 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
|
||||||
|
| StrokeDatum
|
||||||
|
{ dpath = D21 { _D21_v = path }
|
||||||
|
, dstroke = D22 { _D22_v = stroke } }
|
||||||
|
<- ( eqs ( ℝ1 t_mid ) `Seq.index` i ) ( ℝ1 s_mid )
|
||||||
|
= Cusp
|
||||||
|
{ cuspParameters = ℝ2 t_mid s_mid
|
||||||
|
, cuspPathCoords = path
|
||||||
|
, cuspStrokeCoords = stroke
|
||||||
|
}
|
||||||
|
where
|
||||||
|
t_mid = 0.5 * ( t_lo + t_hi )
|
||||||
|
s_mid = 0.5 * ( t_lo + t_hi )
|
||||||
|
|
||||||
|
|
||||||
-- | Interval Newton method with Gauss–Seidel step for inversion
|
-- | Interval Newton method with Gauss–Seidel step for inversion
|
||||||
-- of the interval Jacobian.
|
-- of the interval Jacobian.
|
||||||
--
|
--
|
||||||
|
|
|
@ -16,6 +16,10 @@ import Data.Monoid
|
||||||
import GHC.Show
|
import GHC.Show
|
||||||
( showCommaSpace )
|
( showCommaSpace )
|
||||||
|
|
||||||
|
-- deepseq
|
||||||
|
import Control.DeepSeq
|
||||||
|
( NFData )
|
||||||
|
|
||||||
-- rounded-hw
|
-- rounded-hw
|
||||||
import Numeric.Rounded.Hardware
|
import Numeric.Rounded.Hardware
|
||||||
( Rounded(..) )
|
( Rounded(..) )
|
||||||
|
@ -40,6 +44,7 @@ import Math.Ring
|
||||||
|
|
||||||
newtype 𝕀 a = MkI { ival :: Interval a }
|
newtype 𝕀 a = MkI { ival :: Interval a }
|
||||||
deriving newtype ( Prelude.Num, Prelude.Fractional, Prelude.Floating )
|
deriving newtype ( Prelude.Num, Prelude.Fractional, Prelude.Floating )
|
||||||
|
deriving newtype NFData
|
||||||
|
|
||||||
instance Eq a => Eq ( 𝕀 a ) where
|
instance Eq a => Eq ( 𝕀 a ) where
|
||||||
𝕀 a b == 𝕀 c d =
|
𝕀 a b == 𝕀 c d =
|
||||||
|
|
Loading…
Reference in a new issue