use STRefs to hold cached outline data

This commit is contained in:
sheaf 2021-02-24 22:45:08 +01:00
parent 6dbade1fae
commit 212ac4fded
8 changed files with 404 additions and 398 deletions

View file

@ -16,10 +16,10 @@ module Main
where
-- base
import Control.Arrow
( (&&&) )
import Control.Monad
( forever, void )
import Control.Monad.ST
( stToIO )
import Data.Foldable
( for_ )
import Data.Function
@ -35,7 +35,7 @@ import GHC.Conc
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( adjust, empty )
( empty )
import qualified Data.Sequence as Seq
( fromList )
import Data.Set
@ -62,12 +62,15 @@ import qualified GI.Cairo.Render.Connector as Cairo
-- gi-gdk
import qualified GI.Gdk as GDK
-- gi-glib
import qualified GI.GLib.Constants as GLib
-- gi-gtk
import qualified GI.Gtk as GTK
-- lens
import Control.Lens
( (.~), set )
( (.~) )
import Control.Lens.At
( at )
@ -75,7 +78,7 @@ import Control.Lens.At
import qualified Control.Concurrent.STM as STM
( atomically, retry )
import qualified Control.Concurrent.STM.TVar as STM
( modifyTVar', newTVarIO, readTVar, writeTVar )
( newTVarIO, readTVar, writeTVar )
-- superrecord
import qualified SuperRecord as Super
@ -103,7 +106,7 @@ import Math.Bezier.Cubic.Fit
import Math.Bezier.Spline
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
import Math.Bezier.Stroke
( CachedStroke(..) )
( invalidateCache )
import Math.Vector2D
( Point2D(..) )
import MetaBrush.Action
@ -122,7 +125,7 @@ import MetaBrush.Context
, HoldAction(..), PartialPath(..)
)
import MetaBrush.Document
( Document(..), emptyDocument
( emptyDocument
, Stroke(..), FocusState(..)
, PointData(..)
)
@ -204,9 +207,9 @@ main = do
Spline
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
, splineCurves = OpenCurves $ Seq.fromList
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = CachedStroke Nothing }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = CachedStroke Nothing }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = CachedStroke Nothing }
[ 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 }
]
}
}
@ -350,14 +353,14 @@ main = do
-- Update the document render data in a separate thread.
_ <- forkIO $ forever do
( !mbUpdatedDoc, renderDoc ) <- STM.atomically do
getRenderDoc <- STM.atomically do
needsRecomputation <- STM.readTVar recomputeStrokesTVar
case needsRecomputation of
False -> STM.retry
True -> do
mbDocNow <- fmap present <$> activeDocument variables
case mbDocNow of
Nothing -> pure ( Nothing, const $ blankRender colours )
Nothing -> pure ( pure . const $ blankRender colours )
Just doc -> do
modifiers <- STM.readTVar modifiersTVar
mbMousePos <- STM.readTVar mousePosTVar
@ -369,26 +372,25 @@ main = do
fitParameters <- STM.readTVar fitParametersTVar
STM.writeTVar recomputeStrokesTVar False
let
addRulers :: ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
addRulers ( Nothing , newRender ) viewportSize = newRender viewportSize
addRulers ( Just newDoc, newRender ) viewportSize = do
addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
addRulers newRender viewportSize = do
newRender viewportSize
renderRuler
colours viewportSize ViewportOrigin viewportSize
mbMousePos mbHoldAction showGuides
newDoc
pure $
( fst &&& addRulers ) $ getDocumentRender
colours fitParameters mode debug
modifiers mbMousePos mbHoldAction mbPartialPath
doc
doc
pure
( addRulers <$> getDocumentRender
colours fitParameters mode debug
modifiers mbMousePos mbHoldAction mbPartialPath
doc
)
renderDoc <- stToIO getRenderDoc
STM.atomically do
STM.writeTVar documentRenderTVar renderDoc
for_ mbUpdatedDoc \ newDoc -> do
mbCurrDocUnique <- STM.readTVar activeDocumentTVar
for_ mbCurrDocUnique \ currDocUnique -> do
STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
GTK.widgetQueueDraw viewportDrawingArea
void do
GDK.threadsAddIdle GLib.PRIORITY_HIGH_IDLE
( False <$ GTK.widgetQueueDraw viewportDrawingArea )
-- Render the document using the latest available draw data.
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do

View file

