diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 52c6fdb..fef49f3 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -116,7 +116,7 @@ import MetaBrush.Context ) import MetaBrush.Document ( emptyDocument - , Stroke(..), FocusState(..) + , Stroke(..), StrokeHierarchy(..), FocusState(..) , PointData(..) ) import MetaBrush.Document.History @@ -175,7 +175,7 @@ runApplication application = do [ emptyDocument "Test" docUnique & ( field' @"documentContent" . field' @"strokes" ) .~ ( Seq.fromList - [ Stroke + [ StrokeLeaf $ Stroke { strokeName = "Stroke 1" , strokeVisible = True , strokeUnique = strokeUnique diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index a02a250..4a990e0 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -26,7 +26,8 @@ module MetaBrush.Document ( AABB(..), mkAABB , Document(..), DocumentContent(..) , emptyDocument - , Stroke(..), StrokeSpline, _strokeSpline, overStrokeSpline + , Stroke(..), StrokeHierarchy(..), visibleStrokes + , StrokeSpline, _strokeSpline, overStrokeSpline , PointData(..), BrushPointData(..), DiffPointData(..) , FocusState(..), Hoverable(..), HoverContext(..) , Guide(..) @@ -57,9 +58,9 @@ import Data.Map.Strict import qualified Data.Map.Strict as Map ( empty, insert ) import Data.Sequence - ( Seq ) + ( Seq(..) ) import qualified Data.Sequence as Seq - ( empty ) + ( empty, singleton ) -- deepseq import Control.DeepSeq @@ -158,11 +159,35 @@ data DocumentContent { unsavedChanges :: !Bool , latestChange :: !Text , guides :: !( Map Unique Guide ) - , strokes :: !( Seq Stroke ) + , strokes :: !( Seq StrokeHierarchy ) } deriving stock ( Show, Generic ) deriving anyclass NFData +-- | Hierarchy for groups of strokes. +data StrokeHierarchy + = StrokeGroup + { groupName :: !Text + , groupVisible :: !Bool + , groupContents :: !( Seq StrokeHierarchy ) + } + | StrokeLeaf + { strokeLeaf :: !Stroke } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +visibleStrokes :: StrokeHierarchy -> Seq Stroke +visibleStrokes ( StrokeGroup { groupVisible, groupContents } ) + | groupVisible + = foldMap visibleStrokes groupContents + | otherwise + = Empty +visibleStrokes ( StrokeLeaf { strokeLeaf } ) + | strokeVisible strokeLeaf + = Seq.singleton strokeLeaf + | otherwise + = Empty + type StrokeSpline clo brushParams = Spline clo ( CachedStroke RealWorld ) ( PointData brushParams ) diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 8f8808f..dd2aaef 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -16,8 +17,12 @@ module MetaBrush.Document.Draw where -- base +import Data.Coerce + ( coerce ) import Data.Functor ( ($>) ) +import Data.Semigroup + ( First(..) ) -- acts import Data.Act @@ -26,8 +31,6 @@ import Data.Act -- containers import Data.Sequence ( Seq(..) ) -import qualified Data.Sequence as Seq - ( filter, lookup ) -- deepseq import Control.DeepSeq @@ -78,7 +81,8 @@ import MetaBrush.Assert import MetaBrush.Brush ( BrushAdaptedTo ) import MetaBrush.Document - ( Document(..), DocumentContent(..), Stroke(..), StrokeSpline + ( Document(..), DocumentContent(..) + , Stroke(..), StrokeHierarchy(..), StrokeSpline , FocusState(..), PointData(..) , _selection, _strokeSpline , coords, overStrokeSpline @@ -118,7 +122,8 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) - updateStroke doc + updateStrokeHierarchy + doc of -- Anchor found: use it. ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> @@ -144,12 +149,19 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = newDoc' :: Document newDoc' = over ( field' @"documentContent" . field' @"strokes" ) - ( newStroke :<| ) + ( StrokeLeaf newStroke :<| ) newDoc pure ( newDoc', AnchorAtEnd uniq, c, Nothing ) where -- Deselect all points, and try to find a valid anchor for drawing -- (a path start/end point at mouse click point). + + updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = do + newContents <- traverse updateStrokeHierarchy groupContents + pure ( StrokeGroup { groupContents = newContents, .. } ) + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf + updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke @@ -196,10 +208,19 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document -addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke +addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) updateStrokeHierarchy where - addToStroke :: Stroke -> Stroke - addToStroke stroke@( Stroke { strokeUnique } ) + + updateStrokeHierarchy :: StrokeHierarchy -> StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = + let + newContents = fmap updateStrokeHierarchy groupContents + in + StrokeGroup { groupContents = newContents, .. } + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf $ updateStroke strokeLeaf + + updateStroke :: Stroke -> Stroke + updateStroke stroke@( Stroke { strokeUnique } ) | strokeUnique == anchorStrokeUnique anchor = let @@ -244,8 +265,18 @@ withAnchorBrushData ) -> r withAnchorBrushData anchor ( Document { documentContent = Content { strokes } } ) f = - splineAnchor . Seq.lookup 0 $ Seq.filter ( \ Stroke { strokeUnique } -> strokeUnique == anchorStrokeUnique anchor ) strokes + splineAnchor . coerce $ foldMap getFirstRelevantStroke strokes where + + getFirstRelevantStroke :: StrokeHierarchy -> Maybe ( First Stroke ) + getFirstRelevantStroke ( StrokeGroup { groupContents } ) = + foldMap getFirstRelevantStroke groupContents + getFirstRelevantStroke ( StrokeLeaf { strokeLeaf } ) + | strokeUnique strokeLeaf == anchorStrokeUnique anchor + = Just ( First strokeLeaf ) + | otherwise + = Nothing + splineAnchor :: Maybe Stroke -> r splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) ) | SOpen <- ssplineType @clo diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 7237413..775f02e 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -10,6 +10,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -116,7 +117,7 @@ import Math.Vector2D import {-# SOURCE #-} MetaBrush.Context ( Modifier(..) ) import MetaBrush.Document - ( Document(..), Stroke(..) + ( Document(..), Stroke(..), StrokeHierarchy(..) , PointData(..), DiffPointData , FocusState(..), _selection , StrokeSpline, _strokeSpline, overStrokeSpline @@ -158,8 +159,15 @@ selectionMode = foldMap \case -- | Updates the selected objects on a single click selection event. selectAt :: SelectionMode -> Point2D Double -> Document -> Document selectAt selMode c doc@( Document { zoomFactor } ) = - ( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + ( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc where + + updateStrokeHierarchy :: StrokeHierarchy -> State Bool StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = do + newContents <- traverse updateStrokeHierarchy groupContents + pure ( StrokeGroup { groupContents = newContents, .. } ) + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf + updateStroke :: Stroke -> State Bool Stroke updateStroke stroke@( Stroke { strokeVisible } ) = _strokeSpline updateSpline stroke where @@ -222,7 +230,7 @@ dragMoveSelect c doc@( Document { zoomFactor } ) = let res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document res = do - newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc lift $ Tardis.getPast >>= Tardis.sendPast pure newDoc in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) . runWriterT $ res of @@ -231,6 +239,12 @@ dragMoveSelect c doc@( Document { zoomFactor } ) = _ -> Nothing where + updateStrokeHierarchy :: StrokeHierarchy -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = do + newContents <- traverse updateStrokeHierarchy groupContents + pure ( StrokeGroup { groupContents = newContents, .. } ) + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf + updateStroke :: Stroke -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Stroke updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke where @@ -374,11 +388,20 @@ dragMoveSelect c doc@( Document { zoomFactor } ) = selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"documentContent" . field' @"strokes" . mapped ) - updateStroke + updateStrokeHierarchy where xMin, xMax, yMin, yMax :: Double ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 ) ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 ) + + updateStrokeHierarchy :: StrokeHierarchy -> StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = + let + newContents = fmap updateStrokeHierarchy groupContents + in + StrokeGroup { groupContents = newContents, .. } + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf $ updateStroke strokeLeaf + updateStroke :: Stroke -> Stroke updateStroke stroke@( Stroke { strokeVisible } ) = overStrokeSpline @@ -415,8 +438,15 @@ data UpdateInfo -- Returns the updated document, together with info about how many points were translated. translateSelection :: Vector2D Double -> Document -> ( Document, UpdateInfo ) translateSelection t doc = - ( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + ( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc where + + updateStrokeHierarchy :: StrokeHierarchy -> StateT Bool ( State UpdateInfo ) StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = do + newContents <- traverse updateStrokeHierarchy groupContents + pure ( StrokeGroup { groupContents = newContents, .. } ) + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf + updateStroke :: Stroke -> StateT Bool ( State UpdateInfo ) Stroke updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke where @@ -506,10 +536,17 @@ deleteSelected :: Document -> ( Document, UpdateInfo ) deleteSelected doc = ( `runState` mempty ) $ ( field' @"documentContent" . field' @"strokes" ) - ( traverseMaybe updateStroke ) + ( traverseMaybe updateStrokeHierarchy ) doc where + + updateStrokeHierarchy :: StrokeHierarchy -> State UpdateInfo ( Maybe StrokeHierarchy ) + updateStrokeHierarchy ( StrokeGroup { .. } ) = do + newContents <- traverseMaybe updateStrokeHierarchy groupContents + pure ( Just $ StrokeGroup { groupContents = newContents, .. } ) + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = fmap StrokeLeaf <$> updateStroke strokeLeaf + updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke ) updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke where @@ -664,7 +701,7 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen let ( newDocument, mbStrokeName ) = ( `runState` Nothing ) $ - ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc in case mbStrokeName of Just name -> do let @@ -673,6 +710,13 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen Just ( HistoryChange { newDocument, changeText } ) _ -> Nothing where + + updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe Text ) StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = do + newContents <- traverse updateStrokeHierarchy groupContents + pure ( StrokeGroup { groupContents = newContents, .. } ) + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf + updateStroke :: Stroke -> State ( Maybe Text ) Stroke updateStroke stroke@( Stroke { strokeUnique, strokeName } ) | strokeUnique /= dragStrokeUnique diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index b955f5a..3220be2 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -181,7 +181,7 @@ import MetaBrush.Brush ) import MetaBrush.Document ( Document(..), DocumentContent(..), Guide(..) - , Stroke(..), StrokeSpline + , Stroke(..), StrokeHierarchy(..), StrokeSpline , PointData(..), FocusState(..) ) import MetaBrush.MetaParameter.AST @@ -694,6 +694,33 @@ decodeStroke uniqueSupply = do +encodeStrokeHierarchy :: Monad f => JSON.Encoder f StrokeHierarchy +encodeStrokeHierarchy = JSON.Encoder.mapLikeObj \case + StrokeGroup { groupName, groupVisible, groupContents } -> + JSON.Encoder.atKey' "tag" JSON.Encoder.text "group" + . JSON.Encoder.atKey' "name" JSON.Encoder.text groupName + . JSON.Encoder.atKey' "visible" JSON.Encoder.bool groupVisible + . JSON.Encoder.atKey' "contents" ( encodeSequence encodeStrokeHierarchy ) groupContents + StrokeLeaf { strokeLeaf } -> + JSON.Encoder.atKey' "tag" JSON.Encoder.text "leaf" + . JSON.Encoder.atKey' "stroke" encodeStroke strokeLeaf + +decodeStrokeHierarchy :: MonadIO m => UniqueSupply -> JSON.Decoder m StrokeHierarchy +decodeStrokeHierarchy uniqueSupply = do + tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text + case tag of + "group" -> do + groupName <- JSON.Decoder.atKey "name" JSON.Decoder.text + groupVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool + groupContents <- JSON.Decoder.atKey "contents" ( decodeSequence $ decodeStrokeHierarchy uniqueSupply ) + pure ( StrokeGroup { groupName, groupVisible, groupContents } ) + "leaf" -> do + strokeLeaf <- JSON.Decoder.atKey "leaf" ( decodeStroke uniqueSupply ) + pure ( StrokeLeaf { strokeLeaf } ) + _ -> throwError ( JSON.ParseFailed $ "Unsupported stroke hierarchy type with tag " <> tag ) + + + encodeGuide :: Applicative f => JSON.Encoder f Guide encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) -> JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint @@ -713,8 +740,8 @@ decodeGuide uniqueSupply = do encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) -> - JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides - . JSON.Encoder.atKey' "strokes" ( encodeSequence encodeStroke ) strokes + JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides + . JSON.Encoder.atKey' "strokes" ( encodeSequence encodeStrokeHierarchy ) strokes decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent decodeDocumentContent uniqueSupply = do @@ -723,8 +750,8 @@ decodeDocumentContent uniqueSupply = do unsavedChanges = False latestChange :: Text latestChange = "Load document" - strokes <- JSON.Decoder.atKey "strokes" ( decodeSequence ( decodeStroke uniqueSupply ) ) - guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) ) + strokes <- JSON.Decoder.atKey "strokes" ( decodeSequence ( decodeStrokeHierarchy uniqueSupply ) ) + guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) ) pure ( Content { unsavedChanges, latestChange, strokes, guides } ) diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs index 5bf9791..6023d40 100644 --- a/src/app/MetaBrush/Document/SubdivideStroke.hs +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -60,7 +60,7 @@ import Math.Module import Math.Vector2D ( Point2D(..), Vector2D(..), Segment(..) ) import MetaBrush.Document - ( Document(..), Stroke(..), StrokeSpline + ( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline , PointData(..), DiffPointData(..) , coords, _strokeSpline ) @@ -78,10 +78,16 @@ subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc, mbSubdivLoc ) = ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) - updateStroke + updateStrokeHierarchy doc in ( updatedDoc , ) <$> mbSubdivLoc where + updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe Text ) StrokeHierarchy + updateStrokeHierarchy ( StrokeGroup { .. } ) = do + newContents <- traverse updateStrokeHierarchy groupContents + pure ( StrokeGroup { groupContents = newContents, .. } ) + updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf + updateStroke :: Stroke -> State ( Maybe Text ) Stroke updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 47bdea0..f53bfad 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -35,8 +35,6 @@ import Data.Functor.Compose ( Compose(..) ) import Data.Int ( Int32 ) -import Data.Maybe - ( mapMaybe ) import GHC.Exts ( Proxy#, proxy# ) import GHC.Generics @@ -114,7 +112,8 @@ import MetaBrush.Context import MetaBrush.Document ( Document(..), DocumentContent(..) , mkAABB - , Stroke(..), StrokeSpline + , Stroke(..), visibleStrokes + , StrokeSpline , FocusState(..) , HoverContext(..), Hoverable(..) , PointData(..) @@ -190,8 +189,8 @@ getDocumentRender afterDrag :: Maybe DocChange afterDrag = dragUpdate p0 p1 dragAction alternateMode doc -> case afterDrag of - Just docUpdate -> strokes . documentContent $ newDocument docUpdate - _ -> strokes content + Just docUpdate -> foldMap visibleStrokes . strokes . documentContent $ newDocument docUpdate + _ -> foldMap visibleStrokes . strokes $ content | Just ( PartialPath p0 cp0 anchor firstPoint ) <- mbPartialPath , let mbFinalPoint :: Maybe ( Point2D Double ) @@ -230,8 +229,8 @@ getDocumentRender , strokeName = "Preview stroke (temporary)" , strokeBrush = mbBrush } - -> previewStroke :<| strokes content - _ -> strokes content + -> previewStroke :<| foldMap visibleStrokes ( strokes content ) + _ -> foldMap visibleStrokes ( strokes content ) strokesRenderData <- traverseMaybe ( sequenceA . strokeRenderData fitParams ) modifiedStrokes