hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

refactor: separation of event handling and actions

Browse source
This commit is contained in:
sheaf 2020-09-02 04:52:08 +02:00
parent 101d9515c0
commit 7033578e20
15 changed files with 1005 additions and 718 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
MetaBrush.cabal
View file

@ -96,7 +96,8 @@ executable MetaBrush
Main.hs
other-modules:
MetaBrush.Asset.Brushes
MetaBrush.Action
, MetaBrush.Asset.Brushes
, MetaBrush.Asset.Colours
, MetaBrush.Asset.Cursor
, MetaBrush.Asset.InfoBar
@ -104,6 +105,7 @@ executable MetaBrush
, MetaBrush.Asset.TickBox
, MetaBrush.Asset.Tools
, MetaBrush.Asset.WindowIcons
, MetaBrush.Context
, MetaBrush.Document
, MetaBrush.Document.Draw
, MetaBrush.Document.Selection
@ -148,6 +150,8 @@ executable MetaBrush
^>= 0.0.1
, haskell-gi-base
^>= 0.24
, haskus-utils-variant
^>= 3.0
, lens
^>= 4.19.2
, scientific

98
app/Main.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -12,12 +13,8 @@ module Main
-- base
import Control.Monad
( void )
import Data.Foldable
( for_ )
import Data.Int
( Int32 )
import Data.Word
( Word32 )
import System.Exit
( exitSuccess )
@ -28,6 +25,10 @@ import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
import Data.Set
( Set )
import qualified Data.Set as Set
( empty )
-- directory
import qualified System.Directory as Directory
@ -43,9 +44,17 @@ import qualified GI.Gdk as GDK
-- gi-gtk
import qualified GI.Gtk as GTK
-- haskus-utils-variant
import Haskus.Utils.Variant
( V )
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TQueue as STM
( newTQueueIO )
import qualified Control.Concurrent.STM.TVar as STM
( newTVarIO, readTVarIO )
( newTVarIO, readTVar )
-- text
import qualified Data.Text as Text
@ -56,28 +65,33 @@ import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D
( Point2D(..) )
import MetaBrush.Action
( Actions, handleActions )
import MetaBrush.Asset.Brushes
( ellipse, rect )
import MetaBrush.Asset.Colours
( getColours )
import MetaBrush.Asset.Logo
( drawLogo )
import MetaBrush.Context
( UIElements(..), Variables(..)
, Modifier(..)
, HoldAction(..), PartialPath(..)
, withCurrentDocument
)
import MetaBrush.Document
( Document(..), Stroke(..)
, FocusState(..)
, PointData(..), BrushPointData(..)
, currentDocument
)
import MetaBrush.Event
( HoldEvent, PartialPath
, handleEvents
)
( handleEvents )
import MetaBrush.Render.Document
( renderDocument )
( renderDocument, blankRender )
import MetaBrush.UI.FileBar
( createFileBar )
( FileBar(..), createFileBar )
import MetaBrush.UI.InfoBar
( createInfoBar )
( InfoBar(..), createInfoBar )
import MetaBrush.UI.Menu
( createMenuBar )
import MetaBrush.UI.Panels
@ -176,12 +190,19 @@ main = do
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
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
-- Put all these stateful variables in a record for conciseness.
let
variables :: Variables
variables = Variables { .. }
actionTQueue <- STM.newTQueueIO @( V Actions )
---------------------------------------------------------
-- Initialise GTK
@ -246,7 +267,6 @@ main = do
GTK.panedPack2 mainPane panelBox False False
viewportGrid <- GTK.gridNew
infoBar <- GTK.boxNew GTK.OrientationHorizontal 0
---------------------------------------------------------
-- Background
@ -291,19 +311,22 @@ main = do
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
-- Get the relevant document information
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
for_ mbDoc \ doc -> do
mbMousePos <- STM.readTVarIO mousePosTVar
mbHoldEvent <- STM.readTVarIO mouseHoldTVar
mbPartialPath <- STM.readTVarIO partialPathTVar
mode <- STM.readTVarIO modeTVar
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
( `Cairo.renderWithContext` ctx ) $
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document { .. } ) -> do
mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar
mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar
pure $
renderDocument
colours mode ( viewportWidth, viewportHeight )
mbMousePos mbHoldEvent mbPartialPath
mbMousePos mbHoldAction mbPartialPath
doc
case mbRender of
Just render -> Cairo.renderWithContext render ctx
Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx
pure True
---------------------------------------------------------
@ -314,19 +337,19 @@ main = do
---------------------------------------------------------
-- Info bar
infoBarElements <- createInfoBar colours infoBar
infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
---------------------------------------------------------
-- File bar
fileBar <-
fileBar@( FileBar { fileBarBox } ) <-
createFileBar
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportDrawingArea infoBarElements
variables
window title viewportDrawingArea infoBar
GTK.boxPackStart mainView fileBar False False 0
GTK.boxPackStart mainView fileBarBox False False 0
GTK.boxPackStart mainView viewportGrid True True 0
GTK.boxPackStart mainView infoBar False False 0
GTK.boxPackStart mainView infoBarArea False False 0
---------------------------------------------------------
-- Panels
@ -336,12 +359,13 @@ main = do
---------------------------------------------------------
-- Actions
handleEvents
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar partialPathTVar
window viewportDrawingArea infoBarElements
let
uiElements :: UIElements
uiElements = UIElements { .. }
handleEvents uiElements actionTQueue
void $ GDK.threadsAddIdle 200 ( handleActions actionTQueue uiElements variables )
---------------------------------------------------------
-- GTK main loop

537
src/app/MetaBrush/Action.hs Normal file
View file