@ -17,6 +17,8 @@ module MetaBrush.Action where
-- base
import Control.Monad
( guard, when, unless, void )
import Control.Monad.ST
( RealWorld )
import Data.Foldable
( for_, sequenceA_ )
import Data.Int
@ -84,7 +86,7 @@ import Math.Bezier.Spline
, catMaybesSpline
)
import Math.Bezier.Stroke
( CachedStroke(..) )
( CachedStroke(..), invalidateCache )
import Math.Module
( Module((*^)) )
import Math.Vector2D
@ -621,7 +623,6 @@ instance HandleAction MouseMove where
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
modifiers <- STM.readTVar modifiersTVar
mbMouseHold <- STM.readTVar mouseHoldTVar
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
@ -636,14 +637,10 @@ instance HandleAction MouseMove where
case tool of
Pen
| Just pp <- mbPartialPath
-> do
STM.writeTVar recomputeStrokesTVar True
when ( any ( \ case { Control _ -> True; _ -> False } ) modifiers ) do
STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ | Just _ <- mbMouseHold
-> STM.writeTVar recomputeStrokesTVar True
| otherwise
-> pure ()
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ -> pure ()
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
pure do
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
@ -938,8 +935,8 @@ instance HandleAction MouseRelease where
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Spline Open CachedStroke ( PointData () )
newSegment = catMaybesSpline ( CachedStroke Nothing )
newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
newSegment = catMaybesSpline ( invalidateCache undefined )
( PointData p1 Normal () )
( do
cp <- mbCp2
@ -967,8 +964,8 @@ instance HandleAction MouseRelease where
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Spline Open CachedStroke ( PointData () )
newSegment = catMaybesSpline ( CachedStroke Nothing )
newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
newSegment = catMaybesSpline ( invalidateCache undefined )
( PointData p1 Normal () )
( do
cp <- mbCp2

View file

@ -20,6 +20,8 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module MetaBrush.Document
( AABB(..), mkAABB
, Document(..), DocumentContent(..)
@ -34,6 +36,8 @@ module MetaBrush.Document
where
-- base
import Control.Monad.ST
( RealWorld )
import Data.Coerce
( coerce )
import Data.Functor.Identity
@ -156,7 +160,7 @@ data DocumentContent
deriving stock ( Show, Generic )
deriving anyclass NFData
type StrokeSpline ty brushParams = Spline ty CachedStroke ( PointData brushParams )
type StrokeSpline ty brushParams = Spline ty ( CachedStroke RealWorld ) ( PointData brushParams )
data Stroke where
Stroke

View file

@ -27,6 +27,8 @@ module MetaBrush.Document.Selection
-- base
import Control.Monad
( guard )
import Control.Monad.ST
( RealWorld )
import Data.Functor
( ($>) )
import Data.Functor.Identity
@ -84,8 +86,8 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
( MaybeT(..) )
import Control.Monad.Trans.State.Strict
( StateT, State
, runState, evalState, evalStateT
( StateT(..), State
, evalState, evalStateT, runState
, get, put, modify'
)
import Control.Monad.Trans.Writer.CPS
@ -106,7 +108,7 @@ import Math.Bezier.Spline
, fromNextPoint
)
import Math.Bezier.Stroke
( CachedStroke(..), discardCache )
( CachedStroke(..), invalidateCache )
import Math.Module
( lerp, squaredNorm, closestPointOnSegment )
import Math.Vector2D
@ -247,10 +249,10 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
:: forall clo' brushParams
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
=> PointData brushParams -> Bool -> Unique
-> Int -> PointData brushParams -> Curve clo' CachedStroke ( PointData brushParams )
-> Int -> PointData brushParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams )
-> WriterT ( Maybe DragMoveSelect )
( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) )
( Curve clo' CachedStroke ( PointData brushParams ) )
( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) )
updateSplineCurve start isVisible uniq i sp0 curve = case curve of
line@( LineTo sp1 _ ) -> do
let
@ -434,44 +436,44 @@ translateSelection t doc =
:: forall clo'
. SplineTypeI clo'
=> PointData brushParams
-> Curve clo' CachedStroke ( PointData brushParams )
-> StateT Bool ( State UpdateInfo ) ( Curve clo' CachedStroke ( PointData brushParams ) )
-> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams )
-> StateT Bool ( State UpdateInfo ) ( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) )
updateSplineCurve start crv = do
prevMod <- get
case crv of
LineTo p1 dat -> do
p1' <- traverse ( updatePoint PathPoint ) p1
pure $ LineTo p1' dat'
where
dat' :: CachedStroke
let
dat' :: CachedStroke RealWorld
dat'
| prevMod || ( view _selection ( fromNextPoint start p1 ) == Selected )
= discardCache dat
= invalidateCache dat
| otherwise
= dat
pure $ LineTo p1' dat'
Bezier2To p1 p2 dat -> do
p1' <- updatePoint ControlPoint p1
p2' <- traverse ( updatePoint PathPoint ) p2
pure $ Bezier2To p1' p2' dat'
where
dat' :: CachedStroke
let
dat' :: CachedStroke RealWorld
dat'
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, fromNextPoint start p2 ]
= discardCache dat
= invalidateCache dat
| otherwise
= dat
pure $ Bezier2To p1' p2' dat'
Bezier3To p1 p2 p3 dat -> do
p1' <- updatePoint ControlPoint p1
p2' <- updatePoint ControlPoint p2
p3' <- traverse ( updatePoint PathPoint ) p3
pure $ Bezier3To p1' p2' p3' dat'
where
dat' :: CachedStroke
let
dat' :: CachedStroke RealWorld
dat'
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, p2, fromNextPoint start p3 ]
= discardCache dat
= invalidateCache dat
| otherwise
= dat
pure $ Bezier3To p1' p2' p3' dat'
updatePoint :: PointType -> PointData brushParams -> StateT Bool ( State UpdateInfo ) ( PointData brushParams )
updatePoint PathPoint pt
@ -499,16 +501,13 @@ translateSelection t doc =
--
-- Returns the updated document, together with info about how many points were deleted.
deleteSelected :: Document -> ( Document, UpdateInfo )
deleteSelected doc = deletionResult
deleteSelected doc =
( `runState` mempty ) $
( field' @"documentContent" . field' @"strokes" )
( fmap catMaybes . traverse updateStroke )
doc
where
deletionResult :: ( Document, UpdateInfo )
deletionResult
= ( `runState` mempty )
$ ( field' @"documentContent" . field' @"strokes" )
( fmap catMaybes . traverse updateStroke )
doc
updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke )
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke
where
@ -528,9 +527,6 @@ deleteSelected doc = deletionResult
oldSpline
where
noDat :: CachedStroke
noDat = CachedStroke Nothing
updateSplinePoint
:: Unique
-> PointData brushParams
@ -552,12 +548,12 @@ deleteSelected doc = deletionResult
:: forall clo'. SplineTypeI clo'
=> Unique
-> Maybe ( PointData brushParams )
-> Curve clo' CachedStroke ( PointData brushParams )
-> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams )
-> State UpdateInfo
( Maybe ( Curve clo' CachedStroke ( PointData brushParams ) ) )
( Maybe ( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) ) )
updateSplineCurve uniq mbPrevPt crv =
case crv of
LineTo p1 _ ->
LineTo p1 dat ->
case ssplineType @clo' of
SOpen
| NextPoint pt <- p1
@ -570,9 +566,11 @@ deleteSelected doc = deletionResult
pure Nothing
_ ->
case mbPrevPt of
Nothing -> pure ( Just $ LineTo p1 noDat ) -- no need to update "strokesAffected"
Just _ -> pure ( Just crv )
Bezier2To cp1 p2 _ ->
Nothing ->
pure ( Just $ LineTo p1 ( invalidateCache dat ) ) -- no need to update "strokesAffected"
Just _ ->
pure ( Just crv )
Bezier2To cp1 p2 dat ->
case ssplineType @clo' of
SOpen
| NextPoint pt <- p2
@ -593,8 +591,8 @@ deleteSelected doc = deletionResult
( over ( field' @"controlPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ LineTo p2 noDat )
Bezier3To cp1 cp2 p3 _ ->
pure ( Just $ LineTo p2 ( invalidateCache dat ) )
Bezier3To cp1 cp2 p3 dat ->
case ssplineType @clo' of
SOpen
| NextPoint pt <- p3
@ -618,62 +616,61 @@ deleteSelected doc = deletionResult
( over ( field' @"controlPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ Bezier2To cp1 p3 noDat )
pure ( Just $ Bezier2To cp1 p3 ( invalidateCache dat ) )
| Normal <- view _selection cp2
-> do
modify'
( over ( field' @"controlPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ Bezier2To cp2 p3 noDat )
pure ( Just $ Bezier2To cp2 p3 ( invalidateCache dat ) )
_ -> do
modify'
( over ( field' @"controlPointsAffected" ) ( <> 2 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ LineTo p3 noDat )
pure ( Just $ LineTo p3 ( invalidateCache dat ) )
-- | Perform a drag move action on a document.
dragUpdate :: Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
dragUpdate p0 p PointDrag _ doc = case updateInfo of
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
| null strokesAffected
-> Nothing
| let
ppMv, cpMv :: Maybe Text
ppMv
| pathPointsAffected == 0
= Nothing
| otherwise
= Just ( Text.pack ( show pathPointsAffected ) <> " path points" )
cpMv
| controlPointsAffected == 0
= Nothing
| otherwise
= Just ( Text.pack ( show controlPointsAffected ) <> " control points" )
changeText :: Text
changeText =
"Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
-> Just ( HistoryChange { newDocument, changeText } )
where
newDocument :: Document
updateInfo :: UpdateInfo
dragUpdate p0 p PointDrag _ doc = do
let
( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc
dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc
| Just name <- mbStrokeName
, let
changeText :: Text
changeText = "Drag curve segment of " <> name
= Just ( HistoryChange { newDocument, changeText } )
| otherwise
= Nothing
case updateInfo of
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
| null strokesAffected
-> Nothing
| let
ppMv, cpMv :: Maybe Text
ppMv
| pathPointsAffected == 0
= Nothing
| otherwise
= Just ( Text.pack ( show pathPointsAffected ) <> " path points" )
cpMv
| controlPointsAffected == 0
= Nothing
| otherwise
= Just ( Text.pack ( show controlPointsAffected ) <> " control points" )
changeText :: Text
changeText =
"Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
-> Just ( HistoryChange { newDocument, changeText } )
dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc =
let
( newDocument, mbStrokeName ) =
( `runState` Nothing ) $
( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
in case mbStrokeName of
Just name -> do
let
changeText :: Text
changeText = "Drag curve segment of " <> name
Just ( HistoryChange { newDocument, changeText } )
_ -> Nothing
where
newDocument :: Document
mbStrokeName :: Maybe Text
( newDocument, mbStrokeName )
= ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
updateStroke :: Stroke -> State ( Maybe Text ) Stroke
updateStroke stroke@( Stroke { strokeUnique, strokeName } )
| strokeUnique /= dragStrokeUnique
@ -696,18 +693,21 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
updateSplineCurves
:: Text
-> StrokeSpline Open pointParams
-> State ( Maybe Text ) ( StrokeSpline Open pointParams)
-> State ( Maybe Text ) ( StrokeSpline Open pointParams )
updateSplineCurves name spline = case splitSplineAt dragSegmentIndex spline of
( _ , Spline { splineCurves = OpenCurves Empty } ) -> pure spline
( bef, Spline { splineStart, splineCurves = OpenCurves ( curve :<| next ) } ) -> do
put ( Just name )
pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ updateCurve ( lastPoint bef ) curve :<| next } )
let
curve' :: Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
curve' = updateCurve ( lastPoint bef ) curve
pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ curve':<| next } )
where
updateCurve
:: PointData pointParams
-> Curve Open CachedStroke ( PointData pointParams )
-> Curve Open CachedStroke ( PointData pointParams )
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
updateCurve sp0 curve = case curve of
LineTo ( NextPoint sp1 ) dat -> do
let
@ -737,21 +737,19 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
else cubicDragCurve dat bez3
where
quadraticDragCurve
:: CachedStroke
:: CachedStroke RealWorld
-> Quadratic.Bezier ( PointData pointParams )
-> Curve Open CachedStroke ( PointData pointParams )
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
let
cp :: Point2D Double
Quadratic.Bezier { Quadratic.p1 = cp } =
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p
dat' :: CachedStroke
dat' = discardCache dat
in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) dat'
in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat )
cubicDragCurve
:: CachedStroke
:: CachedStroke RealWorld
-> Cubic.Bezier ( PointData pointParams )
-> Curve Open CachedStroke ( PointData pointParams )
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
let
cp1, cp2 :: Point2D Double
@ -760,6 +758,4 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
dragSegmentParameter
p
dat' :: CachedStroke
dat' = discardCache dat
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) dat'
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat )

View file

@ -25,6 +25,8 @@ import Control.Arrow
( (&&&), first )
import Control.Monad
( unless )
import Control.Monad.ST
( RealWorld, stToIO )
import qualified Data.Bifunctor as Bifunctor
( first )
import Data.Foldable
@ -33,6 +35,8 @@ import Data.Functor.Contravariant
( contramap )
import Data.Functor.Identity
( Identity(..) )
import Data.STRef
( newSTRef )
import Data.Type.Equality
( (:~:)(Refl) )
import GHC.Exts
@ -367,31 +371,33 @@ encodeCurve encodePtData = case ssplineType @clo of
decodeCurve
:: forall clo ptData m
. ( SplineTypeI clo, Monad m )
. ( SplineTypeI clo, MonadIO m )
=> JSON.Decoder m ptData
-> JSON.Decoder m ( Curve clo CachedStroke ptData )
decodeCurve decodePtData = case ssplineType @clo of
SOpen -> do
p1 <- JSON.Decoder.atKey "p1" decodePtData
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
case mb_p2 of
Nothing ->
pure ( LineTo ( NextPoint p1 ) ( CachedStroke Nothing ) )
Just p2 -> do
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
case mb_p3 of
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) ( CachedStroke Nothing ) )
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) ( CachedStroke Nothing ) )
SClosed -> do
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
case mb_p1 of
Nothing ->
pure ( LineTo BackToStart ( CachedStroke Nothing ) )
Just p1 -> do
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
case mb_p2 of
Nothing -> pure ( Bezier2To p1 BackToStart ( CachedStroke Nothing ) )
Just p2 -> pure ( Bezier3To p1 p2 BackToStart ( CachedStroke Nothing ) )
-> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
decodeCurve decodePtData = do
noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
case ssplineType @clo of
SOpen -> do
p1 <- JSON.Decoder.atKey "p1" decodePtData
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
case mb_p2 of
Nothing ->
pure ( LineTo ( NextPoint p1 ) noCache )
Just p2 -> do
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
case mb_p3 of
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) noCache )
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
SClosed -> do
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
case mb_p1 of
Nothing ->
pure ( LineTo BackToStart noCache )
Just p1 -> do
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
case mb_p2 of
Nothing -> pure ( Bezier2To p1 BackToStart noCache )
Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
@ -413,9 +419,9 @@ encodeCurves encodePtData = case ssplineType @clo of
decodeCurves
:: forall clo ptData m
. ( SplineTypeI clo, Monad m )
. ( SplineTypeI clo, MonadIO m )
=> JSON.Decoder m ptData
-> JSON.Decoder m ( Curves clo CachedStroke ptData )
-> JSON.Decoder m ( Curves clo ( CachedStroke RealWorld ) ptData )
decodeCurves decodePtData = case ssplineType @clo of
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
SClosed -> do
@ -440,9 +446,9 @@ encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, sp
decodeSpline
:: forall clo ptData m
. ( SplineTypeI clo, Monad m )
. ( SplineTypeI clo, MonadIO m )
=> JSON.Decoder m ptData
-> JSON.Decoder m ( Spline clo CachedStroke ptData )
-> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
decodeSpline decodePtData = do
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )

View file

@ -13,8 +13,8 @@ module MetaBrush.Document.SubdivideStroke
where
-- base
import Data.Functor
( ($>) )
import Control.Monad.ST
( RealWorld )
import Data.Semigroup
( Min(..), Arg(..) )
@ -54,7 +54,7 @@ import Math.Bezier.Spline
, KnownSplineType(bifoldSpline, adjustSplineType)
)
import Math.Bezier.Stroke
( CachedStroke, discardCache )
( CachedStroke(..), invalidateCache )
import Math.Module
( lerp, quadrance, closestPointOnSegment )
import Math.Vector2D
@ -71,16 +71,17 @@ import MetaBrush.MetaParameter.Interpolation
-- | Subdivide a path at the given center, provided a path indeed lies there.
subdivide :: Point2D Double -> Document -> Maybe ( Document, Text )
subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
where
subdivide c doc@( Document { zoomFactor } ) =
let
updatedDoc :: Document
mbSubdivLoc :: Maybe Text
( updatedDoc, mbSubdivLoc )
= ( `runState` Nothing )
$ ( field' @"documentContent" . field' @"strokes" . traverse )
updateStroke
doc
( updatedDoc, mbSubdivLoc ) =
( `runState` Nothing )
$ ( field' @"documentContent" . field' @"strokes" . traverse )
updateStroke
doc
in ( updatedDoc , ) <$> mbSubdivLoc
where
updateStroke :: Stroke -> State ( Maybe Text ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke
@ -104,9 +105,9 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
:: Text
-> Vector2D Double
-> PointData brushParams
-> Curve Open CachedStroke ( PointData brushParams )
-> Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
-> State ( Maybe Text )
( Seq ( Curve Open CachedStroke ( PointData brushParams ) ) )
( Seq ( Curve Open ( CachedStroke RealWorld ) ( PointData brushParams ) ) )
updateCurve txt offset sp0 curve = case curve of
line@( LineTo ( NextPoint sp1 ) dat ) ->
let
@ -122,9 +123,9 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
let
subdiv :: PointData brushParams
subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1
dat' :: CachedStroke
dat' = discardCache dat
in put ( Just txt ) $> ( LineTo ( NextPoint subdiv ) dat' :<| LineTo ( NextPoint sp1 ) dat' :<| Empty )
in do
put ( Just txt )
pure ( LineTo ( NextPoint subdiv ) ( invalidateCache dat ) :<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) :<| Empty )
else pure $ Seq.singleton line
bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
let
@ -137,14 +138,13 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
= Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset c )
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then case Quadratic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) ->
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
let
dat' :: CachedStroke
dat' = discardCache dat
bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
bez_start = Bezier2To q1 ( NextPoint subdiv ) dat'
bez_end = Bezier2To r1 ( NextPoint sp2 ) dat'
in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat )
put ( Just txt )
pure ( bez_start :<| bez_end :<| Empty )
else pure $ Seq.singleton bez2
bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
let
@ -157,12 +157,11 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
= Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset c )
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then case Cubic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) ->
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
let
dat' :: CachedStroke
dat' = discardCache dat
bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) dat'
bez_end = Bezier3To r1 r2 ( NextPoint sp2 ) dat'
in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
bez_end = Bezier3To r1 r2 ( NextPoint sp2 ) ( invalidateCache dat )
put ( Just txt )
pure ( bez_start :<| bez_end :<| Empty )
else pure $ Seq.singleton bez3

View file

@ -25,6 +25,8 @@ module MetaBrush.Render.Document
-- base
import Control.Monad
( guard, when, unless )
import Control.Monad.ST
( RealWorld, ST )
import Data.Fixed
( mod' )
import Data.Foldable
@ -68,16 +70,12 @@ import Control.DeepSeq
import Generic.Data
( Generically1(..) )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
-- lens
import Control.Lens
( view, set )
( view )
-- superrecord
import qualified SuperRecord as Super
@ -106,7 +104,9 @@ import Math.Bezier.Spline
, catMaybesSpline
)
import Math.Bezier.Stroke
( CachedStroke(..), computeStrokeOutline )
( CachedStroke(..), invalidateCache
, computeStrokeOutline
)
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Asset.Colours
@ -173,102 +173,90 @@ getDocumentRender
:: Colours -> FitParameters -> Mode -> Bool
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
-> Document
-> ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () )
-> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () )
getDocumentRender
cols fitParams mode debug
modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } )
= strokesRenderData `deepseq` ( mbUpdatedDoc, drawingInstructions )
= do
where
let
-- Get any modifications from in-flight user actions (e.g. in the middle of dragging something).
modifiedStrokes :: [ Stroke ]
modifiedStrokes = case mode of
PathMode
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
, Just p1 <- mbMousePos
, p0 /= p1
, let
alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
afterDrag :: Maybe DocChange
afterDrag = dragUpdate p0 p1 dragAction alternateMode doc
-> case afterDrag of
Just docUpdate -> ( strokes . documentContent $ newDocument docUpdate )
_ -> ( strokes content )
| Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
, let
mbFinalPoint :: Maybe ( Point2D Double )
mbControlPoint :: Maybe ( Point2D Double )
( mbFinalPoint, mbControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldEvent
= ( Just holdPos, ( \ cp -> ( cp --> holdPos :: Vector2D Double ) holdPos ) <$> mbMousePos )
| otherwise
= ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint
-> let
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec '[] ) )
previewSpline = catMaybesSpline ( invalidateCache undefined )
( PointData p0 Normal SuperRecord.rnil )
( do
cp <- cp0
guard ( cp /= p0 )
pure ( PointData cp Normal SuperRecord.rnil )
)
( do
cp <- mbControlPoint
guard ( cp /= finalPoint )
pure ( PointData cp Normal SuperRecord.rnil )
)
( PointData finalPoint Normal SuperRecord.rnil )
in
( ( Stroke
{ strokeSpline = previewSpline
, strokeVisible = True
, strokeUnique = unsafeUnique 987654321
, strokeName = "Preview stroke (temporary)"
, strokeBrushRef = NoBrush
}
) : strokes content
)
_ -> strokes content
drawingInstructions :: ( Int32, Int32 ) -> Cairo.Render ()
drawingInstructions ( viewportWidth, viewportHeight ) = do
Cairo.save
Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
Cairo.scale zoomFactor zoomFactor
Cairo.translate ( -cx ) ( -cy )
for_ strokesRenderData
( compositeRenders . getCompose . renderStroke cols mbHoverContext mode debug zoomFactor )
renderSelectionRect
Cairo.restore
renderSelectionRect :: Cairo.Render ()
mbHoverContext :: Maybe HoverContext
( renderSelectionRect, mbHoverContext )
| Just ( SelectionHold p0 ) <- mbHoldEvent
, Just p1 <- mbMousePos
= ( drawSelectionRectangle cols zoomFactor p0 p1, Just $ RectangleHover ( mkAABB p0 p1 ) )
| otherwise
= ( pure (), MouseHover <$> mbMousePos )
strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams documentBrushes ) modifiedStrokes
modifiedStrokes :: [ Stroke ]
noModifiedStrokes :: Bool
( modifiedStrokes, noModifiedStrokes )
| PathMode <- mode
, Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
, Just p1 <- mbMousePos
, p0 /= p1
, let
alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
, Just docUpdate <- dragUpdate p0 p1 dragAction alternateMode doc
= ( strokes . documentContent $ newDocument docUpdate, False )
| PathMode <- mode
, Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
, let
mbFinalPoint :: Maybe ( Point2D Double )
mbControlPoint :: Maybe ( Point2D Double )
( mbFinalPoint, mbControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldEvent
= ( Just holdPos, ( \ cp -> ( cp --> holdPos :: Vector2D Double ) holdPos ) <$> mbMousePos )
| otherwise
= ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint
, let
previewSpline :: Spline Open CachedStroke ( PointData ( Super.Rec '[] ) )
previewSpline = catMaybesSpline ( CachedStroke Nothing )
( PointData p0 Normal SuperRecord.rnil )
( do
cp <- cp0
guard ( cp /= p0 )
pure ( PointData cp Normal SuperRecord.rnil )
)
( do
cp <- mbControlPoint
guard ( cp /= finalPoint )
pure ( PointData cp Normal SuperRecord.rnil )
)
( PointData finalPoint Normal SuperRecord.rnil )
= ( ( Stroke
{ strokeSpline = previewSpline
, strokeVisible = True
, strokeUnique = unsafeUnique 987654321
, strokeName = "Preview stroke (temporary)"
, strokeBrushRef = NoBrush
}
)
: strokes content
, False
)
| otherwise
= ( strokes content, True )
let
renderSelectionRect :: Cairo.Render ()
mbHoverContext :: Maybe HoverContext
( renderSelectionRect, mbHoverContext )
| Just ( SelectionHold p0 ) <- mbHoldEvent
, Just p1 <- mbMousePos
= ( drawSelectionRectangle cols zoomFactor p0 p1, Just $ RectangleHover ( mkAABB p0 p1 ) )
| otherwise
= ( pure (), MouseHover <$> mbMousePos )
strokesRenderData :: [ StrokeRenderData ]
strokesRenderData = mapMaybe ( strokeRenderData fitParams documentBrushes ) modifiedStrokes
mbUpdatedDoc :: Maybe Document
mbUpdatedDoc
| noModifiedStrokes
= let
newDoc :: Document
newDoc =
set ( field' @"documentContent" . field' @"strokes" )
( modifiedStrokes )
doc
in Just newDoc
| otherwise
= Nothing -- TODO: update the original document in this case too (by undoing the modifications)
drawingInstructions :: ( Int32, Int32 ) -> Cairo.Render ()
drawingInstructions ( viewportWidth, viewportHeight ) = do
Cairo.save
Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
Cairo.scale zoomFactor zoomFactor
Cairo.translate ( -cx ) ( -cy )
for_ strokesRenderData
( compositeRenders . getCompose . renderStroke cols mbHoverContext mode debug zoomFactor )
renderSelectionRect
Cairo.restore
strokesRenderData `deepseq` pure drawingInstructions
-- | Utility type to gather information needed to render a stroke.
-- - No outline: just the underlying spline.
@ -305,39 +293,43 @@ instance NFData StrokeRenderData where
-- - the computed outline (using fitting algorithm),
-- - the brush shape function.
-- - Otherwise, this consists of the underlying spline path only.
strokeRenderData :: FitParameters -> Map Unique Brush -> Stroke -> Maybe StrokeRenderData
strokeRenderData fitParams brushes ( Stroke { strokeSpline = spline :: StrokeSpline clo ( Super.Rec pointFields ), .. } ) =
if strokeVisible
then case strokeBrushRef of
BrushReference ( _ :: Proxy# brushFields ) brushUnique
-- TODO: could emit a warning if the following lookup fails.
| Just ( BrushData { brushFunction = AdaptableFunction brushFn :: BrushFunction brushFields' } ) <- Map.lookup brushUnique brushes
-- TODO: the following check could be skipped if we are feeling confident.
, Just Refl <- eqTys @brushFields @brushFields' -- Refl <- ( unsafeCoerce Refl :: brushFields :~: brushFields' )
, ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
, let
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
-- Compute the outline using the brush function.
newSpline :: Spline clo CachedStroke ( PointData ( Super.Rec pointFields ) )
outline :: Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
fitPts :: Seq FitPoint
( newSpline, outline, fitPts ) =
computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
fitParams ( toUsedParams . brushParams ) brushShapeFn spline
-> Just $
StrokeWithOutlineRenderData
{ strokeDataSpline = newSpline
, strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = brushShapeFn . toUsedParams
}
_ -> Just $
StrokeRenderData
{ strokeDataSpline = spline }
else Nothing
strokeRenderData :: FitParameters -> Map Unique Brush -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
strokeRenderData fitParams brushes
( Stroke
{ strokeSpline = spline :: StrokeSpline clo pointParams
, strokeBrushRef = ( strokeBrushRef :: BrushReference pointFields )
, ..
}
) | strokeVisible
= Just $ case strokeBrushRef of
BrushReference ( _ :: Proxy# brushFields ) brushUnique
-- TODO: could emit a warning if the following lookup fails.
| Just ( BrushData { brushFunction = AdaptableFunction brushFn :: BrushFunction brushFields' } ) <- Map.lookup brushUnique brushes
-- TODO: the following check could be skipped if we are feeling confident.
, Just Refl <- eqTys @brushFields @brushFields' -- Refl <- ( unsafeCoerce Refl :: brushFields :~: brushFields' )
, ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
, let
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
-> do
-- Compute the outline using the brush function.
( outline, fitPts ) <-
computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
fitParams ( toUsedParams . brushParams ) brushShapeFn spline
pure $
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = brushShapeFn . toUsedParams
}
_ -> pure $
StrokeRenderData
{ strokeDataSpline = spline }
| otherwise
= Nothing
renderStroke
:: Colours -> Maybe HoverContext -> Mode -> Bool -> Double

View file

@ -8,15 +8,18 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
module Math.Bezier.Stroke
( Offset(..)
, CachedStroke(..), discardCache
, CachedStroke(..), discardCache, invalidateCache
, computeStrokeOutline, joinWithBrush
, withTangent
, between, parallel
@ -30,6 +33,8 @@ import Control.Arrow
( first, (***) )
import Control.Monad
( guard, unless )
import Control.Monad.ST
( RealWorld, ST )
import Data.Bifunctor
( Bifunctor(bimap) )
import Data.Foldable
@ -38,6 +43,10 @@ import Data.List.NonEmpty
( unzip )
import Data.Maybe
( fromMaybe, mapMaybe )
import GHC.Exts
( newMutVar#, runRW# )
import GHC.STRef
( STRef(..), readSTRef, writeSTRef )
import GHC.Generics
( Generic, Generic1 )
@ -57,7 +66,7 @@ import qualified Data.Sequence as Seq
-- deepseq
import Control.DeepSeq
( NFData, NFData1 )
( NFData(..), NFData1, deepseq )
-- generic-lens
import Data.Generics.Product.Typed
@ -81,7 +90,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.State.Strict
( StateT, runStateT, evalStateT, get, put )
import Control.Monad.Trans.Writer.CPS
( Writer, runWriter, tell )
( WriterT, execWriterT, runWriter, tell )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
@ -92,7 +101,7 @@ import Math.Bezier.Spline
, ssplineType, adjustSplineType
, NextPoint(..), fromNextPoint
, KnownSplineType
( bitraverseSpline, ibifoldSpline, bimapSpline )
( bifoldSpline, ibifoldSpline, bimapSpline )
, Spline(..), SplinePts, Curves(..), Curve(..)
, openCurveStart, openCurveEnd
, splitSplineAt, dropCurves
@ -140,12 +149,23 @@ instance Monoid OutlineData where
empt :: ( SplinePts Open, Seq FitPoint )
empt = ( Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }, Empty )
newtype CachedStroke = CachedStroke { upToDateFit :: Maybe OutlineData }
deriving stock ( Show, Generic )
deriving anyclass NFData
newtype CachedStroke s = CachedStroke { cachedStrokeRef :: STRef s ( Maybe OutlineData ) }
instance Show ( CachedStroke s ) where
show _ = "CachedStroke..."
instance NFData ( CachedStroke s ) where
rnf _ = ()
discardCache :: HasType CachedStroke crvData => crvData -> crvData
discardCache = set ( typed @CachedStroke ) ( CachedStroke Nothing )
discardCache :: forall crvData s. HasType ( CachedStroke s ) crvData => crvData -> ST s ()
discardCache ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) =
writeSTRef cachedStrokeRef Nothing
{-# INLINE invalidateCache #-}
invalidateCache :: forall crvData. HasType ( CachedStroke RealWorld ) crvData => crvData -> crvData
invalidateCache = runRW# \ s -> do
case newMutVar# Nothing s of
(# _, mutVar #) ->
set ( typed @( CachedStroke RealWorld ) )
( CachedStroke $ STRef mutVar )
coords :: forall ptData. HasType ( Point2D Double ) ptData => ptData -> Point2D Double
coords = view typed
@ -153,22 +173,22 @@ coords = view typed
--------------------------------------------------------------------------------
computeStrokeOutline ::
forall diffParams ( clo :: SplineType ) brushParams crvData ptData
forall diffParams ( clo :: SplineType ) brushParams crvData ptData s
. ( KnownSplineType clo
, Group diffParams, Module Double diffParams
, Torsor diffParams brushParams
, HasType ( Point2D Double ) ptData
, HasType CachedStroke crvData
, HasType ( CachedStroke s ) crvData
, NFData ptData, NFData crvData
)
=> FitParameters
-> ( ptData -> brushParams )
-> ( brushParams -> SplinePts Closed )
-> Spline clo crvData ptData
-> ( Spline clo crvData ptData
, Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
, Seq FitPoint
)
-> ST s
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
, Seq FitPoint
)
computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of
-- Open brush path with at least one segment.
SOpen
@ -186,11 +206,6 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
startBrush, endBrush :: SplinePts Closed
startBrush = brushShape spt0
endBrush = brushShape endPt
fwdPts, bwdPts :: SplinePts Open
fwdFits, bwdFits :: Seq FitPoint
newSpline :: Spline clo crvData ptData
( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
= updateSpline startTgt
startCap, endCap :: SplinePts Open
startCap
= fmap ( MkVector2D ( coords spt0 ) )
@ -198,10 +213,12 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
endCap
= fmap ( MkVector2D ( coords endPt ) )
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
-> ( newSpline
, Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, fwdFits <> bwdFits
)
-> do
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline startTgt
pure
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, fwdFits <> bwdFits
)
-- Closed brush path with at least one segment.
SClosed
| ClosedCurves prevCurves lastCurve <- splineCurves
@ -213,52 +230,48 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
endTgt = case prevCurves of
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
fwdPts, bwdPts :: SplinePts Open
fwdFits, bwdFits :: Seq FitPoint
newSpline :: Spline clo crvData ptData
( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
= updateSpline endTgt
fwdStartCap, bwdStartCap :: SplinePts Open
TwoSided fwdStartCap bwdStartCap
= fmap fst . snd . runWriter
$ tellBrushJoin endTgt spt0 startTgt
-> ( newSpline
, Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
, fwdFits <> bwdFits
)
-> do
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline endTgt
pure
( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
, fwdFits <> bwdFits
)
-- Single point.
_ -> ( spline
, Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) ) ( brushShape spt0 )
, Empty
)
_ ->
pure
( Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) ) ( brushShape spt0 )
, Empty
)
where
brushShape :: ptData -> SplinePts Closed
brushShape pt = brushFn ( ptParams pt )
updateSpline :: Vector2D Double -> ( Spline clo crvData ptData, OutlineData )
updateSpline :: Vector2D Double -> ST s OutlineData
updateSpline lastTgt
= runWriter
= execWriterT
. ( `evalStateT` lastTgt )
$ fmap ( adjustSplineType @clo )
$ bitraverseSpline
$ bifoldSpline
( \ ptData curve -> do
prev_tgt <- get
let
tgt :: Vector2D Double
tgt = startTangent spt0 ptData curve
lift $ tellBrushJoin prev_tgt ptData tgt
curve' <- lift $ strokeOutline ptData curve
lift $ strokeOutline ptData curve
put ( endTangent spt0 ptData curve )
pure curve'
)
pure
( const ( pure () ) )
( adjustSplineType @Open spline )
strokeOutline
:: ptData -> Curve Open crvData ptData
-> Writer OutlineData ( Curve Open crvData ptData )
strokeOutline sp0 line@( LineTo { curveEnd = NextPoint sp1, curveData } ) =
:: ptData -> Curve Open crvData ptData
-> WriterT OutlineData ( ST s ) ()
strokeOutline sp0 ( LineTo { curveEnd = NextPoint sp1, curveData } ) =
let
p0, p1 :: Point2D Double
p0 = coords sp0
@ -296,10 +309,9 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
in do
crvData' <- updateCurveData curveData fwd bwd
pure ( line { curveData = crvData' } )
strokeOutline sp0 bez2@( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
in
updateCurveData curveData fwd bwd
strokeOutline sp0 ( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
let
p0, p1, p2 :: Point2D Double
p0 = coords sp0
@ -340,10 +352,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
in do
crvData' <- updateCurveData curveData fwd bwd
pure ( bez2 { curveData = crvData' } )
strokeOutline sp0 bez3@( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) =
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
@ -385,41 +395,41 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
in do
crvData' <- updateCurveData curveData fwd bwd
pure ( bez3 { curveData = crvData' } )
in updateCurveData curveData fwd bwd
updateCurveData
:: crvData
-> ( Double -> ( Point2D Double, Vector2D Double ) )
-> ( Double -> ( Point2D Double, Vector2D Double ) )
-> Writer OutlineData crvData
updateCurveData curveData fwd bwd = case upToDateFit $ view ( typed @CachedStroke ) curveData of
-- Cached fit data is available: use it.
Just ( TwoSided fwdData bwdData ) -> do
tell ( TwoSided fwdData bwdData )
pure curveData
-- No cached fit: compute the fit anew.
Nothing -> do
let
fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
( fwdData, bwdData ) =
( fitSpline fitParams fwd, fitSpline fitParams bwd )
`Strats.using`
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
outlineData :: OutlineData
outlineData = TwoSided fwdData bwdData
tell ( outlineData )
pure ( set ( typed @CachedStroke ) ( CachedStroke $ Just outlineData ) curveData )
-> WriterT OutlineData ( ST s ) ()
updateCurveData ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) fwd bwd = do
mbOutline <- lift ( readSTRef cachedStrokeRef )
case mbOutline of
-- Cached fit data is available: use it.
Just outline -> do
tell outline
pure ()
-- No cached fit: compute the fit anew.
Nothing -> do
let
fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
( fwdData, bwdData ) =
( fitSpline fitParams fwd, fitSpline fitParams bwd )
`Strats.using`
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
outlineData :: OutlineData
outlineData = TwoSided fwdData bwdData
outlineData `deepseq` tell ( outlineData )
lift $ writeSTRef cachedStrokeRef ( Just outlineData )
-- 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).
tellBrushJoin
:: Vector2D Double
:: Monad m
=> Vector2D Double
-> ptData
-> Vector2D Double
-> Writer OutlineData ()
-> WriterT OutlineData m ()
tellBrushJoin prevTgt sp0 tgt
| tgt `parallel` prevTgt
= pure ()