add stroke preview when drawing

This commit is contained in:
sheaf 2021-02-25 01:08:13 +01:00
parent 4788ab2efd
commit 46275514ff
3 changed files with 73 additions and 27 deletions

View file

@ -160,7 +160,8 @@ data DocumentContent
deriving stock ( Show, Generic )
deriving anyclass NFData
type StrokeSpline ty brushParams = Spline ty ( CachedStroke RealWorld ) ( PointData brushParams )
type StrokeSpline clo brushParams =
Spline clo ( CachedStroke RealWorld ) ( PointData brushParams )
data Stroke where
Stroke

View file

@ -4,18 +4,22 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Draw
( DrawAnchor(..), anchorsAreComplementary
, getOrCreateDrawAnchor, addToAnchor
, withAnchorBrushData
)
where
-- base
import Data.Functor
( ($>) )
import Data.Maybe
( listToMaybe )
-- acts
import Data.Act
@ -25,6 +29,10 @@ import Data.Act
import Data.Sequence
( Seq(..) )
-- deepseq
import Control.DeepSeq
( NFData )
-- generic-lens
import Data.Generics.Product.Fields
( field, field' )
@ -70,11 +78,17 @@ import MetaBrush.Assert
import MetaBrush.Brush
( BrushReference(NoBrush) )
import MetaBrush.Document
( Document(..), Stroke(..), StrokeSpline
( Document(..), DocumentContent(..), Stroke(..), StrokeSpline
, FocusState(..), PointData(..)
, _selection, _strokeSpline
, coords, overStrokeSpline
)
import MetaBrush.Document.Serialise
( Serialisable )
import MetaBrush.MetaParameter.AST
( STypesI(..) )
import MetaBrush.MetaParameter.Interpolation
( Interpolatable )
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText )
@ -213,3 +227,30 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok
overStrokeSpline updateSpline stroke
| otherwise
= stroke
withAnchorBrushData
:: forall r
. DrawAnchor
-> Document
-> ( forall pointParams pointFields
. ( pointParams ~ Super.Rec pointFields, STypesI pointFields
, Show pointParams, NFData pointParams
, Interpolatable pointParams
, Serialisable pointParams
)
=> BrushReference pointFields
-> pointParams
-> r
)
-> r
withAnchorBrushData anchor ( Document { documentContent = Content { strokes } } ) f =
splineAnchor . listToMaybe $ filter ( \ Stroke { strokeUnique } -> strokeUnique == anchorStrokeUnique anchor ) strokes
where
splineAnchor :: Maybe Stroke -> r
splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrushRef } ) )
| SOpen <- ssplineType @clo
= case anchor of
AnchorAtStart {} -> f strokeBrushRef ( brushParams ( splineStart strokeSpline ) )
AnchorAtEnd {} -> f strokeBrushRef ( brushParams ( splineEnd strokeSpline ) )
splineAnchor _
= f NoBrush SuperRecord.rnil

View file

@ -81,7 +81,7 @@ import Control.Lens
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( Intersect, rnil )
( Intersect )
-- transformers
import Control.Monad.Trans.Class
@ -127,6 +127,8 @@ import MetaBrush.Document
, _selection
, coords
)
import MetaBrush.Document.Draw
( withAnchorBrushData )
import MetaBrush.Document.Selection
( dragUpdate )
import MetaBrush.Document.Serialise
@ -181,7 +183,7 @@ getDocumentRender
= do
let
-- Get any modifications from in-flight user actions (e.g. in the middle of dragging something).
-- Get any modifications from in-flight user actions (e.g. in the middle of dragging something).
modifiedStrokes :: [ Stroke ]
modifiedStrokes = case mode of
PathMode
@ -194,9 +196,9 @@ getDocumentRender
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
Just docUpdate -> strokes . documentContent $ newDocument docUpdate
_ -> strokes content
| Just ( PartialPath p0 cp0 anchor _ ) <- mbPartialPath
, let
mbFinalPoint :: Maybe ( Point2D Double )
mbControlPoint :: Maybe ( Point2D Double )
@ -206,31 +208,33 @@ getDocumentRender
| 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
, let
previewStroke :: Stroke
previewStroke = withAnchorBrushData anchor doc \ brushRef ( pointData :: Super.Rec pointFields ) ->
let
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec pointFields ) )
previewSpline = catMaybesSpline ( invalidateCache undefined )
( PointData p0 Normal pointData )
( do
cp <- cp0
guard ( cp /= p0 )
pure ( PointData cp Normal pointData )
)
( do
cp <- mbControlPoint
guard ( cp /= finalPoint )
pure ( PointData cp Normal pointData )
)
( PointData finalPoint Normal pointData )
in
Stroke
{ strokeSpline = previewSpline
, strokeVisible = True
, strokeUnique = unsafeUnique 987654321
, strokeName = "Preview stroke (temporary)"
, strokeBrushRef = NoBrush
, strokeBrushRef = brushRef
}
) : strokes content
)
-> previewStroke : strokes content
_ -> strokes content
strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams documentBrushes ) modifiedStrokes