mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 09:24:08 +00:00
refactor: separation of event handling and actions
This commit is contained in:
sheaf
parent
101d9515c0
commit
7033578e20
|
|
@ -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
|
||||
|
|
|
|||
94
app/Main.hs
94
app/Main.hs
|
|
@ -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 ) $
|
||||
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
537
src/app/MetaBrush/Action.hs
Normal 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
149
src/app/MetaBrush/Context.hs
Normal 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
9
src/app/MetaBrush/Context.hs-boot
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
module MetaBrush.Context
|
||||
( UIElements, Variables )
|
||||
where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data UIElements
|
||||
|
||||
data Variables
|
||||
|
|
@ -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,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 )
|
||||
|
|
|
|||
|
|
@ -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,12 +90,10 @@ 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
|
||||
Alt _ -> Subtract
|
||||
Shift _ -> Subtract
|
||||
_ -> New
|
||||
|
||||
-- | Updates the selected objects on a single click selection event.
|
||||
|
|
|
|||
|
|
@ -1,43 +1,14 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# 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 )
|
||||
_ <- 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 )
|
||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent actionTQueue )
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent actionTQueue )
|
||||
|
||||
-- Window quit
|
||||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||||
_ <- 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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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
|
||||
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( Map.lookup i docs ) \ ( Document { .. } ) -> do
|
||||
|
||||
----------------------------------------------------------
|
||||
-- Update mouse position in info bar on mouse move event.
|
||||
|
||||
handleMotionEvent :: MouseMove :< action => STM.TQueue ( V action ) -> GDK.EventMotion -> IO Bool
|
||||
handleMotionEvent actionTQueue eventMotion = do
|
||||
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
|
||||
|
||||
STM.atomically $ signalAction actionTQueue ( MouseMove ( Point2D x y ) )
|
||||
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
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
STM.atomically $ signalAction actionTQueue ( Scroll ( Point2D x y ) ( Vector2D dx dy ) )
|
||||
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
|
||||
|
||||
handleMouseButtonEvent :: MouseClick :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonEvent actionTQueue 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 ()
|
||||
|
||||
STM.atomically $ signalAction actionTQueue ( MouseClick button ( Point2D x y ) )
|
||||
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
|
||||
|
||||
handleMouseButtonRelease :: MouseRelease :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonRelease actionTQueue 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 ()
|
||||
|
||||
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
|
||||
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 ( 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 ()
|
||||
STM.atomically $ signalAction actionTQueue ( KeyboardPress keyCode )
|
||||
pure True
|
||||
|
||||
handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
|
||||
handleKeyboardReleaseEvent pressedKeysTVar evt = do
|
||||
handleKeyboardReleaseEvent :: KeyboardRelease :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool
|
||||
handleKeyboardReleaseEvent actionTQueue evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
STM.atomically do
|
||||
pressedKeys <- STM.readTVar pressedKeysTVar
|
||||
STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys )
|
||||
STM.atomically $ signalAction actionTQueue ( KeyboardRelease keyCode )
|
||||
pure True
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
41
src/app/MetaBrush/UI/FileBar.hs-boot
Normal 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 ()
|
||||
|
|
@ -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,18 +161,34 @@ 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 ) <> "%" )
|
||||
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 )
|
||||
|
||||
|
|
|
|||
25
src/app/MetaBrush/UI/InfoBar.hs-boot
Normal file
25
src/app/MetaBrush/UI/InfoBar.hs-boot
Normal 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 ()
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue