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 document history & undo/redo

Browse source
This commit is contained in:
sheaf 2020-09-10 18:43:42 +02:00
parent 0a978b7c59
commit 7e8c2e10d1
22 changed files with 839 additions and 447 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
MetaBrush.cabal
View file

@ -32,6 +32,8 @@ common common
^>= 0.3.1.0
, containers
>= 0.6.0.1 && < 0.6.4
, deepseq
^>= 1.4.4.0
, generic-data
>= 0.8.0.0 && < 0.8.4.0
, generic-lens
@ -45,7 +47,7 @@ common common
Haskell2010
ghc-options:
-O2
-O1
-fexpose-all-unfoldings
-fspecialise-aggressively
-Wall
@ -77,9 +79,7 @@ library
, Math.Vector2D
build-depends:
deepseq
^>= 1.4.4.0
, groups-generic
groups-generic
^>= 0.1.0.0
, hmatrix
^>= 0.20.0.0
@ -114,9 +114,11 @@ executable MetaBrush
, MetaBrush.Context
, MetaBrush.Document
, MetaBrush.Document.Draw
, MetaBrush.Document.History
, MetaBrush.Document.Selection
, MetaBrush.Document.Serialise
, MetaBrush.Document.SubdivideStroke
, MetaBrush.Document.Update
, MetaBrush.Event
, MetaBrush.Render.Document
, MetaBrush.Render.Rulers

105
app/Main.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
@ -16,6 +17,8 @@ import Control.Monad
( void )
import Data.Foldable
( for_ )
import Data.Function
( (&) )
import Data.Int
( Int32 )
import System.Exit
@ -41,6 +44,10 @@ import qualified Data.Set as Set
import qualified System.Directory as Directory
( canonicalizePath )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo
( renderWithContext )
@ -51,6 +58,10 @@ import qualified GI.Gdk as GDK
-- gi-gtk
import qualified GI.Gtk as GTK
-- lens
import Control.Lens
( (.~) )
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
@ -80,13 +91,16 @@ import MetaBrush.Context
( UIElements(..), Variables(..)
, Modifier(..)
, HoldAction(..), PartialPath(..)
, withCurrentDocument
)
import MetaBrush.Document
( Document(..), emptyDocument
, Stroke(..), FocusState(..)
, PointData(..), BrushPointData(..)
)
import MetaBrush.Document.History
( DocumentHistory(..), newHistory )
import MetaBrush.Document.Update
( activeDocument, withActiveDocument )
import MetaBrush.Event
( handleEvents )
import MetaBrush.Render.Document
@ -117,38 +131,35 @@ import qualified Paths_MetaBrush as Cabal
--------------------------------------------------------------------------------
testDocuments :: Map Unique Document
testDocuments = uniqueMapFromList
[ ( emptyDocument "Closed" ( unsafeUnique 0 ) )
{ strokes =
[ Stroke
{ strokeName = "Ellipse"
, strokeVisible = True
, strokeUnique = unsafeUnique 10
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
}
]
}
, ( emptyDocument "Line" ( unsafeUnique 1 ) )
{ strokes =
[ Stroke
{ strokeName = "Line"
, strokeVisible = True
, strokeUnique = unsafeUnique 11
, strokePoints = linePts
}
]
}
, ( emptyDocument "Short line" ( unsafeUnique 2 ) )
{ strokes =
[ Stroke
{ strokeName = "ShortLine"
, strokeVisible = True
, strokeUnique = unsafeUnique 12
, strokePoints = linePts2
}
]
}
testDocuments :: Map Unique DocumentHistory
testDocuments = fmap newHistory $ uniqueMapFromList
[ emptyDocument "Closed" ( unsafeUnique 0 )
& ( field' @"documentContent" . field' @"strokes" ) .~
[ Stroke
{ strokeName = "Ellipse"
, strokeVisible = True
, strokeUnique = unsafeUnique 10
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
}
]
, emptyDocument "Line" ( unsafeUnique 1 )
& ( field' @"documentContent" . field' @"strokes" ) .~
[ Stroke
{ strokeName = "Line"
, strokeVisible = True
, strokeUnique = unsafeUnique 11
, strokePoints = linePts
}
]
, emptyDocument "Short line" ( unsafeUnique 2 )
& ( field' @"documentContent" . field' @"strokes" ) .~
[ Stroke
{ strokeName = "ShortLine"
, strokeVisible = True
, strokeUnique = unsafeUnique 12
, strokePoints = linePts2
}
]
]
where
linePts :: Seq ( StrokePoint PointData )
@ -189,16 +200,17 @@ main = do
-- Initialise state
uniqueSupply <- newUniqueSupply
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
fileBarTabsTVar <- STM.newTVarIO @( Map Unique GTK.Box ) Map.empty
showGuidesTVar <- STM.newTVarIO @Bool True
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
showGuidesTVar <- STM.newTVarIO @Bool True
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
fitParametersTVar <- STM.newTVarIO @FitParameters
( FitParameters
{ maxSubdiv = 2
@ -319,7 +331,7 @@ main = do
-- Get the relevant document information
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do
mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do
mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar
mbPartialPath <- STM.readTVar partialPathTVar
@ -350,7 +362,7 @@ main = do
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
width <- GTK.widgetGetAllocatedWidth rulerDrawingArea
height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do
mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do
mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar
showGuides <- STM.readTVar showGuidesTVar
@ -411,7 +423,8 @@ main = do
-- GTK main loop
GTK.widgetShowAll window
updateInfoBar viewportDrawingArea infoBar variables -- need to update the info bar after widgets have been realized
mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
GTK.main
exitSuccess

6
cabal.project
View file

@ -9,9 +9,9 @@ allow-newer:
-- fixes gi-cairo-render to work with haskell-gi >= 0.24
source-repository-package
type: git
location: https://github.com/thestr4ng3r/gi-cairo-render
tag: 8727c43cdf91aeedffc9cb4c5575f56660a86399
subdir: gi-cairo-render
location: https://github.com/sheaf/gi-cairo-render
tag: a53d1596e36ce7bbff517940260faf1c4d02ffcc
subdir: gi-cairo-render gi-cairo-connector
-- latest version of hmatrix
source-repository-package

2
installation_notes.md
View file

@ -93,7 +93,7 @@ Libs: -L${libdir} -lgraphite2
Cflags: -I${includedir}
```
The package `fontconfig` also presented this issue; this was resolved in [this patch](https://github.com/msys2/MINGW-packages/issues/872).
See [this patch](https://github.com/msys2/MINGW-packages/pull/6966). The package `fontconfig` also presented this issue; this was resolved in [this patch](https://github.com/msys2/MINGW-packages/issues/872).
### Missing C library `openblas`

236
src/app/MetaBrush/Action.hs
View file

@ -9,6 +9,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
@ -18,7 +19,7 @@ module MetaBrush.Action where
import Control.Monad
( guard, when, unless, void )
import Data.Foldable
( for_ )
( for_, sequenceA_ )
import Data.Int
( Int32 )
import Data.Maybe
@ -36,7 +37,7 @@ import Data.Act
-- containers
import qualified Data.Map as Map
( lookup )
( insert, lookup )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
@ -77,6 +78,8 @@ import qualified Control.Concurrent.STM.TVar as STM
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( pack )
-- MetaBrush
import Math.Bezier.Stroke
@ -89,17 +92,17 @@ import MetaBrush.Context
( UIElements(..), Variables(..)
, Modifier(..), modifierKey
, HoldAction(..), GuideAction(..), PartialPath(..)
, currentDocument, withCurrentDocument
, PureDocModification(..), DocModification(..)
, modifyingCurrentDocument
, updateTitle
)
import MetaBrush.Document
( Document(..), PointData(..), FocusState(..) )
( Document(..), DocumentContent(..), PointData(..), FocusState(..) )
import MetaBrush.Document.Draw
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document
( Guide(..), selectedGuide, addGuide )
import MetaBrush.Document.History
( DocumentHistory(..), newHistory
, back, fwd
)
import MetaBrush.Document.Selection
( SelectionMode(..), selectionMode
, selectAt, selectRectangle
@ -111,6 +114,12 @@ import MetaBrush.Document.Serialise
( saveDocument, loadDocument )
import MetaBrush.Document.SubdivideStroke
( subdivide )
import MetaBrush.Document.Update
( activeDocument, withActiveDocument
, DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
, modifyingCurrentDocument
, updateUIAction, updateHistoryState
)
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
@ -148,7 +157,7 @@ data NewFile = NewFile TabLocation
instance HandleAction NewFile where
handleAction uiElts vars ( NewFile tabLoc ) =
newFileTab uiElts vars Nothing tabLoc
newFileTab False uiElts vars Nothing tabLoc
---------------
-- Open file --
@ -175,9 +184,29 @@ instance HandleAction OpenFile where
for_ filePaths \ filePath -> do
mbDoc <- loadDocument uniqueSupply filePath
case mbDoc of
Left _errMessage -> pure () -- TODO: show warning dialog?
Left errMessage -> warningDialog window filePath errMessage
Right doc -> do
newFileTab uiElts vars ( Just doc ) tabLoc
let
newDocHist :: DocumentHistory
newDocHist = newHistory doc
newFileTab False uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist )
warningDialog :: Show errMess => GTK.Window -> FilePath -> errMess -> IO ()
warningDialog window filePath errMess = do
dialog <- GTK.new GTK.MessageDialog []
GTK.setMessageDialogText dialog
( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning
GTK.setWindowResizable dialog False
GTK.setWindowDecorated dialog False
GTK.windowSetTransientFor dialog ( Just window )
GTK.windowSetModal dialog True
widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
closeButton <- GTK.dialogAddButton dialog "OK" 1
widgetAddClass closeButton "dialogButton"
_ <- GTK.dialogRun dialog
GTK.widgetDestroy dialog
-----------------
-- Open folder --
@ -204,9 +233,13 @@ instance HandleAction OpenFolder where
for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
case mbDoc of
Left _errMessage -> pure () -- TODO: show warning dialog?
Left errMessage -> warningDialog window filePath errMessage
Right doc -> do
newFileTab uiElts vars ( Just doc ) tabLoc
let
newDocHist :: DocumentHistory
newDocHist = newHistory doc
newFileTab False uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist )
pure ()
---------------
@ -222,25 +255,19 @@ instance HandleAction Save where
save :: UIElements -> Variables -> Bool -> IO ()
save uiElts vars keepOpen = do
mbDoc <- STM.atomically $ currentDocument vars
mbDoc <- fmap present <$> ( STM.atomically $ activeDocument vars )
for_ mbDoc \case
doc@( Document { mbFilePath, unsavedChanges } )
doc@( Document { mbFilePath, documentContent } )
| Nothing <- mbFilePath
-> saveAs uiElts vars keepOpen
| False <- unsavedChanges
| False <- unsavedChanges documentContent
-> pure ()
| Just filePath <- mbFilePath
-> modifyingCurrentDocument uiElts vars \ _ -> do
let
doc' :: Document
doc' = doc { unsavedChanges = False }
if keepOpen
then
pure $ UpdateDocToAndThen
( Just doc' )
( saveDocument filePath doc' )
else
pure $ UpdateDocToAndThen Nothing ( saveDocument filePath doc' )
modif :: DocumentUpdate
modif = if keepOpen then SaveDocument Nothing else CloseDocument
pure $ UpdateDocAndThen modif ( saveDocument filePath doc )
-------------
-- Save as --
@ -258,15 +285,9 @@ saveAs uiElts vars keepOpen = do
for_ mbSavePath \ savePath -> do
modifyingCurrentDocument uiElts vars \ doc -> do
let
doc' :: Document
doc' = doc { mbFilePath = Just savePath, unsavedChanges = False }
if keepOpen
then
pure $ UpdateDocToAndThen
( Just doc' )
( saveDocument savePath doc' )
else
pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' )
modif :: DocumentUpdate
modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument
pure $ UpdateDocAndThen modif ( saveDocument savePath doc )
askForSavePath :: UIElements -> IO ( Maybe FilePath )
askForSavePath ( UIElements {..} ) = do
@ -312,12 +333,15 @@ instance HandleAction Close where
vars@( Variables {..} )
close = do
mbDoc <- case close of
CloseActive -> STM.atomically ( currentDocument vars )
CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
CloseActive -> fmap ( ( , True ) . present ) <$> STM.atomically ( activeDocument vars )
CloseThis unique -> do
mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars )
mbDoc <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
pure ( ( \ doc currDoc -> ( doc, documentUnique currDoc == unique ) ) <$> mbDoc <*> mbCurrentDoc )
case mbDoc of
Nothing -> pure () -- could show a warning message
Just ( Document { displayName, documentUnique, unsavedChanges } )
| unsavedChanges
Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
| unsavedChanges documentContent
-> do
dialog <- GTK.new GTK.MessageDialog []
GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
@ -335,19 +359,24 @@ instance HandleAction Close where
choice <- GTK.dialogRun dialog
GTK.widgetDestroy dialog
case choice of
JustClose -> closeDocument documentUnique
JustClose -> closeDocument isActiveDoc documentUnique
SaveAndClose -> save uiElts vars False
_ -> pure ()
| otherwise
-> closeDocument documentUnique
-> closeDocument isActiveDoc documentUnique
where
closeDocument :: Unique -> IO ()
closeDocument unique = do
closeDocument :: Bool -> Unique -> IO ()
closeDocument isActiveDoc unique = do
removeFileTab vars unique
updateTitle window title Nothing
updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw viewportDrawingArea
when isActiveDoc do
uiUpdateAction <- STM.atomically do
STM.writeTVar activeDocumentTVar Nothing
uiUpdateAction <- updateUIAction uiElts vars
pure do
uiUpdateAction
updateHistoryState uiElts Nothing
uiUpdateAction
---------------------
-- Switch document --
@ -358,21 +387,17 @@ data SwitchTo = SwitchTo Unique
instance HandleAction SwitchTo where
handleAction
( UIElements { viewport = Viewport {..}, .. } )
uiElts@( UIElements { viewport = Viewport {..}, .. } )
vars@( Variables {..} )
( SwitchTo newUnique ) = do
mbNewDocAndTab <- STM.atomically do
uiUpdateAction <- STM.atomically do
STM.writeTVar activeDocumentTVar ( Just newUnique )
newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
pure ( (,) <$> newDoc <*> newTab )
case mbNewDocAndTab of
Nothing -> updateTitle window title Nothing
Just ( Document {..}, tab ) -> do
updateTitle window title ( Just ( displayName, unsavedChanges ) )
updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw tab
GTK.widgetQueueDraw viewportDrawingArea
mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
uiUpdateAction <- updateUIAction uiElts vars
pure do
uiUpdateAction
updateHistoryState uiElts mbHist
uiUpdateAction
--------------
-- Quitting --
@ -387,38 +412,43 @@ instance HandleAction Quit where
quitEverything :: GTK.Window -> IO ()
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
----------
-- Undo --
----------
----------------
-- Undo & Redo --
----------------
data Undo = Undo
deriving stock Show
-- TODO
instance HandleAction Undo where
handleAction _ _ _ = pure ()
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory back uiElts vars
----------
-- Redo --
----------
data Redo = Redo
deriving stock Show
-- TODO
instance HandleAction Redo where
handleAction _ _ _ = pure ()
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory fwd uiElts vars
---------------------
-- Discard changes --
---------------------
data DiscardChanges = DiscardChanges
deriving stock Show
-- TODO
instance HandleAction DiscardChanges where
handleAction _ _ _ = pure ()
updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO ()
updateHistory f uiElts@( UIElements {..} ) vars@( Variables {..} ) = do
uiUpdateAction <- STM.atomically do
mbUnique <- STM.readTVar activeDocumentTVar
case mbUnique of
Nothing -> pure ( pure () )
Just unique -> do
mbDocHistory <- Map.lookup unique <$> STM.readTVar openDocumentsTVar
case mbDocHistory of
Nothing -> pure ( pure () )
Just docHistory -> do
let
newDocHistory :: DocumentHistory
newDocHistory = f docHistory
STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDocHistory )
uiUpdateAction <- updateUIAction uiElts vars
pure do
updateHistoryState uiElts ( Just newDocHistory )
uiUpdateAction
uiUpdateAction
---------
-- Cut --
@ -482,8 +512,14 @@ instance HandleAction Delete where
case tool of
-- Delete selected points on pressing 'Delete'.
Selection
-> modifyingCurrentDocument uiElts vars \ doc ->
pure ( UpdateDocTo $ Just ( deleteSelected mode doc ) )
-> modifyingCurrentDocument uiElts vars \ doc -> do
let
newDoc :: Document
docChanged :: Bool
( newDoc, docChanged ) = deleteSelected mode doc
if docChanged
then pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange newDoc )
else pure Don'tModifyDoc
_ -> pure ()
-------------------
@ -559,7 +595,7 @@ instance HandleAction MouseMove where
= do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
void . STM.atomically $ withCurrentDocument vars \ ( Document {..} ) -> do
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
modifiers <- STM.readTVar modifiersTVar
let
toViewport :: Point2D Double -> Point2D Double
@ -578,11 +614,12 @@ instance HandleAction MouseMove where
, Just pp <- mbPartialPath
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ -> pure ()
updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw viewportDrawingArea
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
pure do
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
GTK.widgetQueueDraw viewportDrawingArea
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
sequenceA_ uiUpdateAction
-----------------
-- Mouse click --
@ -641,7 +678,7 @@ instance HandleAction MouseClick where
| Just newDoc <- dragMoveSelect mode pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
pure ( UpdateDocTo $ Just newDoc )
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
@ -663,7 +700,7 @@ instance HandleAction MouseClick where
, firstPoint = True
}
)
pure ( UpdateDocTo $ Just newDoc )
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
@ -683,7 +720,7 @@ instance HandleAction MouseClick where
mbSubdivide = subdivide mode pos doc
case mbSubdivide of
Nothing -> pure Don'tModifyDoc
Just newDoc -> pure ( UpdateDocTo $ Just newDoc )
Just newDoc -> pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
-- Ignore double click event otherwise.
_ -> pure Don'tModifyDoc
@ -759,11 +796,11 @@ instance HandleAction MouseRelease where
| keepGuide
-> pure $
over
( field' @"guides" . ix guideUnique . field' @"guidePoint" )
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
( ( holdStartPos --> pos :: Vector2D Double ) • )
doc
| otherwise
-> pure $ set ( field' @"guides" . at guideUnique ) Nothing doc
-> pure $ set ( field' @"documentContent" . field' @"guides" . at guideUnique ) Nothing doc
where
l, t :: Double
Point2D l t = toViewport ( Point2D 0 0 )
@ -773,7 +810,7 @@ instance HandleAction MouseRelease where
&& ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0)
&& x <= viewportWidth
&& y <= viewportHeight
pure ( UpdateDocTo ( Just newDoc ) )
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
_ -> do
tool <- STM.readTVar toolTVar
@ -788,11 +825,17 @@ instance HandleAction MouseRelease where
Just hold
| DragMoveHold pos0 <- hold
, pos0 /= pos
-> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc )
, let
newDoc :: Document
docChanged :: Bool
( newDoc, docChanged ) = translateSelection mode ( pos0 --> pos ) doc
-> if docChanged
then pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
else pure Don'tModifyDoc
| SelectionHold pos0 <- hold
, pos0 /= pos
-> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc )
_ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc )
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc )
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt mode selMode pos doc )
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
@ -843,7 +886,7 @@ instance HandleAction MouseRelease where
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
]
pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc )
else
if firstPoint
-- Continue current partial path.
@ -869,7 +912,7 @@ instance HandleAction MouseRelease where
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
]
pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc )
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
@ -936,8 +979,7 @@ instance HandleAction Scroll where
finalMousePos :: Point2D Double
finalMousePos = toFinalViewport ( Point2D x y )
STM.writeTVar mousePosTVar ( Just finalMousePos )
pure ( UpdateDocTo $ Just newDoc )
updateInfoBar viewportDrawingArea infoBar vars
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
--------------------
-- Keyboard press --

3
src/app/MetaBrush/Action.hs-boot
View file

@ -60,9 +60,6 @@ instance HandleAction Undo
data Redo = Redo
instance HandleAction Redo
data DiscardChanges = DiscardChanges
instance HandleAction DiscardChanges
data Cut = Cut
instance HandleAction Cut

153
src/app/MetaBrush/Context.hs
View file

@ -1,27 +1,14 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module MetaBrush.Context
( UIElements(..), Variables(..)
, LR(..), Modifier(..), modifierKey, modifierType
, HoldAction(..), GuideAction(..), PartialPath(..)
, currentDocument, withCurrentDocument
, PureDocModification(..), DocModification(..)
, modifyingCurrentDocument
, updateTitle
)
where
-- base
import Data.Foldable
( for_, sequenceA_ )
import Data.Word
( Word32 )
@ -30,8 +17,6 @@ import Data.Set
( Set )
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( insert, lookup, delete )
-- gi-gtk
import qualified GI.Gdk as GDK
@ -39,27 +24,9 @@ import qualified GI.Gdk as GDK
-- gi-gtk
import qualified GI.Gtk as GTK
-- lens
import Control.Lens.Fold
( Fold, forOf_, sequenceAOf_ )
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar, readTVar, modifyTVar' )
-- text
import Data.Text
( Text )
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Maybe
( MaybeT(..) )
( TVar )
-- MetaBrush
import Math.Bezier.Cubic.Fit
@ -68,14 +35,14 @@ import Math.Vector2D
( Point2D )
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Document
( Document(..) )
import MetaBrush.Document.Draw
( DrawAnchor )
import MetaBrush.Document.History
( DocumentHistory(..) )
import {-# SOURCE #-} MetaBrush.UI.FileBar
( FileBar, removeFileTab )
( FileBar )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar, updateInfoBar )
( InfoBar )
import {-# SOURCE #-} MetaBrush.UI.Menu
( Menu, ResourceType(Object) )
import MetaBrush.UI.ToolBar
@ -84,8 +51,6 @@ import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) )
import MetaBrush.Unique
( UniqueSupply, Unique )
import MetaBrush.Util
( (>>?=) )
--------------------------------------------------------------------------------
@ -104,17 +69,18 @@ data UIElements
data Variables
= Variables
{ uniqueSupply :: !UniqueSupply
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, openDocumentsTVar :: !( STM.TVar ( Map Unique Document ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
, toolTVar :: !( STM.TVar Tool )
, modeTVar :: !( STM.TVar Mode )
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
, fileBarTabsTVar :: !( STM.TVar ( Map Unique GTK.Box ) )
, showGuidesTVar :: !( STM.TVar Bool )
, fitParametersTVar :: !( STM.TVar FitParameters )
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
, toolTVar :: !( STM.TVar Tool )
, modeTVar :: !( STM.TVar Mode )
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
, fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) )
, showGuidesTVar :: !( STM.TVar Bool )
, maxHistorySizeTVar :: !( STM.TVar Int )
, fitParametersTVar :: !( STM.TVar FitParameters )
}
--------------------------------------------------------------------------------
@ -172,88 +138,3 @@ data PartialPath
, firstPoint :: !Bool
}
deriving stock Show
--------------------------------------------------------------------------------
-- | Read the currently active document from the stateful variables.
currentDocument :: Variables -> STM ( Maybe Document )
currentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } )
= STM.readTVar activeDocumentTVar
>>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar )
-- | Do something with the currently active document.
--
-- Does nothing if no document is currently active.
withCurrentDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a )
withCurrentDocument vars f = traverse f =<< currentDocument vars
data PureDocModification
= Don'tModifyDoc
| UpdateDocTo ( Maybe Document )
data DocModification
= Don'tModifyDocAndThen { postModifAction :: IO () }
| UpdateDocToAndThen
{ modifDocument :: ( Maybe Document )
, postModifAction :: IO ()
}
class DocumentModification modif where
docFold :: Fold modif ( Maybe Document )
actionFold :: Fold modif ( IO () )
instance DocumentModification PureDocModification where
docFold _ Don'tModifyDoc = pure Don'tModifyDoc
docFold f ( UpdateDocTo mbDoc ) = UpdateDocTo <$> ( f mbDoc )
actionFold _ a = pure a
instance DocumentModification DocModification where
docFold _ don't@( Don'tModifyDocAndThen {} ) = pure don't
docFold f ( UpdateDocToAndThen mbDoc action ) = ( \ mbDoc' -> UpdateDocToAndThen mbDoc' action ) <$> f mbDoc
actionFold f modif = ( \ action' -> modif { postModifAction = action' } ) <$> f ( postModifAction modif )
-- | Modify the currently active document.
--
-- Does nothing if no document is currently active.
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
modifyingCurrentDocument ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do
mbAction <- STM.atomically . runMaybeT $ do
unique <- MaybeT ( STM.readTVar activeDocumentTVar )
oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar )
modif <- lift ( f oldDoc )
forOf_ docFold modif \case
Nothing
-> lift ( STM.modifyTVar' openDocumentsTVar ( Map.delete unique ) )
Just newDoc
-> lift ( STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDoc ) )
mbActiveTab <- lift ( Map.lookup unique <$> STM.readTVar fileBarTabsTVar )
pure
do
forOf_ docFold modif \ mbNewDoc -> do
case mbNewDoc of
Nothing -> do
removeFileTab vars ( documentUnique oldDoc )
updateTitle window title Nothing
updateInfoBar viewportDrawingArea infoBar vars
Just ( Document { displayName, unsavedChanges } ) -> do
updateTitle window title ( Just ( displayName, unsavedChanges ) )
GTK.widgetQueueDraw viewportDrawingArea
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
for_ mbActiveTab GTK.widgetQueueDraw
sequenceAOf_ actionFold modif
sequenceA_ mbAction
updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
updateTitle window title mbTitleText = do
GTK.labelSetText title titleText
GTK.setWindowTitle window titleText
where
titleText :: Text
titleText = case mbTitleText of
Nothing -> "MetaBrush"
Just ( name, hasUnsavedChanges )
| hasUnsavedChanges
-> "● " <> name <> " – MetaBrush"
| otherwise
-> name <> " – MetaBrush"

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

@ -1,17 +1,20 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document
( AABB(..), mkAABB
, Document(..), emptyDocument
, Document(..), DocumentContent(..)
, emptyDocument
, Stroke(..)
, PointData(..), BrushPointData(..)
, FocusState(..), Hoverable(..), HoverContext(..)
@ -45,6 +48,10 @@ import qualified Data.Map.Strict as Map
import Data.Sequence
( Seq )
-- deepseq
import Control.DeepSeq
( NFData )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
@ -80,7 +87,8 @@ import MetaBrush.Unique
data AABB
= AABB
{ topLeft, botRight :: !( Point2D Double ) }
deriving stock Show
deriving stock ( Show, Generic )
deriving anyclass NFData
mkAABB :: Point2D Double -> Point2D Double -> AABB
mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2D xmax ymax )
@ -92,18 +100,29 @@ mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2
| y1 > y2 = ( y2, y1 )
| otherwise = ( y1, y2 )
-- | Document, together with some extra metadata.
data Document
= Document
{ displayName :: !Text
, mbFilePath :: !( Maybe FilePath )
, unsavedChanges :: !Bool
, viewportCenter :: !( Point2D Double )
, zoomFactor :: !Double
, documentUnique :: Unique
, strokes :: ![ Stroke ]
, guides :: !( Map Unique Guide )
}
deriving stock ( Show, Generic )
{ displayName :: !Text
, mbFilePath :: !( Maybe FilePath )
, viewportCenter :: !( Point2D Double )
, zoomFactor :: !Double
, documentUnique :: Unique
, documentContent :: !DocumentContent
}
deriving stock ( Show, Generic )
deriving anyclass NFData
-- | Main content of document (data which we keept track of throughout history).
data DocumentContent
= Content
{ unsavedChanges :: !Bool
, latestChange :: !Text
, guides :: !( Map Unique Guide )
, strokes :: ![ Stroke ]
}
deriving stock ( Show, Generic )
deriving anyclass NFData
data Stroke
= Stroke
@ -112,7 +131,8 @@ data Stroke
, strokeUnique :: Unique
, strokePoints :: !( Seq ( StrokePoint PointData ) )
}
deriving stock ( Show, Generic )
deriving stock ( Show, Generic )
deriving anyclass NFData
data PointData
= PointData
@ -120,17 +140,20 @@ data PointData
, brushShape :: Seq ( StrokePoint BrushPointData )
}
deriving stock ( Show, Generic )
deriving anyclass NFData
data BrushPointData
= BrushPointData
{ brushPointState :: FocusState }
deriving stock ( Show, Generic )
deriving anyclass NFData
data FocusState
= Normal
| Hover
| Selected
deriving stock ( Show, Eq )
deriving stock ( Show, Eq, Generic )
deriving anyclass NFData
instance Semigroup FocusState where
Selected <> _ = Selected
@ -150,14 +173,18 @@ _brush = field' @"pointData" . field' @"brushShape"
emptyDocument :: Text -> Unique -> Document
emptyDocument docName unique =
Document
{ displayName = docName
, mbFilePath = Nothing
, unsavedChanges = False
, viewportCenter = Point2D 0 0
, zoomFactor = 1
, documentUnique = unique
, strokes = []
, guides = Map.empty
{ displayName = docName
, mbFilePath = Nothing
, viewportCenter = Point2D 0 0
, zoomFactor = 1
, documentUnique = unique
, documentContent =
Content
{ unsavedChanges = False
, latestChange = "New document"
, strokes = []
, guides = Map.empty
}
}
--------------------------------------------------------------------------------
@ -165,7 +192,8 @@ emptyDocument docName unique =
data HoverContext
= MouseHover !( Point2D Double )
| RectangleHover !AABB
deriving stock Show
deriving stock ( Show, Generic )
deriving anyclass NFData
instance Act ( Vector2D Double ) HoverContext where
v • MouseHover p = MouseHover ( v • p )
@ -200,11 +228,12 @@ data Guide
, guideFocus :: !FocusState
, guideUnique :: Unique
}
deriving stock ( Show, Generic )
deriving stock ( Show, Generic )
deriving anyclass NFData
-- | Try to select a guide at the given document coordinates.
selectedGuide :: Point2D Double -> Document -> Maybe Guide
selectedGuide c ( Document { zoomFactor, guides } ) =
selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =
\case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides
selectGuide_maybe :: Point2D Double -> Double -> Guide -> Maybe ( ArgMin Double Guide )
@ -221,7 +250,7 @@ selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
-- | Add new guide after a mouse drag from a ruler area.
addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document
addGuide uniqueSupply ruler p = ( field' @"guides" ) insertNewGuides
addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" ) insertNewGuides
where
insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide )
insertNewGuides gs = case ruler of

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

@ -1,8 +1,9 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Draw
( DrawAnchor(..), anchorsAreComplementary
@ -36,6 +37,10 @@ import Control.Lens
import Control.Concurrent.STM
( STM )
-- text
import Data.Text
( Text )
-- transformers
import Control.Monad.Trans.State.Strict
( State, runState, get, put )
@ -71,32 +76,46 @@ anchorsAreComplementary ( AnchorAtEnd uniq1 ) ( AnchorAtStart uniq2 )
= True
anchorsAreComplementary _ _ = False
getOrCreateDrawAnchor :: UniqueSupply -> Point2D Double -> Document -> STM ( Document, DrawAnchor, Point2D Double )
getOrCreateDrawAnchor
:: UniqueSupply
-> Point2D Double
-> Document
-> STM ( Document, DrawAnchor, Point2D Double )
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
case ( `runState` Nothing ) $ field' @"strokes" ( traverse updateStroke ) doc of
case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of
-- Anchor found: use it.
( newDoc, Just ( anchor, anchorPt ) ) -> pure ( newDoc, anchor, anchorPt )
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do
let
newDoc' :: Document
newDoc' =
set ( field' @"documentContent" . field' @"latestChange" )
( "Continue stroke " <> anchorName )
newDoc
pure ( newDoc', anchor, anchorPt )
-- No anchor found: start a new stroke (on a new stroke layer).
( newDoc, Nothing ) -> do
( newDoc, Nothing ) -> do
uniq <- freshUnique uniqueSupply
let
newDoc' :: Document
newDoc' =
over ( field' @"strokes" )
( Stroke
{ strokeName = "Stroke " <> uniqueText uniq
, strokeVisible = True
, strokeUnique = uniq
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
}
: )
newDoc
pure ( newDoc' { unsavedChanges = True }, AnchorAtEnd uniq, c )
newDoc'
= over ( field' @"documentContent" )
( over ( field' @"strokes" )
( Stroke
{ strokeName = "Stroke " <> uniqueText uniq
, strokeVisible = True
, strokeUnique = uniq
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
}
: )
. set ( field' @"latestChange" ) "Begin new stroke"
)
$ newDoc
pure ( newDoc', AnchorAtEnd uniq, c )
where
-- Deselect all points, and try to find a valid anchor for drawing
-- (a path start/end point at mouse click point).
updateStroke :: Stroke -> State ( Maybe ( DrawAnchor, Point2D Double ) ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokePoints, strokeUnique } ) = do
updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke
updateStroke stroke@( Stroke { strokeName, strokeVisible, strokePoints, strokeUnique } ) = do
mbAnchor <- get
case mbAnchor of
@ -106,7 +125,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
Nothing
| strokeVisible
, Just anchor <- endpointAnchor strokeUnique strokePoints
-> put ( Just anchor )
-> put ( Just ( anchor, strokeName ) )
$> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
-- Otherwise, just deselect.
_ -> pure $ set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
@ -128,7 +147,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document
addToAnchor anchor newPts = set ( field' @"unsavedChanges" ) True . over ( field' @"strokes" . mapped ) addToStroke
addToAnchor anchor newPts = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
where
addToStroke :: Stroke -> Stroke
addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } )

100
src/app/MetaBrush/Document/History.hs Normal file
View file

@ -0,0 +1,100 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.History
( DocumentHistory(..)
, back, fwd, newHistory, newFutureStep
, atStart, atEnd
, affirmPresent
)
where
-- base
import GHC.Generics
( Generic )
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( length, drop )
-- deepseq
import Control.DeepSeq
( NFData(..), deepseq )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( set )
-- MetaBrush
import MetaBrush.Document
( Document(..), DocumentContent(..) )
--------------------------------------------------------------------------------
data DocumentHistory
= History
{ past :: !( Seq DocumentContent )
, present :: !Document
, future :: ![ DocumentContent ]
}
deriving stock ( Show, Generic )
instance NFData DocumentHistory where
rnf ( History { past = ps, present, future } ) =
ps `deepseq` present `deepseq` future `deepseq` ()
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 }
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 }
newHistory :: Document -> DocumentHistory
newHistory a = History { past = Empty, present = a, future = [] }
newFutureStep :: Int -> Document -> DocumentHistory -> DocumentHistory
newFutureStep maxPastDocs a ( History { past = ps, present = c } ) =
History
{ past = Seq.drop ( n - maxPastDocs ) ( ps :|> documentContent c )
, present = a
, future = []
}
where
n :: Int
n = 1 + Seq.length ps
atStart, atEnd :: DocumentHistory -> Bool
atStart hist = null ( past hist )
atEnd hist = null ( future hist )
--------------------------------------------------------------------------------
affirmPresent :: DocumentHistory -> DocumentHistory
affirmPresent
= set ( field' @"past" . traverse . field' @"unsavedChanges" )
True
. set ( field' @"present" . field' @"documentContent" . field' @"unsavedChanges" )
False
. set ( field' @"future" . traverse . field' @"unsavedChanges" )
True

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

@ -18,6 +18,8 @@ module MetaBrush.Document.Selection
where
-- base
import Control.Arrow
( first )
import Control.Category
( (>>>) )
import Data.Functor
@ -45,15 +47,19 @@ import Control.Lens
-- tardis
import Control.Monad.Trans.Tardis
( Tardis )
( Tardis, TardisT )
import qualified Control.Monad.Trans.Tardis as Tardis
( TardisT(..)
, getPast, getFuture, sendPast, sendFuture
)
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.State.Strict
( State, evalState, get, put )
( StateT(..)
, State, runState, evalState, get, put
)
-- MetaBrush
import Math.Bezier.Stroke
@ -98,7 +104,7 @@ selectionMode = foldMap \case
-- | Updates the selected objects on a single click selection event.
selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document
selectAt mode selMode c doc@( Document { zoomFactor } ) =
( `evalState` False ) $ field' @"strokes" ( traverse updateStroke ) doc
( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
where
updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } )
@ -156,7 +162,7 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
let
res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document
res = do
newDoc <- field' @"strokes" ( traverse updateStroke ) doc
newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
Tardis.getPast >>= Tardis.sendPast
pure newDoc
in case runIdentity $ Tardis.runTardisT res ( Nothing, Nothing ) of
@ -230,7 +236,9 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
-- | Updates the selected objects on a rectangular selection event.
selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" . mapped ) updateStroke
selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
= over ( field' @"documentContent" . field' @"strokes" . mapped )
updateStroke
where
xMin, xMax, yMin, yMax :: Double
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
@ -266,60 +274,74 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field'
| otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax
-- | Translate all selected points by the given vector.
translateSelection :: Mode -> Vector2D Double -> Document -> Document
translateSelection mode t
| Brush <- mode
= over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped . field' @"pointData" . field' @"brushShape" . mapped )
updateStrokePoint
. set ( field' @"unsavedChanges" ) True
| otherwise
= over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped )
updateStrokePoint
. set ( field' @"unsavedChanges" ) True
translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, Bool )
translateSelection mode t doc =
( `runState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
where
updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> StrokePoint pt
updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } )
| not strokeVisible
= pure stroke
| Brush <- mode
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse )
updateStrokePoint
stroke
| otherwise
= ( field' @"strokePoints" . traverse )
updateStrokePoint
stroke
updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> State Bool ( StrokePoint pt )
updateStrokePoint pt
| Selected <- view _selection pt
= pt { coords = t • coords pt }
= put True
$> pt { coords = t • coords pt }
| otherwise
= pt
= pure pt
-- | Delete the selected points.
deleteSelected :: Mode -> Document -> Document
deleteSelected mode doc = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) $ case mode of
Brush ->
( field' @"strokes" . traverse . field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
updateStroke
doc'
_ ->
( field' @"strokes" . traverse . field' @"strokePoints" )
updateStroke
doc'
deleteSelected :: Mode -> Document -> ( Document, Bool )
deleteSelected mode doc
= first fst . runIdentity . ( `runStateT` False ) . ( `Tardis.runTardisT` ( False, False ) )
$ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
where
doc' :: Document
doc' = doc { unsavedChanges = True }
updateStroke
updateStroke :: Stroke -> TardisT Bool Bool ( State Bool ) Stroke
updateStroke stroke@( Stroke { strokeVisible } )
| not strokeVisible
= pure stroke
| Brush <- mode
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
updateStrokePoints
stroke
| otherwise
= ( field' @"strokePoints" )
updateStrokePoints
stroke
updateStrokePoints
:: forall pt
. HasType FocusState pt
=> Seq ( StrokePoint pt )
-> Tardis Bool Bool ( Seq ( StrokePoint pt ) )
updateStroke Empty = pure Empty
updateStroke ( p :<| ps ) = case p of
-> TardisT Bool Bool ( State Bool ) ( Seq ( StrokePoint pt ) )
updateStrokePoints Empty = pure Empty
updateStrokePoints ( p :<| ps ) = case p of
PathPoint {}
| Selected <- selectionState
-> do
Tardis.sendPast True
Tardis.sendFuture True
updateStroke ps
lift $ put True
updateStrokePoints ps
| otherwise
-> do
Tardis.sendPast False
Tardis.sendFuture False
( p :<| ) <$> updateStroke ps
( p :<| ) <$> updateStrokePoints ps
_ -> do
prevPathPointDeleted <- Tardis.getPast
nextPathPointDeleted <- Tardis.getFuture
rest <- updateStroke ps
rest <- updateStrokePoints ps
let
-- Control point must be deleted:
-- - if it is selected,

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

@ -119,7 +119,7 @@ import Math.Bezier.Stroke
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..)
( Document(..), DocumentContent(..)
, Guide(..)
, Stroke(..)
, PointData(..)
@ -350,24 +350,36 @@ decodeGuide uniqueSupply = do
pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes
encodeDocument :: Applicative f => JSON.Encoder f Document
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes, guides } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes
. JSON.Encoder.atKey' "strokes" ( encodeUniqueMap encodeGuide ) guides
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent
decodeDocumentContent uniqueSupply = do
let
unsavedChanges :: Bool
unsavedChanges = False
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) )
pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes, guides } )
latestChange :: Text
latestChange = "Load document"
strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) )
pure ( Content { unsavedChanges, latestChange, strokes, guides } )
encodeDocument :: Applicative f => JSON.Encoder f Document
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } )

6
src/app/MetaBrush/Document/SubdivideStroke.hs
View file

@ -61,7 +61,11 @@ subdivide mode c doc@( Document { zoomFactor } )
updatedDoc :: Document
subdivOccurred :: Bool
( updatedDoc, subdivOccurred ) = ( `runState` False ) $ field' @"strokes" ( traverse updateStroke ) doc
( updatedDoc, subdivOccurred )
= ( `runState` False )
$ ( field' @"documentContent" . field' @"strokes" . traverse )
updateStroke
doc
updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } )

256
src/app/MetaBrush/Document/Update.hs Normal file
View file

@ -0,0 +1,256 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Update
( activeDocument, withActiveDocument
, DocChange(..), DocumentUpdate(..)
, PureDocModification(..), DocModification(..)
, modifyingCurrentDocument
, updateUIAction
, updateHistoryState
)
where
-- base
import Control.Arrow
( (&&&) )
import Control.Monad
( join )
import Data.Coerce
( coerce )
import Data.Foldable
( for_, sequenceA_ )
import Data.Monoid
( Ap(..) )
import Data.Traversable
( for )
-- containers
import qualified Data.Map.Strict as Map
( adjust, delete, lookup )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- gi-gtk
import qualified GI.Gtk as GTK
-- lens
import Control.Lens
( set )
import Control.Lens.Fold
( Fold, foldMapOf, forOf_, sequenceAOf_ )
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( readTVar, readTVar, modifyTVar' )
-- text
import Data.Text
( Text )
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Maybe
( MaybeT(..) )
-- MetaBrush
import MetaBrush.Context
( UIElements(..), Variables(..) )
import MetaBrush.Document
( Document(..), DocumentContent(..) )
import MetaBrush.Document.History
( DocumentHistory(..)
, newFutureStep, affirmPresent
, atStart, atEnd
)
import {-# SOURCE #-} MetaBrush.UI.FileBar
( removeFileTab )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( updateInfoBar )
import MetaBrush.UI.Menu
( ResourceType(..), MenuItem(..), Menu(..), EditMenu(..) )
import MetaBrush.UI.Viewport
( Viewport(..) )
import MetaBrush.Util
( (>>?=) )
--------------------------------------------------------------------------------
-- | Read the currently active document from the stateful variables.
activeDocument :: Variables -> STM ( Maybe DocumentHistory )
activeDocument ( Variables { activeDocumentTVar, openDocumentsTVar } )
= STM.readTVar activeDocumentTVar
>>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar )
-- | Do something with the currently active document.
--
-- Does nothing if no document is currently active.
withActiveDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a )
withActiveDocument vars f = traverse f =<< ( fmap present <$> activeDocument vars )
data DocChange
= TrivialChange { newDocument :: !Document }
| HistoryChange { newDocument :: !Document }
data DocumentUpdate
= CloseDocument
| SaveDocument !( Maybe FilePath )
| UpdateDocumentTo !DocChange
data PureDocModification
= Don'tModifyDoc
| UpdateDoc !DocumentUpdate
-- | Modify a document, and then perform some subsequent IO action.
--
-- It is assumed that the subsequent IO action does not affect the rest of the application,
-- i.e. it doesn't change any of the STM variables or update the UI.
-- For instance: saving a file to disk.
data DocModification
= Don'tModifyDocAndThen
{ postModifAction :: IO () }
| UpdateDocAndThen
{ modifDocument :: !DocumentUpdate
, postModifAction :: IO ()
}
class DocumentModification modif where
docFold :: Fold modif DocumentUpdate
actionFold :: Fold modif ( IO () )
instance DocumentModification PureDocModification where
docFold _ Don'tModifyDoc = pure Don'tModifyDoc
docFold f ( UpdateDoc mbDocInstnt ) = UpdateDoc <$> ( f mbDocInstnt )
actionFold _ a = pure a
instance DocumentModification DocModification where
docFold _ don't@( Don'tModifyDocAndThen {} ) = pure don't
docFold f ( UpdateDocAndThen mbDocInstnt action ) = ( \ new -> UpdateDocAndThen new action ) <$> f mbDocInstnt
actionFold f modif = ( \ action' -> modif { postModifAction = action' } ) <$> f ( postModifAction modif )
-- | Modify the currently active document.
--
-- Does nothing if no document is currently active.
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do
mbAction <- STM.atomically . runMaybeT $ do
unique <- MaybeT ( STM.readTVar activeDocumentTVar )
oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar )
maxHistSize <- lift ( STM.readTVar maxHistorySizeTVar )
modif <- lift ( f oldDoc )
Ap uiUpdateAction <- lift . getAp $ flip ( foldMapOf docFold ) modif $ Ap . \case
CloseDocument -> do
STM.modifyTVar' openDocumentsTVar ( Map.delete unique )
coerce ( updateUIAction uiElts vars )
SaveDocument Nothing -> do
STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique )
pure ( pure () )
SaveDocument ( Just newFilePath ) -> do
STM.modifyTVar' openDocumentsTVar
( Map.adjust
( affirmPresent
. set ( field' @"present" . field' @"mbFilePath" )
( Just newFilePath )
)
unique
)
pure ( pure () )
UpdateDocumentTo ( TrivialChange newDoc ) -> do
STM.modifyTVar' openDocumentsTVar
( Map.adjust ( set ( field' @"present" ) newDoc ) unique )
coerce ( updateUIAction uiElts vars )
UpdateDocumentTo ( HistoryChange newDoc ) -> do
STM.modifyTVar' openDocumentsTVar
( Map.adjust
( newFutureStep maxHistSize
$ set ( field' @"documentContent" . field' @"unsavedChanges" ) True newDoc
)
unique
)
uiUpdateAction <- updateUIAction uiElts vars
pure $ Ap do
uiUpdateAction
GTK.widgetSetSensitive undoMenuItem True
GTK.widgetSetSensitive redoMenuItem False
pure
do
forOf_ docFold modif \ mbNewDoc -> do
case mbNewDoc of
CloseDocument -> removeFileTab vars ( documentUnique oldDoc )
_ -> pure ()
uiUpdateAction
sequenceAOf_ actionFold modif
sequenceA_ mbAction
where
undoMenuItem, redoMenuItem :: GTK.MenuItem
undoMenuItem = menuItem $ undo $ menuItemSubmenu $ edit menu
redoMenuItem = menuItem $ redo $ menuItemSubmenu $ edit menu
updateUIAction :: UIElements -> Variables -> STM ( IO () )
updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
mbDocHist <- activeDocument vars
let
mbDoc :: Maybe Document
mbDoc = present <$> mbDocHist
mbTitleText :: Maybe ( Text, Bool )
mbTitleText = fmap ( displayName &&& unsavedChanges . documentContent ) mbDoc
mbActiveTabDoc <- fmap join $ for mbDoc \doc -> do
mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
pure ( (,) <$> mbActiveTab <*> mbDoc )
pure do
updateTitle window title mbTitleText
updateInfoBar viewportDrawingArea infoBar vars mbDoc
for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do
GTK.buttonSetLabel activeTabLabel ( displayName activeDoc )
GTK.widgetQueueDraw activeTab
GTK.widgetQueueDraw viewportDrawingArea
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
updateTitle window title mbTitleText = do
GTK.labelSetText title titleText
GTK.setWindowTitle window titleText
where
titleText :: Text
titleText = case mbTitleText of
Nothing -> "MetaBrush"
Just ( name, hasUnsavedChanges )
| hasUnsavedChanges
-> "● " <> name <> " – MetaBrush"
| otherwise
-> name <> " – MetaBrush"
updateHistoryState :: UIElements -> Maybe DocumentHistory -> IO ()
updateHistoryState ( UIElements {..} ) mbHist =
case mbHist of
Nothing -> do
GTK.widgetSetSensitive undoMenuItem False
GTK.widgetSetSensitive redoMenuItem False
Just hist -> do
if atStart hist
then GTK.widgetSetSensitive undoMenuItem False
else GTK.widgetSetSensitive undoMenuItem True
if atEnd hist
then GTK.widgetSetSensitive redoMenuItem False
else GTK.widgetSetSensitive redoMenuItem True
where
editMenu :: EditMenu Object
editMenu = menuItemSubmenu ( edit menu )
undoMenuItem, redoMenuItem :: GTK.MenuItem
undoMenuItem = menuItem $ undo $ editMenu
redoMenuItem = menuItem $ redo $ editMenu

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

@ -75,7 +75,8 @@ import MetaBrush.Asset.Colours
import MetaBrush.Context
( HoldAction(..), PartialPath(..) )
import MetaBrush.Document
( Document(..), mkAABB
( Document(..), DocumentContent(..)
, mkAABB
, Stroke(..), FocusState(..)
, HoverContext(..), Hoverable(..)
, PointData(..), BrushPointData(..)
@ -121,7 +122,7 @@ renderDocument
renderDocument
cols params mode ( viewportWidth, viewportHeight )
mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
= do
Cairo.save
@ -144,7 +145,7 @@ renderDocument
| Just ( DragMoveHold p0 ) <- mbHoldEvent
, Just p1 <- mbMousePos
, p0 /= p1
= strokes $ translateSelection mode ( p0 --> p1 ) doc
= strokes . documentContent . fst $ translateSelection mode ( p0 --> p1 ) doc
| Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
, let
mbFinalPoint :: Maybe ( Point2D Double )
@ -172,9 +173,9 @@ renderDocument
, Just ( PathPoint finalPoint ( PointData Normal Empty ) )
]
= ( Stroke { strokePoints = previewPts, strokeVisible = True, strokeUnique = undefined, strokeName = undefined } )
: strokes doc
: strokes content
| otherwise
= strokes doc
= strokes content
for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode zoomFactor )
renderSelectionRect

5
src/app/MetaBrush/Render/Rulers.hs
View file

@ -60,7 +60,8 @@ import MetaBrush.Asset.Colours
import MetaBrush.Context
( HoldAction(..), GuideAction(..) )
import MetaBrush.Document
( Document(..), FocusState(..), Hoverable(..), HoverContext(..)
( Document(..), DocumentContent(..)
, FocusState(..), Hoverable(..), HoverContext(..)
, Guide(..)
)
import MetaBrush.UI.Coordinates
@ -82,7 +83,7 @@ renderRuler
renderRuler
cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height )
mbMousePos mbHoldEvent showGuides
( Document { viewportCenter = center@( Point2D cx cy ), zoomFactor, guides } ) = do
( Document { viewportCenter = center@( Point2D cx cy ), zoomFactor, documentContent = Content { guides } } ) = do
let
modifiedGuides :: [ Guide ]

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

@ -15,7 +15,7 @@ module MetaBrush.UI.FileBar
-- base
import Control.Monad
( join, void )
( join, unless, void )
import Data.Foldable
( for_, sequenceA_ )
import Data.Traversable
@ -48,9 +48,15 @@ import MetaBrush.Asset.Colours
import MetaBrush.Context
( UIElements(..), Variables(..) )
import MetaBrush.Document
( Document(..), emptyDocument )
( Document(..), DocumentContent(..)
, emptyDocument
)
import MetaBrush.Document.History
( DocumentHistory(..), newHistory )
import MetaBrush.Document.Update
( updateUIAction )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar, updateInfoBar )
( InfoBar )
import {-# SOURCE #-} MetaBrush.UI.Menu
( Menu, ResourceType(Object) )
import MetaBrush.UI.Viewport
@ -77,43 +83,44 @@ data TabLocation
deriving stock Show
newFileTab
:: UIElements
:: Bool
-> UIElements
-> Variables
-> Maybe Document
-> Maybe DocumentHistory
-> TabLocation
-> IO ()
newFileTab
initialStage
uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } )
vars@( Variables {..} )
mbDoc
mbDocHist
newTabLoc
= do
newDoc <- case mbDoc of
newDocHist <- case mbDocHist of
-- Use the provided document (e.g. document read from a file).
Just doc -> do
pure doc
Just docHist -> do pure docHist
-- Create a new empty document.
Nothing -> do
newDocUniq <- STM.atomically $ freshUnique uniqueSupply
pure ( emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
let
newUnique :: Unique
newUnique = documentUnique newDoc
newUnique = documentUnique ( present newDocHist )
-- File tab elements.
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName newDoc )
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName $ present newDocHist )
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
closeFileButton <- GTK.buttonNew
closeFileArea <- GTK.drawingAreaNew
GTK.containerAdd closeFileButton closeFileArea
void $ GTK.onWidgetDraw closeFileArea \ cairoContext -> do
mbTabDoc <- Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
mbTabDoc <- fmap present . Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
let
unsaved :: Bool
unsaved = maybe False unsavedChanges mbTabDoc
unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc
flags <- GTK.widgetGetStateFlags closeFileButton
Cairo.renderWithContext ( drawCloseTabButton colours unsaved flags ) cairoContext
@ -135,7 +142,7 @@ newFileTab
mbUnique <- STM.readTVar activeDocumentTVar
for mbUnique \ docUnique -> do
Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
for_ mbActiveTab \ activeTab -> do
for_ mbActiveTab \ ( activeTab, _ ) -> do
children <- GTK.containerGetChildren fileTabsBox
for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do
mbBox <- GTK.castTo GTK.Box childWidget
@ -156,13 +163,17 @@ newFileTab
pure False
-- Update the state: switch to this new document.
STM.atomically do
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique tab )
STM.writeTVar activeDocumentTVar ( Just newUnique )
GTK.widgetQueueDraw viewportDrawingArea
updateInfoBar viewportDrawingArea infoBar vars
uiUpdateAction <- STM.atomically do
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDocHist )
STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique ( tab, pgButton ) )
-- don't update UI if we are just creating file tabs for the first time
-- (we don't have access to the full menu at that point, so this would otherwise loop)
if initialStage
then pure ( pure () )
else do
STM.writeTVar activeDocumentTVar ( Just newUnique )
updateUIAction uiElts vars
uiUpdateAction
void $ GTK.onButtonClicked pgButton do
isActive <- GTK.toggleButtonGetActive pgButton
@ -170,8 +181,7 @@ newFileTab
if isActive
then do
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
handleAction uiElts vars
( SwitchTo newUnique )
handleAction uiElts vars ( SwitchTo newUnique )
else do
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
GTK.widgetQueueDraw closeFileArea
@ -180,7 +190,10 @@ newFileTab
GTK.widgetQueueDraw closeFileArea
handleAction uiElts vars ( CloseThis newUnique )
GTK.toggleButtonSetActive pgButton True
-- Activate the button, unless we are creating buttons for the first time,
-- in which case we shouldn't activate it as we don't have a menu yet,
-- so we wouldn't be able to handle the associated action.
unless initialStage ( GTK.toggleButtonSetActive pgButton True )
-- | Create a file bar: tabs allowing selection of the active document.
--
@ -224,13 +237,13 @@ createFileBar
documents <- STM.readTVarIO openDocumentsTVar
for_ documents \ doc ->
newFileTab
newFileTab True
uiElements vars
( Just doc )
LastTab
void $ GTK.onButtonClicked newFileButton do
newFileTab
newFileTab False
uiElements vars
Nothing
LastTab
@ -244,7 +257,7 @@ removeFileTab ( Variables {..} ) docUnique = do
cleanupAction <- STM.atomically do
-- Remove the tab.
mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
for mbTab \ tab -> do
for mbTab \ ( tab, _ ) -> do
STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique )
pure ( GTK.widgetDestroy tab )

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

@ -15,8 +15,8 @@ import MetaBrush.Asset.Colours
( Colours )
import {-# SOURCE #-} MetaBrush.Context
( Variables, UIElements )
import MetaBrush.Document
( Document )
import MetaBrush.Document.History
( DocumentHistory )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar )
import {-# SOURCE #-} MetaBrush.UI.Menu
@ -47,8 +47,9 @@ createFileBar
-> IO FileBar
newFileTab
:: UIElements -> Variables
-> Maybe Document -> TabLocation
:: Bool
-> UIElements -> Variables
-> Maybe DocumentHistory -> TabLocation
-> IO ()
removeFileTab :: Variables -> Unique -> IO ()

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

@ -33,8 +33,6 @@ import qualified GI.Cairo.Render as Cairo
import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( readTVarIO )
@ -52,9 +50,7 @@ import MetaBrush.Asset.Cursor
import MetaBrush.Asset.InfoBar
( drawMagnifier, drawTopLeftCornerRect )
import MetaBrush.Context
( Variables(..)
, currentDocument
)
( Variables(..) )
import MetaBrush.Document
( Document(..) )
import MetaBrush.UI.Coordinates
@ -161,12 +157,11 @@ createInfoBar colours = do
pure ( InfoBar {..} )
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO ()
updateInfoBar viewportDrawingArea ( InfoBar {..} ) vars@( Variables { mousePosTVar } )
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar } ) mbDoc
= do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
mbDoc <- STM.atomically $ currentDocument vars
case mbDoc of
Nothing -> do
GTK.labelSetText zoomText $ na

