add stroke layer view

This commit is contained in:
sheaf 2024-09-27 23:36:33 +02:00
parent 0eb0724dde
commit 24f182feec
26 changed files with 1753 additions and 442 deletions

View file

@ -149,7 +149,7 @@ common gtk
, gi-cairo-connector
^>= 0.1.0
, gi-gdk
>= 4.0.2 && < 4.1
>= 4.0.9 && < 4.1
, gi-gio
>= 2.0.34 && < 2.1
, gi-glib
@ -161,7 +161,7 @@ common gtk
, haskell-gi
>= 0.26.10 && < 0.27
, haskell-gi-base
>= 0.26.6 && < 0.27
>= 0.26.8 && < 0.27
-- Workaround for https://github.com/haskell/cabal/issues/4237
-- See https://github.com/commercialhaskell/stack/issues/2197
@ -246,6 +246,7 @@ executable MetaBrush
, MetaBrush.UI.InfoBar
, MetaBrush.UI.Menu
, MetaBrush.UI.Panels
, MetaBrush.UI.StrokeTreeView
, MetaBrush.UI.ToolBar
, MetaBrush.UI.Viewport

View file

@ -1,7 +1,32 @@
/*
.metabrush * {
all: unset;
}
*/
.toggle, .dialogButton, .titleBar, .windowIcon, .fileBarCloseButton,
.newFileButton, .header, .paned, .panel, .tabs, .frame {
all: unset;
}
.reorderable-page {
all: unset;
}
.menu * {
all: unset;
}
.frame > * {
all: unset;
}
.notebook {
all: unset;
}
@import url("colours.css");
@ -470,4 +495,100 @@ To specify it in CSS, set the box-shadow of the contents node."
.infoBarInfo {
margin-left: -4px;
padding-right: 16px;
}
}
/* Stroke hierarchy layers */
row {
border-top: 0px;
border-bottom: 0px;
margin-top: -2px;
margin-bottom: -2px;
}
/* Slightly hacky way to align layers and groups */
indent {
margin-left: 4px;
margin-right: 4px;
}
:selected {
background-color: rgba(255,255,255,0);
font-weight: bold;
color: black;
}
.layer-item {
color: @plain;
background-color: @active;
border: 0px solid @bg;
transition:
border-color 0.3s ease-out,
border-color 0.2s ease-in,
background-color 0.6s ease-out,
background-color 0.4s ease-in,
box-shadow 0.6s ease-out,
box-shadow 0.4s ease-in;
padding-top: 4px;
padding-bottom: 4px;
border-top: 1px solid @active;
border-bottom: 1px solid @active;
margin-top: -1px;
margin-bottom: -1px;
padding-left: 3px;
}
:selected .layer-item {
color: black;
background-color: @contrast;
border: 0px solid @contrast;
}
/* Add "drop here" areas when a drag has been initiated */
.dragging-item .layer-item {
}
/* Style when dragging over an item */
.drag-over.layer-item {
}
/* Style when dragging over the top part of an item */
.drag-top.layer-item {
border-top: 2px solid @highlight;
margin-top: -2px;
box-shadow:
0 -1px 6px 1px @highlight,
inset 0 8px 6px -6px @highlight;
}
/* Style when dragging over the bottom part of an item */
.drag-bot.layer-item {
border-bottom: 2px solid @highlight;
margin-bottom: -2px;
box-shadow:
inset 0 -8px 6px -6px @highlight;
}
/* Style for item being dragged */
.dragged.layer-item {
background-color: @bg;
transition:
background-color 0.4s ease-in-out;
}
/* Wide separator styling */
.metabrush .wide {
background-color: @bg;
background-size: 0px;
background-image: none;
min-width: 2px;
min-height: 2px;
}
/* List view */
.metabrush .view {
margin-top: 3px;
border: 0px;
background-color: @bg;
}

View file

