From 46275514ff44705382d8b3a9bbe37cb96ce59648 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 25 Feb 2021 01:08:13 +0100 Subject: [PATCH] add stroke preview when drawing --- src/app/MetaBrush/Document.hs | 3 +- src/app/MetaBrush/Document/Draw.hs | 43 +++++++++++++++++++++- src/app/MetaBrush/Render/Document.hs | 54 +++++++++++++++------------- 3 files changed, 73 insertions(+), 27 deletions(-) diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 9276f75..9136848 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 56baa20..cd4b4af 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 5b7d1f3..be04cf9 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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