diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 1ce9b5d..52c6fdb 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -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 ] ) diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index c5c8144..a02a250 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 } } diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 6ad11dc..8f8808f 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -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 } ) ) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 7a441a4..7237413 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 09ec9a6..b955f5a 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -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 } ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index ce9e562..47bdea0 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 () diff --git a/src/app/MetaBrush/Util.hs b/src/app/MetaBrush/Util.hs index 198e161..5cc8dea 100644 --- a/src/app/MetaBrush/Util.hs +++ b/src/app/MetaBrush/Util.hs @@ -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