add stroke preview when drawing

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

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

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 )
+                Just docUpdate -> strokes . documentContent $ newDocument docUpdate
-                _              -> ( strokes content )
+                _              -> strokes content
-            | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
+            | 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
+            , let
-                  previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec '[] ) )
+                previewStroke :: Stroke
-                  previewSpline = catMaybesSpline ( invalidateCache undefined )
+                previewStroke = withAnchorBrushData anchor doc \ brushRef ( pointData :: Super.Rec pointFields ) ->
-                    ( PointData p0 Normal SuperRecord.rnil )
+                  let
-                    ( do
+                    previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec pointFields ) )
-                        cp <- cp0
+                    previewSpline = catMaybesSpline ( invalidateCache undefined )
-                        guard ( cp /= p0 )
+                      ( PointData p0 Normal pointData )
-                        pure ( PointData cp Normal SuperRecord.rnil )
+                      ( do
-                    )
+                          cp <- cp0
-                    ( do
+                          guard ( cp /= p0 )
-                        cp <- mbControlPoint
+                          pure ( PointData cp Normal pointData )
-                        guard ( cp /= finalPoint )
+                      )
-                        pure ( PointData cp Normal SuperRecord.rnil )
+                      ( do
-                    )
+                          cp <- mbControlPoint
-                    ( PointData finalPoint Normal SuperRecord.rnil )
+                          guard ( cp /= finalPoint )
-                in
+                          pure ( PointData cp Normal pointData )
-                  ( ( Stroke
+                      )
+                      ( 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