mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
use STRefs to hold cached outline data
This commit is contained in:
parent
6dbade1fae
commit
212ac4fded
48
app/Main.hs
48
app/Main.hs
|
@ -16,10 +16,10 @@ module Main
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Control.Arrow
|
|
||||||
( (&&&) )
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( forever, void )
|
( forever, void )
|
||||||
|
import Control.Monad.ST
|
||||||
|
( stToIO )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_ )
|
( for_ )
|
||||||
import Data.Function
|
import Data.Function
|
||||||
|
@ -35,7 +35,7 @@ import GHC.Conc
|
||||||
import Data.Map.Strict
|
import Data.Map.Strict
|
||||||
( Map )
|
( Map )
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
( adjust, empty )
|
( empty )
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
( fromList )
|
( fromList )
|
||||||
import Data.Set
|
import Data.Set
|
||||||
|
@ -62,12 +62,15 @@ import qualified GI.Cairo.Render.Connector as Cairo
|
||||||
-- gi-gdk
|
-- gi-gdk
|
||||||
import qualified GI.Gdk as GDK
|
import qualified GI.Gdk as GDK
|
||||||
|
|
||||||
|
-- gi-glib
|
||||||
|
import qualified GI.GLib.Constants as GLib
|
||||||
|
|
||||||
-- gi-gtk
|
-- gi-gtk
|
||||||
import qualified GI.Gtk as GTK
|
import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
-- lens
|
-- lens
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
( (.~), set )
|
( (.~) )
|
||||||
import Control.Lens.At
|
import Control.Lens.At
|
||||||
( at )
|
( at )
|
||||||
|
|
||||||
|
@ -75,7 +78,7 @@ import Control.Lens.At
|
||||||
import qualified Control.Concurrent.STM as STM
|
import qualified Control.Concurrent.STM as STM
|
||||||
( atomically, retry )
|
( atomically, retry )
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
import qualified Control.Concurrent.STM.TVar as STM
|
||||||
( modifyTVar', newTVarIO, readTVar, writeTVar )
|
( newTVarIO, readTVar, writeTVar )
|
||||||
|
|
||||||
-- superrecord
|
-- superrecord
|
||||||
import qualified SuperRecord as Super
|
import qualified SuperRecord as Super
|
||||||
|
@ -103,7 +106,7 @@ import Math.Bezier.Cubic.Fit
|
||||||
import Math.Bezier.Spline
|
import Math.Bezier.Spline
|
||||||
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
|
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
( CachedStroke(..) )
|
( invalidateCache )
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
( Point2D(..) )
|
( Point2D(..) )
|
||||||
import MetaBrush.Action
|
import MetaBrush.Action
|
||||||
|
@ -122,7 +125,7 @@ import MetaBrush.Context
|
||||||
, HoldAction(..), PartialPath(..)
|
, HoldAction(..), PartialPath(..)
|
||||||
)
|
)
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
( Document(..), emptyDocument
|
( emptyDocument
|
||||||
, Stroke(..), FocusState(..)
|
, Stroke(..), FocusState(..)
|
||||||
, PointData(..)
|
, PointData(..)
|
||||||
)
|
)
|
||||||
|
@ -204,9 +207,9 @@ main = do
|
||||||
Spline
|
Spline
|
||||||
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
||||||
, splineCurves = OpenCurves $ Seq.fromList
|
, splineCurves = OpenCurves $ Seq.fromList
|
||||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = CachedStroke Nothing }
|
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = CachedStroke Nothing }
|
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = CachedStroke Nothing }
|
, 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.
|
-- Update the document render data in a separate thread.
|
||||||
_ <- forkIO $ forever do
|
_ <- forkIO $ forever do
|
||||||
( !mbUpdatedDoc, renderDoc ) <- STM.atomically do
|
getRenderDoc <- STM.atomically do
|
||||||
needsRecomputation <- STM.readTVar recomputeStrokesTVar
|
needsRecomputation <- STM.readTVar recomputeStrokesTVar
|
||||||
case needsRecomputation of
|
case needsRecomputation of
|
||||||
False -> STM.retry
|
False -> STM.retry
|
||||||
True -> do
|
True -> do
|
||||||
mbDocNow <- fmap present <$> activeDocument variables
|
mbDocNow <- fmap present <$> activeDocument variables
|
||||||
case mbDocNow of
|
case mbDocNow of
|
||||||
Nothing -> pure ( Nothing, const $ blankRender colours )
|
Nothing -> pure ( pure . const $ blankRender colours )
|
||||||
Just doc -> do
|
Just doc -> do
|
||||||
modifiers <- STM.readTVar modifiersTVar
|
modifiers <- STM.readTVar modifiersTVar
|
||||||
mbMousePos <- STM.readTVar mousePosTVar
|
mbMousePos <- STM.readTVar mousePosTVar
|
||||||
|
@ -369,26 +372,25 @@ main = do
|
||||||
fitParameters <- STM.readTVar fitParametersTVar
|
fitParameters <- STM.readTVar fitParametersTVar
|
||||||
STM.writeTVar recomputeStrokesTVar False
|
STM.writeTVar recomputeStrokesTVar False
|
||||||
let
|
let
|
||||||
addRulers :: ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
|
addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
|
||||||
addRulers ( Nothing , newRender ) viewportSize = newRender viewportSize
|
addRulers newRender viewportSize = do
|
||||||
addRulers ( Just newDoc, newRender ) viewportSize = do
|
|
||||||
newRender viewportSize
|
newRender viewportSize
|
||||||
renderRuler
|
renderRuler
|
||||||
colours viewportSize ViewportOrigin viewportSize
|
colours viewportSize ViewportOrigin viewportSize
|
||||||
mbMousePos mbHoldAction showGuides
|
mbMousePos mbHoldAction showGuides
|
||||||
newDoc
|
doc
|
||||||
pure $
|
pure
|
||||||
( fst &&& addRulers ) $ getDocumentRender
|
( addRulers <$> getDocumentRender
|
||||||
colours fitParameters mode debug
|
colours fitParameters mode debug
|
||||||
modifiers mbMousePos mbHoldAction mbPartialPath
|
modifiers mbMousePos mbHoldAction mbPartialPath
|
||||||
doc
|
doc
|
||||||
|
)
|
||||||
|
renderDoc <- stToIO getRenderDoc
|
||||||
STM.atomically do
|
STM.atomically do
|
||||||
STM.writeTVar documentRenderTVar renderDoc
|
STM.writeTVar documentRenderTVar renderDoc
|
||||||
for_ mbUpdatedDoc \ newDoc -> do
|
void do
|
||||||
mbCurrDocUnique <- STM.readTVar activeDocumentTVar
|
GDK.threadsAddIdle GLib.PRIORITY_HIGH_IDLE
|
||||||
for_ mbCurrDocUnique \ currDocUnique -> do
|
( False <$ GTK.widgetQueueDraw viewportDrawingArea )
|
||||||
STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
|
|
||||||
GTK.widgetQueueDraw viewportDrawingArea
|
|
||||||
|
|
||||||
-- Render the document using the latest available draw data.
|
-- Render the document using the latest available draw data.
|
||||||
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
|
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
|
||||||
|
|
|
@ -17,6 +17,8 @@ module MetaBrush.Action where
|
||||||
-- base
|
-- base
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( guard, when, unless, void )
|
( guard, when, unless, void )
|
||||||
|
import Control.Monad.ST
|
||||||
|
( RealWorld )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_, sequenceA_ )
|
( for_, sequenceA_ )
|
||||||
import Data.Int
|
import Data.Int
|
||||||
|
@ -84,7 +86,7 @@ import Math.Bezier.Spline
|
||||||
, catMaybesSpline
|
, catMaybesSpline
|
||||||
)
|
)
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
( CachedStroke(..) )
|
( CachedStroke(..), invalidateCache )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( Module((*^)) )
|
( Module((*^)) )
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
|
@ -621,7 +623,6 @@ instance HandleAction MouseMove where
|
||||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||||
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
|
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
|
||||||
modifiers <- STM.readTVar modifiersTVar
|
modifiers <- STM.readTVar modifiersTVar
|
||||||
mbMouseHold <- STM.readTVar mouseHoldTVar
|
|
||||||
let
|
let
|
||||||
toViewport :: Point2D Double -> Point2D Double
|
toViewport :: Point2D Double -> Point2D Double
|
||||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||||
|
@ -636,14 +637,10 @@ instance HandleAction MouseMove where
|
||||||
case tool of
|
case tool of
|
||||||
Pen
|
Pen
|
||||||
| Just pp <- mbPartialPath
|
| Just pp <- mbPartialPath
|
||||||
-> do
|
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
||||||
STM.writeTVar recomputeStrokesTVar True
|
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
||||||
when ( any ( \ case { Control _ -> True; _ -> False } ) modifiers ) do
|
_ -> pure ()
|
||||||
STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
|
||||||
_ | Just _ <- mbMouseHold
|
|
||||||
-> STM.writeTVar recomputeStrokesTVar True
|
|
||||||
| otherwise
|
|
||||||
-> pure ()
|
|
||||||
pure do
|
pure do
|
||||||
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
||||||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||||||
|
@ -938,8 +935,8 @@ instance HandleAction MouseRelease where
|
||||||
then do
|
then do
|
||||||
STM.writeTVar partialPathTVar Nothing
|
STM.writeTVar partialPathTVar Nothing
|
||||||
let
|
let
|
||||||
newSegment :: Spline Open CachedStroke ( PointData () )
|
newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
|
||||||
newSegment = catMaybesSpline ( CachedStroke Nothing )
|
newSegment = catMaybesSpline ( invalidateCache undefined )
|
||||||
( PointData p1 Normal () )
|
( PointData p1 Normal () )
|
||||||
( do
|
( do
|
||||||
cp <- mbCp2
|
cp <- mbCp2
|
||||||
|
@ -967,8 +964,8 @@ instance HandleAction MouseRelease where
|
||||||
else do
|
else do
|
||||||
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
|
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
|
||||||
let
|
let
|
||||||
newSegment :: Spline Open CachedStroke ( PointData () )
|
newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
|
||||||
newSegment = catMaybesSpline ( CachedStroke Nothing )
|
newSegment = catMaybesSpline ( invalidateCache undefined )
|
||||||
( PointData p1 Normal () )
|
( PointData p1 Normal () )
|
||||||
( do
|
( do
|
||||||
cp <- mbCp2
|
cp <- mbCp2
|
||||||
|
|
|
@ -20,6 +20,8 @@
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
module MetaBrush.Document
|
module MetaBrush.Document
|
||||||
( AABB(..), mkAABB
|
( AABB(..), mkAABB
|
||||||
, Document(..), DocumentContent(..)
|
, Document(..), DocumentContent(..)
|
||||||
|
@ -34,6 +36,8 @@ module MetaBrush.Document
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Control.Monad.ST
|
||||||
|
( RealWorld )
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
( coerce )
|
( coerce )
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
|
@ -156,7 +160,7 @@ data DocumentContent
|
||||||
deriving stock ( Show, Generic )
|
deriving stock ( Show, Generic )
|
||||||
deriving anyclass NFData
|
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
|
data Stroke where
|
||||||
Stroke
|
Stroke
|
||||||
|
|
|
@ -27,6 +27,8 @@ module MetaBrush.Document.Selection
|
||||||
-- base
|
-- base
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( guard )
|
( guard )
|
||||||
|
import Control.Monad.ST
|
||||||
|
( RealWorld )
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
( ($>) )
|
( ($>) )
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
|
@ -84,8 +86,8 @@ import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
( MaybeT(..) )
|
( MaybeT(..) )
|
||||||
import Control.Monad.Trans.State.Strict
|
import Control.Monad.Trans.State.Strict
|
||||||
( StateT, State
|
( StateT(..), State
|
||||||
, runState, evalState, evalStateT
|
, evalState, evalStateT, runState
|
||||||
, get, put, modify'
|
, get, put, modify'
|
||||||
)
|
)
|
||||||
import Control.Monad.Trans.Writer.CPS
|
import Control.Monad.Trans.Writer.CPS
|
||||||
|
@ -106,7 +108,7 @@ import Math.Bezier.Spline
|
||||||
, fromNextPoint
|
, fromNextPoint
|
||||||
)
|
)
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
( CachedStroke(..), discardCache )
|
( CachedStroke(..), invalidateCache )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( lerp, squaredNorm, closestPointOnSegment )
|
( lerp, squaredNorm, closestPointOnSegment )
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
|
@ -247,10 +249,10 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
|
||||||
:: forall clo' brushParams
|
:: forall clo' brushParams
|
||||||
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
|
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
|
||||||
=> PointData brushParams -> Bool -> Unique
|
=> PointData brushParams -> Bool -> Unique
|
||||||
-> Int -> PointData brushParams -> Curve clo' CachedStroke ( PointData brushParams )
|
-> Int -> PointData brushParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||||
-> WriterT ( Maybe DragMoveSelect )
|
-> WriterT ( Maybe DragMoveSelect )
|
||||||
( Tardis ( Maybe DragMoveSelect ) ( 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
|
updateSplineCurve start isVisible uniq i sp0 curve = case curve of
|
||||||
line@( LineTo sp1 _ ) -> do
|
line@( LineTo sp1 _ ) -> do
|
||||||
let
|
let
|
||||||
|
@ -434,44 +436,44 @@ translateSelection t doc =
|
||||||
:: forall clo'
|
:: forall clo'
|
||||||
. SplineTypeI clo'
|
. SplineTypeI clo'
|
||||||
=> PointData brushParams
|
=> PointData brushParams
|
||||||
-> Curve clo' CachedStroke ( PointData brushParams )
|
-> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||||
-> StateT Bool ( State UpdateInfo ) ( Curve clo' CachedStroke ( PointData brushParams ) )
|
-> StateT Bool ( State UpdateInfo ) ( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) )
|
||||||
updateSplineCurve start crv = do
|
updateSplineCurve start crv = do
|
||||||
prevMod <- get
|
prevMod <- get
|
||||||
case crv of
|
case crv of
|
||||||
LineTo p1 dat -> do
|
LineTo p1 dat -> do
|
||||||
p1' <- traverse ( updatePoint PathPoint ) p1
|
p1' <- traverse ( updatePoint PathPoint ) p1
|
||||||
pure $ LineTo p1' dat'
|
let
|
||||||
where
|
dat' :: CachedStroke RealWorld
|
||||||
dat' :: CachedStroke
|
|
||||||
dat'
|
dat'
|
||||||
| prevMod || ( view _selection ( fromNextPoint start p1 ) == Selected )
|
| prevMod || ( view _selection ( fromNextPoint start p1 ) == Selected )
|
||||||
= discardCache dat
|
= invalidateCache dat
|
||||||
| otherwise
|
| otherwise
|
||||||
= dat
|
= dat
|
||||||
|
pure $ LineTo p1' dat'
|
||||||
Bezier2To p1 p2 dat -> do
|
Bezier2To p1 p2 dat -> do
|
||||||
p1' <- updatePoint ControlPoint p1
|
p1' <- updatePoint ControlPoint p1
|
||||||
p2' <- traverse ( updatePoint PathPoint ) p2
|
p2' <- traverse ( updatePoint PathPoint ) p2
|
||||||
pure $ Bezier2To p1' p2' dat'
|
let
|
||||||
where
|
dat' :: CachedStroke RealWorld
|
||||||
dat' :: CachedStroke
|
|
||||||
dat'
|
dat'
|
||||||
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, fromNextPoint start p2 ]
|
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, fromNextPoint start p2 ]
|
||||||
= discardCache dat
|
= invalidateCache dat
|
||||||
| otherwise
|
| otherwise
|
||||||
= dat
|
= dat
|
||||||
|
pure $ Bezier2To p1' p2' dat'
|
||||||
Bezier3To p1 p2 p3 dat -> do
|
Bezier3To p1 p2 p3 dat -> do
|
||||||
p1' <- updatePoint ControlPoint p1
|
p1' <- updatePoint ControlPoint p1
|
||||||
p2' <- updatePoint ControlPoint p2
|
p2' <- updatePoint ControlPoint p2
|
||||||
p3' <- traverse ( updatePoint PathPoint ) p3
|
p3' <- traverse ( updatePoint PathPoint ) p3
|
||||||
pure $ Bezier3To p1' p2' p3' dat'
|
let
|
||||||
where
|
dat' :: CachedStroke RealWorld
|
||||||
dat' :: CachedStroke
|
|
||||||
dat'
|
dat'
|
||||||
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, p2, fromNextPoint start p3 ]
|
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, p2, fromNextPoint start p3 ]
|
||||||
= discardCache dat
|
= invalidateCache dat
|
||||||
| otherwise
|
| otherwise
|
||||||
= dat
|
= dat
|
||||||
|
pure $ Bezier3To p1' p2' p3' dat'
|
||||||
|
|
||||||
updatePoint :: PointType -> PointData brushParams -> StateT Bool ( State UpdateInfo ) ( PointData brushParams )
|
updatePoint :: PointType -> PointData brushParams -> StateT Bool ( State UpdateInfo ) ( PointData brushParams )
|
||||||
updatePoint PathPoint pt
|
updatePoint PathPoint pt
|
||||||
|
@ -499,16 +501,13 @@ translateSelection t doc =
|
||||||
--
|
--
|
||||||
-- Returns the updated document, together with info about how many points were deleted.
|
-- Returns the updated document, together with info about how many points were deleted.
|
||||||
deleteSelected :: Document -> ( Document, UpdateInfo )
|
deleteSelected :: Document -> ( Document, UpdateInfo )
|
||||||
deleteSelected doc = deletionResult
|
deleteSelected doc =
|
||||||
where
|
( `runState` mempty ) $
|
||||||
|
( field' @"documentContent" . field' @"strokes" )
|
||||||
deletionResult :: ( Document, UpdateInfo )
|
|
||||||
deletionResult
|
|
||||||
= ( `runState` mempty )
|
|
||||||
$ ( field' @"documentContent" . field' @"strokes" )
|
|
||||||
( fmap catMaybes . traverse updateStroke )
|
( fmap catMaybes . traverse updateStroke )
|
||||||
doc
|
doc
|
||||||
|
|
||||||
|
where
|
||||||
updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke )
|
updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke )
|
||||||
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke
|
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke
|
||||||
where
|
where
|
||||||
|
@ -528,9 +527,6 @@ deleteSelected doc = deletionResult
|
||||||
oldSpline
|
oldSpline
|
||||||
where
|
where
|
||||||
|
|
||||||
noDat :: CachedStroke
|
|
||||||
noDat = CachedStroke Nothing
|
|
||||||
|
|
||||||
updateSplinePoint
|
updateSplinePoint
|
||||||
:: Unique
|
:: Unique
|
||||||
-> PointData brushParams
|
-> PointData brushParams
|
||||||
|
@ -552,12 +548,12 @@ deleteSelected doc = deletionResult
|
||||||
:: forall clo'. SplineTypeI clo'
|
:: forall clo'. SplineTypeI clo'
|
||||||
=> Unique
|
=> Unique
|
||||||
-> Maybe ( PointData brushParams )
|
-> Maybe ( PointData brushParams )
|
||||||
-> Curve clo' CachedStroke ( PointData brushParams )
|
-> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||||
-> State UpdateInfo
|
-> State UpdateInfo
|
||||||
( Maybe ( Curve clo' CachedStroke ( PointData brushParams ) ) )
|
( Maybe ( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) ) )
|
||||||
updateSplineCurve uniq mbPrevPt crv =
|
updateSplineCurve uniq mbPrevPt crv =
|
||||||
case crv of
|
case crv of
|
||||||
LineTo p1 _ ->
|
LineTo p1 dat ->
|
||||||
case ssplineType @clo' of
|
case ssplineType @clo' of
|
||||||
SOpen
|
SOpen
|
||||||
| NextPoint pt <- p1
|
| NextPoint pt <- p1
|
||||||
|
@ -570,9 +566,11 @@ deleteSelected doc = deletionResult
|
||||||
pure Nothing
|
pure Nothing
|
||||||
_ ->
|
_ ->
|
||||||
case mbPrevPt of
|
case mbPrevPt of
|
||||||
Nothing -> pure ( Just $ LineTo p1 noDat ) -- no need to update "strokesAffected"
|
Nothing ->
|
||||||
Just _ -> pure ( Just crv )
|
pure ( Just $ LineTo p1 ( invalidateCache dat ) ) -- no need to update "strokesAffected"
|
||||||
Bezier2To cp1 p2 _ ->
|
Just _ ->
|
||||||
|
pure ( Just crv )
|
||||||
|
Bezier2To cp1 p2 dat ->
|
||||||
case ssplineType @clo' of
|
case ssplineType @clo' of
|
||||||
SOpen
|
SOpen
|
||||||
| NextPoint pt <- p2
|
| NextPoint pt <- p2
|
||||||
|
@ -593,8 +591,8 @@ deleteSelected doc = deletionResult
|
||||||
( over ( field' @"controlPointsAffected" ) ( <> 1 )
|
( over ( field' @"controlPointsAffected" ) ( <> 1 )
|
||||||
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
||||||
)
|
)
|
||||||
pure ( Just $ LineTo p2 noDat )
|
pure ( Just $ LineTo p2 ( invalidateCache dat ) )
|
||||||
Bezier3To cp1 cp2 p3 _ ->
|
Bezier3To cp1 cp2 p3 dat ->
|
||||||
case ssplineType @clo' of
|
case ssplineType @clo' of
|
||||||
SOpen
|
SOpen
|
||||||
| NextPoint pt <- p3
|
| NextPoint pt <- p3
|
||||||
|
@ -618,25 +616,28 @@ deleteSelected doc = deletionResult
|
||||||
( over ( field' @"controlPointsAffected" ) ( <> 1 )
|
( over ( field' @"controlPointsAffected" ) ( <> 1 )
|
||||||
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
||||||
)
|
)
|
||||||
pure ( Just $ Bezier2To cp1 p3 noDat )
|
pure ( Just $ Bezier2To cp1 p3 ( invalidateCache dat ) )
|
||||||
| Normal <- view _selection cp2
|
| Normal <- view _selection cp2
|
||||||
-> do
|
-> do
|
||||||
modify'
|
modify'
|
||||||
( over ( field' @"controlPointsAffected" ) ( <> 1 )
|
( over ( field' @"controlPointsAffected" ) ( <> 1 )
|
||||||
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
||||||
)
|
)
|
||||||
pure ( Just $ Bezier2To cp2 p3 noDat )
|
pure ( Just $ Bezier2To cp2 p3 ( invalidateCache dat ) )
|
||||||
_ -> do
|
_ -> do
|
||||||
modify'
|
modify'
|
||||||
( over ( field' @"controlPointsAffected" ) ( <> 2 )
|
( over ( field' @"controlPointsAffected" ) ( <> 2 )
|
||||||
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
. 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.
|
-- | Perform a drag move action on a document.
|
||||||
dragUpdate :: Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
|
dragUpdate :: Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
|
||||||
dragUpdate p0 p PointDrag _ doc = case updateInfo of
|
dragUpdate p0 p PointDrag _ doc = do
|
||||||
|
let
|
||||||
|
( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc
|
||||||
|
case updateInfo of
|
||||||
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
|
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
|
||||||
| null strokesAffected
|
| null strokesAffected
|
||||||
-> Nothing
|
-> Nothing
|
||||||
|
@ -657,23 +658,19 @@ dragUpdate p0 p PointDrag _ doc = case updateInfo of
|
||||||
"Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
|
"Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
|
||||||
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
|
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
|
||||||
-> Just ( HistoryChange { newDocument, changeText } )
|
-> Just ( HistoryChange { newDocument, changeText } )
|
||||||
where
|
dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc =
|
||||||
newDocument :: Document
|
let
|
||||||
updateInfo :: UpdateInfo
|
( newDocument, mbStrokeName ) =
|
||||||
( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc
|
( `runState` Nothing ) $
|
||||||
dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc
|
( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
|
||||||
| Just name <- mbStrokeName
|
in case mbStrokeName of
|
||||||
, let
|
Just name -> do
|
||||||
|
let
|
||||||
changeText :: Text
|
changeText :: Text
|
||||||
changeText = "Drag curve segment of " <> name
|
changeText = "Drag curve segment of " <> name
|
||||||
= Just ( HistoryChange { newDocument, changeText } )
|
Just ( HistoryChange { newDocument, changeText } )
|
||||||
| otherwise
|
_ -> Nothing
|
||||||
= Nothing
|
|
||||||
where
|
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 -> State ( Maybe Text ) Stroke
|
||||||
updateStroke stroke@( Stroke { strokeUnique, strokeName } )
|
updateStroke stroke@( Stroke { strokeUnique, strokeName } )
|
||||||
| strokeUnique /= dragStrokeUnique
|
| strokeUnique /= dragStrokeUnique
|
||||||
|
@ -701,13 +698,16 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
|
||||||
( _ , Spline { splineCurves = OpenCurves Empty } ) -> pure spline
|
( _ , Spline { splineCurves = OpenCurves Empty } ) -> pure spline
|
||||||
( bef, Spline { splineStart, splineCurves = OpenCurves ( curve :<| next ) } ) -> do
|
( bef, Spline { splineStart, splineCurves = OpenCurves ( curve :<| next ) } ) -> do
|
||||||
put ( Just name )
|
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
|
where
|
||||||
updateCurve
|
updateCurve
|
||||||
:: PointData pointParams
|
:: PointData pointParams
|
||||||
-> Curve Open CachedStroke ( PointData pointParams )
|
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
|
||||||
-> Curve Open CachedStroke ( PointData pointParams )
|
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
|
||||||
updateCurve sp0 curve = case curve of
|
updateCurve sp0 curve = case curve of
|
||||||
LineTo ( NextPoint sp1 ) dat -> do
|
LineTo ( NextPoint sp1 ) dat -> do
|
||||||
let
|
let
|
||||||
|
@ -737,21 +737,19 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
|
||||||
else cubicDragCurve dat bez3
|
else cubicDragCurve dat bez3
|
||||||
where
|
where
|
||||||
quadraticDragCurve
|
quadraticDragCurve
|
||||||
:: CachedStroke
|
:: CachedStroke RealWorld
|
||||||
-> Quadratic.Bezier ( PointData pointParams )
|
-> 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 } ) =
|
quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
|
||||||
let
|
let
|
||||||
cp :: Point2D Double
|
cp :: Point2D Double
|
||||||
Quadratic.Bezier { Quadratic.p1 = cp } =
|
Quadratic.Bezier { Quadratic.p1 = cp } =
|
||||||
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p
|
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p
|
||||||
dat' :: CachedStroke
|
in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat )
|
||||||
dat' = discardCache dat
|
|
||||||
in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) dat'
|
|
||||||
cubicDragCurve
|
cubicDragCurve
|
||||||
:: CachedStroke
|
:: CachedStroke RealWorld
|
||||||
-> Cubic.Bezier ( PointData pointParams )
|
-> 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 } ) =
|
cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
|
||||||
let
|
let
|
||||||
cp1, cp2 :: Point2D Double
|
cp1, cp2 :: Point2D Double
|
||||||
|
@ -760,6 +758,4 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
|
||||||
( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
|
( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
|
||||||
dragSegmentParameter
|
dragSegmentParameter
|
||||||
p
|
p
|
||||||
dat' :: CachedStroke
|
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat )
|
||||||
dat' = discardCache dat
|
|
||||||
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) dat'
|
|
||||||
|
|
|
@ -25,6 +25,8 @@ import Control.Arrow
|
||||||
( (&&&), first )
|
( (&&&), first )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( unless )
|
( unless )
|
||||||
|
import Control.Monad.ST
|
||||||
|
( RealWorld, stToIO )
|
||||||
import qualified Data.Bifunctor as Bifunctor
|
import qualified Data.Bifunctor as Bifunctor
|
||||||
( first )
|
( first )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
|
@ -33,6 +35,8 @@ import Data.Functor.Contravariant
|
||||||
( contramap )
|
( contramap )
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
( Identity(..) )
|
( Identity(..) )
|
||||||
|
import Data.STRef
|
||||||
|
( newSTRef )
|
||||||
import Data.Type.Equality
|
import Data.Type.Equality
|
||||||
( (:~:)(Refl) )
|
( (:~:)(Refl) )
|
||||||
import GHC.Exts
|
import GHC.Exts
|
||||||
|
@ -367,31 +371,33 @@ encodeCurve encodePtData = case ssplineType @clo of
|
||||||
|
|
||||||
decodeCurve
|
decodeCurve
|
||||||
:: forall clo ptData m
|
:: forall clo ptData m
|
||||||
. ( SplineTypeI clo, Monad m )
|
. ( SplineTypeI clo, MonadIO m )
|
||||||
=> JSON.Decoder m ptData
|
=> JSON.Decoder m ptData
|
||||||
-> JSON.Decoder m ( Curve clo CachedStroke ptData )
|
-> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
|
||||||
decodeCurve decodePtData = case ssplineType @clo of
|
decodeCurve decodePtData = do
|
||||||
|
noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
|
||||||
|
case ssplineType @clo of
|
||||||
SOpen -> do
|
SOpen -> do
|
||||||
p1 <- JSON.Decoder.atKey "p1" decodePtData
|
p1 <- JSON.Decoder.atKey "p1" decodePtData
|
||||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||||
case mb_p2 of
|
case mb_p2 of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
pure ( LineTo ( NextPoint p1 ) ( CachedStroke Nothing ) )
|
pure ( LineTo ( NextPoint p1 ) noCache )
|
||||||
Just p2 -> do
|
Just p2 -> do
|
||||||
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
|
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
|
||||||
case mb_p3 of
|
case mb_p3 of
|
||||||
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) ( CachedStroke Nothing ) )
|
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) noCache )
|
||||||
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) ( CachedStroke Nothing ) )
|
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
|
||||||
SClosed -> do
|
SClosed -> do
|
||||||
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
|
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
|
||||||
case mb_p1 of
|
case mb_p1 of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
pure ( LineTo BackToStart ( CachedStroke Nothing ) )
|
pure ( LineTo BackToStart noCache )
|
||||||
Just p1 -> do
|
Just p1 -> do
|
||||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||||
case mb_p2 of
|
case mb_p2 of
|
||||||
Nothing -> pure ( Bezier2To p1 BackToStart ( CachedStroke Nothing ) )
|
Nothing -> pure ( Bezier2To p1 BackToStart noCache )
|
||||||
Just p2 -> pure ( Bezier3To p1 p2 BackToStart ( CachedStroke Nothing ) )
|
Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -413,9 +419,9 @@ encodeCurves encodePtData = case ssplineType @clo of
|
||||||
|
|
||||||
decodeCurves
|
decodeCurves
|
||||||
:: forall clo ptData m
|
:: forall clo ptData m
|
||||||
. ( SplineTypeI clo, Monad m )
|
. ( SplineTypeI clo, MonadIO m )
|
||||||
=> JSON.Decoder m ptData
|
=> 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
|
decodeCurves decodePtData = case ssplineType @clo of
|
||||||
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
|
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
|
||||||
SClosed -> do
|
SClosed -> do
|
||||||
|
@ -440,9 +446,9 @@ encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, sp
|
||||||
|
|
||||||
decodeSpline
|
decodeSpline
|
||||||
:: forall clo ptData m
|
:: forall clo ptData m
|
||||||
. ( SplineTypeI clo, Monad m )
|
. ( SplineTypeI clo, MonadIO m )
|
||||||
=> JSON.Decoder m ptData
|
=> JSON.Decoder m ptData
|
||||||
-> JSON.Decoder m ( Spline clo CachedStroke ptData )
|
-> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
|
||||||
decodeSpline decodePtData = do
|
decodeSpline decodePtData = do
|
||||||
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
|
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
|
||||||
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
|
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
|
||||||
|
|
|
@ -13,8 +13,8 @@ module MetaBrush.Document.SubdivideStroke
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Data.Functor
|
import Control.Monad.ST
|
||||||
( ($>) )
|
( RealWorld )
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
( Min(..), Arg(..) )
|
( Min(..), Arg(..) )
|
||||||
|
|
||||||
|
@ -54,7 +54,7 @@ import Math.Bezier.Spline
|
||||||
, KnownSplineType(bifoldSpline, adjustSplineType)
|
, KnownSplineType(bifoldSpline, adjustSplineType)
|
||||||
)
|
)
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
( CachedStroke, discardCache )
|
( CachedStroke(..), invalidateCache )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( lerp, quadrance, closestPointOnSegment )
|
( lerp, quadrance, closestPointOnSegment )
|
||||||
import Math.Vector2D
|
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 a path at the given center, provided a path indeed lies there.
|
||||||
subdivide :: Point2D Double -> Document -> Maybe ( Document, Text )
|
subdivide :: Point2D Double -> Document -> Maybe ( Document, Text )
|
||||||
subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
|
subdivide c doc@( Document { zoomFactor } ) =
|
||||||
where
|
let
|
||||||
updatedDoc :: Document
|
updatedDoc :: Document
|
||||||
mbSubdivLoc :: Maybe Text
|
mbSubdivLoc :: Maybe Text
|
||||||
( updatedDoc, mbSubdivLoc )
|
( updatedDoc, mbSubdivLoc ) =
|
||||||
= ( `runState` Nothing )
|
( `runState` Nothing )
|
||||||
$ ( field' @"documentContent" . field' @"strokes" . traverse )
|
$ ( field' @"documentContent" . field' @"strokes" . traverse )
|
||||||
updateStroke
|
updateStroke
|
||||||
doc
|
doc
|
||||||
|
in ( updatedDoc , ) <$> mbSubdivLoc
|
||||||
|
where
|
||||||
updateStroke :: Stroke -> State ( Maybe Text ) Stroke
|
updateStroke :: Stroke -> State ( Maybe Text ) Stroke
|
||||||
updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke
|
updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke
|
||||||
|
|
||||||
|
@ -104,9 +105,9 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
|
||||||
:: Text
|
:: Text
|
||||||
-> Vector2D Double
|
-> Vector2D Double
|
||||||
-> PointData brushParams
|
-> PointData brushParams
|
||||||
-> Curve Open CachedStroke ( PointData brushParams )
|
-> Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||||
-> State ( Maybe Text )
|
-> State ( Maybe Text )
|
||||||
( Seq ( Curve Open CachedStroke ( PointData brushParams ) ) )
|
( Seq ( Curve Open ( CachedStroke RealWorld ) ( PointData brushParams ) ) )
|
||||||
updateCurve txt offset sp0 curve = case curve of
|
updateCurve txt offset sp0 curve = case curve of
|
||||||
line@( LineTo ( NextPoint sp1 ) dat ) ->
|
line@( LineTo ( NextPoint sp1 ) dat ) ->
|
||||||
let
|
let
|
||||||
|
@ -122,9 +123,9 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
|
||||||
let
|
let
|
||||||
subdiv :: PointData brushParams
|
subdiv :: PointData brushParams
|
||||||
subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1
|
subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1
|
||||||
dat' :: CachedStroke
|
in do
|
||||||
dat' = discardCache dat
|
put ( Just txt )
|
||||||
in put ( Just txt ) $> ( LineTo ( NextPoint subdiv ) dat' :<| LineTo ( NextPoint sp1 ) dat' :<| Empty )
|
pure ( LineTo ( NextPoint subdiv ) ( invalidateCache dat ) :<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) :<| Empty )
|
||||||
else pure $ Seq.singleton line
|
else pure $ Seq.singleton line
|
||||||
bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
|
bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
|
||||||
let
|
let
|
||||||
|
@ -137,14 +138,13 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
|
||||||
= Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset • c )
|
= Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset • c )
|
||||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
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
|
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
|
let
|
||||||
dat' :: CachedStroke
|
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||||
dat' = discardCache dat
|
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
|
||||||
bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
|
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat )
|
||||||
bez_start = Bezier2To q1 ( NextPoint subdiv ) dat'
|
put ( Just txt )
|
||||||
bez_end = Bezier2To r1 ( NextPoint sp2 ) dat'
|
pure ( bez_start :<| bez_end :<| Empty )
|
||||||
in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
|
|
||||||
else pure $ Seq.singleton bez2
|
else pure $ Seq.singleton bez2
|
||||||
bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
|
bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
|
||||||
let
|
let
|
||||||
|
@ -157,12 +157,11 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
|
||||||
= Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset • c )
|
= Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset • c )
|
||||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
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
|
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
|
let
|
||||||
dat' :: CachedStroke
|
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||||
dat' = discardCache dat
|
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
|
||||||
bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
|
bez_end = Bezier3To r1 r2 ( NextPoint sp2 ) ( invalidateCache dat )
|
||||||
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) dat'
|
put ( Just txt )
|
||||||
bez_end = Bezier3To r1 r2 ( NextPoint sp2 ) dat'
|
pure ( bez_start :<| bez_end :<| Empty )
|
||||||
in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
|
|
||||||
else pure $ Seq.singleton bez3
|
else pure $ Seq.singleton bez3
|
||||||
|
|
|
@ -25,6 +25,8 @@ module MetaBrush.Render.Document
|
||||||
-- base
|
-- base
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( guard, when, unless )
|
( guard, when, unless )
|
||||||
|
import Control.Monad.ST
|
||||||
|
( RealWorld, ST )
|
||||||
import Data.Fixed
|
import Data.Fixed
|
||||||
( mod' )
|
( mod' )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
|
@ -68,16 +70,12 @@ import Control.DeepSeq
|
||||||
import Generic.Data
|
import Generic.Data
|
||||||
( Generically1(..) )
|
( Generically1(..) )
|
||||||
|
|
||||||
-- generic-lens
|
|
||||||
import Data.Generics.Product.Fields
|
|
||||||
( field' )
|
|
||||||
|
|
||||||
-- gi-cairo-render
|
-- gi-cairo-render
|
||||||
import qualified GI.Cairo.Render as Cairo
|
import qualified GI.Cairo.Render as Cairo
|
||||||
|
|
||||||
-- lens
|
-- lens
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
( view, set )
|
( view )
|
||||||
|
|
||||||
-- superrecord
|
-- superrecord
|
||||||
import qualified SuperRecord as Super
|
import qualified SuperRecord as Super
|
||||||
|
@ -106,7 +104,9 @@ import Math.Bezier.Spline
|
||||||
, catMaybesSpline
|
, catMaybesSpline
|
||||||
)
|
)
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
( CachedStroke(..), computeStrokeOutline )
|
( CachedStroke(..), invalidateCache
|
||||||
|
, computeStrokeOutline
|
||||||
|
)
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
( Point2D(..), Vector2D(..) )
|
( Point2D(..), Vector2D(..) )
|
||||||
import MetaBrush.Asset.Colours
|
import MetaBrush.Asset.Colours
|
||||||
|
@ -173,49 +173,30 @@ getDocumentRender
|
||||||
:: Colours -> FitParameters -> Mode -> Bool
|
:: Colours -> FitParameters -> Mode -> Bool
|
||||||
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
|
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
|
||||||
-> Document
|
-> Document
|
||||||
-> ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () )
|
-> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () )
|
||||||
getDocumentRender
|
getDocumentRender
|
||||||
cols fitParams mode debug
|
cols fitParams mode debug
|
||||||
modifiers mbMousePos mbHoldEvent mbPartialPath
|
modifiers mbMousePos mbHoldEvent mbPartialPath
|
||||||
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } )
|
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } )
|
||||||
= strokesRenderData `deepseq` ( mbUpdatedDoc, drawingInstructions )
|
= do
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
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 )
|
|
||||||
|
|
||||||
|
let
|
||||||
|
-- Get any modifications from in-flight user actions (e.g. in the middle of dragging something).
|
||||||
modifiedStrokes :: [ Stroke ]
|
modifiedStrokes :: [ Stroke ]
|
||||||
noModifiedStrokes :: Bool
|
modifiedStrokes = case mode of
|
||||||
( modifiedStrokes, noModifiedStrokes )
|
PathMode
|
||||||
| PathMode <- mode
|
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
|
||||||
, Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
|
|
||||||
, Just p1 <- mbMousePos
|
, Just p1 <- mbMousePos
|
||||||
, p0 /= p1
|
, p0 /= p1
|
||||||
, let
|
, let
|
||||||
alternateMode :: Bool
|
alternateMode :: Bool
|
||||||
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
||||||
, Just docUpdate <- dragUpdate p0 p1 dragAction alternateMode doc
|
afterDrag :: Maybe DocChange
|
||||||
= ( strokes . documentContent $ newDocument docUpdate, False )
|
afterDrag = dragUpdate p0 p1 dragAction alternateMode doc
|
||||||
| PathMode <- mode
|
-> case afterDrag of
|
||||||
, Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
|
Just docUpdate -> ( strokes . documentContent $ newDocument docUpdate )
|
||||||
|
_ -> ( strokes content )
|
||||||
|
| Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
|
||||||
, let
|
, let
|
||||||
mbFinalPoint :: Maybe ( Point2D Double )
|
mbFinalPoint :: Maybe ( Point2D Double )
|
||||||
mbControlPoint :: Maybe ( Point2D Double )
|
mbControlPoint :: Maybe ( Point2D Double )
|
||||||
|
@ -225,9 +206,9 @@ getDocumentRender
|
||||||
| otherwise
|
| otherwise
|
||||||
= ( mbMousePos, Nothing )
|
= ( mbMousePos, Nothing )
|
||||||
, Just finalPoint <- mbFinalPoint
|
, Just finalPoint <- mbFinalPoint
|
||||||
, let
|
-> let
|
||||||
previewSpline :: Spline Open CachedStroke ( PointData ( Super.Rec '[] ) )
|
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec '[] ) )
|
||||||
previewSpline = catMaybesSpline ( CachedStroke Nothing )
|
previewSpline = catMaybesSpline ( invalidateCache undefined )
|
||||||
( PointData p0 Normal SuperRecord.rnil )
|
( PointData p0 Normal SuperRecord.rnil )
|
||||||
( do
|
( do
|
||||||
cp <- cp0
|
cp <- cp0
|
||||||
|
@ -240,35 +221,42 @@ getDocumentRender
|
||||||
pure ( PointData cp Normal SuperRecord.rnil )
|
pure ( PointData cp Normal SuperRecord.rnil )
|
||||||
)
|
)
|
||||||
( PointData finalPoint Normal SuperRecord.rnil )
|
( PointData finalPoint Normal SuperRecord.rnil )
|
||||||
= ( ( Stroke
|
in
|
||||||
|
( ( Stroke
|
||||||
{ strokeSpline = previewSpline
|
{ strokeSpline = previewSpline
|
||||||
, strokeVisible = True
|
, strokeVisible = True
|
||||||
, strokeUnique = unsafeUnique 987654321
|
, strokeUnique = unsafeUnique 987654321
|
||||||
, strokeName = "Preview stroke (temporary)"
|
, strokeName = "Preview stroke (temporary)"
|
||||||
, strokeBrushRef = NoBrush
|
, strokeBrushRef = NoBrush
|
||||||
}
|
}
|
||||||
|
) : strokes content
|
||||||
)
|
)
|
||||||
: strokes content
|
_ -> strokes content
|
||||||
, False
|
|
||||||
)
|
|
||||||
| otherwise
|
|
||||||
= ( strokes content, True )
|
|
||||||
|
|
||||||
strokesRenderData :: [ StrokeRenderData ]
|
strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams documentBrushes ) modifiedStrokes
|
||||||
strokesRenderData = mapMaybe ( strokeRenderData fitParams documentBrushes ) modifiedStrokes
|
|
||||||
|
|
||||||
mbUpdatedDoc :: Maybe Document
|
let
|
||||||
mbUpdatedDoc
|
renderSelectionRect :: Cairo.Render ()
|
||||||
| noModifiedStrokes
|
mbHoverContext :: Maybe HoverContext
|
||||||
= let
|
( renderSelectionRect, mbHoverContext )
|
||||||
newDoc :: Document
|
| Just ( SelectionHold p0 ) <- mbHoldEvent
|
||||||
newDoc =
|
, Just p1 <- mbMousePos
|
||||||
set ( field' @"documentContent" . field' @"strokes" )
|
= ( drawSelectionRectangle cols zoomFactor p0 p1, Just $ RectangleHover ( mkAABB p0 p1 ) )
|
||||||
( modifiedStrokes )
|
|
||||||
doc
|
|
||||||
in Just newDoc
|
|
||||||
| otherwise
|
| otherwise
|
||||||
= Nothing -- TODO: update the original document in this case too (by undoing the modifications)
|
= ( pure (), MouseHover <$> mbMousePos )
|
||||||
|
|
||||||
|
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.
|
-- | Utility type to gather information needed to render a stroke.
|
||||||
-- - No outline: just the underlying spline.
|
-- - No outline: just the underlying spline.
|
||||||
|
@ -305,10 +293,15 @@ instance NFData StrokeRenderData where
|
||||||
-- - the computed outline (using fitting algorithm),
|
-- - the computed outline (using fitting algorithm),
|
||||||
-- - the brush shape function.
|
-- - the brush shape function.
|
||||||
-- - Otherwise, this consists of the underlying spline path only.
|
-- - Otherwise, this consists of the underlying spline path only.
|
||||||
strokeRenderData :: FitParameters -> Map Unique Brush -> Stroke -> Maybe StrokeRenderData
|
strokeRenderData :: FitParameters -> Map Unique Brush -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
|
||||||
strokeRenderData fitParams brushes ( Stroke { strokeSpline = spline :: StrokeSpline clo ( Super.Rec pointFields ), .. } ) =
|
strokeRenderData fitParams brushes
|
||||||
if strokeVisible
|
( Stroke
|
||||||
then case strokeBrushRef of
|
{ strokeSpline = spline :: StrokeSpline clo pointParams
|
||||||
|
, strokeBrushRef = ( strokeBrushRef :: BrushReference pointFields )
|
||||||
|
, ..
|
||||||
|
}
|
||||||
|
) | strokeVisible
|
||||||
|
= Just $ case strokeBrushRef of
|
||||||
BrushReference ( _ :: Proxy# brushFields ) brushUnique
|
BrushReference ( _ :: Proxy# brushFields ) brushUnique
|
||||||
-- TODO: could emit a warning if the following lookup fails.
|
-- TODO: could emit a warning if the following lookup fails.
|
||||||
| Just ( BrushData { brushFunction = AdaptableFunction brushFn :: BrushFunction brushFields' } ) <- Map.lookup brushUnique brushes
|
| Just ( BrushData { brushFunction = AdaptableFunction brushFn :: BrushFunction brushFields' } ) <- Map.lookup brushUnique brushes
|
||||||
|
@ -321,23 +314,22 @@ strokeRenderData fitParams brushes ( Stroke { strokeSpline = spline :: StrokeSpl
|
||||||
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
|
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
|
||||||
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
|
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
|
||||||
( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
|
( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
|
||||||
|
-> do
|
||||||
-- Compute the outline using the brush function.
|
-- Compute the outline using the brush function.
|
||||||
newSpline :: Spline clo CachedStroke ( PointData ( Super.Rec pointFields ) )
|
( outline, fitPts ) <-
|
||||||
outline :: Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
|
||||||
fitPts :: Seq FitPoint
|
|
||||||
( newSpline, outline, fitPts ) =
|
|
||||||
computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
|
computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
|
||||||
fitParams ( toUsedParams . brushParams ) brushShapeFn spline
|
fitParams ( toUsedParams . brushParams ) brushShapeFn spline
|
||||||
-> Just $
|
pure $
|
||||||
StrokeWithOutlineRenderData
|
StrokeWithOutlineRenderData
|
||||||
{ strokeDataSpline = newSpline
|
{ strokeDataSpline = spline
|
||||||
, strokeOutlineData = ( outline, fitPts )
|
, strokeOutlineData = ( outline, fitPts )
|
||||||
, strokeBrushFunction = brushShapeFn . toUsedParams
|
, strokeBrushFunction = brushShapeFn . toUsedParams
|
||||||
}
|
}
|
||||||
_ -> Just $
|
_ -> pure $
|
||||||
StrokeRenderData
|
StrokeRenderData
|
||||||
{ strokeDataSpline = spline }
|
{ strokeDataSpline = spline }
|
||||||
else Nothing
|
| otherwise
|
||||||
|
= Nothing
|
||||||
|
|
||||||
renderStroke
|
renderStroke
|
||||||
:: Colours -> Maybe HoverContext -> Mode -> Bool -> Double
|
:: Colours -> Maybe HoverContext -> Mode -> Bool -> Double
|
||||||
|
|
|
@ -8,15 +8,18 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE MagicHash #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE UnboxedTuples #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
module Math.Bezier.Stroke
|
module Math.Bezier.Stroke
|
||||||
( Offset(..)
|
( Offset(..)
|
||||||
, CachedStroke(..), discardCache
|
, CachedStroke(..), discardCache, invalidateCache
|
||||||
, computeStrokeOutline, joinWithBrush
|
, computeStrokeOutline, joinWithBrush
|
||||||
, withTangent
|
, withTangent
|
||||||
, between, parallel
|
, between, parallel
|
||||||
|
@ -30,6 +33,8 @@ import Control.Arrow
|
||||||
( first, (***) )
|
( first, (***) )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( guard, unless )
|
( guard, unless )
|
||||||
|
import Control.Monad.ST
|
||||||
|
( RealWorld, ST )
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
( Bifunctor(bimap) )
|
( Bifunctor(bimap) )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
|
@ -38,6 +43,10 @@ import Data.List.NonEmpty
|
||||||
( unzip )
|
( unzip )
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( fromMaybe, mapMaybe )
|
( fromMaybe, mapMaybe )
|
||||||
|
import GHC.Exts
|
||||||
|
( newMutVar#, runRW# )
|
||||||
|
import GHC.STRef
|
||||||
|
( STRef(..), readSTRef, writeSTRef )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic, Generic1 )
|
( Generic, Generic1 )
|
||||||
|
|
||||||
|
@ -57,7 +66,7 @@ import qualified Data.Sequence as Seq
|
||||||
|
|
||||||
-- deepseq
|
-- deepseq
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
( NFData, NFData1 )
|
( NFData(..), NFData1, deepseq )
|
||||||
|
|
||||||
-- generic-lens
|
-- generic-lens
|
||||||
import Data.Generics.Product.Typed
|
import Data.Generics.Product.Typed
|
||||||
|
@ -81,7 +90,7 @@ import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.State.Strict
|
import Control.Monad.Trans.State.Strict
|
||||||
( StateT, runStateT, evalStateT, get, put )
|
( StateT, runStateT, evalStateT, get, put )
|
||||||
import Control.Monad.Trans.Writer.CPS
|
import Control.Monad.Trans.Writer.CPS
|
||||||
( Writer, runWriter, tell )
|
( WriterT, execWriterT, runWriter, tell )
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import qualified Math.Bezier.Cubic as Cubic
|
import qualified Math.Bezier.Cubic as Cubic
|
||||||
|
@ -92,7 +101,7 @@ import Math.Bezier.Spline
|
||||||
, ssplineType, adjustSplineType
|
, ssplineType, adjustSplineType
|
||||||
, NextPoint(..), fromNextPoint
|
, NextPoint(..), fromNextPoint
|
||||||
, KnownSplineType
|
, KnownSplineType
|
||||||
( bitraverseSpline, ibifoldSpline, bimapSpline )
|
( bifoldSpline, ibifoldSpline, bimapSpline )
|
||||||
, Spline(..), SplinePts, Curves(..), Curve(..)
|
, Spline(..), SplinePts, Curves(..), Curve(..)
|
||||||
, openCurveStart, openCurveEnd
|
, openCurveStart, openCurveEnd
|
||||||
, splitSplineAt, dropCurves
|
, splitSplineAt, dropCurves
|
||||||
|
@ -140,12 +149,23 @@ instance Monoid OutlineData where
|
||||||
empt :: ( SplinePts Open, Seq FitPoint )
|
empt :: ( SplinePts Open, Seq FitPoint )
|
||||||
empt = ( Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }, Empty )
|
empt = ( Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }, Empty )
|
||||||
|
|
||||||
newtype CachedStroke = CachedStroke { upToDateFit :: Maybe OutlineData }
|
newtype CachedStroke s = CachedStroke { cachedStrokeRef :: STRef s ( Maybe OutlineData ) }
|
||||||
deriving stock ( Show, Generic )
|
instance Show ( CachedStroke s ) where
|
||||||
deriving anyclass NFData
|
show _ = "CachedStroke..."
|
||||||
|
instance NFData ( CachedStroke s ) where
|
||||||
|
rnf _ = ()
|
||||||
|
|
||||||
discardCache :: HasType CachedStroke crvData => crvData -> crvData
|
discardCache :: forall crvData s. HasType ( CachedStroke s ) crvData => crvData -> ST s ()
|
||||||
discardCache = set ( typed @CachedStroke ) ( CachedStroke Nothing )
|
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 :: forall ptData. HasType ( Point2D Double ) ptData => ptData -> Point2D Double
|
||||||
coords = view typed
|
coords = view typed
|
||||||
|
@ -153,20 +173,20 @@ coords = view typed
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
computeStrokeOutline ::
|
computeStrokeOutline ::
|
||||||
forall diffParams ( clo :: SplineType ) brushParams crvData ptData
|
forall diffParams ( clo :: SplineType ) brushParams crvData ptData s
|
||||||
. ( KnownSplineType clo
|
. ( KnownSplineType clo
|
||||||
, Group diffParams, Module Double diffParams
|
, Group diffParams, Module Double diffParams
|
||||||
, Torsor diffParams brushParams
|
, Torsor diffParams brushParams
|
||||||
, HasType ( Point2D Double ) ptData
|
, HasType ( Point2D Double ) ptData
|
||||||
, HasType CachedStroke crvData
|
, HasType ( CachedStroke s ) crvData
|
||||||
, NFData ptData, NFData crvData
|
, NFData ptData, NFData crvData
|
||||||
)
|
)
|
||||||
=> FitParameters
|
=> FitParameters
|
||||||
-> ( ptData -> brushParams )
|
-> ( ptData -> brushParams )
|
||||||
-> ( brushParams -> SplinePts Closed )
|
-> ( brushParams -> SplinePts Closed )
|
||||||
-> Spline clo crvData ptData
|
-> Spline clo crvData ptData
|
||||||
-> ( Spline clo crvData ptData
|
-> ST s
|
||||||
, Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
||||||
, Seq FitPoint
|
, Seq FitPoint
|
||||||
)
|
)
|
||||||
computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of
|
computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of
|
||||||
|
@ -186,11 +206,6 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
startBrush, endBrush :: SplinePts Closed
|
startBrush, endBrush :: SplinePts Closed
|
||||||
startBrush = brushShape spt0
|
startBrush = brushShape spt0
|
||||||
endBrush = brushShape endPt
|
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, endCap :: SplinePts Open
|
||||||
startCap
|
startCap
|
||||||
= fmap ( MkVector2D ( coords spt0 ) • )
|
= fmap ( MkVector2D ( coords spt0 ) • )
|
||||||
|
@ -198,8 +213,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
endCap
|
endCap
|
||||||
= fmap ( MkVector2D ( coords endPt ) • )
|
= fmap ( MkVector2D ( coords endPt ) • )
|
||||||
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
|
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
|
||||||
-> ( newSpline
|
-> do
|
||||||
, Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
|
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline startTgt
|
||||||
|
pure
|
||||||
|
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
|
||||||
, fwdFits <> bwdFits
|
, fwdFits <> bwdFits
|
||||||
)
|
)
|
||||||
-- Closed brush path with at least one segment.
|
-- Closed brush path with at least one segment.
|
||||||
|
@ -213,22 +230,20 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
endTgt = case prevCurves of
|
endTgt = case prevCurves of
|
||||||
Empty -> endTangent spt0 spt0 lastCurve
|
Empty -> endTangent spt0 spt0 lastCurve
|
||||||
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
||||||
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
|
fwdStartCap, bwdStartCap :: SplinePts Open
|
||||||
TwoSided fwdStartCap bwdStartCap
|
TwoSided fwdStartCap bwdStartCap
|
||||||
= fmap fst . snd . runWriter
|
= fmap fst . snd . runWriter
|
||||||
$ tellBrushJoin endTgt spt0 startTgt
|
$ tellBrushJoin endTgt spt0 startTgt
|
||||||
-> ( newSpline
|
-> do
|
||||||
, Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
|
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline endTgt
|
||||||
|
pure
|
||||||
|
( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
|
||||||
, fwdFits <> bwdFits
|
, fwdFits <> bwdFits
|
||||||
)
|
)
|
||||||
-- Single point.
|
-- Single point.
|
||||||
_ -> ( spline
|
_ ->
|
||||||
, Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
|
pure
|
||||||
|
( Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
|
||||||
, Empty
|
, Empty
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
@ -236,29 +251,27 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
brushShape :: ptData -> SplinePts Closed
|
brushShape :: ptData -> SplinePts Closed
|
||||||
brushShape pt = brushFn ( ptParams pt )
|
brushShape pt = brushFn ( ptParams pt )
|
||||||
|
|
||||||
updateSpline :: Vector2D Double -> ( Spline clo crvData ptData, OutlineData )
|
updateSpline :: Vector2D Double -> ST s OutlineData
|
||||||
updateSpline lastTgt
|
updateSpline lastTgt
|
||||||
= runWriter
|
= execWriterT
|
||||||
. ( `evalStateT` lastTgt )
|
. ( `evalStateT` lastTgt )
|
||||||
$ fmap ( adjustSplineType @clo )
|
$ bifoldSpline
|
||||||
$ bitraverseSpline
|
|
||||||
( \ ptData curve -> do
|
( \ ptData curve -> do
|
||||||
prev_tgt <- get
|
prev_tgt <- get
|
||||||
let
|
let
|
||||||
tgt :: Vector2D Double
|
tgt :: Vector2D Double
|
||||||
tgt = startTangent spt0 ptData curve
|
tgt = startTangent spt0 ptData curve
|
||||||
lift $ tellBrushJoin prev_tgt ptData tgt
|
lift $ tellBrushJoin prev_tgt ptData tgt
|
||||||
curve' <- lift $ strokeOutline ptData curve
|
lift $ strokeOutline ptData curve
|
||||||
put ( endTangent spt0 ptData curve )
|
put ( endTangent spt0 ptData curve )
|
||||||
pure curve'
|
|
||||||
)
|
)
|
||||||
pure
|
( const ( pure () ) )
|
||||||
( adjustSplineType @Open spline )
|
( adjustSplineType @Open spline )
|
||||||
|
|
||||||
strokeOutline
|
strokeOutline
|
||||||
:: ptData -> Curve Open crvData ptData
|
:: ptData -> Curve Open crvData ptData
|
||||||
-> Writer OutlineData ( Curve Open crvData ptData )
|
-> WriterT OutlineData ( ST s ) ()
|
||||||
strokeOutline sp0 line@( LineTo { curveEnd = NextPoint sp1, curveData } ) =
|
strokeOutline sp0 ( LineTo { curveEnd = NextPoint sp1, curveData } ) =
|
||||||
let
|
let
|
||||||
p0, p1 :: Point2D Double
|
p0, p1 :: Point2D Double
|
||||||
p0 = coords sp0
|
p0 = coords sp0
|
||||||
|
@ -296,10 +309,9 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
||||||
| otherwise
|
| otherwise
|
||||||
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
||||||
in do
|
in
|
||||||
crvData' <- updateCurveData curveData fwd bwd
|
updateCurveData curveData fwd bwd
|
||||||
pure ( line { curveData = crvData' } )
|
strokeOutline sp0 ( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
|
||||||
strokeOutline sp0 bez2@( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
|
|
||||||
let
|
let
|
||||||
p0, p1, p2 :: Point2D Double
|
p0, p1, p2 :: Point2D Double
|
||||||
p0 = coords sp0
|
p0 = coords sp0
|
||||||
|
@ -340,10 +352,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
||||||
| otherwise
|
| otherwise
|
||||||
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
||||||
in do
|
in updateCurveData curveData fwd bwd
|
||||||
crvData' <- updateCurveData curveData fwd bwd
|
strokeOutline sp0 ( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) =
|
||||||
pure ( bez2 { curveData = crvData' } )
|
|
||||||
strokeOutline sp0 bez3@( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) =
|
|
||||||
let
|
let
|
||||||
p0, p1, p2, p3 :: Point2D Double
|
p0, p1, p2, p3 :: Point2D Double
|
||||||
p0 = coords sp0
|
p0 = coords sp0
|
||||||
|
@ -385,20 +395,20 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
= 1e9 *^ ( off s --> off (s + 1e-9) )
|
||||||
| otherwise
|
| otherwise
|
||||||
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
= 1e9 *^ ( off (s - 1e-9) --> off s )
|
||||||
in do
|
in updateCurveData curveData fwd bwd
|
||||||
crvData' <- updateCurveData curveData fwd bwd
|
|
||||||
pure ( bez3 { curveData = crvData' } )
|
|
||||||
|
|
||||||
updateCurveData
|
updateCurveData
|
||||||
:: crvData
|
:: crvData
|
||||||
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||||
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||||
-> Writer OutlineData crvData
|
-> WriterT OutlineData ( ST s ) ()
|
||||||
updateCurveData curveData fwd bwd = case upToDateFit $ view ( typed @CachedStroke ) curveData of
|
updateCurveData ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) fwd bwd = do
|
||||||
|
mbOutline <- lift ( readSTRef cachedStrokeRef )
|
||||||
|
case mbOutline of
|
||||||
-- Cached fit data is available: use it.
|
-- Cached fit data is available: use it.
|
||||||
Just ( TwoSided fwdData bwdData ) -> do
|
Just outline -> do
|
||||||
tell ( TwoSided fwdData bwdData )
|
tell outline
|
||||||
pure curveData
|
pure ()
|
||||||
-- No cached fit: compute the fit anew.
|
-- No cached fit: compute the fit anew.
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
let
|
let
|
||||||
|
@ -409,17 +419,17 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
||||||
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
|
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
|
||||||
outlineData :: OutlineData
|
outlineData :: OutlineData
|
||||||
outlineData = TwoSided fwdData bwdData
|
outlineData = TwoSided fwdData bwdData
|
||||||
tell ( outlineData )
|
outlineData `deepseq` tell ( outlineData )
|
||||||
pure ( set ( typed @CachedStroke ) ( CachedStroke $ Just outlineData ) curveData )
|
lift $ writeSTRef cachedStrokeRef ( Just outlineData )
|
||||||
|
|
||||||
|
|
||||||
-- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
|
-- 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).
|
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
|
||||||
tellBrushJoin
|
tellBrushJoin
|
||||||
:: Vector2D Double
|
:: Monad m
|
||||||
|
=> Vector2D Double
|
||||||
-> ptData
|
-> ptData
|
||||||
-> Vector2D Double
|
-> Vector2D Double
|
||||||
-> Writer OutlineData ()
|
-> WriterT OutlineData m ()
|
||||||
tellBrushJoin prevTgt sp0 tgt
|
tellBrushJoin prevTgt sp0 tgt
|
||||||
| tgt `parallel` prevTgt
|
| tgt `parallel` prevTgt
|
||||||
= pure ()
|
= pure ()
|
||||||
|
|
Loading…
Reference in a new issue