update selected objects on selection event

This commit is contained in:
sheaf 2020-08-15 19:11:52 +02:00
parent 91e1431306
commit 10dccd1dad
6 changed files with 191 additions and 58 deletions

View file

@ -94,6 +94,7 @@ executable MetaBrush
, MetaBrush.Document
, MetaBrush.Document.Selection
, MetaBrush.Event
, MetaBrush.Event.KeyCodes
, MetaBrush.Render.Document
, MetaBrush.Render.Util
, MetaBrush.Time

View file

@ -95,9 +95,9 @@ testDocuments = IntMap.fromList
"Stroke1"
False
, Stroke
[ StrokePoint ( Point2D 100 0 ) PathPoint Hover
[ StrokePoint ( Point2D 100 0 ) PathPoint Normal
, StrokePoint ( Point2D 105 0 ) ControlPoint Normal
, StrokePoint ( Point2D 110 0 ) PathPoint Selected
, StrokePoint ( Point2D 110 0 ) PathPoint Normal
]
"Stroke2"
True
@ -107,7 +107,7 @@ testDocuments = IntMap.fromList
True
, Stroke
[ StrokePoint ( Point2D 100 100 ) PathPoint Normal
, StrokePoint ( Point2D 105 105 ) ControlPoint Selected
, StrokePoint ( Point2D 105 105 ) ControlPoint Normal
, StrokePoint ( Point2D 110 100 ) PathPoint Normal
]
"Stroke4"

View file

@ -1,14 +1,24 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module MetaBrush.Document where
module MetaBrush.Document
( AABB(..)
, Document(..), currentDocument
, Stroke(..), StrokePoint(..), PointType(..)
, FocusState(..), switchFocusState
, Overlay(..)
)
where
-- containers
import Data.IntMap.Strict
( IntMap )
import qualified Data.IntMap.Strict as IntMap
( lookup )
import GHC.Generics
( Generic )
-- text
import Data.Text
@ -43,7 +53,7 @@ data Document
, viewportCenter :: !( Point2D Double )
, zoomFactor :: !Double
}
deriving stock Show
deriving stock ( Show, Generic )
data Stroke
= Stroke
@ -51,7 +61,7 @@ data Stroke
, strokeName :: !Text
, strokeVisible :: !Bool
}
deriving stock Show
deriving stock ( Show, Generic )
data StrokePoint
= StrokePoint
@ -59,7 +69,7 @@ data StrokePoint
, pointType :: !PointType
, pointState :: !FocusState
}
deriving stock Show
deriving stock ( Show, Generic )
data PointType
= PathPoint
@ -72,6 +82,11 @@ data FocusState
| Selected
deriving stock Show
switchFocusState :: FocusState -> FocusState
switchFocusState Normal = Selected
switchFocusState Hover = Hover
switchFocusState Selected = Normal
data Overlay
= SelectionRectangle !( Point2D Double ) !( Point2D Double )
deriving stock Show

View file

@ -1,3 +1,12 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Selection
( selectAt, selectRectangle )
where
@ -6,16 +15,110 @@ module MetaBrush.Document.Selection
import Data.Word
( Word32 )
-- acts
import Data.Act
( Torsor((-->)) )
-- generic-lens
import Data.GenericLens.Internal
( over )
import Data.Generics.Product.Fields
( field' )
-- MetaBrush
import Math.Module
( squaredNorm )
import Math.Vector2D
( Point2D(..) )
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..) )
( Document(..), Stroke(..), StrokePoint(..)
, FocusState(..), switchFocusState
)
import MetaBrush.Event.KeyCodes
( pattern Alt_L , pattern Alt_R
, pattern Shift_L, pattern Shift_R
)
--------------------------------------------------------------------------------
selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document
selectAt _ _ doc = doc
data SelectionMode
= New
| Add
| Subtract
deriving stock Show
instance Semigroup SelectionMode where
Subtract <> _ = Subtract
New <> m = m
_ <> Subtract = Subtract
m <> New = m
Add <> Add = Add
instance Monoid SelectionMode where
mempty = New
selectionMode :: [ Word32 ] -> SelectionMode
selectionMode = foldMap \case
Alt_L -> Subtract
Alt_R -> Subtract
Shift_L -> Add
Shift_R -> Add
_ -> New
-- | Updates the selected objects on a single click selection event.
--
-- 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 } ) =
over ( field' @"strokes" ) ( fmap updateStroke ) doc
where
mode :: SelectionMode
mode = selectionMode pressedKeys
updateStroke :: Stroke -> Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" )
( fmap ( updatePoint strokeVisible ) )
stroke
updatePoint :: Bool -> StrokePoint -> StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
| selected = case mode of
New -> pt { pointState = switchFocusState oldFocusState }
Add -> pt { pointState = Selected }
Subtract -> pt { pointState = Normal }
| otherwise = case mode of
New -> pt { pointState = Normal }
_ -> pt
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 _ _ _ doc = doc
selectRectangle pressedKeys ( 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" )
( fmap ( updatePoint strokeVisible ) )
stroke
updatePoint :: Bool -> StrokePoint -> StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = Point2D x y } )
| selected = case mode of
Subtract -> pt { pointState = Normal }
_ -> pt { pointState = Selected }
| otherwise = case mode of
New -> pt { pointState = Normal }
_ -> pt
where
selected :: Bool
selected
| not isVisible = False
| otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax

View file

@ -4,7 +4,9 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Event where
module MetaBrush.Event
( handleEvents )
where
-- base
import Control.Monad
@ -51,6 +53,11 @@ import MetaBrush.Document
( Document(..), Overlay(..) )
import MetaBrush.Document.Selection
( selectAt, selectRectangle )
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
@ -325,7 +332,7 @@ handleMouseButtonRelease
Selection
| Just ( pos0, t0 ) <- mbHoldPos
, pos0 /= pos
, ( t0 --> t ) > DSeconds 0.3
, ( t0 --> t ) > DSeconds 0.01
-> selectRectangle pressedKeys pos0 pos doc
| otherwise
-> selectAt pressedKeys pos doc
@ -372,47 +379,3 @@ handleKeyboardReleaseEvent pressedKeysTVar evt = do
pressedKeys <- STM.readTVar pressedKeysTVar
STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys )
pure True
--------------------
-- GDK keycodes.
pattern Escape :: Word32
pattern Escape = 0xff1b
pattern Delete :: Word32
pattern Delete = 0xffff
pattern BackSpace :: Word32
pattern BackSpace = 0xff08
pattern Tab :: Word32
pattern Tab = 0xff09
pattern Return :: Word32
pattern Return = 0xff0d
pattern Pause :: Word32
pattern Pause = 0xff13
pattern Left :: Word32
pattern Left = 0xff51
pattern Up :: Word32
pattern Up = 0xff52
pattern Right :: Word32
pattern Right = 0xff53
pattern Down :: Word32
pattern Down = 0xff54
pattern PageUp :: Word32
pattern PageUp = 0xff55
pattern Next :: Word32
pattern Next = 0xff56
pattern PageDown :: Word32
pattern PageDown = 0xff56
pattern End :: Word32
pattern End = 0xff57
pattern Shift_L :: Word32
pattern Shift_L = 0xffe1
pattern Shift_R :: Word32
pattern Shift_R = 0xffe2
pattern Control_L :: Word32
pattern Control_L = 0xffe3
pattern Control_R :: Word32
pattern Control_R = 0xffe4
pattern Alt_L :: Word32
pattern Alt_L = 0xffe9
pattern Alt_R :: Word32
pattern Alt_R = 0xffea

View file

@ -0,0 +1,51 @@
{-# LANGUAGE PatternSynonyms #-}
module MetaBrush.Event.KeyCodes where
-- base
import Data.Word
( Word32 )
--------------------------------------------------------------------------------
-- GDK keycodes.
pattern Escape :: Word32
pattern Escape = 0xff1b
pattern Delete :: Word32
pattern Delete = 0xffff
pattern BackSpace :: Word32
pattern BackSpace = 0xff08
pattern Tab :: Word32
pattern Tab = 0xff09
pattern Return :: Word32
pattern Return = 0xff0d
pattern Pause :: Word32
pattern Pause = 0xff13
pattern Left :: Word32
pattern Left = 0xff51
pattern Up :: Word32
pattern Up = 0xff52
pattern Right :: Word32
pattern Right = 0xff53
pattern Down :: Word32
pattern Down = 0xff54
pattern PageUp :: Word32
pattern PageUp = 0xff55
pattern Next :: Word32
pattern Next = 0xff56
pattern PageDown :: Word32
pattern PageDown = 0xff56
pattern End :: Word32
pattern End = 0xff57
pattern Shift_L :: Word32
pattern Shift_L = 0xffe1
pattern Shift_R :: Word32
pattern Shift_R = 0xffe2
pattern Control_L :: Word32
pattern Control_L = 0xffe3
pattern Control_R :: Word32
pattern Control_R = 0xffe4
pattern Alt_L :: Word32
pattern Alt_L = 0xffe9
pattern Alt_R :: Word32
pattern Alt_R = 0xffea