mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
stroke hierarchy
This commit is contained in:
parent
a5fdce1133
commit
d604d4120e
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 } )
|
||||
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Reference in a new issue