mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
add mouse drag-move operation
This commit is contained in:
sheaf
parent
10dccd1dad
commit
38c4e9fa6c
|
|
@ -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
|
||||
|
|
|
|||
55
app/Main.hs
55
app/Main.hs
|
|
@ -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
|
||||
|
||||
---------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 { .. } )
|
||||
|
|
|
|||
Loading…
Reference in a new issue