mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 17:34:08 +00:00
add mouse drag-move operation
This commit is contained in:
parent
10dccd1dad
commit
38c4e9fa6c
|
@ -139,5 +139,7 @@ executable MetaBrush
|
||||||
^>= 0.24
|
^>= 0.24
|
||||||
, stm
|
, stm
|
||||||
^>= 2.5.0.0
|
^>= 2.5.0.0
|
||||||
|
, tardis
|
||||||
|
^>= 0.4.1.0
|
||||||
, text
|
, text
|
||||||
^>= 1.2.3.1 && < 1.2.5
|
^>= 1.2.3.1 && < 1.2.5
|
||||||
|
|
43
app/Main.hs
43
app/Main.hs
|
@ -4,6 +4,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Main
|
module Main
|
||||||
|
@ -13,6 +14,8 @@ module Main
|
||||||
-- base
|
-- base
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( void )
|
( void )
|
||||||
|
import Data.Foldable
|
||||||
|
( for_ )
|
||||||
import Data.Int
|
import Data.Int
|
||||||
( Int32 )
|
( Int32 )
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
@ -42,7 +45,7 @@ import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
-- stm
|
-- stm
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
import qualified Control.Concurrent.STM.TVar as STM
|
||||||
( newTVarIO )
|
( newTVarIO, readTVarIO )
|
||||||
|
|
||||||
-- text
|
-- text
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
@ -58,14 +61,14 @@ import MetaBrush.Asset.Logo
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
( Document(..), AABB(..)
|
( Document(..), AABB(..)
|
||||||
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
|
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
|
||||||
, Overlay
|
, currentDocument
|
||||||
)
|
)
|
||||||
import MetaBrush.Event
|
import MetaBrush.Event
|
||||||
( handleEvents )
|
( HoldEvent, handleEvents )
|
||||||
|
import MetaBrush.Render.Document
|
||||||
|
( renderDocument )
|
||||||
import MetaBrush.Render.Util
|
import MetaBrush.Render.Util
|
||||||
( widgetAddClass, widgetAddClasses )
|
( widgetAddClass, widgetAddClasses )
|
||||||
import MetaBrush.Time
|
|
||||||
( Time )
|
|
||||||
import MetaBrush.UI.FileBar
|
import MetaBrush.UI.FileBar
|
||||||
( createFileBar )
|
( createFileBar )
|
||||||
import MetaBrush.UI.InfoBar
|
import MetaBrush.UI.InfoBar
|
||||||
|
@ -146,11 +149,10 @@ main = do
|
||||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
|
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
|
||||||
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
|
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
|
||||||
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
||||||
mouseHoldTVar <- STM.newTVarIO @( Maybe ( Point2D Double, Time ) ) Nothing
|
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing
|
||||||
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
|
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
|
||||||
toolTVar <- STM.newTVarIO @Tool Selection
|
toolTVar <- STM.newTVarIO @Tool Selection
|
||||||
modeTVar <- STM.newTVarIO @Mode Path
|
modeTVar <- STM.newTVarIO @Mode Path
|
||||||
overlayTVar <- STM.newTVarIO @( Maybe Overlay ) Nothing
|
|
||||||
|
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- Initialise GTK
|
-- Initialise GTK
|
||||||
|
@ -264,13 +266,25 @@ main = do
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- Main viewport
|
-- Main viewport
|
||||||
|
|
||||||
Viewport { viewportDrawingArea } <-
|
Viewport { viewportDrawingArea } <- createViewport viewportGrid
|
||||||
createViewport
|
|
||||||
colours
|
-----------------
|
||||||
activeDocumentTVar
|
-- Viewport rendering
|
||||||
openDocumentsTVar
|
|
||||||
overlayTVar
|
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
|
||||||
viewportGrid
|
-- 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
|
-- Info bar
|
||||||
|
@ -302,7 +316,6 @@ main = do
|
||||||
activeDocumentTVar openDocumentsTVar
|
activeDocumentTVar openDocumentsTVar
|
||||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||||
toolTVar modeTVar
|
toolTVar modeTVar
|
||||||
overlayTVar
|
|
||||||
window viewportDrawingArea infoBarElements
|
window viewportDrawingArea infoBarElements
|
||||||
|
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
|
|
|
@ -8,7 +8,6 @@ module MetaBrush.Document
|
||||||
, Document(..), currentDocument
|
, Document(..), currentDocument
|
||||||
, Stroke(..), StrokePoint(..), PointType(..)
|
, Stroke(..), StrokePoint(..), PointType(..)
|
||||||
, FocusState(..), switchFocusState
|
, FocusState(..), switchFocusState
|
||||||
, Overlay(..)
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -67,7 +66,7 @@ data StrokePoint
|
||||||
= StrokePoint
|
= StrokePoint
|
||||||
{ strokePoint :: !( Point2D Double )
|
{ strokePoint :: !( Point2D Double )
|
||||||
, pointType :: !PointType
|
, pointType :: !PointType
|
||||||
, pointState :: !FocusState
|
, pointState :: FocusState -- needs to be lazy for drag selection code
|
||||||
}
|
}
|
||||||
deriving stock ( Show, Generic )
|
deriving stock ( Show, Generic )
|
||||||
|
|
||||||
|
@ -87,10 +86,6 @@ switchFocusState Normal = Selected
|
||||||
switchFocusState Hover = Hover
|
switchFocusState Hover = Hover
|
||||||
switchFocusState Selected = Normal
|
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 :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
|
||||||
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
|
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
|
||||||
mbActive <- STM.readTVar activeDocumentTVar
|
mbActive <- STM.readTVar activeDocumentTVar
|
||||||
|
|
|
@ -1,23 +1,31 @@
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE RecursiveDo #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module MetaBrush.Document.Selection
|
module MetaBrush.Document.Selection
|
||||||
( selectAt, selectRectangle )
|
( SelectionMode(..), selectionMode
|
||||||
|
, selectAt, selectRectangle
|
||||||
|
, DragMoveSelect(..), dragMoveSelect
|
||||||
|
, translateSelection
|
||||||
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Data.Functor.Identity
|
||||||
|
( runIdentity )
|
||||||
import Data.Word
|
import Data.Word
|
||||||
( Word32 )
|
( Word32 )
|
||||||
|
|
||||||
-- acts
|
-- acts
|
||||||
import Data.Act
|
import Data.Act
|
||||||
( Torsor((-->)) )
|
( Act((•)), Torsor((-->)) )
|
||||||
|
|
||||||
-- generic-lens
|
-- generic-lens
|
||||||
import Data.GenericLens.Internal
|
import Data.GenericLens.Internal
|
||||||
|
@ -25,6 +33,14 @@ import Data.GenericLens.Internal
|
||||||
import Data.Generics.Product.Fields
|
import Data.Generics.Product.Fields
|
||||||
( field' )
|
( field' )
|
||||||
|
|
||||||
|
-- tardis
|
||||||
|
import Control.Monad.Trans.Tardis
|
||||||
|
( Tardis )
|
||||||
|
import qualified Control.Monad.Trans.Tardis as Tardis
|
||||||
|
( TardisT(..)
|
||||||
|
, getPast, getFuture, sendPast, modifyForwards
|
||||||
|
)
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( squaredNorm )
|
( squaredNorm )
|
||||||
|
@ -69,12 +85,10 @@ selectionMode = foldMap \case
|
||||||
--
|
--
|
||||||
-- TODO: currently selects points regardless of layers,
|
-- TODO: currently selects points regardless of layers,
|
||||||
-- e.g. it will simultaneously select points with equal coordinates.
|
-- e.g. it will simultaneously select points with equal coordinates.
|
||||||
selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document
|
selectAt :: SelectionMode -> Point2D Double -> Document -> Document
|
||||||
selectAt pressedKeys c doc@( Document { zoomFactor } ) =
|
selectAt mode c doc@( Document { zoomFactor } ) =
|
||||||
over ( field' @"strokes" ) ( fmap updateStroke ) doc
|
over ( field' @"strokes" ) ( fmap updateStroke ) doc
|
||||||
where
|
where
|
||||||
mode :: SelectionMode
|
|
||||||
mode = selectionMode pressedKeys
|
|
||||||
updateStroke :: Stroke -> Stroke
|
updateStroke :: Stroke -> Stroke
|
||||||
updateStroke stroke@( Stroke { strokeVisible } ) =
|
updateStroke stroke@( Stroke { strokeVisible } ) =
|
||||||
over ( field' @"strokePoints" )
|
over ( field' @"strokePoints" )
|
||||||
|
@ -95,15 +109,78 @@ selectAt pressedKeys c doc@( Document { zoomFactor } ) =
|
||||||
| not isVisible = False
|
| not isVisible = False
|
||||||
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
|
| 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.
|
-- | Updates the selected objects on a rectangular selection event.
|
||||||
selectRectangle :: [ Word32 ] -> Point2D Double -> Point2D Double -> Document -> Document
|
selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
|
||||||
selectRectangle pressedKeys ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" ) ( fmap updateStroke )
|
selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" ) ( fmap updateStroke )
|
||||||
where
|
where
|
||||||
xMin, xMax, yMin, yMax :: Double
|
xMin, xMax, yMin, yMax :: Double
|
||||||
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
|
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
|
||||||
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
|
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
|
||||||
mode :: SelectionMode
|
|
||||||
mode = selectionMode pressedKeys
|
|
||||||
updateStroke :: Stroke -> Stroke
|
updateStroke :: Stroke -> Stroke
|
||||||
updateStroke stroke@( Stroke { strokeVisible } ) =
|
updateStroke stroke@( Stroke { strokeVisible } ) =
|
||||||
over ( field' @"strokePoints" )
|
over ( field' @"strokePoints" )
|
||||||
|
@ -122,3 +199,16 @@ selectRectangle pressedKeys ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field'
|
||||||
selected
|
selected
|
||||||
| not isVisible = False
|
| not isVisible = False
|
||||||
| otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax
|
| 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 BlockArguments #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module MetaBrush.Event
|
module MetaBrush.Event
|
||||||
( handleEvents )
|
( handleEvents
|
||||||
|
, HoldEvent(..)
|
||||||
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
@ -37,8 +40,6 @@ import qualified GI.Gdk as GDK
|
||||||
import qualified GI.Gtk as GTK
|
import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
-- stm
|
-- stm
|
||||||
import Control.Concurrent.STM
|
|
||||||
( STM )
|
|
||||||
import qualified Control.Concurrent.STM as STM
|
import qualified Control.Concurrent.STM as STM
|
||||||
( atomically )
|
( atomically )
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
import qualified Control.Concurrent.STM.TVar as STM
|
||||||
|
@ -50,16 +51,17 @@ import Math.Module
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
( Point2D(..), Vector2D(..) )
|
( Point2D(..), Vector2D(..) )
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
( Document(..), Overlay(..) )
|
( Document(..) )
|
||||||
import MetaBrush.Document.Selection
|
import MetaBrush.Document.Selection
|
||||||
( selectAt, selectRectangle )
|
( SelectionMode(..), selectionMode
|
||||||
|
, selectAt, selectRectangle
|
||||||
|
, dragMoveSelect, translateSelection
|
||||||
|
)
|
||||||
import MetaBrush.Event.KeyCodes
|
import MetaBrush.Event.KeyCodes
|
||||||
( pattern Escape
|
( pattern Escape
|
||||||
, pattern Control_L, pattern Control_R
|
, pattern Control_L, pattern Control_R
|
||||||
, pattern Shift_L , pattern Shift_R
|
, pattern Shift_L , pattern Shift_R
|
||||||
)
|
)
|
||||||
import MetaBrush.Time
|
|
||||||
( Time, monotonicTime, DTime(DSeconds) )
|
|
||||||
import MetaBrush.UI.Coordinates
|
import MetaBrush.UI.Coordinates
|
||||||
( toViewportCoordinates )
|
( toViewportCoordinates )
|
||||||
import MetaBrush.UI.InfoBar
|
import MetaBrush.UI.InfoBar
|
||||||
|
@ -71,27 +73,25 @@ import MetaBrush.UI.ToolBar
|
||||||
|
|
||||||
handleEvents
|
handleEvents
|
||||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
:: 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 Tool -> STM.TVar Mode
|
||||||
-> STM.TVar ( Maybe Overlay )
|
|
||||||
-> GTK.Window -> GTK.DrawingArea -> InfoBar
|
-> GTK.Window -> GTK.DrawingArea -> InfoBar
|
||||||
-> IO ()
|
-> IO ()
|
||||||
handleEvents
|
handleEvents
|
||||||
activeDocumentTVar openDocumentsTVar
|
activeDocumentTVar openDocumentsTVar
|
||||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||||
toolTVar _modeTVar
|
toolTVar _modeTVar
|
||||||
overlayTVar
|
|
||||||
window viewportDrawingArea infoBar = do
|
window viewportDrawingArea infoBar = do
|
||||||
|
|
||||||
-- Mouse events
|
-- Mouse events
|
||||||
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
|
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
|
||||||
( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar )
|
( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar viewportDrawingArea infoBar )
|
||||||
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
|
_ <- 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
|
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
|
||||||
( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
|
( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
|
||||||
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
|
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
|
||||||
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea )
|
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea )
|
||||||
|
|
||||||
-- Keyboard events
|
-- Keyboard events
|
||||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
||||||
|
@ -102,22 +102,29 @@ handleEvents
|
||||||
|
|
||||||
pure ()
|
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.
|
-- Mouse events.
|
||||||
|
|
||||||
handleMotionEvent
|
handleMotionEvent
|
||||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
:: 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 Tool
|
||||||
-> STM.TVar ( Maybe Overlay )
|
|
||||||
-> GTK.DrawingArea -> InfoBar
|
-> GTK.DrawingArea -> InfoBar
|
||||||
-> GDK.EventMotion
|
-> GDK.EventMotion
|
||||||
-> IO Bool
|
-> IO Bool
|
||||||
handleMotionEvent
|
handleMotionEvent
|
||||||
activeDocumentTVar openDocumentsTVar
|
activeDocumentTVar openDocumentsTVar
|
||||||
mousePosTVar mouseHoldTVar
|
mousePosTVar _mouseHoldTVar
|
||||||
toolTVar
|
_toolTVar
|
||||||
overlayTVar
|
|
||||||
viewportDrawingArea infoBar
|
viewportDrawingArea infoBar
|
||||||
eventMotion
|
eventMotion
|
||||||
= do
|
= do
|
||||||
|
@ -150,27 +157,21 @@ handleMotionEvent
|
||||||
updateInfoBar infoBar infoData
|
updateInfoBar infoBar infoData
|
||||||
STM.atomically do
|
STM.atomically do
|
||||||
STM.writeTVar mousePosTVar ( Just pos )
|
STM.writeTVar mousePosTVar ( Just pos )
|
||||||
|
|
||||||
----------------------------------------------------------
|
|
||||||
-- Tool dependent updating.
|
|
||||||
updateOverlay mouseHoldTVar toolTVar overlayTVar pos
|
|
||||||
|
|
||||||
|
|
||||||
GTK.widgetQueueDraw viewportDrawingArea
|
GTK.widgetQueueDraw viewportDrawingArea
|
||||||
|
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
handleScrollEvent
|
handleScrollEvent
|
||||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
:: 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 )
|
-> STM.TVar Tool
|
||||||
-> GTK.DrawingArea -> InfoBar
|
-> GTK.DrawingArea -> InfoBar
|
||||||
-> GDK.EventScroll
|
-> GDK.EventScroll
|
||||||
-> IO Bool
|
-> IO Bool
|
||||||
handleScrollEvent
|
handleScrollEvent
|
||||||
activeDocumentTVar openDocumentsTVar
|
activeDocumentTVar openDocumentsTVar
|
||||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
mousePosTVar _mouseHoldTVar pressedKeysTVar
|
||||||
toolTVar overlayTVar
|
_toolTVar
|
||||||
viewportDrawingArea infoBar
|
viewportDrawingArea infoBar
|
||||||
scrollEvent
|
scrollEvent
|
||||||
= do
|
= do
|
||||||
|
@ -243,20 +244,19 @@ handleScrollEvent
|
||||||
STM.atomically do
|
STM.atomically do
|
||||||
STM.writeTVar openDocumentsTVar docs'
|
STM.writeTVar openDocumentsTVar docs'
|
||||||
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||||||
updateOverlay mouseHoldTVar toolTVar overlayTVar finalMousePos
|
|
||||||
GTK.widgetQueueDraw viewportDrawingArea
|
GTK.widgetQueueDraw viewportDrawingArea
|
||||||
|
|
||||||
pure False
|
pure False
|
||||||
|
|
||||||
handleMouseButtonEvent
|
handleMouseButtonEvent
|
||||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
:: 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
|
-> GTK.DrawingArea
|
||||||
-> GDK.EventButton
|
-> GDK.EventButton
|
||||||
-> IO Bool
|
-> IO Bool
|
||||||
handleMouseButtonEvent
|
handleMouseButtonEvent
|
||||||
activeDocumentTVar openDocumentsTVar
|
activeDocumentTVar openDocumentsTVar
|
||||||
mousePosTVar mouseHoldTVar _pressedKeysTVar
|
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||||
viewportDrawingArea
|
viewportDrawingArea
|
||||||
mouseClickEvent
|
mouseClickEvent
|
||||||
= do
|
= do
|
||||||
|
@ -268,7 +268,7 @@ handleMouseButtonEvent
|
||||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||||
for_ mbActiveDoc \ i -> do
|
for_ mbActiveDoc \ i -> do
|
||||||
docs <- STM.readTVarIO openDocumentsTVar
|
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
|
x <- GDK.getEventButtonX mouseClickEvent
|
||||||
y <- GDK.getEventButtonY mouseClickEvent
|
y <- GDK.getEventButtonY mouseClickEvent
|
||||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||||
|
@ -278,19 +278,41 @@ handleMouseButtonEvent
|
||||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||||
pos :: Point2D Double
|
pos :: Point2D Double
|
||||||
pos = toViewport ( Point2D x y )
|
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.atomically do
|
||||||
STM.writeTVar mousePosTVar ( Just pos )
|
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 ()
|
||||||
|
|
||||||
pure False
|
pure False
|
||||||
|
|
||||||
handleMouseButtonRelease
|
handleMouseButtonRelease
|
||||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
:: 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 Tool
|
||||||
-> STM.TVar ( Maybe Overlay )
|
|
||||||
-> GTK.DrawingArea
|
-> GTK.DrawingArea
|
||||||
-> GDK.EventButton
|
-> GDK.EventButton
|
||||||
-> IO Bool
|
-> IO Bool
|
||||||
|
@ -298,7 +320,6 @@ handleMouseButtonRelease
|
||||||
activeDocumentTVar openDocumentsTVar
|
activeDocumentTVar openDocumentsTVar
|
||||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||||
toolTVar
|
toolTVar
|
||||||
overlayTVar
|
|
||||||
viewportDrawingArea
|
viewportDrawingArea
|
||||||
mouseReleaseEvent
|
mouseReleaseEvent
|
||||||
= do
|
= do
|
||||||
|
@ -320,22 +341,23 @@ handleMouseButtonRelease
|
||||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||||
pos :: Point2D Double
|
pos :: Point2D Double
|
||||||
pos = toViewport ( Point2D x y )
|
pos = toViewport ( Point2D x y )
|
||||||
t <- monotonicTime
|
|
||||||
STM.atomically do
|
STM.atomically do
|
||||||
pressedKeys <- STM.readTVar pressedKeysTVar
|
pressedKeys <- STM.readTVar pressedKeysTVar
|
||||||
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
|
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
|
||||||
STM.writeTVar overlayTVar Nothing
|
|
||||||
tool <- STM.readTVar toolTVar
|
tool <- STM.readTVar toolTVar
|
||||||
let
|
let
|
||||||
|
mode :: SelectionMode
|
||||||
|
mode = selectionMode pressedKeys
|
||||||
newDoc :: Document
|
newDoc :: Document
|
||||||
newDoc = case tool of
|
newDoc = case tool of
|
||||||
Selection
|
Selection
|
||||||
| Just ( pos0, t0 ) <- mbHoldPos
|
| Just ( SelectionHold pos0 ) <- mbHoldPos
|
||||||
, pos0 /= pos
|
, pos0 /= pos
|
||||||
, ( t0 --> t ) > DSeconds 0.01
|
-> selectRectangle mode pos0 pos doc
|
||||||
-> selectRectangle pressedKeys pos0 pos doc
|
| Just ( DragMoveHold pos0 ) <- mbHoldPos
|
||||||
|
-> translateSelection ( pos0 --> pos ) doc
|
||||||
| otherwise
|
| otherwise
|
||||||
-> selectAt pressedKeys pos doc
|
-> selectAt mode pos doc
|
||||||
Pen -> doc -- TODO
|
Pen -> doc -- TODO
|
||||||
newDocs :: IntMap Document
|
newDocs :: IntMap Document
|
||||||
newDocs = IntMap.insert i newDoc docs
|
newDocs = IntMap.insert i newDoc docs
|
||||||
|
@ -348,19 +370,6 @@ handleMouseButtonRelease
|
||||||
|
|
||||||
pure False
|
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.
|
-- Keyboard events.
|
||||||
|
|
||||||
|
|
|
@ -11,12 +11,16 @@ module MetaBrush.Render.Document
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_, traverse_ )
|
( traverse_ )
|
||||||
import Data.Functor.Compose
|
import Data.Functor.Compose
|
||||||
( Compose(..) )
|
( Compose(..) )
|
||||||
import Data.Int
|
import Data.Int
|
||||||
( Int32 )
|
( Int32 )
|
||||||
|
|
||||||
|
-- acts
|
||||||
|
import Data.Act
|
||||||
|
( Torsor((-->)) )
|
||||||
|
|
||||||
-- gi-cairo-render
|
-- gi-cairo-render
|
||||||
import qualified GI.Cairo.Render as Cairo
|
import qualified GI.Cairo.Render as Cairo
|
||||||
|
|
||||||
|
@ -32,8 +36,11 @@ import MetaBrush.Asset.Colours
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
( Document(..)
|
( Document(..)
|
||||||
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
|
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
|
||||||
, Overlay(..)
|
|
||||||
)
|
)
|
||||||
|
import MetaBrush.Document.Selection
|
||||||
|
( translateSelection )
|
||||||
|
import MetaBrush.Event
|
||||||
|
( HoldEvent(..) )
|
||||||
import MetaBrush.Render.Util
|
import MetaBrush.Render.Util
|
||||||
( withRGBA )
|
( withRGBA )
|
||||||
|
|
||||||
|
@ -56,8 +63,10 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render ()
|
renderDocument :: Colours -> ( Int32, Int32 ) -> Maybe ( HoldEvent, Point2D Double ) -> Document -> Cairo.Render ()
|
||||||
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do
|
renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
|
||||||
|
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
|
||||||
|
= do
|
||||||
|
|
||||||
Cairo.save
|
Cairo.save
|
||||||
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
|
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
|
||||||
|
@ -65,10 +74,20 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente
|
||||||
Cairo.translate ( -cx ) ( -cy )
|
Cairo.translate ( -cx ) ( -cy )
|
||||||
|
|
||||||
let
|
let
|
||||||
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes
|
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
|
rdrPaths
|
||||||
rdrPoints
|
rdrPoints
|
||||||
for_ mbOverlay ( renderOverlay cols zoomFactor )
|
renderSelectionRect
|
||||||
|
|
||||||
Cairo.restore
|
Cairo.restore
|
||||||
|
|
||||||
|
@ -248,8 +267,8 @@ drawCubicBezier ( Colours { path } ) zoom
|
||||||
Cairo.restore
|
Cairo.restore
|
||||||
|
|
||||||
|
|
||||||
renderOverlay :: Colours -> Double -> Overlay -> Cairo.Render ()
|
renderSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
|
||||||
renderOverlay ( Colours { .. } ) zoom ( SelectionRectangle ( Point2D x0 y0 ) ( Point2D x1 y1 ) ) = do
|
renderSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
|
||||||
|
|
||||||
Cairo.save
|
Cairo.save
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,3 @@
|
||||||
{-# LANGUAGE BlockArguments #-}
|
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
@ -8,39 +6,13 @@ module MetaBrush.UI.Viewport
|
||||||
( Viewport(..), createViewport )
|
( Viewport(..), createViewport )
|
||||||
where
|
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
|
-- gi-gdk
|
||||||
import qualified GI.Gdk as GDK
|
import qualified GI.Gdk as GDK
|
||||||
|
|
||||||
-- gi-gtk
|
-- gi-gtk
|
||||||
import qualified GI.Gtk as GTK
|
import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
-- stm
|
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
|
||||||
( TVar, readTVarIO )
|
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import MetaBrush.Asset.Colours
|
|
||||||
( Colours )
|
|
||||||
import MetaBrush.Document
|
|
||||||
( Document(..), currentDocument
|
|
||||||
, Overlay
|
|
||||||
)
|
|
||||||
import MetaBrush.Render.Document
|
|
||||||
( renderDocument )
|
|
||||||
import MetaBrush.Render.Util
|
import MetaBrush.Render.Util
|
||||||
( widgetAddClass )
|
( widgetAddClass )
|
||||||
|
|
||||||
|
@ -51,14 +23,8 @@ data Viewport
|
||||||
{ viewportDrawingArea :: !GTK.DrawingArea
|
{ viewportDrawingArea :: !GTK.DrawingArea
|
||||||
}
|
}
|
||||||
|
|
||||||
createViewport
|
createViewport :: GTK.Grid -> IO Viewport
|
||||||
:: Colours
|
createViewport viewportGrid = do
|
||||||
-> STM.TVar ( Maybe Int )
|
|
||||||
-> STM.TVar ( IntMap Document )
|
|
||||||
-> STM.TVar ( Maybe Overlay )
|
|
||||||
-> GTK.Grid
|
|
||||||
-> IO Viewport
|
|
||||||
createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
|
|
||||||
|
|
||||||
widgetAddClass viewportGrid "viewport"
|
widgetAddClass viewportGrid "viewport"
|
||||||
|
|
||||||
|
@ -139,18 +105,4 @@ createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewport
|
||||||
widgetAddClass viewportHScrollbar "viewportScrollbar"
|
widgetAddClass viewportHScrollbar "viewportScrollbar"
|
||||||
widgetAddClass viewportVScrollbar "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 { .. } )
|
pure ( Viewport { .. } )
|
||||||
|
|
Loading…
Reference in a new issue