diff --git a/MetaBrush.cabal b/MetaBrush.cabal index f2fcde0..86bd167 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -94,6 +94,7 @@ executable MetaBrush , MetaBrush.Document , MetaBrush.Document.Selection , MetaBrush.Event + , MetaBrush.Event.KeyCodes , MetaBrush.Render.Document , MetaBrush.Render.Util , MetaBrush.Time diff --git a/app/Main.hs b/app/Main.hs index c14d96a..235a591 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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" diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index dfc31ac..5d01339 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 479af12..3167c73 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index e0b3f56..00fde9d 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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 diff --git a/src/app/MetaBrush/Event/KeyCodes.hs b/src/app/MetaBrush/Event/KeyCodes.hs new file mode 100644 index 0000000..84fc39c --- /dev/null +++ b/src/app/MetaBrush/Event/KeyCodes.hs @@ -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