hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

use Seq for strokes

Browse source
This commit is contained in:
sheaf 2021-04-26 14:34:34 +02:00
parent e1c5d266eb
commit a5fdce1133
7 changed files with 51 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -174,22 +174,24 @@ runApplication application = do
testDocuments = fmap newHistory $ uniqueMapFromList
[ emptyDocument "Test" docUnique
& ( field' @"documentContent" . field' @"strokes" ) .~
[ Stroke
{ strokeName = "Stroke 1"
, strokeVisible = True
, strokeUnique = strokeUnique
, strokeBrush = Just $ adaptBrush @'[ "r" SuperRecord.:= Double ] circleBrush
, strokeSpline =
Spline
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
, splineCurves = OpenCurves $ Seq.fromList
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined }
]
}
}
]
( Seq.fromList
[ Stroke
{ strokeName = "Stroke 1"
, strokeVisible = True
, strokeUnique = strokeUnique
, strokeBrush = Just $ adaptBrush @'[ "r" SuperRecord.:= Double ] circleBrush
, strokeSpline =
Spline
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
, splineCurves = OpenCurves $ Seq.fromList
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined }
]
}
}
]
)
]
where
mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )

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

@ -56,6 +56,10 @@ import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( empty, insert )
import Data.Sequence
( Seq )
import qualified Data.Sequence as Seq
( empty )
-- deepseq
import Control.DeepSeq
@ -154,7 +158,7 @@ data DocumentContent
{ unsavedChanges :: !Bool
, latestChange :: !Text
, guides :: !( Map Unique Guide )
, strokes :: ![ Stroke ]
, strokes :: !( Seq Stroke )
}
deriving stock ( Show, Generic )
deriving anyclass NFData
@ -262,7 +266,7 @@ emptyDocument docName unique =
Content
{ unsavedChanges = False
, latestChange = "New document"
, strokes = []
, strokes = Seq.empty
, guides = Map.empty
}
}

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

@ -18,8 +18,6 @@ module MetaBrush.Document.Draw
-- base
import Data.Functor
( ($>) )
import Data.Maybe
( listToMaybe )
-- acts
import Data.Act
@ -28,6 +26,8 @@ import Data.Act
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( filter, lookup )
-- deepseq
import Control.DeepSeq
@ -144,7 +144,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
newDoc' :: Document
newDoc'
= over ( field' @"documentContent" . field' @"strokes" )
( newStroke : )
( newStroke :<| )
newDoc
pure ( newDoc', AnchorAtEnd uniq, c, Nothing )
where
@ -244,7 +244,7 @@ withAnchorBrushData
)
-> r
withAnchorBrushData anchor ( Document { documentContent = Content { strokes } } ) f =
splineAnchor . listToMaybe $ filter ( \ Stroke { strokeUnique } -> strokeUnique == anchorStrokeUnique anchor ) strokes
splineAnchor . Seq.lookup 0 $ Seq.filter ( \ Stroke { strokeUnique } -> strokeUnique == anchorStrokeUnique anchor ) strokes
where
splineAnchor :: Maybe Stroke -> r
splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) )

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

@ -128,6 +128,8 @@ import MetaBrush.MetaParameter.Interpolation
( Interpolatable(Diff) )
import MetaBrush.Unique
( Unique )
import MetaBrush.Util
( traverseMaybe )
--------------------------------------------------------------------------------
@ -504,7 +506,7 @@ deleteSelected :: Document -> ( Document, UpdateInfo )
deleteSelected doc =
( `runState` mempty ) $
( field' @"documentContent" . field' @"strokes" )
( fmap catMaybes . traverse updateStroke )
( traverseMaybe updateStroke )
doc
where

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

@ -713,8 +713,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" ( JSON.Encoder.list encodeStroke ) strokes
JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides
. JSON.Encoder.atKey' "strokes" ( encodeSequence encodeStroke ) strokes
decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent
decodeDocumentContent uniqueSupply = do
@ -723,8 +723,8 @@ decodeDocumentContent uniqueSupply = do
unsavedChanges = False
latestChange :: Text
latestChange = "Load document"
strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) )
strokes <- JSON.Decoder.atKey "strokes" ( decodeSequence ( decodeStroke uniqueSupply ) )
guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) )
pure ( Content { unsavedChanges, latestChange, strokes, guides } )

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

@ -138,7 +138,7 @@ import MetaBrush.UI.ToolBar
import MetaBrush.Unique
( unsafeUnique )
import MetaBrush.Util
( withRGBA )
( traverseMaybe, withRGBA )
--------------------------------------------------------------------------------
@ -178,7 +178,7 @@ getDocumentRender
let
-- Get any modifications from in-flight user actions (e.g. in the middle of dragging something).
modifiedStrokes :: [ Stroke ]
modifiedStrokes :: Seq Stroke
modifiedStrokes = case mode of
PathMode
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
@ -230,10 +230,10 @@ getDocumentRender
, strokeName = "Preview stroke (temporary)"
, strokeBrush = mbBrush
}
-> previewStroke : strokes content
-> previewStroke :<| strokes content
_ -> strokes content
strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams ) modifiedStrokes
strokesRenderData <- traverseMaybe ( sequenceA . strokeRenderData fitParams ) modifiedStrokes
let
renderSelectionRect :: Cairo.Render ()

12
src/app/MetaBrush/Util.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -9,6 +10,7 @@ module MetaBrush.Util
( withRGBA, showRGBA
, widgetAddClasses, widgetAddClass
, (>=?=>), (>>?=)
, traverseMaybe
, Exists(..)
)
where
@ -23,6 +25,10 @@ import Data.Foldable
import GHC.Stack
( HasCallStack )
-- containers
import Data.Sequence
( Seq(..) )
-- gi-gdk
import qualified GI.Gdk as GDK
@ -73,5 +79,11 @@ infixl 1 >>?=
--------------------------------------------------------------------------------
traverseMaybe :: Applicative f => ( a -> f ( Maybe b ) ) -> Seq a -> f ( Seq b )
traverseMaybe _ Empty = pure Empty
traverseMaybe f ( a :<| as ) = ( \ case { Nothing -> id; Just b -> ( b :<| ) } ) <$> f a <*> traverseMaybe f as
--------------------------------------------------------------------------------
data Exists c where
Exists :: c a => a -> Exists c