update selected objects on selection event

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

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"

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

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

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

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