hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

add stroke layer view

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

5
MetaBrush.cabal
View file

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

123
assets/theme.css
View file

@ -1,7 +1,32 @@
/*
.metabrush * { .metabrush * {
all: unset; 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"); @import url("colours.css");
@ -470,4 +495,100 @@ To specify it in CSS, set the box-shadow of the contents node."
.infoBarInfo { .infoBarInfo {
margin-left: -4px; margin-left: -4px;
padding-right: 16px; 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;
}

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

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

30
src/app/MetaBrush/Application/Action.hs
View file

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

22
src/app/MetaBrush/Application/Action.hs-boot
View file

@ -7,21 +7,10 @@ import Data.Word
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- hashable
import Data.Hashable
( Hashable )
-- text
import Data.Text
( Text )
-- MetaBrush -- MetaBrush
import Math.Linear import Math.Linear
( ℝ(..), T(..) ) ( ℝ(..), T(..) )
import {-# SOURCE #-} MetaBrush.Application.Context import MetaBrush.Application.Context
( UIElements, Variables )
import {-# SOURCE #-} MetaBrush.UI.FileBar
( TabLocation(..) )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Ruler(..) ) ( Ruler(..) )
import MetaBrush.Unique 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 class HandleAction action where
handleAction :: UIElements -> Variables -> action -> IO () handleAction :: UIElements -> Variables -> action -> IO ()

129
src/app/MetaBrush/Application/Context.hs
View file

@ -1,15 +1,12 @@
module MetaBrush.Application.Context module MetaBrush.Application.Context where
( UIElements(..), Variables(..)
, LR(..), Modifier(..), modifierKey
, HoldAction(..), GuideAction(..), PartialPath(..)
)
where
-- base -- base
import Data.Int import Data.Int
( Int32 ) ( Int32 )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
import GHC.Generics
( Generic )
-- containers -- containers
import Data.Set import Data.Set
@ -30,9 +27,17 @@ import qualified GI.Gio as GIO
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- hashable
import Data.Hashable
( Hashable )
-- stm -- stm
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( TVar ) import qualified Control.Concurrent.STM.TMVar as STM
-- text
import Data.Text
( Text )
-- unordered-containers -- unordered-containers
import Data.HashMap.Strict import Data.HashMap.Strict
@ -51,8 +56,6 @@ import Math.Root.Isolation
-- MetaBrush -- MetaBrush
import MetaBrush.Action import MetaBrush.Action
( BrushWidgetActionState ) ( BrushWidgetActionState )
import {-# SOURCE #-} MetaBrush.Application.Action
( ActionName )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Document.Diff import MetaBrush.Document.Diff
@ -61,14 +64,10 @@ import MetaBrush.Draw
( DrawAnchor ) ( DrawAnchor )
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory(..) ) ( DocumentHistory(..) )
import {-# SOURCE #-} MetaBrush.UI.FileBar import MetaBrush.Layer
( FileBar, FileBarTab ) ( Parent )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar )
import MetaBrush.UI.Panels import MetaBrush.UI.Panels
( PanelsBar ) ( PanelsBar )
import {-# SOURCE #-} MetaBrush.UI.ToolBar
( Tool, Mode )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) ) ( Viewport(..), Ruler(..) )
import MetaBrush.Unique import MetaBrush.Unique
@ -79,18 +78,19 @@ import MetaBrush.Unique
data UIElements data UIElements
= UIElements = UIElements
{ application :: !GTK.Application { application :: !GTK.Application
, window :: !GTK.ApplicationWindow , window :: !GTK.ApplicationWindow
, windowKeys :: !GTK.EventControllerKey , windowKeys :: !GTK.EventControllerKey
, titleBar :: !GTK.HeaderBar , titleBar :: !GTK.HeaderBar
, titleLabel :: !GTK.Label , titleLabel :: !GTK.Label
, fileBar :: !FileBar , fileBar :: !FileBar
, viewport :: !Viewport , viewport :: !Viewport
, infoBar :: !InfoBar , infoBar :: !InfoBar
, menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo , menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
, menuActions :: !( HashMap ActionName GIO.SimpleAction ) , menuActions :: !( HashMap ActionName GIO.SimpleAction )
, panelsBar :: !PanelsBar , panelsBar :: !PanelsBar
, colours :: !Colours , strokesListView :: GTK.ListView
, colours :: !Colours
} }
data Variables data Variables
@ -100,7 +100,19 @@ data Variables
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) ) , documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) , 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 ) ) ) , mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) )
@ -176,3 +188,62 @@ data PartialPath
, firstPoint :: !Bool , firstPoint :: !Bool
} }
deriving stock Show 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
--------------------------------------------------------------------------------

17
src/app/MetaBrush/Application/Context.hs-boot
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

31
src/app/MetaBrush/Application/UpdateDocument.hs
View file

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

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

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

34
src/app/MetaBrush/UI/FileBar.hs
View file

@ -44,20 +44,17 @@ import Data.HashMap.Lazy
-- MetaBrush -- MetaBrush
import {-# SOURCE #-} MetaBrush.Application.Action import {-# SOURCE #-} MetaBrush.Application.Action
( ActionName, SwitchFromTo(..), Close(..), handleAction ) ( SwitchFromTo(..), Close(..), handleAction )
import MetaBrush.Application.Context
import MetaBrush.Asset.CloseTabButton import MetaBrush.Asset.CloseTabButton
( drawCloseTabButton ) ( drawCloseTabButton )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Application.Context
( UIElements(..), Variables(..) )
import MetaBrush.Document import MetaBrush.Document
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory(..), newHistory ) ( DocumentHistory(..), newHistory )
import MetaBrush.Application.UpdateDocument import MetaBrush.Application.UpdateDocument
( updateUIAction, ActiveDocChange (..) ) ( updateUIAction, ActiveDocChange (..) )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar )
import MetaBrush.UI.Panels import MetaBrush.UI.Panels
( PanelsBar ) ( PanelsBar )
import MetaBrush.UI.Viewport 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 newFileTab
:: UIElements :: UIElements
-> Variables -> Variables
@ -158,8 +136,8 @@ newFileTab
} }
-- Update the state: switch to this new document. -- Update the state: switch to this new document.
uiUpdateAction <- STM.atomically do uiUpdateAction <- STM.atomically do
STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist ) STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist )
STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab ) STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab )
mbOldDoc <- STM.readTVar activeDocumentTVar mbOldDoc <- STM.readTVar activeDocumentTVar
STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique ) STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
let change = ActiveDocChange { mbOldDocUnique = mbOldDoc } let change = ActiveDocChange { mbOldDocUnique = mbOldDoc }
@ -212,11 +190,13 @@ createFileBar
-> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar -> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar
-> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction -> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction
-> PanelsBar -> PanelsBar
-> GTK.ListView
-> IO FileBar -> IO FileBar
createFileBar createFileBar
colours colours
vars@( Variables { openDocumentsTVar } ) 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 = do
-- Create file bar: box containing scrollable tabs, and a "+" button after it. -- Create file bar: box containing scrollable tabs, and a "+" button after it.

26
src/app/MetaBrush/UI/FileBar.hs-boot
View file

@ -4,12 +4,8 @@ module MetaBrush.UI.FileBar
) )
where where
-- gi-gtk
import qualified GI.Gtk as GTK
-- MetaBrush -- MetaBrush
import {-# SOURCE #-} MetaBrush.Application.Context import MetaBrush.Application.Context
( Variables, UIElements )
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory ) ( DocumentHistory )
import MetaBrush.Unique 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 () newFileTab :: UIElements -> Variables -> Maybe ( Unique, DocumentHistory ) -> TabLocation -> IO ()
removeFileTab :: UIElements -> Variables -> Unique -> IO () removeFileTab :: UIElements -> Variables -> Unique -> IO ()

14
src/app/MetaBrush/UI/InfoBar.hs
View file

@ -34,17 +34,18 @@ import qualified Control.Concurrent.STM.TVar as STM
import qualified Data.Text as Text import qualified Data.Text as Text
( pack ) ( pack )
-- MetaBrush -- brush-strokes
import Math.Linear import Math.Linear
( ℝ(..) ) ( ℝ(..) )
-- MetaBrush
import MetaBrush.Application.Context
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Asset.Cursor import MetaBrush.Asset.Cursor
( drawCursorIcon ) ( drawCursorIcon )
import MetaBrush.Asset.InfoBar import MetaBrush.Asset.InfoBar
( drawMagnifier, drawTopLeftCornerRect ) ( drawMagnifier, drawTopLeftCornerRect )
import MetaBrush.Application.Context
( Variables(..) )
import MetaBrush.Document import MetaBrush.Document
( DocumentMetadata(..), Zoom(..) ) ( DocumentMetadata(..), Zoom(..) )
import MetaBrush.UI.Coordinates 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: -- | Add the UI elements for the info bar:
-- --
-- * current zoom level, -- * current zoom level,

24
src/app/MetaBrush/UI/InfoBar.hs-boot
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 ()

3
src/app/MetaBrush/UI/Menu.hs
View file

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

31
src/app/MetaBrush/UI/Panels.hs
View file

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

1235
src/app/MetaBrush/UI/StrokeTreeView.hs
View file

File diff suppressed because it is too large Load diff

16
src/app/MetaBrush/UI/StrokeTreeView.hs-boot Normal file
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

20
src/app/MetaBrush/UI/ToolBar.hs
View file

@ -28,36 +28,18 @@ import qualified Control.Concurrent.STM.TVar as STM
( writeTVar ) ( writeTVar )
-- MetaBrush -- MetaBrush
import MetaBrush.Application.Context
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Asset.Cursor import MetaBrush.Asset.Cursor
( drawCursorIcon ) ( drawCursorIcon )
import MetaBrush.Asset.Tools import MetaBrush.Asset.Tools
( drawBug, drawBrush, drawMeta, drawPath, drawPen ) ( drawBug, drawBrush, drawMeta, drawPath, drawPen )
import MetaBrush.Application.Context
( Variables(..) )
import MetaBrush.GTK.Util import MetaBrush.GTK.Util
( widgetAddClass ) ( 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 -> GTK.Box -> IO ToolBar
createToolBar ( Variables {..} ) colours toolBar = do createToolBar ( Variables {..} ) colours toolBar = do

29
src/app/MetaBrush/UI/ToolBar.hs-boot
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
}

10
src/metabrushes/MetaBrush/Document/Diff.hs
View file

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

42
src/metabrushes/MetaBrush/Document/History.hs
View file

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

76
src/metabrushes/MetaBrush/Document/Serialise.hs
View file

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

23
src/metabrushes/MetaBrush/Layer.hs
View file

@ -1,6 +1,8 @@
module MetaBrush.Layer where module MetaBrush.Layer where
-- base -- base
import Data.Maybe
( fromJust )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
import GHC.Generics import GHC.Generics
@ -86,3 +88,24 @@ emptyHierarchy =
, groups = Map.empty , groups = Map.empty
, content = 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 )

69
src/metabrushes/MetaBrush/Stroke.hs
View file

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

17
src/metabrushes/MetaBrush/Unique.hs
View file

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

16
src/metabrushes/MetaBrush/Util.hs
View file

@ -1,9 +1,25 @@
module MetaBrush.Util module MetaBrush.Util
( Exists(..) ( Exists(..)
, (!)
) )
where where
-- base
import GHC.Stack
( HasCallStack )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Exists c where data Exists c where
Exists :: c a => a -> Exists c 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