mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
use Seq for strokes
This commit is contained in:
parent
e1c5d266eb
commit
a5fdce1133
|
@ -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 ] )
|
||||
|
|
|
@ -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
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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 } ) )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 } )
|
||||
|
||||
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue