metabrush/src/app/MetaBrush/Action.hs

{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE BlockArguments       #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE PatternSynonyms      #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module MetaBrush.Action
  ( Actions, HandleAction(..)
  , handleActions, signalAction, quitEverything
  , MouseMove(..), MouseClick(..), MouseRelease(..)
  , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
  )
  where

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

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

-- containers
import qualified Data.Map as Map
  ( lookup )
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

-- haskus-utils-variant
import Haskus.Utils.Variant
  ( V, pattern V, ReduceVariant, reduceVariant
  , type (:<)
  )

-- stm
import Control.Concurrent.STM
  ( STM )
import qualified Control.Concurrent.STM as STM
  ( atomically )
import qualified Control.Concurrent.STM.TQueue as STM
  ( TQueue, flushTQueue, writeTQueue )
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(..) )

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

type Actions = [ MouseMove, MouseClick, MouseRelease, Scroll, KeyboardPress, KeyboardRelease ]

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

instance ReduceVariant HandleAction actions => HandleAction ( V actions ) where
  handleAction elts vars = reduceVariant @HandleAction ( handleAction elts vars )

handleActions :: ( Show action, HandleAction action ) => STM.TQueue action -> UIElements -> Variables -> IO Bool
handleActions actionTQueue elts vars = do
  --actions <- STM.atomically do
  --  actions <- STM.flushTQueue actionTQueue
  --  if null actions
  --  then STM.retry
  --  else pure actions
  actions <- STM.atomically $ STM.flushTQueue actionTQueue
  traverse_ ( handleAction elts vars ) actions
  pure True

signalAction :: action :< actions => STM.TQueue ( V actions ) -> action  -> STM ()
signalAction tqueue = STM.writeTQueue tqueue . V

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

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

--------------------
-- 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 ( 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 -> quitEverything window

      GDK.KEY_Return -> 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 ()

      GDK.KEY_Delete -> 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 ()

      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 ()

      GDK.KEY_F1 -> do
        mbActiveDoc <- STM.readTVarIO activeDocumentTVar
        for_ mbActiveDoc \ i -> do
          docs <- STM.readTVarIO openDocumentsTVar
          for_ ( Map.lookup i docs ) \ doc -> do
            writeFile "log.txt" ( show doc <> "\n\n" )

      -- Create a new document with Ctrl+N
      n
        | ( n == GDK.KEY_n || n == GDK.KEY_N )
        , any ( \ case { Control _ -> True; _ -> False } ) modifiers
        ->
          newFileTab
            vars
            window title fileBar viewportDrawingArea infoBar
            Nothing
            AfterCurrentTab

      _ -> 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 )