hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

stroke hierarchy

Browse source
This commit is contained in:
sheaf 2021-04-26 17:18:48 +02:00
parent a5fdce1133
commit d604d4120e
7 changed files with 168 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/app/MetaBrush/Application.hs
View file

@ -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

33
src/app/MetaBrush/Document.hs
View file

@ -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 )

49
src/app/MetaBrush/Document/Draw.hs
View file

@ -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

58
src/app/MetaBrush/Document/Selection.hs
View file

@ -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

37
src/app/MetaBrush/Document/Serialise.hs
View file

@ -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 } )

10
src/app/MetaBrush/Document/SubdivideStroke.hs
View file

@ -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

13
src/app/MetaBrush/Render/Document.hs
View file

@ -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