metabrush/src/app/MetaBrush/Action.hs

{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE UndecidableInstances  #-}

module MetaBrush.Action
  ( HandleAction(..)
  , quitEverything
  , NewFile(..), OpenFile(..), Save(..), SaveAs(..), Close(..), Quit(..)
  , Undo(..), Redo(..), Cut(..), Copy(..), Paste(..), Duplicate(..), Delete(..)
  , Confirm(..)
  , About(..)
  , MouseMove(..), MouseClick(..), MouseRelease(..)
  , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
  )
  where

-- base
import Control.Monad
  ( guard, unless, void )
import Data.Foldable
  ( for_ )
import Data.Maybe
  ( catMaybes )
import Data.Word
  ( Word32 )

-- acts
import Data.Act
  ( Act
    ( (•) )
  , Torsor
    ( (-->) )
  )

-- containers
import Data.Sequence
  ( Seq(..) )
import qualified Data.Sequence as Seq
  ( fromList )
import qualified Data.Set as Set
  ( insert, delete )

-- gi-gdk
import qualified GI.Gdk as GDK

-- gi-gtk
import qualified GI.Gtk as GTK

-- stm
import qualified Control.Concurrent.STM as STM
  ( atomically )
import qualified Control.Concurrent.STM.TVar as STM
  ( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )

-- MetaBrush
import Math.Bezier.Stroke
  ( StrokePoint(..) )
import Math.Module
  ( Module((*^)) )
import Math.Vector2D
  ( Point2D(..), Vector2D(..) )
import MetaBrush.Context
  ( UIElements(..), Variables(..)
  , Modifier(..), modifierKey
  , HoldAction(..), PartialPath(..)
  , withCurrentDocument, modifyingCurrentDocument
  )
import MetaBrush.Document
  ( Document(..)
  , PointData(..), FocusState(..)
  )
import MetaBrush.Document.Draw
  ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document.Selection
  ( SelectionMode(..), selectionMode
  , selectAt, selectRectangle
  , dragMoveSelect
  , translateSelection
  , deleteSelected
  )
import MetaBrush.UI.Coordinates
  ( toViewportCoordinates )
import MetaBrush.UI.InfoBar
  ( updateInfoBar )
import MetaBrush.UI.FileBar
  ( TabLocation(..), newFileTab )
import MetaBrush.UI.ToolBar
  ( Tool(..) )

--------------------------------------------------------------------------------

class HandleAction action where
  handleAction :: UIElements -> Variables -> action -> IO ()

--------------------------------------------------------------------------------
-- General actions

instance HandleAction () where
  handleAction _ _ _ = pure ()

--------------
-- New file --
--------------

data NewFile = NewFile TabLocation
  deriving stock Show

instance HandleAction NewFile where
  handleAction uiElts vars ( NewFile tabLoc ) =
    newFileTab vars uiElts Nothing tabLoc

---------------
-- Open file --
---------------

data OpenFile = OpenFile TabLocation
  deriving stock Show

instance HandleAction OpenFile where
  handleAction _ _ _ = pure ()

---------------
-- Save file --
---------------

data Save = Save
  deriving stock Show

-- TODO
instance HandleAction Save where
  handleAction _ _ _ = pure ()

-------------
-- Save as --
-------------

data SaveAs = SaveAs
  deriving stock Show

-- TODO
instance HandleAction SaveAs where
  handleAction _ _ _ = pure ()

-----------
-- Close --
-----------

data Close = Close
  deriving stock Show

-- TODO
instance HandleAction Close where
  handleAction _ _ _ = pure ()

--------------
-- Quitting --
--------------

data Quit = Quit
  deriving stock Show

instance HandleAction Quit where
  handleAction ( UIElements { window } ) _ _ = quitEverything window

quitEverything :: GTK.Window -> IO ()
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit

----------
-- Undo --
----------

data Undo = Undo
  deriving stock Show

-- TODO
instance HandleAction Undo where
  handleAction _ _ _ = pure ()

----------
-- Redo --
----------

data Redo = Redo
  deriving stock Show

-- TODO
instance HandleAction Redo where
  handleAction _ _ _ = pure ()

---------
-- Cut --
---------

data Cut = Cut
  deriving stock Show

-- TODO
instance HandleAction Cut where
  handleAction _ _ _ = pure ()

----------
-- Copy --
----------

data Copy = Copy
  deriving stock Show

-- TODO
instance HandleAction Copy where
  handleAction _ _ _ = pure ()

-----------
-- Paste --
-----------

data Paste = Paste
  deriving stock Show

-- TODO
instance HandleAction Paste where
  handleAction _ _ _ = pure ()

---------------
-- Duplicate --
---------------

data Duplicate = Duplicate
  deriving stock Show

-- TODO
instance HandleAction Duplicate where
  handleAction _ _ _ = pure ()

------------
-- Delete --
------------

data Delete = Delete
  deriving stock Show

instance HandleAction Delete where
  handleAction
    ( UIElements { viewportDrawingArea } )
    vars@( Variables { toolTVar, modeTVar } )
    _
    = do
        tool <- STM.readTVarIO toolTVar
        mode <- STM.readTVarIO modeTVar
        case tool of
          -- Delete selected points on pressing 'Delete'.
          Selection -> do
            STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
            GTK.widgetQueueDraw viewportDrawingArea
          _ -> pure ()

------------
-- Confirm --
------------

data Confirm = Confirm
  deriving stock Show

instance HandleAction Confirm where
  handleAction
    ( UIElements { viewportDrawingArea } )
    ( Variables { .. } )
    _
    = do
        tool <- STM.readTVarIO toolTVar
        case tool of
          -- End ongoing drawing on pressing enter key.
          Pen -> do
            STM.atomically $ STM.writeTVar partialPathTVar Nothing
            GTK.widgetQueueDraw viewportDrawingArea
          _ -> pure ()

----------------
-- About page --
----------------

data About = About
  deriving stock Show

-- TODO
instance HandleAction About where
  handleAction _ _ _ = pure ()

--------------------------------------------------------------------------------
-- Input actions

--------------------
-- Mouse movement --
--------------------

data MouseMove = MouseMove ( Point2D Double )
  deriving stock Show

instance HandleAction MouseMove where
  handleAction
    ( UIElements { viewportDrawingArea, infoBar } )
    vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } )
    ( MouseMove ( Point2D x y ) )
    = do
      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
      void . STM.atomically $ withCurrentDocument vars \ ( Document { .. } ) -> do
        modifiers <- STM.readTVar modifiersTVar
        let
          toViewport :: Point2D Double -> Point2D Double
          toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
          pos :: Point2D Double
          pos = toViewport ( Point2D x y )
        STM.writeTVar mousePosTVar ( Just pos )
        ----------------------------------------------------------
        -- With the pen tool, keeping control pressed while moving the mouse
        -- moves the partial control point (if one exists).
        tool <- STM.readTVar toolTVar
        mbPartialPath <- STM.readTVar partialPathTVar
        case tool of
          Pen
            | any ( \ case { Control _ -> True; _ -> False } ) modifiers
            , Just pp <- mbPartialPath
            -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
          _ -> pure ()

      updateInfoBar viewportDrawingArea infoBar vars
      GTK.widgetQueueDraw viewportDrawingArea

