mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 23:44:07 +00:00
add stroke preview when drawing
This commit is contained in:
sheaf
parent
4788ab2efd
commit
46275514ff
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue