{-# 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 )