-----------------
-- Mouse click --
-----------------

data MouseClick = MouseClick Word32 ( Point2D Double )
  deriving stock Show

instance HandleAction MouseClick where
  handleAction
    ( UIElements { viewportDrawingArea } )
    vars@( Variables { .. } )
    ( MouseClick button mouseClickCoords )
    = case button of

      -- Left mouse button.
      1 -> do
        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
        STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
          let
            toViewport :: Point2D Double -> Point2D Double
            toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
            pos :: Point2D Double
            pos = toViewport mouseClickCoords
          STM.writeTVar mousePosTVar ( Just pos )
          modifiers <- STM.readTVar modifiersTVar
          tool <- STM.readTVar toolTVar
          mode <- STM.readTVar modeTVar
          case tool of
            -- 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.
            Selection ->
              case selectionMode modifiers of
                -- Drag move: not holding shift or alt, click has selected something.
                New
                  | Just newDoc <- dragMoveSelect mode pos doc
                  -> do
                    STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
                    pure ( Just newDoc )
                -- Rectangular selection.
                _ -> do
                    STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
                    pure Nothing

            -- Pen tool: start or continue a drawing operation.
            Pen -> do
              mbPartialPath <- STM.readTVar partialPathTVar
              STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
              case mbPartialPath of
                -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
                Nothing -> do
                  ( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
                  STM.writeTVar partialPathTVar
                    ( Just $ PartialPath
                      { partialStartPos     = anchorPt
                      , partialControlPoint = Nothing
                      , partialPathAnchor   = drawAnchor
                      , firstPoint          = True
                      }
                    )
                  pure ( Just newDoc )
                -- Path already started: indicate that we are continuing a path.
                Just pp -> do
                  STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
                  pure Nothing
        GTK.widgetQueueDraw viewportDrawingArea

      -- Right mouse button: end partial path.
      3 -> do
        STM.atomically $ STM.writeTVar partialPathTVar Nothing
        GTK.widgetQueueDraw viewportDrawingArea

      -- Other mouse buttons: ignored (for the moment at least).
      _ -> pure ()


-------------------
-- Mouse release --
-------------------

data MouseRelease = MouseRelease Word32 ( Point2D Double )
  deriving stock Show

instance HandleAction MouseRelease where
  handleAction 
    ( UIElements { viewportDrawingArea } )
    vars@( Variables { .. } )
    ( MouseRelease button ( Point2D x y ) )
    = case button of

      -- Left mouse button.
      1 -> do
        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
        STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } )  -> do
          let
            toViewport :: Point2D Double -> Point2D Double
            toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
            pos :: Point2D Double
            pos = toViewport ( Point2D x y )
          STM.writeTVar mousePosTVar  ( Just pos )
          modifiers <- STM.readTVar modifiersTVar
          mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
          tool      <- STM.readTVar toolTVar
          mode      <- STM.readTVar modeTVar

          case tool of

            Selection -> do
              let
                selMode :: SelectionMode
                selMode = selectionMode modifiers
              case mbHoldPos of
                Just hold
                  | DragMoveHold  pos0 <- hold
                  , pos0 /= pos
                  -> pure . Just $ translateSelection mode ( pos0 --> pos ) doc
                  | SelectionHold pos0 <- hold
                  , pos0 /= pos
                  -> pure . Just $ selectRectangle mode selMode pos0 pos doc
                _ -> pure . Just $ selectAt mode selMode pos doc

            Pen -> do
              mbPartialPath <- STM.readTVar partialPathTVar
              case mbPartialPath of
                -- Normal pen mode mouse click should have created an anchor.
                -- If no anchor exists, then just ignore the mouse release event.
                Nothing -> pure Nothing
                -- Mouse click release possibilities:
                --
                --  - click was on complementary draw stroke draw anchor to close the path,
                --  - release at same point as click: finish current segment,
                --  - release at different point as click: finish current segment, adding a control point.
                Just
                  ( PartialPath
                    { partialStartPos     = p1
                    , partialControlPoint = mbCp2
                    , partialPathAnchor   = anchor
                    , firstPoint
                    }
                  ) -> do
                  let
                    pathPoint :: Point2D Double
                    mbControlPoint :: Maybe ( Point2D Double )
                    partialControlPoint :: Maybe ( Point2D Double )
                    ( pathPoint, mbControlPoint, partialControlPoint )
                      | Just ( DrawHold holdPos ) <- mbHoldPos
                      = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
                      | otherwise
                      = ( pos, Nothing, Nothing )
                  ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
                  if not firstPoint && anchorsAreComplementary anchor otherAnchor
                  -- Close path.
                  then do
                    STM.writeTVar partialPathTVar Nothing
                    let 
                      newSegment :: Seq ( StrokePoint PointData )
                      newSegment
                        = Seq.fromList
                        $ catMaybes
                        [ Just ( PathPoint p1 ( PointData Normal Empty ) )
                        , do
                            cp <- mbCp2
                            guard ( cp /= p1 )
                            pure $ ControlPoint cp ( PointData Normal Empty )
                        , do
                            cp <- mbControlPoint
                            guard ( cp /= otherAnchorPt )
                            pure $ ControlPoint cp ( PointData Normal Empty )
                        , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
                        ]
                    pure ( Just $ addToAnchor anchor newSegment doc )
                  else
                    if firstPoint
                    -- Continue current partial path.
                    then do
                      STM.writeTVar partialPathTVar ( Just $ PartialPath p1        partialControlPoint anchor False )
                      pure Nothing
                    -- Finish current partial path.
                    else do
                      STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
                      let 
                        newSegment :: Seq ( StrokePoint PointData )
                        newSegment
                          = Seq.fromList
                          $ catMaybes
                          [ Just ( PathPoint p1 ( PointData Normal Empty ) )
                          , do
                              cp <- mbCp2
                              guard ( cp /= p1 )
                              pure $ ControlPoint cp ( PointData Normal Empty )
                          , do
                              cp <- mbControlPoint
                              guard ( cp /= pathPoint )
                              pure $ ControlPoint cp ( PointData Normal Empty )
                          , Just ( PathPoint pathPoint ( PointData Normal Empty ) )
                          ]
                      pure ( Just $ addToAnchor anchor newSegment doc )

        GTK.widgetQueueDraw viewportDrawingArea

      -- Other mouse buttons: ignored (for the moment at least).
      _ -> pure ()

