add document history & undo/redo

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

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

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

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

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`

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 --

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

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"

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

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 } )

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

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,

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 } )

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 } )

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

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

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 ]

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 )

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 ()

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

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 ()

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

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 )