add mouse drag-move operation

This commit is contained in:
sheaf 2020-08-15 23:49:14 +02:00
parent 10dccd1dad
commit 38c4e9fa6c
7 changed files with 247 additions and 167 deletions

View file

@ -139,5 +139,7 @@ executable MetaBrush
^>= 0.24
, stm
^>= 2.5.0.0
, tardis
^>= 0.4.1.0
, text
^>= 1.2.3.1 && < 1.2.5

View file

@ -4,6 +4,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Main
@ -13,6 +14,8 @@ module Main
-- base
import Control.Monad
( void )
import Data.Foldable
( for_ )
import Data.Int
( Int32 )
import Data.Word
@ -42,7 +45,7 @@ import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM.TVar as STM
( newTVarIO )
( newTVarIO, readTVarIO )
-- text
import qualified Data.Text as Text
@ -58,14 +61,14 @@ import MetaBrush.Asset.Logo
import MetaBrush.Document
( Document(..), AABB(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, Overlay
, currentDocument
)
import MetaBrush.Event
( handleEvents )
( HoldEvent, handleEvents )
import MetaBrush.Render.Document
( renderDocument )
import MetaBrush.Render.Util
( widgetAddClass, widgetAddClasses )
import MetaBrush.Time
( Time )
import MetaBrush.UI.FileBar
( createFileBar )
import MetaBrush.UI.InfoBar
@ -143,14 +146,13 @@ main = do
---------------------------------------------------------
-- Initialise state
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe ( Point2D Double, Time ) ) Nothing
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path
overlayTVar <- STM.newTVarIO @( Maybe Overlay ) Nothing
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path
---------------------------------------------------------
-- Initialise GTK
@ -264,13 +266,25 @@ main = do
---------------------------------------------------------
-- Main viewport
Viewport { viewportDrawingArea } <-
createViewport
colours
activeDocumentTVar
openDocumentsTVar
overlayTVar
viewportGrid
Viewport { viewportDrawingArea } <- createViewport viewportGrid
-----------------
-- Viewport rendering
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
-- Get the relevant document information
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
for_ mbDoc \ doc -> do
mousePos <- STM.readTVarIO mousePosTVar
holdEvent <- STM.readTVarIO mouseHoldTVar
let
mbHoldEvent :: Maybe ( HoldEvent, Point2D Double )
mbHoldEvent = (,) <$> holdEvent <*> mousePos
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
( `Cairo.renderWithContext` ctx ) $
renderDocument colours ( viewportWidth, viewportHeight ) mbHoldEvent doc
pure True
---------------------------------------------------------
-- Info bar
@ -302,7 +316,6 @@ main = do
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar
overlayTVar
window viewportDrawingArea infoBarElements
---------------------------------------------------------

View file

@ -8,7 +8,6 @@ module MetaBrush.Document
, Document(..), currentDocument
, Stroke(..), StrokePoint(..), PointType(..)
, FocusState(..), switchFocusState
, Overlay(..)
)
where
@ -67,7 +66,7 @@ data StrokePoint
= StrokePoint
{ strokePoint :: !( Point2D Double )
, pointType :: !PointType
, pointState :: !FocusState
, pointState :: FocusState -- needs to be lazy for drag selection code
}
deriving stock ( Show, Generic )
@ -87,10 +86,6 @@ switchFocusState Normal = Selected
switchFocusState Hover = Hover
switchFocusState Selected = Normal
data Overlay
= SelectionRectangle !( Point2D Double ) !( Point2D Double )
deriving stock Show
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar

View file

@ -1,23 +1,31 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Selection
( selectAt, selectRectangle )
( SelectionMode(..), selectionMode
, selectAt, selectRectangle
, DragMoveSelect(..), dragMoveSelect
, translateSelection
)
where
-- base
import Data.Functor.Identity
( runIdentity )
import Data.Word
( Word32 )
-- acts
import Data.Act
( Torsor((-->)) )
( Act(()), Torsor((-->)) )
-- generic-lens
import Data.GenericLens.Internal
@ -25,6 +33,14 @@ import Data.GenericLens.Internal
import Data.Generics.Product.Fields
( field' )
-- tardis
import Control.Monad.Trans.Tardis
( Tardis )
import qualified Control.Monad.Trans.Tardis as Tardis
( TardisT(..)
, getPast, getFuture, sendPast, modifyForwards
)
-- MetaBrush
import Math.Module
( squaredNorm )
@ -69,12 +85,10 @@ selectionMode = foldMap \case
--
-- TODO: currently selects points regardless of layers,
-- e.g. it will simultaneously select points with equal coordinates.
selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document
selectAt pressedKeys c doc@( Document { zoomFactor } ) =
selectAt :: SelectionMode -> Point2D Double -> Document -> Document
selectAt mode c doc@( Document { zoomFactor } ) =
over ( field' @"strokes" ) ( fmap updateStroke ) doc
where
mode :: SelectionMode
mode = selectionMode pressedKeys
updateStroke :: Stroke -> Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" )
@ -95,15 +109,78 @@ selectAt pressedKeys c doc@( Document { zoomFactor } ) =
| not isVisible = False
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
-- | Type of a drag move selection:
--
-- - user initiated drag by clicking on an already selected item: selection is preserved;
-- - user initiated drag by clicking on an unselected item: select this item and deselect the previous selection.
data DragMoveSelect
= ClickedOnSelected
| ClickedOnUnselected
deriving stock Show
instance {-# OVERLAPPING #-} Semigroup ( Maybe DragMoveSelect ) where
Just ( ClickedOnSelected ) <> _ = Just ( ClickedOnSelected )
Nothing <> r = r
_ <> Just ( ClickedOnSelected ) = Just ( ClickedOnSelected )
l <> Nothing = l
_ <> _ = Just ClickedOnUnselected
instance {-# OVERLAPPING #-} Monoid ( Maybe DragMoveSelect ) where
mempty = Nothing
-- | Checks whether a mouse click can initiate a drag move event,
-- and if so returns an updated document with the selection modified from the start of the drag move.
dragMoveSelect :: Point2D Double -> Document -> Maybe Document
dragMoveSelect c doc@( Document { zoomFactor } ) =
let
res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document
res = do
newDoc <- field' @"strokes" ( traverse updateStroke ) doc
Tardis.getPast >>= Tardis.sendPast
pure newDoc
in case runIdentity $ Tardis.runTardisT res ( Nothing, Nothing ) of
( newDoc, ( _, Just _ ) ) -> Just newDoc
( _ , ( _, Nothing ) ) -> Nothing
where
updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
field' @"strokePoints"
( traverse ( updatePoint strokeVisible ) )
stroke
updatePoint :: Bool -> StrokePoint -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
| selected
= do
case oldFocusState of
Selected -> Tardis.modifyForwards ( const $ Just ClickedOnSelected )
_ -> Tardis.modifyForwards ( <> Just ClickedOnUnselected )
pure $ pt { pointState = Selected }
| otherwise
= do
mbDragClick <- Tardis.getFuture
let
-- needs to be lazy
newPointState :: FocusState
newPointState
| Just ClickedOnSelected <- mbDragClick
= pointState pt
| otherwise
= Normal
pure ( pt { pointState = newPointState } )
where
selected :: Bool
selected
| not isVisible = False
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
-- | Updates the selected objects on a rectangular selection event.
selectRectangle :: [ Word32 ] -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle pressedKeys ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" ) ( fmap updateStroke )
selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" ) ( fmap updateStroke )
where
xMin, xMax, yMin, yMax :: Double
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
mode :: SelectionMode
mode = selectionMode pressedKeys
updateStroke :: Stroke -> Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" )
@ -122,3 +199,16 @@ selectRectangle pressedKeys ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field'
selected
| not isVisible = False
| otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax
-- | Translate all selected points by the given vector.
translateSelection :: Vector2D Double -> Document -> Document
translateSelection t = over ( field' @"strokes" ) ( fmap updateStroke )
where
updateStroke :: Stroke -> Stroke
updateStroke = over ( field' @"strokePoints" ) ( fmap updateStrokePoint )
updateStrokePoint :: StrokePoint -> StrokePoint
updateStrokePoint pt@( StrokePoint { strokePoint = p, pointState } )
| Selected <- pointState
= pt { strokePoint = t p }
| otherwise
= pt

View file

@ -1,11 +1,14 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Event
( handleEvents )
( handleEvents
, HoldEvent(..)
)
where
-- base
@ -37,8 +40,6 @@ import qualified GI.Gdk as GDK
import qualified GI.Gtk as GTK
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
@ -50,16 +51,17 @@ import Math.Module
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Overlay(..) )
( Document(..) )
import MetaBrush.Document.Selection
( selectAt, selectRectangle )
( SelectionMode(..), selectionMode
, selectAt, selectRectangle
, dragMoveSelect, translateSelection
)
import MetaBrush.Event.KeyCodes
( pattern Escape
, pattern Control_L, pattern Control_R
, pattern Shift_L , pattern Shift_R
)
import MetaBrush.Time
( Time, monotonicTime, DTime(DSeconds) )
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
@ -71,27 +73,25 @@ import MetaBrush.UI.ToolBar
handleEvents
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode
-> STM.TVar ( Maybe Overlay )
-> GTK.Window -> GTK.DrawingArea -> InfoBar
-> IO ()
handleEvents
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar _modeTVar
overlayTVar
window viewportDrawingArea infoBar = do
-- Mouse events
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar )
( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea infoBar )
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea )
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea )
-- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
@ -102,22 +102,29 @@ handleEvents
pure ()
-- | Keep track of a mouse hold event:
--
-- - start a rectangular selection,
-- - move objects by dragging.
data HoldEvent
= SelectionHold { holdStartPos :: !( Point2D Double ) }
| DragMoveHold { holdStartPos :: !( Point2D Double ) }
deriving stock Show
--------------------------------------------------------------------------------
-- Mouse events.
handleMotionEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent )
-> STM.TVar Tool
-> STM.TVar ( Maybe Overlay )
-> GTK.DrawingArea -> InfoBar
-> GDK.EventMotion
-> IO Bool
handleMotionEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar
toolTVar
overlayTVar
mousePosTVar _mouseHoldTVar
_toolTVar
viewportDrawingArea infoBar
eventMotion
= do
@ -150,27 +157,21 @@ handleMotionEvent
updateInfoBar infoBar infoData
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
----------------------------------------------------------
-- Tool dependent updating.
updateOverlay mouseHoldTVar toolTVar overlayTVar pos
GTK.widgetQueueDraw viewportDrawingArea
pure True
handleScrollEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe Overlay )
-> 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 overlayTVar
mousePosTVar _mouseHoldTVar pressedKeysTVar
_toolTVar
viewportDrawingArea infoBar
scrollEvent
= do
@ -243,20 +244,19 @@ handleScrollEvent
STM.atomically do
STM.writeTVar openDocumentsTVar docs'
STM.writeTVar mousePosTVar ( Just finalMousePos )
updateOverlay mouseHoldTVar toolTVar overlayTVar finalMousePos
GTK.widgetQueueDraw viewportDrawingArea
pure False
handleMouseButtonEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
handleMouseButtonEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar _pressedKeysTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
viewportDrawingArea
mouseClickEvent
= do
@ -268,7 +268,7 @@ handleMouseButtonEvent
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ ( Document { zoomFactor, viewportCenter } ) -> do
for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY mouseClickEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
@ -278,19 +278,41 @@ handleMouseButtonEvent
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
time <- monotonicTime
-- 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.
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
STM.writeTVar mouseHoldTVar ( Just ( pos, time ) )
pressedKeys <- STM.readTVar pressedKeysTVar
let
mode :: SelectionMode
mode = selectionMode pressedKeys
case mode of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just newDoc <- dragMoveSelect pos doc
-> do
let
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
-- Rectangular selection.
_ ->
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
_ -> pure ()
pure False
handleMouseButtonRelease
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool
-> STM.TVar ( Maybe Overlay )
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
@ -298,7 +320,6 @@ handleMouseButtonRelease
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar
overlayTVar
viewportDrawingArea
mouseReleaseEvent
= do
@ -320,22 +341,23 @@ handleMouseButtonRelease
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
t <- monotonicTime
STM.atomically do
pressedKeys <- STM.readTVar pressedKeysTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
STM.writeTVar overlayTVar Nothing
tool <- STM.readTVar toolTVar
let
mode :: SelectionMode
mode = selectionMode pressedKeys
newDoc :: Document
newDoc = case tool of
Selection
| Just ( pos0, t0 ) <- mbHoldPos
| Just ( SelectionHold pos0 ) <- mbHoldPos
, pos0 /= pos
, ( t0 --> t ) > DSeconds 0.01
-> selectRectangle pressedKeys pos0 pos doc
-> selectRectangle mode pos0 pos doc
| Just ( DragMoveHold pos0 ) <- mbHoldPos
-> translateSelection ( pos0 --> pos ) doc
| otherwise
-> selectAt pressedKeys pos doc
-> selectAt mode pos doc
Pen -> doc -- TODO
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
@ -348,19 +370,6 @@ handleMouseButtonRelease
pure False
updateOverlay :: STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar Tool -> STM.TVar ( Maybe Overlay ) -> Point2D Double -> STM ()
updateOverlay mouseHoldTVar toolTVar overlayTVar p = do
tool <- STM.readTVar toolTVar
case tool of
-- Draw selection rectangle if performing a selection.
Selection -> do
mbHold <- STM.readTVar mouseHoldTVar
case mbHold of
Just ( p0, _ ) -> STM.writeTVar overlayTVar ( Just ( SelectionRectangle p0 p ) )
Nothing -> STM.writeTVar overlayTVar Nothing
-- Pen tool: show preview (TODO).
Pen -> STM.writeTVar overlayTVar Nothing
--------------------------------------------------------------------------------
-- Keyboard events.