@ -0,0 +1,537 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Action
( Actions, HandleAction(..)
, handleActions, signalAction, quitEverything
, MouseMove(..), MouseClick(..), MouseRelease(..)
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
)
where
-- base
import Control.Monad
( guard, unless, void )
import Data.Foldable
( for_, traverse_ )
import Data.Maybe
( catMaybes )
import Data.Word
( Word32 )
-- acts
import Data.Act
( Act
( (•) )
, Torsor
( (-->) )
)
-- containers
import qualified Data.Map as Map
( lookup )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
import qualified Data.Set as Set
( insert, delete )
-- gi-gdk
import qualified GI.Gdk as GDK
-- gi-gtk
import qualified GI.Gtk as GTK
-- haskus-utils-variant
import Haskus.Utils.Variant
( V, pattern V, ReduceVariant, reduceVariant
, type (:<)
)
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically, retry )
import qualified Control.Concurrent.STM.TQueue as STM
( TQueue, flushTQueue, writeTQueue )
import qualified Control.Concurrent.STM.TVar as STM
( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module
( Module((*^)) )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Context
( UIElements(..), Variables(..)
, Modifier(..), modifierKey
, HoldAction(..), PartialPath(..)
, withCurrentDocument, modifyingCurrentDocument
)
import MetaBrush.Document
( Document(..)
, PointData(..), FocusState(..)
)
import MetaBrush.Document.Draw
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document.Selection
( SelectionMode(..), selectionMode
, selectAt, selectRectangle
, dragMoveSelect
, translateSelection
, deleteSelected
)
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
( updateInfoBar )
import MetaBrush.UI.FileBar
( TabLocation(..), newFileTab )
import MetaBrush.UI.ToolBar
( Tool(..) )
import Debug.Trace
--------------------------------------------------------------------------------
type Actions = [ MouseMove, MouseClick, MouseRelease, Scroll, KeyboardPress, KeyboardRelease ]
class HandleAction action where
handleAction :: UIElements -> Variables -> action -> IO ()
instance ReduceVariant HandleAction actions => HandleAction ( V actions ) where
handleAction elts vars = reduceVariant @HandleAction ( handleAction elts vars )
handleActions :: ( Show action, HandleAction action ) => STM.TQueue action -> UIElements -> Variables -> IO Bool
handleActions actionTQueue elts vars = do
actions <- STM.atomically $ STM.flushTQueue actionTQueue
--actions <- STM.atomically do
-- actions <- STM.flushTQueue actionTQueue
-- if null actions
-- then STM.retry
-- else pure actions
traverse_ ( handleAction elts vars ) actions
pure True
signalAction :: action :< actions => STM.TQueue ( V actions ) -> action -> STM ()
signalAction tqueue = STM.writeTQueue tqueue . V
--------------
-- Quitting --
--------------
quitEverything :: GTK.Window -> IO ()
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
--------------------
-- Mouse movement --
--------------------
data MouseMove = MouseMove ( Point2D Double )
deriving stock Show
instance HandleAction MouseMove where
handleAction
( UIElements { viewportDrawingArea, infoBar } )
vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } )
( MouseMove ( Point2D x y ) )
= do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
void . STM.atomically $ withCurrentDocument vars \ ( Document { .. } ) -> do
modifiers <- STM.readTVar modifiersTVar
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
STM.writeTVar mousePosTVar ( Just pos )
----------------------------------------------------------
-- With the pen tool, keeping control pressed while moving the mouse
-- moves the partial control point (if one exists).
tool <- STM.readTVar toolTVar
mbPartialPath <- STM.readTVar partialPathTVar
case tool of
Pen
| any ( \ case { Control _ -> True; _ -> False } ) modifiers
, Just pp <- mbPartialPath
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ -> pure ()
updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw viewportDrawingArea
-----------------
-- Mouse click --
-----------------
data MouseClick = MouseClick Word32 ( Point2D Double )
deriving stock Show
instance HandleAction MouseClick where
handleAction
( UIElements { viewportDrawingArea } )
vars@( Variables { .. } )
( MouseClick button mouseClickCoords )
= case button of
-- Left mouse button.
1 -> do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport mouseClickCoords
STM.writeTVar mousePosTVar ( Just pos )
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just newDoc <- dragMoveSelect mode pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
pure ( Just newDoc )
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Nothing
-- Pen tool: start or continue a drawing operation.
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do
( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar
( Just $ PartialPath
{ partialStartPos = anchorPt
, partialControlPoint = Nothing
, partialPathAnchor = drawAnchor
, firstPoint = True
}
)
pure ( Just newDoc )
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Nothing
GTK.widgetQueueDraw viewportDrawingArea
-- Right mouse button: end partial path.
3 -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
-------------------
-- Mouse release --
-------------------
data MouseRelease = MouseRelease Word32 ( Point2D Double )
deriving stock Show
instance HandleAction MouseRelease where
handleAction
( UIElements { viewportDrawingArea } )
vars@( Variables { .. } )
( MouseRelease button ( Point2D x y ) )
= case button of
-- Left mouse button.
1 -> do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
STM.writeTVar mousePosTVar ( Just pos )
modifiers <- STM.readTVar modifiersTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
Selection -> do
let
selMode :: SelectionMode
selMode = selectionMode modifiers
case mbHoldPos of
Just hold
| DragMoveHold pos0 <- hold
, pos0 /= pos
-> pure . Just $ translateSelection mode ( pos0 --> pos ) doc
| SelectionHold pos0 <- hold
, pos0 /= pos
-> pure . Just $ selectRectangle mode selMode pos0 pos doc
_ -> pure . Just $ selectAt mode selMode pos doc
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor.
-- If no anchor exists, then just ignore the mouse release event.
Nothing -> pure Nothing
-- Mouse click release possibilities:
--
-- - click was on complementary draw stroke draw anchor to close the path,
-- - release at same point as click: finish current segment,
-- - release at different point as click: finish current segment, adding a control point.
Just
( PartialPath
{ partialStartPos = p1
, partialControlPoint = mbCp2
, partialPathAnchor = anchor
, firstPoint
}
) -> do
let
pathPoint :: Point2D Double
mbControlPoint :: Maybe ( Point2D Double )
partialControlPoint :: Maybe ( Point2D Double )
( pathPoint, mbControlPoint, partialControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldPos
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
| otherwise
= ( pos, Nothing, Nothing )
( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
if not firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path.
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
]
pure ( Just $ addToAnchor anchor newSegment doc )
else
if firstPoint
-- Continue current partial path.
then do
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
pure Nothing
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
]
pure ( Just $ addToAnchor anchor newSegment doc )
GTK.widgetQueueDraw viewportDrawingArea
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
---------------
-- Scrolling --
---------------
data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
deriving stock Show
instance HandleAction Scroll where
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
unless ( dx == 0 && dy == 0 ) do
STM.atomically $ modifyingCurrentDocument vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
modifiers <- STM.readTVar modifiersTVar
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
mousePos :: Point2D Double
mousePos = toViewport ( Point2D x y )
newDoc :: Document
newDoc
-- Zooming using 'Control'.
| any ( \ case { Control _ -> True; _ -> False } ) modifiers
= let
newZoomFactor :: Double
newZoomFactor
| dy > 0
= max 0.0078125 ( oldZoomFactor / sqrt 2 )
| otherwise
= min 256 ( oldZoomFactor * sqrt 2 )
newCenter :: Point2D Double
newCenter
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
• oldCenter
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
= let
newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
in doc { viewportCenter = newCenter }
-- Vertical scrolling.
| otherwise
= let
newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
in doc { viewportCenter = newCenter }
finalZoomFactor :: Double
finalZoomFactor = zoomFactor newDoc
finalCenter :: Point2D Double
finalCenter = viewportCenter newDoc
toFinalViewport :: Point2D Double -> Point2D Double
toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
finalMousePos :: Point2D Double
finalMousePos = toFinalViewport ( Point2D x y )
STM.writeTVar mousePosTVar ( Just finalMousePos )
pure ( Just newDoc )
updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw viewportDrawingArea
--------------------
-- Keyboard press --
--------------------
data KeyboardPress = KeyboardPress Word32
deriving stock Show
instance HandleAction KeyboardPress where
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do
modifiers <- STM.atomically do
!modifiers <- STM.readTVar modifiersTVar
for_ ( modifierKey keyCode ) \ modifier ->
( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
pure modifiers
case keyCode of
GDK.KEY_Escape -> quitEverything window
GDK.KEY_Return -> do
tool <- STM.readTVarIO toolTVar
case tool of
-- End ongoing drawing on pressing enter key.
Pen -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
GDK.KEY_Delete -> do
tool <- STM.readTVarIO toolTVar
mode <- STM.readTVarIO modeTVar
case tool of
-- Delete selected points on pressing 'Delete'.
Selection -> do
STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
ctrl
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
-> do
----------------------------------------------------------
-- With the pen tool, pressing control moves
-- the partial point control point to the mouse position.
tool <- STM.readTVarIO toolTVar
mbMousePos <- STM.readTVarIO mousePosTVar
mbPartialPath <- STM.readTVarIO partialPathTVar
case tool of
Pen
| Just mp <- mbMousePos
, Just pp <- mbPartialPath
-> do
STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
GDK.KEY_F1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( Map.lookup i docs ) \ doc -> do
writeFile "log.txt" ( show doc <> "\n\n" )
-- Create a new document with Ctrl+N
n
| ( n == GDK.KEY_n || n == GDK.KEY_N )
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
->
newFileTab
vars
window title fileBar viewportDrawingArea infoBar
Nothing
AfterCurrentTab
_ -> pure ()
----------------------
-- Keyboard release --
----------------------
data KeyboardRelease = KeyboardRelease Word32
deriving stock Show
instance HandleAction KeyboardRelease where
handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) =
for_ ( modifierKey keyCode ) \ modifier -> do
STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier )

149
src/app/MetaBrush/Context.hs Normal file
View file

@ -0,0 +1,149 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
module MetaBrush.Context
( UIElements(..), Variables(..)
, LR(..), Modifier(..), modifierKey
, HoldAction(..), PartialPath(..)
, currentDocument, withCurrentDocument, modifyingCurrentDocument
)
where
-- base
import Data.Foldable
( for_ )
import Data.Word
( Word32 )
-- containers
import Data.Set
( Set )
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( insert, lookup )
-- gi-gtk
import qualified GI.Gdk as GDK
-- gi-gtk
import qualified GI.Gtk as GTK
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar, readTVar, writeTVar )
-- MetaBrush
import Math.Vector2D
( Point2D )
import MetaBrush.Document
( Document )
import MetaBrush.Document.Draw
( DrawAnchor )
import {-# SOURCE #-} MetaBrush.UI.FileBar
( FileBar )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar )
import MetaBrush.UI.ToolBar
( Tool, Mode )
import MetaBrush.Unique
( UniqueSupply, Unique )
import MetaBrush.Util
( (>>?=) )
--------------------------------------------------------------------------------
data UIElements
= UIElements
{ window :: !GTK.Window
, title :: !GTK.Label
, fileBar :: !FileBar
, viewportDrawingArea :: !GTK.DrawingArea
, infoBar :: !InfoBar
}
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 ) )
}
--------------------------------------------------------------------------------
data LR = L | R
deriving stock ( Show, Eq, Ord )
data Modifier
= Control LR
| Alt LR
| Shift LR
deriving stock ( Show, Eq, Ord )
modifierKey :: Word32 -> Maybe Modifier
modifierKey GDK.KEY_Control_L = Just ( Control L )
modifierKey GDK.KEY_Control_R = Just ( Control R )
modifierKey GDK.KEY_Shift_L = Just ( Shift L )
modifierKey GDK.KEY_Shift_R = Just ( Shift R )
modifierKey GDK.KEY_Alt_L = Just ( Alt L )
modifierKey GDK.KEY_Alt_R = Just ( Alt R )
modifierKey _ = Nothing
-- | Keep track of a mouse hold action:
--
-- - start a rectangular selection,
-- - move objects by dragging,
-- - drawing a control point.
data HoldAction
= SelectionHold { holdStartPos :: !( Point2D Double ) }
| DragMoveHold { holdStartPos :: !( Point2D Double ) }
| DrawHold { holdStartPos :: !( Point2D Double ) }
deriving stock Show
-- | Keep track of a path that is in the middle of being drawn.
data PartialPath
= PartialPath
{ partialStartPos :: !( Point2D Double )
, partialControlPoint :: !( Maybe ( Point2D Double ) )
, partialPathAnchor :: !DrawAnchor
, 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
-- | Modify the currently active document.
--
-- Does nothing if no document is currently active.
modifyingCurrentDocument :: Variables -> ( Document -> STM ( Maybe Document ) ) -> STM ()
modifyingCurrentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) f = do
mbUnique <- STM.readTVar activeDocumentTVar
case mbUnique of
Nothing -> pure ()
Just unique -> do
docs <- STM.readTVar openDocumentsTVar
for_ ( Map.lookup unique docs ) \ oldDoc -> do
mbNewDoc <- f oldDoc
for_ mbNewDoc \ newDoc -> do
STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs )

9
src/app/MetaBrush/Context.hs-boot Normal file
View file

@ -0,0 +1,9 @@
module MetaBrush.Context
( UIElements, Variables )
where
--------------------------------------------------------------------------------
data UIElements
data Variables

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

@ -8,7 +8,7 @@
module MetaBrush.Document
( AABB(..)
, Document(..), emptyDocument, currentDocument
, Document(..), emptyDocument
, Stroke(..)
, PointData(..), BrushPointData(..)
, FocusState(..)
@ -21,10 +21,6 @@ import GHC.Generics
( Generic )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( lookup )
import Data.Sequence
( Seq )
@ -42,12 +38,6 @@ import Control.Lens
import Data.Text
( Text )
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
@ -108,15 +98,6 @@ _selection = field' @"pointData" . typed @FocusState
_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
_brush = field' @"pointData" . field' @"brushShape"
currentDocument :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar
case mbActive of
Nothing -> pure Nothing
Just unique -> do
docs <- STM.readTVar openDocumentsTVar
pure ( Map.lookup unique docs )
emptyDocument :: Text -> Unique -> Document
emptyDocument docName unique =
Document

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

@ -6,7 +6,7 @@
module MetaBrush.Document.Draw
( DrawAnchor(..), anchorsAreComplementary
, getDrawAnchor, addToAnchor
, getOrCreateDrawAnchor, addToAnchor
)
where
@ -71,8 +71,8 @@ anchorsAreComplementary ( AnchorAtEnd uniq1 ) ( AnchorAtStart uniq2 )
= True
anchorsAreComplementary _ _ = False
getDrawAnchor :: UniqueSupply -> Point2D Double -> Document -> STM ( Document, DrawAnchor, Point2D Double )
getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
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
-- Anchor found: use it.
( newDoc, Just ( anchor, anchorPt ) ) -> pure ( newDoc, anchor, anchorPt )

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

@ -25,8 +25,6 @@ import Data.Functor
( ($>) )
import Data.Functor.Identity
( runIdentity )
import Data.Word
( Word32 )
-- acts
import Data.Act
@ -42,9 +40,6 @@ import Data.Generics.Product.Fields
import Data.Generics.Product.Typed
( HasType )
-- gi-gdk
import qualified GI.Gdk.Constants as GDK
-- lens
import Control.Lens
( view, set, over, mapped )
@ -68,6 +63,8 @@ import Math.Module
( squaredNorm )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Context
( Modifier(..) )
import MetaBrush.Document
( Document(..), Stroke(..)
, FocusState(..), _selection
@ -93,13 +90,11 @@ instance Semigroup SelectionMode where
instance Monoid SelectionMode where
mempty = New
selectionMode :: [ Word32 ] -> SelectionMode
selectionMode :: Foldable f => f Modifier -> SelectionMode
selectionMode = foldMap \case
GDK.KEY_Alt_L -> Subtract
GDK.KEY_Alt_R -> Subtract
GDK.KEY_Shift_L -> Add
GDK.KEY_Shift_R -> Add
_ -> New
Alt _ -> Subtract
Shift _ -> Subtract
_ -> New
-- | Updates the selected objects on a single click selection event.
selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document

638
src/app/MetaBrush/Event.hs
View file

@ -1,43 +1,14 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Event
( handleEvents
, HoldEvent(..), PartialPath(..)
)
( handleEvents )
where
-- base
import Control.Monad
( unless, guard )
import Data.Foldable
( for_ )
import Data.Maybe
( catMaybes )
import Data.Word
( Word32 )
-- acts
import Data.Act
( Act
( (•) )
, Torsor
( (-->) )
)
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( insert, lookup )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
-- haskus-utils-variant
import Haskus.Utils.Variant
( V, type (:<), type (:<<) )
-- gi-gdk
import qualified GI.Gdk as GDK
@ -48,564 +19,87 @@ import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar, readTVarIO, writeTVar, swapTVar )
import qualified Control.Concurrent.STM.TQueue as STM
( TQueue )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module
( (*^) )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), FocusState(..), PointData(..) )
import MetaBrush.Document.Draw
( DrawAnchor(..), getDrawAnchor, addToAnchor, anchorsAreComplementary )
import MetaBrush.Document.Selection
( SelectionMode(..), selectionMode
, selectAt, selectRectangle
, dragMoveSelect, translateSelection
, deleteSelected
import MetaBrush.Action
( Actions
, MouseMove(..), MouseClick(..), MouseRelease(..)
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
, signalAction, quitEverything
)
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar )
import MetaBrush.UI.ToolBar
( Tool(..), Mode )
import MetaBrush.Unique
( UniqueSupply, Unique )
import MetaBrush.Context
( UIElements(..) )
--------------------------------------------------------------------------------
handleEvents
:: UniqueSupply
-> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.Window -> GTK.DrawingArea -> InfoBar
-> IO ()
handleEvents
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar partialPathTVar
window viewportDrawingArea infoBar = do
handleEvents :: Actions :<< action => UIElements -> STM.TQueue ( V action ) -> IO ()
handleEvents ( UIElements { window, viewportDrawingArea } ) actionTQueue = do
-- Mouse events
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
( handleMouseButtonEvent uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
( handleMouseButtonRelease uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea )
-- Mouse events
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent actionTQueue )
_ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent actionTQueue )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent actionTQueue )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease actionTQueue )
-- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent activeDocumentTVar openDocumentsTVar mousePosTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
-- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent actionTQueue )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent actionTQueue )
-- Window quit
_ <- GTK.onWidgetDestroy window GTK.mainQuit
-- Window quit
_ <- GTK.onWidgetDestroy window ( quitEverything window )
pure ()
-- | Keep track of a mouse hold event:
--
-- - start a rectangular selection,
-- - move objects by dragging,
-- - drawing a control point.
data HoldEvent
= SelectionHold { holdStartPos :: !( Point2D Double ) }
| DragMoveHold { holdStartPos :: !( Point2D Double ) }
| DrawHold { holdStartPos :: !( Point2D Double ) }
deriving stock Show
-- | Keep track of a path that is in the middle of being drawn.
data PartialPath
= PartialPath
{ partialStartPos :: !( Point2D Double )
, partialControlPoint :: !( Maybe ( Point2D Double ) )
, partialPathAnchor :: !DrawAnchor
, firstPoint :: !Bool
}
deriving stock Show
pure ()
--------------------------------------------------------------------------------
-- Mouse events.
handleMotionEvent
:: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool
-> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> InfoBar
-> GDK.EventMotion
-> IO Bool
handleMotionEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar pressedKeysTVar
toolTVar
partialPathTVar
viewportDrawingArea infoBar
eventMotion
= do
handleMotionEvent :: MouseMove :< action => STM.TQueue ( V action ) -> GDK.EventMotion -> IO Bool
handleMotionEvent actionTQueue eventMotion = do
x <- GDK.getEventMotionX eventMotion
y <- GDK.getEventMotionY eventMotion
STM.atomically $ signalAction actionTQueue ( MouseMove ( Point2D x y ) )
pure True
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( Map.lookup i docs ) \ ( Document { .. } ) -> do
handleScrollEvent :: Scroll :< action => STM.TQueue ( V action ) -> GDK.EventScroll -> IO Bool
handleScrollEvent actionTQueue scrollEvent = do
dx <- GDK.getEventScrollDeltaX scrollEvent
dy <- GDK.getEventScrollDeltaY scrollEvent
x <- GDK.getEventScrollX scrollEvent
y <- GDK.getEventScrollY scrollEvent
STM.atomically $ signalAction actionTQueue ( Scroll ( Point2D x y ) ( Vector2D dx dy ) )
pure False
----------------------------------------------------------
-- Update mouse position in info bar on mouse move event.
handleMouseButtonEvent :: MouseClick :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
handleMouseButtonEvent actionTQueue mouseClickEvent = do
button <- GDK.getEventButtonButton mouseClickEvent
x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY mouseClickEvent
STM.atomically $ signalAction actionTQueue ( MouseClick button ( Point2D x y ) )
pure False
x <- GDK.getEventMotionX eventMotion
y <- GDK.getEventMotionY eventMotion
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
infoData :: InfoData
infoData =
InfoData
{ zoom = zoomFactor
, mousePos = pos
, topLeftPos = toViewport ( Point2D 0 0 )
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
}
updateInfoBar infoBar infoData
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
----------------------------------------------------------
-- With the pen tool, keeping control pressed while moving the mouse
-- moves the partial control point (if one exists).
tool <- STM.readTVar toolTVar
pressedKeys <- STM.readTVar pressedKeysTVar
mbPartialPath <- STM.readTVar partialPathTVar
case tool of
Pen
| any ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys
, Just pp <- mbPartialPath
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ -> pure ()
GTK.widgetQueueDraw viewportDrawingArea
pure True
handleScrollEvent
:: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool
-> GTK.DrawingArea -> InfoBar
-> GDK.EventScroll
-> IO Bool
handleScrollEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar _mouseHoldTVar pressedKeysTVar
_toolTVar
viewportDrawingArea infoBar
scrollEvent
= do
dx <- GDK.getEventScrollDeltaX scrollEvent
dy <- GDK.getEventScrollDeltaY scrollEvent
x <- GDK.getEventScrollX scrollEvent
y <- GDK.getEventScrollY scrollEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
unless ( dx == 0 && dy == 0 ) do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( Map.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
pressedKeys <- STM.readTVarIO pressedKeysTVar
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
mousePos :: Point2D Double
mousePos = toViewport ( Point2D x y )
newDoc :: Document
newDoc
-- Zooming using 'Control'.
| any ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys
= let
newZoomFactor :: Double
newZoomFactor
| dy > 0
= max 0.0078125 ( oldZoomFactor / sqrt 2 )
| otherwise
= min 256 ( oldZoomFactor * sqrt 2 )
newCenter :: Point2D Double
newCenter
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
• oldCenter
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
| dx == 0 && any ( \ key -> key == GDK.KEY_Shift_L || key == GDK.KEY_Shift_R ) pressedKeys
= let
newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
in doc { viewportCenter = newCenter }
-- Vertical scrolling.
| otherwise
= let
newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
in doc { viewportCenter = newCenter }
docs' :: Map Unique Document
docs' = Map.insert i newDoc docs
finalZoomFactor :: Double
finalZoomFactor = zoomFactor newDoc
finalCenter :: Point2D Double
finalCenter = viewportCenter newDoc
toFinalViewport :: Point2D Double -> Point2D Double
toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
finalMousePos :: Point2D Double
finalMousePos = toFinalViewport ( Point2D x y )
infoData :: InfoData
infoData = InfoData
{ zoom = finalZoomFactor
, mousePos = finalMousePos
, topLeftPos = toFinalViewport ( Point2D 0 0 )
, botRightPos = toFinalViewport ( Point2D viewportWidth viewportHeight )
}
updateInfoBar infoBar infoData
STM.atomically do
STM.writeTVar openDocumentsTVar docs'
STM.writeTVar mousePosTVar ( Just finalMousePos )
GTK.widgetQueueDraw viewportDrawingArea
pure False
handleMouseButtonEvent
:: UniqueSupply
-> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
handleMouseButtonEvent
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar partialPathTVar
viewportDrawingArea
mouseClickEvent
= do
button <- GDK.getEventButtonButton mouseClickEvent
case button of
-- Left mouse button.
1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY mouseClickEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
pressedKeys <- STM.readTVar pressedKeysTVar
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode pressedKeys of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just newDoc <- dragMoveSelect mode pos doc
-> do
let
newDocs :: Map Unique Document
newDocs = Map.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
-- Rectangular selection.
_ ->
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
-- Pen tool: start or continue a drawing operation.
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do
( newDoc, drawAnchor, anchorPt ) <- getDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar
( Just $ PartialPath
{ partialStartPos = anchorPt
, partialControlPoint = Nothing
, partialPathAnchor = drawAnchor
, firstPoint = True
}
)
let
newDocs :: Map Unique Document
newDocs = Map.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
-- Path already started: indicate that we are continuing a path.
Just pp ->
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
GTK.widgetQueueDraw viewportDrawingArea
-- Right mouse button: end partial path.
3 -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
pure False
handleMouseButtonRelease
:: UniqueSupply
-> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
handleMouseButtonRelease
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar partialPathTVar
viewportDrawingArea
mouseReleaseEvent
= do
button <- GDK.getEventButtonButton mouseReleaseEvent
case button of
-- Left mouse button.
1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
x <- GDK.getEventButtonX mouseReleaseEvent
y <- GDK.getEventButtonY mouseReleaseEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
pressedKeys <- STM.readTVar pressedKeysTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
newDoc <- case tool of
Selection -> do
let
selMode :: SelectionMode
selMode = selectionMode pressedKeys
case mbHoldPos of
Just hold
| DragMoveHold pos0 <- hold
, pos0 /= pos
-> pure $ translateSelection mode ( pos0 --> pos ) doc
| SelectionHold pos0 <- hold
, pos0 /= pos
-> pure $ selectRectangle mode selMode pos0 pos doc
_ -> pure $ selectAt mode selMode pos doc
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor.
-- If no anchor exists, then just ignore the mouse release event.
Nothing -> pure doc
-- Mouse click release possibilities:
--
-- - click was on complementary draw stroke draw anchor to close the path,
-- - release at same point as click: finish current segment,
-- - release at different point as click: finish current segment, adding a control point.
Just
( PartialPath
{ partialStartPos = p1
, partialControlPoint = mbCp2
, partialPathAnchor = anchor
, firstPoint
}
) -> do
let
pathPoint :: Point2D Double
mbControlPoint :: Maybe ( Point2D Double )
partialControlPoint :: Maybe ( Point2D Double )
( pathPoint, mbControlPoint, partialControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldPos
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
| otherwise
= ( pos, Nothing, Nothing )
( _, otherAnchor, otherAnchorPt ) <- getDrawAnchor uniqueSupply pathPoint doc
if not firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path.
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
]
pure ( addToAnchor anchor newSegment doc )
else
if firstPoint
-- Continue current partial path.
then do
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
pure doc
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
]
pure ( addToAnchor anchor newSegment doc )
let
newDocs :: Map Unique Document
newDocs = Map.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
GTK.widgetQueueDraw viewportDrawingArea
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
pure False
handleMouseButtonRelease :: MouseRelease :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
handleMouseButtonRelease actionTQueue mouseReleaseEvent = do
button <- GDK.getEventButtonButton mouseReleaseEvent
x <- GDK.getEventButtonX mouseReleaseEvent
y <- GDK.getEventButtonY mouseReleaseEvent
STM.atomically $ signalAction actionTQueue ( MouseRelease button ( Point2D x y ) )
pure False
--------------------------------------------------------------------------------
-- Keyboard events.
handleKeyboardPressEvent
:: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea
-> GDK.EventKey
-> IO Bool
handleKeyboardPressEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar pressedKeysTVar
toolTVar modeTVar partialPathTVar
viewportDrawingArea
evt = do
keyCode <- GDK.getEventKeyKeyval evt
STM.atomically do
pressedKeys <- STM.readTVar pressedKeysTVar
STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
case keyCode of
GDK.KEY_Escape -> GTK.mainQuit
GDK.KEY_Return -> do
tool <- STM.readTVarIO toolTVar
case tool of
-- End ongoing drawing on pressing enter key.
Pen -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
GDK.KEY_Delete -> do
tool <- STM.readTVarIO toolTVar
mode <- STM.readTVarIO modeTVar
case tool of
-- Delete selected points on pressing 'Delete'.
Selection -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( Map.lookup i docs ) \ doc -> do
let
newDoc :: Document
newDoc = deleteSelected mode doc
newDocs :: Map Unique Document
newDocs = Map.insert i newDoc docs
STM.atomically $ STM.writeTVar openDocumentsTVar newDocs
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
ctrl
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
-> do
----------------------------------------------------------
-- With the pen tool, pressing control moves
-- the partial point control point to the mouse position.
tool <- STM.readTVarIO toolTVar
mbMousePos <- STM.readTVarIO mousePosTVar
mbPartialPath <- STM.readTVarIO partialPathTVar
case tool of
Pen
| Just mp <- mbMousePos
, Just pp <- mbPartialPath
-> do
STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
GDK.KEY_F1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( Map.lookup i docs ) \ doc -> do
writeFile "log.txt" ( show doc <> "\n\n" )
_ -> pure ()
pure True
handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
handleKeyboardReleaseEvent pressedKeysTVar evt = do
handleKeyboardPressEvent :: KeyboardPress :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool
handleKeyboardPressEvent actionTQueue evt = do
keyCode <- GDK.getEventKeyKeyval evt
STM.atomically do
pressedKeys <- STM.readTVar pressedKeysTVar
STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys )
STM.atomically $ signalAction actionTQueue ( KeyboardPress keyCode )
pure True
handleKeyboardReleaseEvent :: KeyboardRelease :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool
handleKeyboardReleaseEvent actionTQueue evt = do
keyCode <- GDK.getEventKeyKeyval evt
STM.atomically $ signalAction actionTQueue ( KeyboardRelease keyCode )
pure True

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

@ -10,7 +10,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
module MetaBrush.Render.Document
( renderDocument )
( renderDocument, blankRender )
where
-- base
@ -67,6 +67,8 @@ import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Context
( HoldAction(..), PartialPath(..) )
import MetaBrush.Document
( Document(..)
, Stroke(..), FocusState(..)
@ -75,8 +77,6 @@ import MetaBrush.Document
)
import MetaBrush.Document.Selection
( translateSelection )
import MetaBrush.Event
( HoldEvent(..), PartialPath(..) )
import MetaBrush.UI.ToolBar
( Mode(..) )
import MetaBrush.Util
@ -104,9 +104,12 @@ toAll action = Compose ( pure action )
--------------------------------------------------------------------------------
blankRender :: Colours -> Cairo.Render ()
blankRender ( Colours { .. } ) = pure ()
renderDocument
:: Colours -> Mode -> ( Int32, Int32 )
-> Maybe ( Point2D Double ) -> Maybe HoldEvent -> Maybe PartialPath
-> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
-> Document
-> Cairo.Render ()
renderDocument

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

@ -1,11 +1,14 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.FileBar
( createFileBar )
( FileBar(..), createFileBar, newFileTab
, TabLocation(..)
)
where
-- base
@ -17,8 +20,6 @@ import Data.Foldable
( for_ )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( lookup, insert )
@ -29,23 +30,21 @@ import qualified GI.Gtk as GTK
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, writeTVar, readTVarIO, modifyTVar' )
( writeTVar, readTVarIO, modifyTVar' )
-- text
import Data.Text
( Text )
-- MetaBrush
import Math.Vector2D
( Point2D(..) )
import MetaBrush.Context
( Variables(..) )
import MetaBrush.Document
( Document(..), emptyDocument )
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar, updateInfoBar )
import MetaBrush.Unique
( UniqueSupply, Unique, freshUnique, uniqueText )
( Unique, freshUnique, uniqueText )
import MetaBrush.Util
( widgetAddClass, widgetAddClasses
, (>>?=), Exists(..)
@ -53,20 +52,27 @@ import MetaBrush.Util
--------------------------------------------------------------------------------
data FileBar
= FileBar
{ fileBarBox :: !GTK.Box
, fileTabsBox :: !GTK.Box
, fileBarPhantomRadioButton :: !GTK.RadioButton
}
data TabLocation
= AfterCurrentTab
| LastTab
deriving stock Show
newFileTab
:: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> GTK.Window -> GTK.Label -> GTK.DrawingArea -> GTK.Box -> GTK.RadioButton -> InfoBar
:: Variables
-> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar
-> Maybe Document
-> TabLocation
-> IO ()
newFileTab
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } )
window title ( FileBar { fileTabsBox, fileBarPhantomRadioButton } ) viewportArea infoBar
mbDoc
newTabLoc
= do
@ -158,20 +164,7 @@ newFileTab
= displayName <> " – MetaBrush"
GTK.labelSetText title titleText
GTK.setWindowTitle window titleText
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportArea
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
infoData :: InfoData
infoData =
InfoData
{ zoom = zoomFactor
, mousePos = Point2D 0 0
, topLeftPos = toViewport ( Point2D 0 0 )
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
}
updateInfoBar infoBar infoData
updateInfoBar viewportArea infoBar vars
GTK.widgetQueueDraw viewportArea
else do
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
@ -186,17 +179,17 @@ newFileTab
--
-- Updates the active document when buttons are clicked.
createFileBar
:: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
:: Variables
-> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
-> IO GTK.Box
-> IO FileBar
createFileBar
uniqueSupply activeDocumentTVar openDocumentsTVar
vars@( Variables { openDocumentsTVar } )
window title viewportArea infoBar
= do
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
fileBar <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClass fileBar "fileBar"
fileBarBox <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClass fileBarBox "fileBar"
fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
GTK.scrolledWindowSetPolicy fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
@ -205,8 +198,8 @@ createFileBar
newFileButton <- GTK.buttonNewWithLabel "+"
widgetAddClasses newFileButton [ "newFileButton" ]
GTK.boxPackStart fileBar fileTabsScroll True True 0
GTK.boxPackStart fileBar newFileButton False False 0
GTK.boxPackStart fileBarBox fileTabsScroll True True 0
GTK.boxPackStart fileBarBox newFileButton False False 0
fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0
GTK.containerAdd fileTabsScroll fileTabsBox
@ -215,18 +208,22 @@ createFileBar
-- Phantom radio button for when no page is selected (e.g. no documents opened yet).
fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
let
fileBar :: FileBar
fileBar = FileBar { .. }
documents <- STM.readTVarIO openDocumentsTVar
for_ documents \ doc ->
newFileTab
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
vars
window title fileBar viewportArea infoBar
( Just doc )
LastTab
void $ GTK.onButtonClicked newFileButton do
newFileTab
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
vars
window title fileBar viewportArea infoBar
Nothing
LastTab

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

@ -0,0 +1,41 @@
module MetaBrush.UI.FileBar
( FileBar(..), createFileBar, newFileTab
, TabLocation(..)
)
where
-- gi-gtk
import qualified GI.Gtk as GTK
-- MetaBrush
import {-# SOURCE #-} MetaBrush.Context
( Variables )
import MetaBrush.Document
( Document )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar )
--------------------------------------------------------------------------------
data FileBar
= FileBar
{ fileBarBox :: !GTK.Box
, fileTabsBox :: !GTK.Box
, fileBarPhantomRadioButton :: !GTK.RadioButton
}
data TabLocation
= AfterCurrentTab
| LastTab
createFileBar
:: Variables
-> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
-> IO FileBar
newFileTab
:: Variables
-> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar
-> Maybe Document
-> TabLocation
-> IO ()

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

@ -4,11 +4,10 @@
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.InfoBar
( InfoBar(..), createInfoBar, updateInfoBar
, InfoData(..)
)
( InfoBar(..), createInfoBar, updateInfoBar )
where
-- base
@ -18,6 +17,8 @@ import Control.Monad
( void )
import Data.Foldable
( for_ )
import Data.String
( IsString )
import Numeric
( showFFloat )
@ -31,6 +32,12 @@ import qualified GI.Cairo.Render as Cairo
-- gi-gtk
import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( readTVarIO )
-- text
import qualified Data.Text as Text
( pack )
@ -44,6 +51,14 @@ import MetaBrush.Asset.Cursor
( drawCursorIcon )
import MetaBrush.Asset.InfoBar
( drawMagnifier, drawTopLeftCornerRect )
import MetaBrush.Context
( Variables(..)
, currentDocument
)
import MetaBrush.Document
( Document(..) )
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.Util
( widgetAddClass, widgetAddClasses )
@ -51,17 +66,11 @@ import MetaBrush.Util
data InfoBar
= InfoBar
{ zoomText :: !GTK.Label -- make this editable
{ infoBarArea :: !GTK.Box
, zoomText :: !GTK.Label -- make this editable
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
}
data InfoData
= InfoData
{ zoom :: !Double
, mousePos, topLeftPos, botRightPos :: !( Point2D Double )
}
deriving stock Show
-- | Add the UI elements for the info bar:
--
-- * current zoom level,
@ -69,9 +78,10 @@ data InfoData
-- * current viewport extent (top left and bottom right corner coordinates).
--
-- Returns the GTK label widgets, so that the information can be updated.
createInfoBar :: Colours -> GTK.Box -> IO InfoBar
createInfoBar colours infoBar = do
widgetAddClasses infoBar [ "infoBar", "monospace", "contrast" ]
createInfoBar :: Colours -> IO InfoBar
createInfoBar colours = do
infoBarArea <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClasses infoBarArea [ "infoBar", "monospace", "contrast" ]
zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0
cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
@ -79,7 +89,7 @@ createInfoBar colours infoBar = do
botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do
GTK.boxPackEnd infoBar box False False 0
GTK.boxPackEnd infoBarArea box False False 0
widgetAddClass box "infoBarBox"
-------------
@ -151,20 +161,36 @@ createInfoBar colours infoBar = do
pure ( InfoBar { .. } )
updateInfoBar :: InfoBar -> InfoData -> IO ()
updateInfoBar
( InfoBar { .. } )
( InfoData
{ zoom
, mousePos = Point2D mx my
, topLeftPos = Point2D l t
, botRightPos = Point2D r b
}
) = do
GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoom ) <> "%" )
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> fixed 6 2 mx <> "\ny: " <> fixed 6 2 my )
GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> fixed 6 2 l <> "\ny: " <> fixed 6 2 t )
GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> fixed 6 2 r <> "\ny: " <> fixed 6 2 b )
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO ()
updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePosTVar } )
= do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
mbDoc <- STM.atomically $ currentDocument vars
let
na :: IsString a => a
na = " n/a"
case mbDoc of
Nothing -> do
GTK.labelSetText zoomText $ na
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
Just ( Document { zoomFactor, viewportCenter } ) -> do
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
Point2D l t = toViewport ( Point2D 0 0 )
Point2D r b = toViewport ( Point2D viewportWidth viewportHeight )
mbMousePos <- fmap toViewport <$> STM.readTVarIO mousePosTVar
GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" )
case mbMousePos of
Just ( Point2D mx my ) ->
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> fixed 6 2 mx <> "\ny: " <> fixed 6 2 my )
Nothing ->
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> fixed 6 2 l <> "\ny: " <> fixed 6 2 t )
GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> fixed 6 2 r <> "\ny: " <> fixed 6 2 b )
fixed :: Int -> Int -> Double -> String
fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFloat ( Just digitsAfter ) x "" of

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

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

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

@ -56,6 +56,8 @@ import Control.Monad.IO.Class
( MonadIO(liftIO) )
-- MetaBrush
import MetaBrush.Action
( quitEverything )
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Asset.WindowIcons
@ -319,7 +321,7 @@ createMenuBar colours window titleBar = do
---------------------------------------------------------
-- Actions
_ <- GTK.onButtonClicked closeButton GTK.mainQuit
_ <- GTK.onButtonClicked closeButton ( quitEverything window )
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
_ <- GTK.onButtonClicked fullscreenButton do
Just gdkWindow <- GTK.widgetGetWindow window