mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
update selected objects on selection event
This commit is contained in:
parent
91e1431306
commit
10dccd1dad
|
@ -94,6 +94,7 @@ executable MetaBrush
|
|||
, MetaBrush.Document
|
||||
, MetaBrush.Document.Selection
|
||||
, MetaBrush.Event
|
||||
, MetaBrush.Event.KeyCodes
|
||||
, MetaBrush.Render.Document
|
||||
, MetaBrush.Render.Util
|
||||
, MetaBrush.Time
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
51
src/app/MetaBrush/Event/KeyCodes.hs
Normal file
51
src/app/MetaBrush/Event/KeyCodes.hs
Normal 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
|
Loading…
Reference in a new issue