View file

@ -11,12 +11,16 @@ module MetaBrush.Render.Document
-- base
import Data.Foldable
( for_, traverse_ )
( traverse_ )
import Data.Functor.Compose
( Compose(..) )
import Data.Int
( Int32 )
-- acts
import Data.Act
( Torsor((-->)) )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
@ -32,8 +36,11 @@ import MetaBrush.Asset.Colours
import MetaBrush.Document
( Document(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, Overlay(..)
)
import MetaBrush.Document.Selection
( translateSelection )
import MetaBrush.Event
( HoldEvent(..) )
import MetaBrush.Render.Util
( withRGBA )
@ -56,23 +63,35 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
--------------------------------------------------------------------------------
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render ()
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do
renderDocument :: Colours -> ( Int32, Int32 ) -> Maybe ( HoldEvent, Point2D Double ) -> Document -> Cairo.Render ()
renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
= do
Cairo.save
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
Cairo.scale zoomFactor zoomFactor
Cairo.translate ( -cx ) ( -cy )
Cairo.save
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
Cairo.scale zoomFactor zoomFactor
Cairo.translate ( -cx ) ( -cy )
let
translatedStrokes :: [ Stroke ]
renderSelectionRect :: Cairo.Render ()
( translatedStrokes, renderSelectionRect )
= case mbHoldEvent of
Nothing
-> ( strokes doc, pure () )
Just ( SelectionHold p0, p1 )
-> ( strokes doc, renderSelectionRectangle cols zoomFactor p0 p1 )
Just ( DragMoveHold p0, p1 )
-> ( strokes $ translateSelection ( p0 --> p1 ) doc, pure () )
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) translatedStrokes
rdrPaths
rdrPoints
renderSelectionRect
let
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes
rdrPaths
rdrPoints
for_ mbOverlay ( renderOverlay cols zoomFactor )
Cairo.restore
pure ()
Cairo.restore
pure ()
renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render ()
renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } )
@ -248,8 +267,8 @@ drawCubicBezier ( Colours { path } ) zoom
Cairo.restore
renderOverlay :: Colours -> Double -> Overlay -> Cairo.Render ()
renderOverlay ( Colours { .. } ) zoom ( SelectionRectangle ( Point2D x0 y0 ) ( Point2D x1 y1 ) ) = do
renderSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
renderSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
Cairo.save

View file

@ -1,5 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
@ -8,39 +6,13 @@ module MetaBrush.UI.Viewport
( Viewport(..), createViewport )
where
-- base
import Control.Monad
( void )
import Data.Foldable
( for_ )
-- containers
import Data.IntMap.Strict
( IntMap )
-- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo
( renderWithContext )
-- gi-gdk
import qualified GI.Gdk as GDK
-- gi-gtk
import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVarIO )
-- MetaBrush
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Document
( Document(..), currentDocument
, Overlay
)
import MetaBrush.Render.Document
( renderDocument )
import MetaBrush.Render.Util
( widgetAddClass )
@ -51,14 +23,8 @@ data Viewport
{ viewportDrawingArea :: !GTK.DrawingArea
}
createViewport
:: Colours
-> STM.TVar ( Maybe Int )
-> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe Overlay )
-> GTK.Grid
-> IO Viewport
createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
createViewport :: GTK.Grid -> IO Viewport
createViewport viewportGrid = do
widgetAddClass viewportGrid "viewport"
@ -139,18 +105,4 @@ createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewport
widgetAddClass viewportHScrollbar "viewportScrollbar"
widgetAddClass viewportVScrollbar "viewportScrollbar"
-----------------
-- Rendering
void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do
-- Get the relevant document information
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
mbOverlay <- STM.readTVarIO overlayTVar
for_ mbDoc \ doc -> do
( `Cairo.renderWithContext` ctx ) $ do
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay
pure True
pure ( Viewport { .. } )