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