---------------
-- Scrolling --
---------------

data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
  deriving stock Show

instance HandleAction Scroll where
  handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do

    viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea

    unless ( dx == 0 && dy == 0 ) do
      STM.atomically $ modifyingCurrentDocument vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
        modifiers <- STM.readTVar modifiersTVar
        let
          toViewport :: Point2D Double -> Point2D Double
          toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
          -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
          mousePos :: Point2D Double
          mousePos = toViewport ( Point2D x y )
          newDoc :: Document
          newDoc
            -- Zooming using 'Control'.
            | any ( \ case { Control _ -> True; _ -> False } ) modifiers
            = let
                newZoomFactor :: Double
                newZoomFactor
                  | dy > 0
                  = max 0.0078125 ( oldZoomFactor / sqrt 2 )
                  | otherwise
                  = min 256 ( oldZoomFactor * sqrt 2 )
                newCenter :: Point2D Double
                newCenter
                  = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
                  • oldCenter
              in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
            -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
            | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
            = let
                newCenter :: Point2D Double
                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
              in doc { viewportCenter = newCenter }
            -- Vertical scrolling.
            | otherwise
            = let
                newCenter :: Point2D Double
                newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
              in doc { viewportCenter = newCenter }
          finalZoomFactor :: Double
          finalZoomFactor = zoomFactor     newDoc
          finalCenter :: Point2D Double
          finalCenter     = viewportCenter newDoc
          toFinalViewport :: Point2D Double -> Point2D Double
          toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
          finalMousePos :: Point2D Double
          finalMousePos = toFinalViewport ( Point2D x y )
        STM.writeTVar mousePosTVar ( Just finalMousePos )
        pure ( Just newDoc )
      updateInfoBar viewportDrawingArea infoBar vars
      GTK.widgetQueueDraw viewportDrawingArea

--------------------
-- Keyboard press --
--------------------

data KeyboardPress = KeyboardPress Word32
  deriving stock Show

instance HandleAction KeyboardPress where
  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do

    _modifiers <- STM.atomically do
      !modifiers <- STM.readTVar modifiersTVar
      for_ ( modifierKey keyCode ) \ modifier ->
        ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
      pure modifiers

    case keyCode of

      GDK.KEY_Escape -> handleAction uiElts vars Quit

      GDK.KEY_Return -> handleAction uiElts vars Confirm

      ctrl
        | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
        -> do
          ----------------------------------------------------------
          -- With the pen tool, pressing control moves
          -- the partial point control point to the mouse position.
          tool <- STM.readTVarIO toolTVar
          mbMousePos <- STM.readTVarIO mousePosTVar
          mbPartialPath <- STM.readTVarIO partialPathTVar
          case tool of
            Pen
              | Just mp <- mbMousePos
              , Just pp <- mbPartialPath
              -> do
                  STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
                  GTK.widgetQueueDraw viewportDrawingArea
            _ -> pure ()

      _ -> pure ()

----------------------
-- Keyboard release --
----------------------

data KeyboardRelease = KeyboardRelease Word32
  deriving stock Show

instance HandleAction KeyboardRelease where
  handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) =
    for_ ( modifierKey keyCode ) \ modifier -> do
      STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier )