diff --git a/app/Main.hs b/app/Main.hs index 1591ed8..3933fb6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 0d254c0..be911c2 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 940535c..9276f75 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 3fff17d..7a441a4 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 ) diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 17865f4..e30c10d 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -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 ) diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs index d09c73b..265b388 100644 --- a/src/app/MetaBrush/Document/SubdivideStroke.hs +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index b635cbc..5b7d1f3 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index 39ccd54..f1233da 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -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 ()