mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
use STRefs to hold cached outline data
This commit is contained in:
sheaf
parent
6dbade1fae
commit
212ac4fded
54
app/Main.hs
54
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Reference in a new issue