@ -25,8 +25,6 @@ import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import Data.Set
( Set )
import qualified Data.Set as Set
-- directory
@ -61,9 +59,6 @@ import Control.Lens
-- stm
import qualified Control.Concurrent.STM as STM
( atomically, retry )
import qualified Control.Concurrent.STM.TVar as STM
( newTVarIO, readTVar, writeTVar )
-- transformers
import Control.Monad.Trans.Reader
@ -71,7 +66,7 @@ import Control.Monad.Trans.Reader
-- brush-strokes
import Math.Root.Isolation
( RootIsolationOptions(..), defaultRootIsolationOptions )
( defaultRootIsolationOptions )
import Math.Bezier.Cubic.Fit
( FitParameters(..) )
import Math.Bezier.Spline
@ -86,16 +81,14 @@ import Math.Linear
-- MetaBrush
import MetaBrush.Application.Action
( ActionOrigin(..) )
import MetaBrush.Application.Context
( UIElements(..), Variables(..) )
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
import MetaBrush.Asset.Colours
( getColours )
import MetaBrush.Asset.Logo
( drawLogo )
import MetaBrush.Application.Context
( UIElements(..), Variables(..)
, Modifier(..)
, HoldAction(..), PartialPath(..)
)
import MetaBrush.Application.UpdateDocument
( activeDocument, withActiveDocument )
import MetaBrush.Document
@ -113,15 +106,14 @@ import MetaBrush.Render.Rulers
( renderRuler )
import MetaBrush.Stroke
import MetaBrush.UI.FileBar
( FileBar(..), FileBarTab, createFileBar )
( FileBar(..), createFileBar )
import MetaBrush.UI.InfoBar
( InfoBar(..), createInfoBar, updateInfoBar )
import MetaBrush.UI.Menu
( createMenuBar, createMenuActions )
import MetaBrush.UI.Panels
( createPanelBar )
--import MetaBrush.UI.StrokeTreeView
-- ( newStrokeView )
import MetaBrush.UI.StrokeTreeView
( newLayerView )
import MetaBrush.UI.ToolBar
( Tool(..), Mode(..), createToolBar )
import MetaBrush.UI.Viewport
@ -147,7 +139,6 @@ runApplication application = do
uniqueSupply <- newUniqueSupply
docUnique <- runReaderT freshUnique uniqueSupply
strokeUnique <- runReaderT freshUnique uniqueSupply
let
testStroke =
@ -175,17 +166,30 @@ runApplication application = do
testLayers :: Layers
testLayers =
[ StrokeLayer
{ layerUnique = strokeUnique
, layerName = "Stroke 1"
, layerVisible = True
, layerLocked = False
, layerStroke = testStroke
[ GroupLayer
{ layerName = "Group 1"
, layerVisible = True
, layerLocked = False
, groupChildren =
[ StrokeLayer
{ layerName = "Stroke 1"
, layerVisible = True
, layerLocked = False
, layerStroke = testStroke
}
]
}
, GroupLayer
{ layerName = "Group 2"
, layerVisible = True
, layerLocked = False
, groupChildren = []
}
]
( layerMeta, testStrokes ) = layersStrokeHierarchy testLayers
( layerMeta, testStrokes ) <- ( `runReaderT` uniqueSupply ) $ layersStrokeHierarchy testLayers
let
testDoc :: Document
testDoc
= emptyDocument "Test"
@ -196,39 +200,38 @@ runApplication application = do
testDocuments = newHistory <$> Map.fromList
[ ( docUnique, testDoc ) ]
recomputeStrokesTVar <- STM.newTVarIO @Bool False
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( 2 ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode PathMode
debugTVar <- STM.newTVarIO @Bool False
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
fileBarTabsTVar <- STM.newTVarIO @( Map Unique FileBarTab ) Map.empty
showGuidesTVar <- STM.newTVarIO @Bool True
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
fitParametersTVar <- STM.newTVarIO @FitParameters $
FitParameters
{ maxSubdiv = 2 --5 --2 --3 -- 6
, nbSegments = 3
, dist_tol = 5e-3
, t_tol = 1e-4
, maxIters = 20
}
rootsAlgoTVar <- STM.newTVarIO @RootSolvingAlgorithm $
--HalleyM2
NewtonRaphson
{ maxIters = 20, precision = 8 }
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
recomputeStrokesTVar <- STM.newTVarIO False
documentRenderTVar <- STM.newTVarIO ( const $ pure () )
activeDocumentTVar <- STM.newTVarIO Nothing
openDocumentsTVar <- STM.newTVarIO testDocuments
strokeListModelsTVar <- STM.newTVarIO Map.empty
parStoresTVar <- STM.newTVarIO Map.empty
listModelUpToDateTMVar <- STM.newTMVarIO ()
mousePosTVar <- STM.newTVarIO Nothing
mouseHoldTVar <- STM.newTVarIO Nothing
modifiersTVar <- STM.newTVarIO Set.empty
toolTVar <- STM.newTVarIO Selection
modeTVar <- STM.newTVarIO PathMode
debugTVar <- STM.newTVarIO False
partialPathTVar <- STM.newTVarIO Nothing
fileBarTabsTVar <- STM.newTVarIO Map.empty
showGuidesTVar <- STM.newTVarIO True
maxHistorySizeTVar <- STM.newTVarIO 1000
fitParametersTVar <- STM.newTVarIO $
FitParameters
{ maxSubdiv = 2 --5 --2 --3 -- 6
, nbSegments = 3
, dist_tol = 5e-3
, t_tol = 1e-4
, maxIters = 20
}
rootsAlgoTVar <- STM.newTVarIO $
--HalleyM2
NewtonRaphson
{ maxIters = 20, precision = 8 }
cuspFindingOptionsTVar <- STM.newTVarIO $
Just defaultRootIsolationOptions
--testDocsStrokeListModels <-
-- for testDocuments ( newStrokeView . strokes . documentContent . present )
strokeListModelsTVar <- STM.newTVarIO @( Map Unique GTK.SelectionModel ) Map.empty --testDocsStrokeListModels
-- Put all these stateful variables in a record for conciseness.
let
variables :: Variables
@ -274,6 +277,7 @@ runApplication application = do
toolBar <- GTK.boxNew GTK.OrientationVertical 0
mainPane <- GTK.panedNew GTK.OrientationHorizontal
GTK.panedSetWideHandle mainPane True
panelBox <- GTK.boxNew GTK.OrientationVertical 0
GTK.gridAttach uiGrid toolBar 0 0 2 1
@ -428,11 +432,6 @@ runApplication application = do
_ <- createToolBar variables colours toolBar
---------------------------------------------------------
-- Panels bar
panelsBar <- createPanelBar panelBox
---------------------------------------------------------
-- Info bar
@ -440,6 +439,11 @@ runApplication application = do
menuActions <- createMenuActions
---------------------------------------------------------
-- Panels bar
panelsBar <- createPanelBar panelBox
rec
---------------------------------------------------------
@ -450,7 +454,7 @@ runApplication application = do
colours variables
application window windowKeys titleBar titleLabel viewport infoBar
menuBar menuActions
panelsBar
panelsBar strokesListView
let
uiElements :: UIElements
@ -461,6 +465,15 @@ runApplication application = do
menuBar <- createMenuBar uiElements variables colours
---------------------------------------------------------
-- Strokes view
strokesListView <- newLayerView uiElements variables
GTK.scrolledWindowSetChild
( layersScrolledWindow panelsBar )
( Just strokesListView )
GTK.boxAppend mainView fileBarBox
GTK.boxAppend mainView viewportGrid
GTK.boxAppend mainView infoBarArea

View file

@ -20,8 +20,6 @@ import Data.Traversable
( for )
import Data.Word
( Word32 )
import GHC.Generics
( Generic )
-- acts
import Data.Act
@ -66,10 +64,6 @@ import qualified GI.Gtk as GTK
-- haskell-gi-base
import qualified Data.GI.Base as GI
-- hashable
import Data.Hashable
( Hashable )
-- lens
import Control.Lens
( over, set )
@ -103,10 +97,6 @@ import Math.Linear
-- MetaBrush
import MetaBrush.Action
import MetaBrush.Application.Context
( UIElements(..), Variables(..)
, Modifier(..), modifierKey
, HoldAction(..), GuideAction(..), PartialPath(..)
)
import MetaBrush.Document
( Document(..), DocumentContent(..), DocumentMetadata(..)
, Zoom(..)
@ -142,10 +132,8 @@ import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
( updateInfoBar )
import {-# SOURCE #-} MetaBrush.UI.FileBar
( FileBarTab(..), TabLocation(..), newFileTab, removeFileTab )
import MetaBrush.UI.ToolBar
( Tool(..), Mode(..) )
import MetaBrush.UI.FileBar
( newFileTab, removeFileTab )
import MetaBrush.UI.Viewport
( Viewport(..) )
import MetaBrush.Unique
@ -157,12 +145,6 @@ import MetaBrush.GTK.Util
--------------------------------------------------------------------------------
data ActionName
= AppAction { actionSimpleName :: !Text }
| WinAction { actionSimpleName :: !Text }
deriving stock ( Eq, Ord, Show, Generic )
deriving anyclass Hashable
actionPrefix :: ActionName -> Text
actionPrefix ( AppAction _ ) = "app."
actionPrefix ( WinAction _ ) = "win."
@ -664,10 +646,9 @@ instance HandleAction Delete where
Nothing ->
pure Don'tModifyDoc
Just ( doc', affectedPoints, delStrokes ) -> do
-- TODO: this would also be a hierarchy diff...
-- but for now we will just have emtpy strokes in the
-- layers view.
let diff = HistoryDiff $ ContentDiff $
-- TODO: only a hierarchy diff if there are
-- any deleted strokes.
let diff = HistoryDiff $ HierarchyDiff $
DeletePoints
{ deletedPoints = affectedPoints
, deletedStrokes = delStrokes
@ -968,6 +949,7 @@ instance HandleAction MouseClick where
, newPosition = WithinParent Root 0
-- TODO: add the stroke above the selected layer
-- or something of the sort.
, newIsGroup = False
}
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
else

View file

@ -7,21 +7,10 @@ import Data.Word
-- gi-gtk
import qualified GI.Gtk as GTK
-- hashable
import Data.Hashable
( Hashable )
-- text
import Data.Text
( Text )
-- MetaBrush
import Math.Linear
( (..), T(..) )
import {-# SOURCE #-} MetaBrush.Application.Context
( UIElements, Variables )
import {-# SOURCE #-} MetaBrush.UI.FileBar
( TabLocation(..) )
import MetaBrush.Application.Context
import MetaBrush.UI.Viewport
( Ruler(..) )
import MetaBrush.Unique
@ -29,15 +18,6 @@ import MetaBrush.Unique
--------------------------------------------------------------------------------
data ActionName
= AppAction { actionSimpleName :: !Text }
| WinAction { actionSimpleName :: !Text }
instance Eq ActionName
instance Ord ActionName
instance Show ActionName
instance Hashable ActionName
class HandleAction action where
handleAction :: UIElements -> Variables -> action -> IO ()

View file

@ -1,15 +1,12 @@
module MetaBrush.Application.Context
( UIElements(..), Variables(..)
, LR(..), Modifier(..), modifierKey
, HoldAction(..), GuideAction(..), PartialPath(..)
)
where
module MetaBrush.Application.Context where
-- base
import Data.Int
( Int32 )
import Data.Word
( Word32 )
import GHC.Generics
( Generic )
-- containers
import Data.Set
@ -30,9 +27,17 @@ import qualified GI.Gio as GIO
-- gi-gtk
import qualified GI.Gtk as GTK
-- hashable
import Data.Hashable
( Hashable )
-- stm
import qualified Control.Concurrent.STM.TVar as STM
( TVar )
import qualified Control.Concurrent.STM.TVar as STM
import qualified Control.Concurrent.STM.TMVar as STM
-- text
import Data.Text
( Text )
-- unordered-containers
import Data.HashMap.Strict
@ -51,8 +56,6 @@ import Math.Root.Isolation
-- MetaBrush
import MetaBrush.Action
( BrushWidgetActionState )
import {-# SOURCE #-} MetaBrush.Application.Action
( ActionName )
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Document.Diff
@ -61,14 +64,10 @@ import MetaBrush.Draw
( DrawAnchor )
import MetaBrush.Document.History
( DocumentHistory(..) )
import {-# SOURCE #-} MetaBrush.UI.FileBar
( FileBar, FileBarTab )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar )
import MetaBrush.Layer
( Parent )
import MetaBrush.UI.Panels
( PanelsBar )
import {-# SOURCE #-} MetaBrush.UI.ToolBar
( Tool, Mode )
import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) )
import MetaBrush.Unique
@ -79,18 +78,19 @@ import MetaBrush.Unique
data UIElements
= UIElements
{ application :: !GTK.Application
, window :: !GTK.ApplicationWindow
, windowKeys :: !GTK.EventControllerKey
, titleBar :: !GTK.HeaderBar
, titleLabel :: !GTK.Label
, fileBar :: !FileBar
, viewport :: !Viewport
, infoBar :: !InfoBar
, menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
, menuActions :: !( HashMap ActionName GIO.SimpleAction )
, panelsBar :: !PanelsBar
, colours :: !Colours
{ application :: !GTK.Application
, window :: !GTK.ApplicationWindow
, windowKeys :: !GTK.EventControllerKey
, titleBar :: !GTK.HeaderBar
, titleLabel :: !GTK.Label
, fileBar :: !FileBar
, viewport :: !Viewport
, infoBar :: !InfoBar
, menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
, menuActions :: !( HashMap ActionName GIO.SimpleAction )
, panelsBar :: !PanelsBar
, strokesListView :: GTK.ListView
, colours :: !Colours
}
data Variables
@ -100,7 +100,19 @@ data Variables
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
, strokeListModelsTVar :: !( STM.TVar ( Map Unique GTK.SelectionModel ) )
, strokeListModelsTVar :: !( STM.TVar ( Map Unique GTK.SingleSelection ) )
-- | This TVar allows us to look up which 'GIO.ListStore' is used
-- for the children of a given parent.
--
-- This allows us to know, given a parent and a child index,
-- how to insert/delete from the 'GTK.TreeListModel'.
, parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) )
-- | This TMVar is used to ensure that the layer hierarchy data
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
, listModelUpToDateTMVar :: !( STM.TMVar () )
, mousePosTVar :: !( STM.TVar ( Maybe ( 2 ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
@ -176,3 +188,62 @@ data PartialPath
, firstPoint :: !Bool
}
deriving stock Show
--------------------------------------------------------------------------------
data Tool
= Selection
| Pen
deriving stock ( Show, Eq )
data Mode
= PathMode
| BrushMode
| MetaMode
deriving stock ( Show, Eq )
data ToolBar
= ToolBar
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
:: !GTK.ToggleButton
}
--------------------------------------------------------------------------------
data FileBar
= FileBar
{ fileBarBox :: !GTK.Box
, fileTabsBox :: !GTK.Box
, fileBarPhantomToggleButton :: !GTK.ToggleButton
}
data FileBarTab
= FileBarTab
{ fileBarTab :: !GTK.Box
, fileBarTabButton :: !GTK.ToggleButton
, fileBarTabCloseArea :: !GTK.DrawingArea
}
data TabLocation
= AfterCurrentTab
| LastTab
deriving stock Show
--------------------------------------------------------------------------------
data InfoBar
= InfoBar
{ infoBarArea :: !GTK.Box
, zoomText :: !GTK.Label -- make this editable
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
}
--------------------------------------------------------------------------------
data ActionName
= AppAction { actionSimpleName :: !Text }
| WinAction { actionSimpleName :: !Text }
deriving stock ( Eq, Show, Generic )
deriving anyclass Hashable
--------------------------------------------------------------------------------

View file

@ -1,17 +0,0 @@
module MetaBrush.Application.Context
( UIElements, Variables
, Modifier(..), LR(..) )
where
--------------------------------------------------------------------------------
data UIElements
data Variables
data LR = L | R
data Modifier
= Control LR
| Alt LR
| Shift LR

View file

@ -18,12 +18,14 @@ import Data.Traversable
-- containers
import qualified Data.Map.Strict as Map
( adjust, delete, lookup )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- gi-glib
import qualified GI.GLib as GLib
-- gi-gio
import qualified GI.Gio as GIO
@ -40,9 +42,6 @@ import Control.Lens.Fold
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( readTVar, readTVar, modifyTVar', writeTVar )
-- text
import Data.Text
@ -59,24 +58,23 @@ import qualified Data.HashMap.Lazy as HashMap
( lookup )
-- MetaBrush
import {-# SOURCE #-} MetaBrush.Application.Action
( ActionName(..) )
import MetaBrush.Application.Context
( UIElements(..), Variables(..) )
import MetaBrush.Document
( Document(..), DocumentContent(..), DocumentMetadata(..)
)
import MetaBrush.Document.Diff
import MetaBrush.Document.History
( DocumentHistory(..), atStart, atEnd
, newFutureStep, affirmPresent
, newFutureStep, affirmPresentSaved
)
import MetaBrush.GTK.Util
( (>>?=) )
import {-# SOURCE #-} MetaBrush.UI.FileBar
( FileBarTab(..), removeFileTab )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( removeFileTab )
import MetaBrush.UI.InfoBar
( updateInfoBar )
import {-# SOURCE #-} MetaBrush.UI.StrokeTreeView
( switchStrokeView )
import MetaBrush.UI.Viewport
( Viewport(..) )
import MetaBrush.Unique
@ -152,14 +150,14 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables
let change = ActiveDocChange { mbOldDocUnique = Just unique }
coerce ( updateUIAction change uiElts vars )
SaveDocument Nothing -> do
STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique )
STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresentSaved unique )
coerce ( updateUIAction NoActiveDocChange uiElts vars )
SaveDocument ( Just newFilePath ) -> do
STM.modifyTVar' openDocumentsTVar
( Map.adjust
( affirmPresent
( affirmPresentSaved
. set ( field' @"present" . field' @"documentMetadata" . field' @"documentFilePath" )
( Just newFilePath )
( Just newFilePath )
)
unique
)
@ -175,7 +173,7 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables
-- Content change.
STM.modifyTVar' openDocumentsTVar
( Map.adjust
( newFutureStep maxHistSize
( newFutureStep maxHistSize histDiff
. set ( field' @"documentContent" . field' @"unsavedChanges" ) True
$ newDocument
)
@ -216,11 +214,12 @@ updateUIAction _docChange uiElts@( UIElements { viewport = Viewport {..}, .. } )
mbActiveTabDoc <- fmap join $ for mbDoc \ ( docUnique, _doc ) -> do
mbActiveTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
pure ( (,) <$> mbActiveTab <*> mbDoc )
--strokeModels <- STM.readTVar strokeListModelsTVar
pure do
updateTitle window titleLabel mbTitleText
updateInfoBar viewportDrawingArea infoBar vars ( fmap ( documentMetadata . snd ) mbDoc )
--switchStrokeView (strokesListView $ panelsBar) strokeModels (fst <$> mbDoc)
_ <- GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do
switchStrokeView strokesListView vars ( fst <$> mbDoc )
return False
for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, ( _, activeDoc ) ) -> do
GTK.buttonSetLabel fileBarTabButton ( documentName $ documentMetadata activeDoc )
GTK.widgetQueueDraw fileBarTab

View file

@ -251,17 +251,15 @@ getDocumentRender
getVisibleStrokes :: Document -> [ ( Maybe Unique, Stroke ) ]
getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
let res =
Writer.execWriter $
forStrokeHierarchy
( layerMetadata documentMetadata )
( strokeHierarchy documentContent )
( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
when strokeVisible $
Writer.tell [ ( Just uniq, stroke ) ]
return PreserveStroke
)
in if null res then error ( show $ strokeHierarchy documentContent ) else res
Writer.execWriter $
forStrokeHierarchy
( layerMetadata documentMetadata )
( strokeHierarchy documentContent )
( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
when strokeVisible $
Writer.tell [ ( Just uniq, stroke ) ]
return PreserveStroke
)
-- | Utility type to gather information needed to render a stroke.
-- - No outline: just the underlying spline.

View file

@ -44,20 +44,17 @@ import Data.HashMap.Lazy
-- MetaBrush
import {-# SOURCE #-} MetaBrush.Application.Action
( ActionName, SwitchFromTo(..), Close(..), handleAction )
( SwitchFromTo(..), Close(..), handleAction )
import MetaBrush.Application.Context
import MetaBrush.Asset.CloseTabButton
( drawCloseTabButton )
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Application.Context
( UIElements(..), Variables(..) )
import MetaBrush.Document
import MetaBrush.Document.History
( DocumentHistory(..), newHistory )
import MetaBrush.Application.UpdateDocument
( updateUIAction, ActiveDocChange (..) )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar )
import MetaBrush.UI.Panels
( PanelsBar )
import MetaBrush.UI.Viewport
@ -69,25 +66,6 @@ import MetaBrush.GTK.Util
--------------------------------------------------------------------------------
data FileBar
= FileBar
{ fileBarBox :: !GTK.Box
, fileTabsBox :: !GTK.Box
, fileBarPhantomToggleButton :: !GTK.ToggleButton
}
data FileBarTab
= FileBarTab
{ fileBarTab :: !GTK.Box
, fileBarTabButton :: !GTK.ToggleButton
, fileBarTabCloseArea :: !GTK.DrawingArea
}
data TabLocation
= AfterCurrentTab
| LastTab
deriving stock Show
newFileTab
:: UIElements
-> Variables
@ -158,8 +136,8 @@ newFileTab
}
-- Update the state: switch to this new document.
uiUpdateAction <- STM.atomically do
STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist )
STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab )
STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist )
STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab )
mbOldDoc <- STM.readTVar activeDocumentTVar
STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
let change = ActiveDocChange { mbOldDocUnique = mbOldDoc }
@ -212,11 +190,13 @@ createFileBar
-> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar
-> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction
-> PanelsBar
-> GTK.ListView
-> IO FileBar
createFileBar
colours
vars@( Variables { openDocumentsTVar } )
application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions panelsBar
application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions
panelsBar strokesListView
= do
-- Create file bar: box containing scrollable tabs, and a "+" button after it.

View file

@ -4,12 +4,8 @@ module MetaBrush.UI.FileBar
)
where
-- gi-gtk
import qualified GI.Gtk as GTK
-- MetaBrush
import {-# SOURCE #-} MetaBrush.Application.Context
( Variables, UIElements )
import MetaBrush.Application.Context
import MetaBrush.Document.History
( DocumentHistory )
import MetaBrush.Unique
@ -17,25 +13,5 @@ import MetaBrush.Unique
--------------------------------------------------------------------------------
data FileBar
= FileBar
{ fileBarBox :: !GTK.Box
, fileTabsBox :: !GTK.Box
, fileBarPhantomToggleButton :: !GTK.ToggleButton
}
data FileBarTab
= FileBarTab
{ fileBarTab :: !GTK.Box
, fileBarTabButton :: !GTK.ToggleButton
, fileBarTabCloseArea :: !GTK.DrawingArea
}
data TabLocation
= AfterCurrentTab
| LastTab
instance Show TabLocation
newFileTab :: UIElements -> Variables -> Maybe ( Unique, DocumentHistory ) -> TabLocation -> IO ()
removeFileTab :: UIElements -> Variables -> Unique -> IO ()

View file

@ -34,17 +34,18 @@ import qualified Control.Concurrent.STM.TVar as STM
import qualified Data.Text as Text
( pack )
-- MetaBrush
-- brush-strokes
import Math.Linear
( (..) )
-- MetaBrush
import MetaBrush.Application.Context
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Asset.Cursor
( drawCursorIcon )
import MetaBrush.Asset.InfoBar
( drawMagnifier, drawTopLeftCornerRect )
import MetaBrush.Application.Context
( Variables(..) )
import MetaBrush.Document
( DocumentMetadata(..), Zoom(..) )
import MetaBrush.UI.Coordinates
@ -54,13 +55,6 @@ import MetaBrush.GTK.Util
--------------------------------------------------------------------------------
data InfoBar
= InfoBar
{ infoBarArea :: !GTK.Box
, zoomText :: !GTK.Label -- make this editable
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
}
-- | Add the UI elements for the info bar:
--
-- * current zoom level,

View file

@ -1,24 +0,0 @@
module MetaBrush.UI.InfoBar
( InfoBar(..), updateInfoBar )
where
-- gi-gtk
import qualified GI.Gtk as GTK
-- MetaBrush
import {-# SOURCE #-} MetaBrush.Application.Context
( Variables )
import MetaBrush.Document
( DocumentMetadata )
--------------------------------------------------------------------------------
data InfoBar
= InfoBar
{ infoBarArea :: !GTK.Box
, zoomText :: !GTK.Label
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
}
updateInfoBar
:: GTK.DrawingArea -> InfoBar -> Variables -> Maybe DocumentMetadata -> IO ()

View file

@ -42,13 +42,10 @@ import qualified Data.HashSet as HashSet
import MetaBrush.Application.Action
hiding ( save, saveAs )
import MetaBrush.Application.Context
( UIElements(..), Variables(..) )
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Asset.WindowIcons
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
import MetaBrush.UI.FileBar
( TabLocation(..) )
import MetaBrush.GTK.Util
( widgetAddClass, widgetAddClasses )

View file

@ -25,10 +25,10 @@ import MetaBrush.GTK.Util
data PanelsBar
= PanelsBar
{ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox
:: GTK.Box
, strokesListView
:: GTK.ListView
{ layersScrolledWindow
:: !GTK.ScrolledWindow
, brushesPanelBox, transformPanelBox, historyPanelBox
:: !GTK.Box
}
-- | Creates the right hand side panel UI.
@ -38,6 +38,7 @@ createPanelBar panelBox = do
widgetAddClass panelBox "panels"
pane1 <- GTK.panedNew GTK.OrientationVertical
GTK.panedSetWideHandle pane1 True
GTK.widgetSetVexpand pane1 True
GTK.boxAppend panelBox pane1
@ -50,7 +51,9 @@ createPanelBar panelBox = do
GTK.panedSetStartChild pane1 ( Just panels1 )
GTK.panedSetEndChild pane1 ( Just panels2 )
strokesPanelBox <- GTK.boxNew GTK.OrientationVertical 0
layersScrolledWindow <- GTK.scrolledWindowNew
GTK.scrolledWindowSetPolicy layersScrolledWindow GTK.PolicyTypeNever GTK.PolicyTypeAutomatic
brushesPanelBox <- GTK.boxNew GTK.OrientationVertical 0
transformPanelBox <- GTK.boxNew GTK.OrientationVertical 0
historyPanelBox <- GTK.boxNew GTK.OrientationVertical 0
@ -63,17 +66,18 @@ createPanelBar panelBox = do
for_ [ strokesTab, brushesTab, transformTab, historyTab ] \ tab -> do
widgetAddClasses tab [ "plain", "text", "panelTab" ]
for_ [ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do
widgetAddClass layersScrolledWindow "panel"
for_ [ brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do
widgetAddClass panel "panel"
void $ GTK.notebookAppendPage panels1 strokesPanelBox ( Just strokesTab )
void $ GTK.notebookAppendPage panels1 brushesPanelBox ( Just brushesTab )
void $ GTK.notebookAppendPage panels1 layersScrolledWindow ( Just strokesTab )
void $ GTK.notebookAppendPage panels1 brushesPanelBox ( Just brushesTab )
void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab )
void $ GTK.notebookAppendPage panels2 historyPanelBox ( Just historyTab )
GTK.notebookSetTabReorderable panels1 strokesPanelBox True
GTK.notebookSetTabDetachable panels1 strokesPanelBox True
GTK.notebookSetTabReorderable panels1 layersScrolledWindow True
GTK.notebookSetTabDetachable panels1 layersScrolledWindow True
GTK.notebookSetTabReorderable panels1 brushesPanelBox True
GTK.notebookSetTabDetachable panels1 brushesPanelBox True
@ -90,8 +94,7 @@ createPanelBar panelBox = do
GTK.boxAppend transformPanelBox transformContent
GTK.boxAppend historyPanelBox historyContent
--GTK.boxAppend strokesPanelBox strokesListView
return $
PanelsBar { strokesPanelBox, strokesListView = error "todo"
, brushesPanelBox, transformPanelBox, historyPanelBox }
PanelsBar { layersScrolledWindow
, brushesPanelBox, transformPanelBox, historyPanelBox
}

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,16 @@
module MetaBrush.UI.StrokeTreeView where
-- gi-gtk
import qualified GI.Gtk as GTK
-- MetaBrush
import MetaBrush.Application.Context
import MetaBrush.Unique
--------------------------------------------------------------------------------
newLayersListModel :: Variables -> Unique -> IO GTK.SingleSelection
switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO ()
newLayerView :: UIElements -> Variables -> IO GTK.ListView

View file

@ -28,36 +28,18 @@ import qualified Control.Concurrent.STM.TVar as STM
( writeTVar )
-- MetaBrush
import MetaBrush.Application.Context
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Asset.Cursor
( drawCursorIcon )
import MetaBrush.Asset.Tools
( drawBug, drawBrush, drawMeta, drawPath, drawPen )
import MetaBrush.Application.Context
( Variables(..) )
import MetaBrush.GTK.Util
( widgetAddClass )
--------------------------------------------------------------------------------
data Tool
= Selection
| Pen
deriving stock ( Show, Eq )
data Mode
= PathMode
| BrushMode
| MetaMode
deriving stock ( Show, Eq )
data ToolBar
= ToolBar
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
:: !GTK.ToggleButton
}
createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar
createToolBar ( Variables {..} ) colours toolBar = do

View file

@ -1,29 +0,0 @@
module MetaBrush.UI.ToolBar
( Tool(..), Mode(..)
, ToolBar(..)
)
where
-- gi-gtk
import qualified GI.Gtk as GTK
--------------------------------------------------------------------------------
data Tool
= Selection
| Pen
instance Show Tool
data Mode
= PathMode
| BrushMode
| MetaMode
instance Show Mode
data ToolBar
= ToolBar
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
:: !GTK.ToggleButton
}

View file

@ -56,12 +56,18 @@ data DocumentDiff
data HierarchyDiff
= NewLayer
{ newUnique :: !Unique
, newIsGroup :: !Bool
, newPosition :: !ChildLayerPosition
}
| DeleteLayer
{ delUnique :: !Unique
, delIsGroup :: !Bool
, delPosition :: !ChildLayerPosition
}
| DeletePoints
{ deletedPoints :: !StrokePoints
, deletedStrokes :: !( Set Unique )
}
| MoveLayer
{ moveUnique :: !Unique
, srcPos :: !ChildLayerPosition
@ -113,10 +119,6 @@ data ContentDiff
{ continuedStroke :: !Unique
, newSegment :: !( Spline Open () () )
}
| DeletePoints
{ deletedPoints :: !StrokePoints
, deletedStrokes :: !( Set Unique)
}
| UpdateBrushParameters
{ updateBrushStroke :: !Unique
, updateBrushPoint :: !PointIndex

View file

@ -2,7 +2,7 @@ module MetaBrush.Document.History
( DocumentHistory(..)
, back, fwd, newHistory, newFutureStep
, atStart, atEnd
, affirmPresent
, affirmPresentSaved
)
where
@ -27,18 +27,22 @@ import Data.Generics.Product.Fields
-- lens
import Control.Lens
( set )
import Control.Lens.Tuple
( _1, _2 )
-- MetaBrush
import MetaBrush.Document
( Document(..), DocumentContent(..) )
import MetaBrush.Document.Diff
( HistoryDiff )
--------------------------------------------------------------------------------
data DocumentHistory
= History
{ past :: !( Seq DocumentContent )
{ past :: !( Seq ( DocumentContent, HistoryDiff ) )
, present :: !Document
, future :: ![ DocumentContent ]
, future :: ![ ( HistoryDiff, DocumentContent ) ]
}
deriving stock ( Show, Generic )
instance NFData DocumentHistory where
@ -47,21 +51,29 @@ instance NFData DocumentHistory where
back :: DocumentHistory -> DocumentHistory
back hist@( History { past = ps, present = c, future = fs } ) = case ps of
Empty -> hist
qs :|> q -> History { past = qs, present = c { documentContent = q }, future = documentContent c : fs }
Empty
-> hist
qs :|> ( q, diff )
-> History { past = qs
, present = c { documentContent = q }
, future = ( diff, documentContent c ) : fs }
fwd :: DocumentHistory -> DocumentHistory
fwd hist@( History { past = ps, present = c, future = fs } ) = case fs of
[] -> hist
g : gs -> History { past = ps :|> documentContent c, present = c { documentContent = g }, future = gs }
[]
-> hist
( diff, g ) : gs
-> History { past = ps :|> ( documentContent c, diff )
, present = c { documentContent = g }
, future = gs }
newHistory :: Document -> DocumentHistory
newHistory a = History { past = Empty, present = a, future = [] }
newFutureStep :: Int -> Document -> DocumentHistory -> DocumentHistory
newFutureStep maxPastDocs a ( History { past = ps, present = c } ) =
newFutureStep :: Int -> HistoryDiff -> Document -> DocumentHistory -> DocumentHistory
newFutureStep maxPastDocs diff a ( History { past = ps, present = c } ) =
History
{ past = Seq.drop ( n - maxPastDocs ) ( ps :|> documentContent c )
{ past = Seq.drop ( n - maxPastDocs ) ( ps :|> ( documentContent c, diff ) )
, present = a
, future = []
}
@ -77,11 +89,11 @@ atEnd hist = null ( future hist )
--------------------------------------------------------------------------------
affirmPresent :: DocumentHistory -> DocumentHistory
affirmPresent
= set ( field' @"past" . traverse . field' @"unsavedChanges" )
affirmPresentSaved :: DocumentHistory -> DocumentHistory
affirmPresentSaved
= set ( field' @"past" . traverse . _1 . field' @"unsavedChanges" )
True
. set ( field' @"present" . field' @"documentContent" . field' @"unsavedChanges" )
. set ( field' @"present" . field' @"documentContent" . field' @"unsavedChanges" )
False
. set ( field' @"future" . traverse . field' @"unsavedChanges" )
. set ( field' @"future" . traverse . _2 . field' @"unsavedChanges" )
True

View file

@ -305,9 +305,8 @@ encodeLayer =
. JSON.Encoder.atOptKey' "locked" JSON.Encoder.bool ( if layerLocked layer then Just True else Nothing )
. encodeLayerData
decodeLayer :: MonadIO m => UniqueSupply -> JSON.Decoder m Layer
decodeLayer uniqueSupply = do
layerUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply )
decodeLayer :: MonadIO m => JSON.Decoder m Layer
decodeLayer = do
mbLayerName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text
mbLayerVisible <- JSON.Decoder.atKeyOptional "visible" JSON.Decoder.bool
mbLayerLocked <- JSON.Decoder.atKeyOptional "locked" JSON.Decoder.bool
@ -317,11 +316,11 @@ decodeLayer uniqueSupply = do
case mbLayerStroke of
Nothing -> do
let layerName = fromMaybe "Group" mbLayerName
groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list ( decodeLayer uniqueSupply ) )
pure ( GroupLayer { layerUnique, layerName, layerVisible, layerLocked, groupChildren } )
groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list decodeLayer )
pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } )
Just layerStroke -> do
let layerName = fromMaybe "Stroke" mbLayerName
pure ( StrokeLayer { layerUnique, layerName, layerVisible, layerLocked, layerStroke } )
pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } )
encodeGuide :: Applicative f => JSON.Encoder f Guide
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
@ -335,31 +334,6 @@ decodeGuide uniqueSupply = do
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( 2 ) ) )
pure ( guideUnique, Guide { guidePoint, guideNormal } )
encodeDocumentContent :: Applicative f => JSON.Encoder f ( LayerMetadata, DocumentContent )
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( layerMetadata, Content { strokeHierarchy } ) ->
JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) $
strokeHierarchyLayers layerMetadata strokeHierarchy
decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m ( LayerMetadata, DocumentContent )
decodeDocumentContent uniqueSupply = do
let
unsavedChanges :: Bool
unsavedChanges = False
layers <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list $ decodeLayer uniqueSupply )
let ( layerMetadata, strokeHierarchy ) = layersStrokeHierarchy layers
pure ( layerMetadata, Content { unsavedChanges, strokeHierarchy } )
encodeDocumentMetadata :: Applicative f => JSON.Encoder f DocumentMetadata
encodeDocumentMetadata =
JSON.Encoder.mapLikeObj
\ ( Metadata { documentName, viewportCenter, documentZoom, documentGuides } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text documentName
. JSON.Encoder.atKey' "center" ( encoder @( 2 ) ) viewportCenter
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor documentZoom )
. JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems documentGuides )
decodeDocumentMetadata
:: MonadIO m
=> UniqueSupply
@ -367,31 +341,41 @@ decodeDocumentMetadata
-> LayerMetadata
-> JSON.Decoder m DocumentMetadata
decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do
documentName <- JSON.Decoder.atKey "name" JSON.Decoder.text
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( 2 ) )
zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
guides <- JSON.Decoder.atKey "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply )
documentName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text
viewportCenter <- JSON.Decoder.atKeyOptional "center" ( decoder @( 2 ) )
zoomFactor <- JSON.Decoder.atKeyOptional "zoom" ( decoder @Double )
guides <- JSON.Decoder.atKeyOptional "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply )
pure $
Metadata
{ documentName
{ documentName = fromMaybe "Document" documentName
, documentFilePath = mbFilePath
, viewportCenter
, documentZoom = Zoom { zoomFactor }
, documentGuides = Map.fromList guides
, viewportCenter = fromMaybe ( 2 0 0 ) viewportCenter
, documentZoom = maybe ( Zoom 1 ) Zoom zoomFactor
, documentGuides = Map.fromList $ fromMaybe [] guides
, layerMetadata
, selectedPoints = mempty
, selectedPoints = mempty
}
encodeDocument :: Applicative f => JSON.Encoder f Document
encodeDocument = JSON.Encoder.mapLikeObj
\ ( Document { documentMetadata, documentContent } ) ->
\ ( Document { documentMetadata = meta, documentContent } ) ->
JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version )
. JSON.Encoder.atKey' "metadata" encodeDocumentMetadata documentMetadata
. JSON.Encoder.atKey' "content" encodeDocumentContent ( layerMetadata documentMetadata, documentContent )
. JSON.Encoder.atKey' "name" JSON.Encoder.text ( documentName meta )
. JSON.Encoder.atKey' "center" ( encoder @( 2 ) ) ( viewportCenter meta )
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor $ documentZoom meta )
. JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems $ documentGuides meta )
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) )
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do
( layerMetadata, documentContent ) <-
JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
documentMetadata <- JSON.Decoder.atKey "metadata" $ decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
let
unsavedChanges :: Bool
unsavedChanges = False
mbLayers1 <- JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer )
-- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes').
mbLayers2 <- JSON.Decoder.atKeyOptional "content" ( JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) )
let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 )
( layerMetadata, strokeHierarchy ) <- lift $ ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers
let documentContent = Content { unsavedChanges, strokeHierarchy }
documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
pure ( Document { documentMetadata, documentContent } )

View file

@ -1,6 +1,8 @@
module MetaBrush.Layer where
-- base
import Data.Maybe
( fromJust )
import Data.Word
( Word32 )
import GHC.Generics
@ -86,3 +88,24 @@ emptyHierarchy =
, groups = Map.empty
, content = Map.empty
}
lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ]
lookupChildren p h = fromJust $ lookupChildren_maybe p h
lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel
lookupChildren_maybe ( Parent u ) ( Hierarchy { groups } ) = groups Map.!? u
insertGroup :: Parent Unique -> [ Unique ] -> Hierarchy a -> Hierarchy a
insertGroup Root us h = h { topLevel = us }
insertGroup ( Parent u ) us h = h { groups = Map.insert u us ( groups h ) }
-- | Delete the key of a layer in a 'Hierarchy'.
--
-- Does not remove it from any child lists, just from the "keys" of the maps.
deleteLayerKey :: Unique -> Hierarchy a -> ( Hierarchy a, Maybe [ Unique ] )
deleteLayerKey u ( Hierarchy tl gs cs ) =
case Map.updateLookupWithKey ( \ _ _ -> Nothing ) u gs of
( mbChildren, gs' ) ->
let cs' = Map.delete u cs
in ( Hierarchy tl gs' cs', mbChildren )

View file

@ -4,6 +4,8 @@
module MetaBrush.Stroke where
-- base
import Control.Arrow
( (***) )
import Control.Monad.ST
( RealWorld )
import Data.Coerce
@ -52,9 +54,13 @@ import Data.Text
( Text )
-- transformers
import Control.Monad.State.Strict
( State )
import qualified Control.Monad.State.Strict as State
import Control.Monad.IO.Class
( MonadIO )
import Control.Monad.Trans.Reader
( ReaderT )
import Control.Monad.Trans.State.Strict
( StateT )
import qualified Control.Monad.Trans.State.Strict as State
-- brush-strokes
import Math.Bezier.Spline
@ -73,10 +79,13 @@ import Math.Linear
-- MetaBrush
import MetaBrush.Brush
( NamedBrush, PointFields )
import MetaBrush.Layer hiding ( Layer(..) )
import MetaBrush.Layer
( Hierarchy(..), LayerMetadata(..), emptyHierarchy )
import MetaBrush.Records
import MetaBrush.Unique
( Unique )
( Unique, UniqueSupply, freshUnique )
import MetaBrush.Util
( (!) )
--------------------------------------------------------------------------------
@ -273,12 +282,12 @@ forStrokeHierarchy
let
meta =
StrokeMetadata
{ strokeName = layerNames Map.! u
{ strokeName = layerNames ! u
, strokeVisible = vis'
, strokeLocked = lock'
}
in
insertMaybe par u <$> acc <*> f u ( content hierarchy0 Map.! u ) meta
insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta
Just ds ->
foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
@ -294,15 +303,13 @@ type Layers = [ Layer ]
-- Used for serialisation/deserialisation only.
data Layer
= StrokeLayer
{ layerUnique :: !Unique
, layerName :: !Text
{ layerName :: !Text
, layerVisible :: !Bool
, layerLocked :: !Bool
, layerStroke :: !Stroke
}
| GroupLayer
{ layerUnique :: !Unique
, layerName :: !Text
{ layerName :: !Text
, layerVisible :: !Bool
, layerLocked :: !Bool
, groupChildren :: !Layers
@ -317,50 +324,44 @@ strokeHierarchyLayers
go :: Unique -> Layer
go layerUnique =
let
layerName = layerNames Map.! layerUnique
layerName = layerNames ! layerUnique
layerVisible = not $ layerUnique `Set.member` invisibleLayers
layerLocked = layerUnique `Set.member` lockedLayers
in
case Map.lookup layerUnique hierarchy of
Nothing ->
StrokeLayer
{ layerUnique, layerName, layerVisible, layerLocked
, layerStroke = content Map.! layerUnique
{ layerName, layerVisible, layerLocked
, layerStroke = content ! layerUnique
}
Just cs ->
GroupLayer
{ layerUnique, layerName, layerVisible, layerLocked
{ layerName, layerVisible, layerLocked
, groupChildren = map go cs
}
layersStrokeHierarchy :: Layers -> ( LayerMetadata, StrokeHierarchy )
layersStrokeHierarchy lays = ( `State.execState` ( mempty, emptyHierarchy ) ) $ do
{-# INLINEABLE layersStrokeHierarchy #-}
layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )
layersStrokeHierarchy lays = ( `State.execStateT` ( mempty, emptyHierarchy ) ) $ do
us <- traverse go lays
State.modify' ( \ ( meta, hierarchy ) -> ( meta, hierarchy { topLevel = us } ) )
where
go :: Layer -> State ( LayerMetadata, StrokeHierarchy ) Unique
go :: Layer -> StateT ( LayerMetadata, StrokeHierarchy ) ( ReaderT UniqueSupply m ) Unique
go l = do
( LayerMetadata { layerNames = nms, invisibleLayers = invis, lockedLayers = locked }
, oldHierarchy@( Hierarchy _topLevel oldGroups oldStrokes )
) <- State.get
let u = layerUnique l
newMeta =
u <- freshUnique
let updMeta ( LayerMetadata nms invis locked ) =
LayerMetadata
{ layerNames = Map.insert u ( layerName l ) nms
, invisibleLayers = if layerVisible l then invis else Set.insert u invis
, lockedLayers = if layerLocked l then Set.insert u locked else locked
}
newHierarchy <-
case l of
StrokeLayer { layerStroke } ->
return $
oldHierarchy
{ content = Map.insert u layerStroke oldStrokes }
GroupLayer { groupChildren } -> do
us <- traverse go groupChildren
return $
oldHierarchy { groups = Map.insert u us oldGroups }
State.put ( newMeta, newHierarchy )
updHierarchy <- case l of
StrokeLayer { layerStroke } ->
return $ \ h -> h { content = Map.insert u layerStroke ( content h ) }
GroupLayer { groupChildren } -> do
us <- traverse go groupChildren
return $ \ h -> h { groups = Map.insert u us ( groups h ) }
State.modify' ( updMeta *** updHierarchy )
return u
--------------------------------------------------------------------------------

View file

@ -46,9 +46,6 @@ import Control.Monad.Reader
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, newTVarIO, readTVar, writeTVar )
-- text
import Data.Text
@ -96,15 +93,13 @@ class Monad m => MonadUnique m where
instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where
freshUnique = do
UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply )
liftIO $ STM.atomically do
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
pure uniq
liftIO $ STM.atomically $ STM.stateTVar uniqueSupplyTVar doSucc
instance MonadUnique ( ReaderT UniqueSupply STM ) where
freshUnique = do
UniqueSupply { uniqueSupplyTVar } <- ask
lift do
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
pure uniq
lift $ STM.stateTVar uniqueSupplyTVar doSucc
doSucc :: Unique -> ( Unique, Unique )
doSucc uniq@( Unique !i ) = ( uniq, Unique ( succ i ) )

View file

@ -1,9 +1,25 @@
module MetaBrush.Util
( Exists(..)
, (!)
)
where
-- base
import GHC.Stack
( HasCallStack )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
--------------------------------------------------------------------------------
data Exists c where
Exists :: c a => a -> Exists c
infixl 9 !
(!) :: ( Show k, Ord k, HasCallStack ) => Map k a -> k -> a
m ! k = case Map.lookup k m of
Nothing -> error $ "MetaBrush internal error: key not in map: " ++ show k
Just a -> a