mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
fix stroke cache issues
This commit is contained in:
sheaf
parent
3886dca483
commit
f7a4b02e90
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
module Math.Bezier.Stroke
|
||||
( Offset(..), Cusp(..)
|
||||
, CachedStroke(..), discardCache, invalidateCache
|
||||
, CachedStroke(..), discardCache, newCache, invalidateCache
|
||||
, computeStrokeOutline, joinWithBrush
|
||||
, withTangent
|
||||
|
||||
|
|
@ -58,7 +58,7 @@ import Data.Semigroup
|
|||
import GHC.Exts
|
||||
( newMutVar#, runRW# )
|
||||
import GHC.STRef
|
||||
( STRef(..), readSTRef, writeSTRef )
|
||||
( STRef(..), readSTRef, newSTRef, writeSTRef )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1, Generically(..) )
|
||||
import GHC.TypeNats
|
||||
|
|
@ -201,6 +201,9 @@ invalidateCache = runRW# \ s ->
|
|||
Lens.set ( typed @( CachedStroke RealWorld ) )
|
||||
( CachedStroke $ STRef mutVar )
|
||||
|
||||
newCache :: forall s. ST s ( CachedStroke s )
|
||||
newCache = CachedStroke <$> newSTRef Nothing
|
||||
|
||||
coords :: forall ptData. HasType ( ℝ 2 ) ptData => ptData -> ℝ 2
|
||||
coords = Lens.view typed
|
||||
|
||||
|
|
@ -250,7 +253,7 @@ computeStrokeOutline ::
|
|||
, Module 𝕀 (T ( 𝕀ℝ nbUsedParams ) )
|
||||
|
||||
-- Debugging.
|
||||
, Show ptData, Show ( ℝ nbBrushParams )
|
||||
, Show ptData, Show crvData, Show ( ℝ nbBrushParams )
|
||||
|
||||
)
|
||||
=> RootSolvingAlgorithm
|
||||
|
|
@ -536,7 +539,7 @@ outlineFunction
|
|||
, Representable 𝕀 ( 𝕀ℝ nbUsedParams )
|
||||
|
||||
-- Debugging.
|
||||
, Show ptData, Show ( ℝ nbBrushParams )
|
||||
, Show ptData, Show crvData, Show ( ℝ nbBrushParams )
|
||||
)
|
||||
=> RootSolvingAlgorithm
|
||||
-> Maybe ( RootIsolationOptions N 3 )
|
||||
|
|
|
|||
|
|
@ -399,7 +399,7 @@ renderStrokeSpline
|
|||
=> Colours -> Mode -> RenderMode
|
||||
-> Set PointIndex -> Maybe HoverContext -> Zoom
|
||||
-> ( PointData pointData -> Compose Renders Cairo.Render () )
|
||||
-> Spline clo CurveData ( PointData pointData )
|
||||
-> Spline clo ( CurveData RealWorld ) ( PointData pointData )
|
||||
-> Compose Renders Cairo.Render ()
|
||||
renderStrokeSpline cols mode rdrMode selPts mbHover zoom renderSubcontent spline =
|
||||
bifoldSpline ( renderSplineCurve ( splineStart spline ) ) ( renderSplinePoint FirstPoint ) spline
|
||||
|
|
@ -416,7 +416,7 @@ renderStrokeSpline cols mode rdrMode selPts mbHover zoom renderSubcontent spline
|
|||
renderSplineCurve
|
||||
:: forall clo'
|
||||
. SplineTypeI clo'
|
||||
=> PointData pointData -> PointData pointData -> Curve clo' CurveData ( PointData pointData ) -> Compose Renders Cairo.Render ()
|
||||
=> PointData pointData -> PointData pointData -> Curve clo' ( CurveData RealWorld ) ( PointData pointData ) -> Compose Renders Cairo.Render ()
|
||||
renderSplineCurve start p0 ( LineTo np1 ( CurveData { curveIndex } ) )
|
||||
= Compose blank
|
||||
{ renderPPts = when ( rdrMode == RenderingPath ) do
|
||||
|
|
@ -491,7 +491,7 @@ renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt =
|
|||
*> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts
|
||||
*> toAll Cairo.restore
|
||||
where
|
||||
noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed CurveData ( PointData () )
|
||||
noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed ( CurveData RealWorld ) ( PointData () )
|
||||
noCurveData =
|
||||
bimapSpline
|
||||
( \ _ -> bimapCurve ( \ _ -> CurveData 987654321 ( invalidateCache undefined ) ) ( \ _ p -> PointData p () ) )
|
||||
|
|
|
|||
|
|
@ -22,6 +22,8 @@ import Control.Arrow
|
|||
( second )
|
||||
import Control.Monad
|
||||
( guard, when )
|
||||
import Control.Monad.ST
|
||||
( RealWorld )
|
||||
import Data.Foldable
|
||||
( for_, traverse_ )
|
||||
import Data.Functor
|
||||
|
|
@ -153,9 +155,9 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
|
|||
subdivideCurve
|
||||
:: T ( ℝ 2 )
|
||||
-> PointData brushParams
|
||||
-> Curve Open CurveData ( PointData brushParams )
|
||||
-> Curve Open ( CurveData RealWorld ) ( PointData brushParams )
|
||||
-> Writer [ ( Curve Open () (), Double ) ]
|
||||
( Seq ( Curve Open CurveData ( PointData brushParams ) ) )
|
||||
( Seq ( Curve Open ( CurveData RealWorld ) ( PointData brushParams ) ) )
|
||||
subdivideCurve offset sp0 crv =
|
||||
case crv of
|
||||
LineTo ( NextPoint sp1 ) dat -> do
|
||||
|
|
@ -193,7 +195,7 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
|
|||
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
|
||||
Writer.tell [ ( stripData crv, t ) ]
|
||||
let
|
||||
bez_start, bez_end :: Curve Open CurveData ( PointData brushParams )
|
||||
bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
|
||||
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
|
||||
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat )
|
||||
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
|
||||
|
|
@ -213,7 +215,7 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
|
|||
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
|
||||
Writer.tell [ ( stripData crv, t ) ]
|
||||
let
|
||||
bez_start, bez_end :: Curve Open CurveData ( PointData brushParams )
|
||||
bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
|
||||
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
|
||||
bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( invalidateCache dat )
|
||||
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
|
||||
|
|
@ -257,7 +259,7 @@ selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
|
|||
return PreserveStroke
|
||||
|
||||
selectSplineCurve :: SplineTypeI clo
|
||||
=> Curve clo CurveData ( PointData ptData )
|
||||
=> Curve clo ( CurveData RealWorld ) ( PointData ptData )
|
||||
-> Except PointIndex ()
|
||||
selectSplineCurve = \case
|
||||
LineTo p1 ( CurveData { curveIndex } ) ->
|
||||
|
|
@ -311,7 +313,7 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
|
|||
=> Unique
|
||||
-> PointData brushParams
|
||||
-> Int
|
||||
-> PointData brushParams -> Curve clo' CurveData ( PointData brushParams )
|
||||
-> PointData brushParams -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
|
||||
-> Except DragMoveSelect ()
|
||||
dragSelectSplineCurve uniq start i sp0 = \case
|
||||
LineTo sp1 ( CurveData { curveIndex } ) -> do
|
||||
|
|
@ -442,7 +444,7 @@ selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) doc@( Document { documentC
|
|||
return PreserveStroke
|
||||
|
||||
selectRectSplineCurve :: SplineTypeI clo
|
||||
=> Curve clo CurveData ( PointData ptData )
|
||||
=> Curve clo ( CurveData RealWorld ) ( PointData ptData )
|
||||
-> Writer ( Set PointIndex ) ()
|
||||
selectRectSplineCurve = \case
|
||||
LineTo p1 ( CurveData { curveIndex } ) ->
|
||||
|
|
@ -495,7 +497,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
|||
firstPointSel = FirstPoint `Set.member` strokeSelPts
|
||||
( spline', ( modPts, _ ) ) =
|
||||
( `State.runState` ( mempty, False ) ) $
|
||||
bitraverseSpline @_ @_ @CurveData @( PointData _ )
|
||||
bitraverseSpline @_ @_ @( CurveData RealWorld ) @( PointData _ )
|
||||
( \ _ -> updateSplineCurve firstPointSel strokeSelPts )
|
||||
( \ pt -> do { ( NextPoint pt', _ ) <- updatePoint firstPointSel strokeSelPts FirstPoint ( NextPoint pt ) ; return pt' } )
|
||||
strokeSpline
|
||||
|
|
@ -511,15 +513,15 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
|||
. SplineTypeI clo'
|
||||
=> Bool
|
||||
-> Set PointIndex
|
||||
-> Curve clo' CurveData ( PointData brushParams )
|
||||
-> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
|
||||
-> State ( Set PointIndex, Bool )
|
||||
( Curve clo' CurveData ( PointData brushParams ) )
|
||||
( Curve clo' ( CurveData RealWorld ) ( PointData brushParams ) )
|
||||
updateSplineCurve startPtSel strokeSelPts = \case
|
||||
LineTo p1 dat@( CurveData { curveIndex } ) -> do
|
||||
( _, sel0 ) <- State.get
|
||||
( p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p1
|
||||
let
|
||||
dat' :: CurveData
|
||||
dat' :: ( CurveData RealWorld )
|
||||
dat'
|
||||
| sel0 || sel1
|
||||
= invalidateCache dat
|
||||
|
|
@ -532,7 +534,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
|||
( NextPoint p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez2Cp )) ( NextPoint p1 )
|
||||
( p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p2
|
||||
let
|
||||
dat' :: CurveData
|
||||
dat' :: ( CurveData RealWorld )
|
||||
dat'
|
||||
| sel0 || sel1 || sel2
|
||||
= invalidateCache dat
|
||||
|
|
@ -546,7 +548,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
|||
( NextPoint p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez3Cp2 )) ( NextPoint p2 )
|
||||
( p3', sel3 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p3
|
||||
let
|
||||
dat' :: CurveData
|
||||
dat' :: ( CurveData RealWorld )
|
||||
dat'
|
||||
| sel0 || sel1 || sel2 || sel3
|
||||
= invalidateCache dat
|
||||
|
|
@ -644,9 +646,9 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
|||
updateSplineCurve
|
||||
:: forall clo' hasStart. SplineTypeI clo'
|
||||
=> CurrentStart hasStart ( PointData brushParams )
|
||||
-> Curve clo' CurveData ( PointData brushParams )
|
||||
-> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
|
||||
-> Writer ( Set PointIndex )
|
||||
( WitherResult hasStart clo' CurveData ( PointData brushParams ) )
|
||||
( WitherResult hasStart clo' ( CurveData RealWorld ) ( PointData brushParams ) )
|
||||
updateSplineCurve mbPrevPt crv = case crv of
|
||||
|
||||
LineTo p1 ( CurveData { curveIndex } ) ->
|
||||
|
|
@ -789,9 +791,9 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
|
|||
|
||||
updateCurve
|
||||
:: PointData pointParams
|
||||
-> Curve Open CurveData ( PointData pointParams )
|
||||
-> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
|
||||
-> Writer ( Set PointIndex )
|
||||
( Curve Open CurveData ( PointData pointParams ) )
|
||||
( Curve Open ( CurveData RealWorld ) ( PointData pointParams ) )
|
||||
updateCurve sp0 curve = case curve of
|
||||
LineTo ( NextPoint sp1 ) dat@( CurveData { curveIndex } ) -> do
|
||||
let
|
||||
|
|
@ -852,9 +854,9 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
|
|||
pure $ cubicDragCurve dat bez3
|
||||
where
|
||||
quadraticDragCurve
|
||||
:: CurveData
|
||||
:: ( CurveData RealWorld )
|
||||
-> Quadratic.Bezier ( PointData pointParams )
|
||||
-> Curve Open CurveData ( PointData pointParams )
|
||||
-> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
|
||||
quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
|
||||
let
|
||||
cp :: ℝ 2
|
||||
|
|
@ -862,9 +864,9 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
|
|||
Quadratic.interpolate @( T ( ℝ 2 ) ) ( coords sp0 ) ( coords sp2 ) dragCurveParameter p
|
||||
in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat )
|
||||
cubicDragCurve
|
||||
:: CurveData
|
||||
:: ( CurveData RealWorld )
|
||||
-> Cubic.Bezier ( PointData pointParams )
|
||||
-> Curve Open CurveData ( PointData pointParams )
|
||||
-> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
|
||||
cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
|
||||
let
|
||||
cp1, cp2 :: ℝ 2
|
||||
|
|
@ -939,9 +941,9 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
|||
-> ( pointParams -> Record brushFields )
|
||||
-> ( Record brushFields -> pointParams -> pointParams )
|
||||
-> Unique
|
||||
-> PointData pointParams -> Curve clo' CurveData ( PointData pointParams )
|
||||
-> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
|
||||
-> State ( Maybe BrushWidgetActionState, Bool )
|
||||
( Curve clo' CurveData ( PointData pointParams ) )
|
||||
( Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) )
|
||||
updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do
|
||||
( mbAct, prevCurveAct ) <- State.get
|
||||
-- We can only perform a brush widget update if:
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ module MetaBrush.Document.Serialise
|
|||
import Control.Monad
|
||||
( unless )
|
||||
import Control.Monad.ST
|
||||
( stToIO )
|
||||
( RealWorld, stToIO )
|
||||
import qualified Data.Bifunctor as Bifunctor
|
||||
( first )
|
||||
import Data.Functor.Identity
|
||||
|
|
@ -259,7 +259,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
|
|||
. mbEncodeBrush
|
||||
. JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline
|
||||
|
||||
newCurveData :: MonadIO m => ( Integer -> m CurveData )
|
||||
newCurveData :: MonadIO m => ( Integer -> m ( CurveData RealWorld ) )
|
||||
newCurveData i = do
|
||||
noCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
|
||||
return $
|
||||
|
|
|
|||
|
|
@ -11,6 +11,8 @@ module MetaBrush.Draw
|
|||
-- base
|
||||
import Control.Monad
|
||||
( when )
|
||||
import Control.Monad.ST
|
||||
( RealWorld, ST, runST )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Functor.Identity
|
||||
|
|
@ -52,7 +54,7 @@ import Control.Monad.Trans.Reader
|
|||
-- brush-strokes
|
||||
import Math.Bezier.Spline
|
||||
import Math.Bezier.Stroke
|
||||
( invalidateCache )
|
||||
( newCache )
|
||||
import Math.Linear
|
||||
( ℝ(..) )
|
||||
|
||||
|
|
@ -70,6 +72,9 @@ import MetaBrush.Stroke
|
|||
import MetaBrush.Unique
|
||||
( Unique, UniqueSupply, freshUnique )
|
||||
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A draw anchor, to continue drawing from one end of an existing stroke.
|
||||
|
|
@ -216,48 +221,73 @@ addToAnchor :: DrawAnchor -> Spline Open () ( PointData () ) -> Document -> Docu
|
|||
addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = oldContent } ) =
|
||||
let
|
||||
strokes' =
|
||||
runIdentity $
|
||||
runST $
|
||||
forStrokeHierarchy
|
||||
( layerMetadata documentMetadata )
|
||||
( strokeHierarchy oldContent )
|
||||
( \ u s _ -> Identity $ updateStroke u s )
|
||||
( \ u s _ -> updateStroke u s )
|
||||
in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
|
||||
where
|
||||
|
||||
updateStroke :: Unique -> Stroke -> UpdateStroke
|
||||
updateStroke strokeUnique stroke
|
||||
updateStroke :: forall s. Unique -> Stroke -> ST s UpdateStroke
|
||||
updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
|
||||
| strokeUnique == anchorStroke anchor
|
||||
, let
|
||||
updateSpline
|
||||
:: forall clo brushData
|
||||
. SplineTypeI clo
|
||||
=> StrokeSpline clo brushData -> StrokeSpline clo brushData
|
||||
updateSpline prevSpline
|
||||
| SOpen <- ssplineType @clo
|
||||
= if anchorIsAtEnd anchor
|
||||
then
|
||||
let
|
||||
i0 = case splineCurves prevSpline of
|
||||
OpenCurves ( _ :|> lastCurve ) ->
|
||||
curveIndex ( curveData lastCurve ) + 1
|
||||
_ -> 0
|
||||
setBrushData :: PointData () -> PointData brushData
|
||||
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
|
||||
setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData
|
||||
in prevSpline <> setData newSpline
|
||||
else
|
||||
let
|
||||
i0 = case splineCurves prevSpline of
|
||||
OpenCurves ( firstCurve :<| _ ) ->
|
||||
curveIndex ( curveData firstCurve ) - 1
|
||||
_ -> 0
|
||||
setBrushData :: PointData () -> PointData brushData
|
||||
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
|
||||
setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData
|
||||
in setData ( reverseSpline newSpline ) <> prevSpline
|
||||
, SOpen <- ssplineType @clo
|
||||
, let prevSpline0 = co @RealWorld @s oldSpline
|
||||
= do
|
||||
finalSpline <-
|
||||
if anchorIsAtEnd anchor
|
||||
then do
|
||||
( i0, prevSpline ) <-
|
||||
case splineCurves prevSpline0 of
|
||||
OpenCurves ( prevCurves :|> lastCurve ) -> do
|
||||
cache <- newCache
|
||||
-- Invalidate the point we are connecting to (stroke endpoint).
|
||||
let lastCurve' = set ( field' @"curveData" . field' @"cachedStroke" ) cache lastCurve
|
||||
return
|
||||
( curveIndex ( curveData lastCurve ) + 1
|
||||
|
||||
, prevSpline0 { splineCurves =
|
||||
OpenCurves ( prevCurves :|> lastCurve' ) }
|
||||
)
|
||||
OpenCurves _ ->
|
||||
return ( 0, prevSpline0 )
|
||||
newSpline' <- newCaches ( \ i -> i0 + fromIntegral i ) ( brushParams ( splineEnd prevSpline ) ) newSpline
|
||||
return $ prevSpline <> newSpline'
|
||||
else do
|
||||
( i0, prevSpline ) <-
|
||||
case splineCurves prevSpline0 of
|
||||
OpenCurves ( firstCurve :<| nextCurves ) -> do
|
||||
cache <- newCache
|
||||
-- Invalidate the point we are connecting to (stroke endpoint).
|
||||
let firstCurve' = set ( field' @"curveData" . field' @"cachedStroke" ) cache firstCurve
|
||||
return
|
||||
( curveIndex ( curveData firstCurve ) - 1
|
||||
-- Invalidate the point we are connecting to (stroke endpoint).
|
||||
, prevSpline0 { splineCurves = OpenCurves ( firstCurve' :<| nextCurves ) }
|
||||
)
|
||||
OpenCurves _ ->
|
||||
return ( 0, prevSpline0 )
|
||||
newSpline' <- newCaches ( \ i -> i0 - fromIntegral i - 1 ) ( brushParams ( splineStart prevSpline ) ) ( reverseSpline newSpline )
|
||||
return $ newSpline' <> prevSpline
|
||||
return $ UpdateStrokeTo ( stroke { strokeSpline = co @s @RealWorld finalSpline } )
|
||||
| otherwise
|
||||
= assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
|
||||
prevSpline -- should never add to a closed spline
|
||||
= UpdateStrokeTo $ overStrokeSpline updateSpline stroke
|
||||
| otherwise
|
||||
= PreserveStroke
|
||||
= return PreserveStroke
|
||||
|
||||
{-# NOINLINE co #-}
|
||||
co :: forall s t brushParams. Spline Open ( CurveData s ) ( PointData brushParams ) -> Spline Open ( CurveData t ) ( PointData brushParams )
|
||||
co = unsafeCoerce
|
||||
|
||||
newCaches :: ( Int -> Rational )
|
||||
-> brushParams
|
||||
-> Spline Open () ( PointData () )
|
||||
-> ST s ( Spline Open ( CurveData s ) ( PointData brushParams ) )
|
||||
newCaches mkCrvIx brushParams =
|
||||
ibitraverseSpline
|
||||
( \ i _ -> bitraverseCurve
|
||||
( \ _ -> CurveData ( mkCrvIx i ) <$> newCache )
|
||||
( \ _ -> return . setBrushData )
|
||||
)
|
||||
( return . setBrushData )
|
||||
where
|
||||
setBrushData = set ( field @"brushParams" ) brushParams
|
||||
|
|
|
|||
|
|
@ -99,20 +99,20 @@ data PointData params
|
|||
deriving anyclass NFData
|
||||
|
||||
-- | Data attached to each curve in a spline.
|
||||
data CurveData =
|
||||
data CurveData s =
|
||||
CurveData
|
||||
{ curveIndex :: !Rational
|
||||
, cachedStroke :: !( CachedStroke RealWorld )
|
||||
, cachedStroke :: !( CachedStroke s )
|
||||
}
|
||||
deriving stock Generic
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Show CurveData where
|
||||
instance Show ( CurveData s ) where
|
||||
show ( CurveData { curveIndex } ) = show curveIndex
|
||||
instance Eq CurveData where
|
||||
instance Eq ( CurveData s ) where
|
||||
( CurveData { curveIndex = i1 } ) == ( CurveData { curveIndex = i2 } )
|
||||
= i1 == i2
|
||||
instance Ord CurveData where
|
||||
instance Ord ( CurveData s ) where
|
||||
compare ( CurveData { curveIndex = i1 } ) ( CurveData { curveIndex = i2 } )
|
||||
= compare i1 i2
|
||||
|
||||
|
|
@ -135,7 +135,7 @@ coords :: PointData brushParams -> ℝ 2
|
|||
coords = view _coords
|
||||
|
||||
type StrokeSpline clo brushParams =
|
||||
Spline clo CurveData ( PointData brushParams )
|
||||
Spline clo ( CurveData RealWorld ) ( PointData brushParams )
|
||||
|
||||
data Stroke where
|
||||
Stroke
|
||||
|
|
|
|||
Loading…
Reference in a new issue