From 38c4e9fa6c3843d8c9ce58eb2302898407df4db5 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 15 Aug 2020 23:49:14 +0200 Subject: [PATCH] add mouse drag-move operation --- MetaBrush.cabal | 2 + app/Main.hs | 55 ++++++---- src/app/MetaBrush/Document.hs | 7 +- src/app/MetaBrush/Document/Selection.hs | 110 ++++++++++++++++++-- src/app/MetaBrush/Event.hs | 131 +++++++++++++----------- src/app/MetaBrush/Render/Document.hs | 57 +++++++---- src/app/MetaBrush/UI/Viewport.hs | 52 +--------- 7 files changed, 247 insertions(+), 167 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 86bd167..931c4f8 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 235a591..7551700 100644 --- a/app/Main.hs +++ b/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 --------------------------------------------------------- diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 5d01339..0b32900 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 3167c73..d659ab8 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 00fde9d..f751af7 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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. diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index e4a7d14..224ab7d 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 753fed2..4af2758 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -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 { .. } )