4
src/app/MetaBrush/UI/InfoBar.hs-boot
View file

@ -10,6 +10,8 @@ import MetaBrush.Asset.Colours
( Colours )
import {-# SOURCE #-} MetaBrush.Context
( Variables )
import MetaBrush.Document
( Document )
--------------------------------------------------------------------------------
@ -22,4 +24,4 @@ data InfoBar
createInfoBar :: Colours -> IO InfoBar
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO ()
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()

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

@ -136,7 +136,6 @@ data EditMenu ( rt :: ResourceType )
= EditMenu
{ undo :: !( MenuItem Undo NoSubresource rt )
, redo :: !( MenuItem Redo NoSubresource rt )
, discardChanges :: !( MenuItem DiscardChanges NoSubresource rt )
, editSep1 :: !( Separator rt )
, cut :: !( MenuItem Cut NoSubresource rt )
, copy :: !( MenuItem Copy NoSubresource rt )
@ -196,7 +195,6 @@ editMenuDescription
= EditMenu
{ undo = MenuItemDescription "Undo" [ "submenuItem" ] Undo ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
, redo = MenuItemDescription "Redo" [ "submenuItem" ] Redo ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
, discardChanges = MenuItemDescription "Discard changes" [ "submenuItem" ] DiscardChanges ( Just ( GDK.KEY_Z, [ Control L, Shift L ] ) ) NoSubresource
, editSep1 = SeparatorDescription [ "submenuSeparator" ]
, cut = MenuItemDescription "Cut" [ "submenuItem" ] Cut ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
, copy = MenuItemDescription "Copy" [ "submenuItem" ] Copy ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource

6
src/app/MetaBrush/Unique.hs
View file

@ -28,6 +28,10 @@ import Data.Map.Strict
import qualified Data.Map.Strict as Map
( fromList )
-- deepseq
import Control.DeepSeq
( NFData )
-- generic-lens
import Data.Generics.Product.Typed
( HasType(typed) )
@ -52,7 +56,7 @@ import qualified Data.Text as Text
newtype Unique = Unique { unique :: Int64 }
deriving stock Show
deriving newtype ( Eq, Ord, Storable )
deriving newtype ( Eq, Ord, Storable, NFData )
unsafeUnique :: Word32 -> Unique
unsafeUnique i = Unique ( - fromIntegral i - 1 )