From 7033578e2093f61bac979190bc7a4207aa712388 Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 2 Sep 2020 04:52:08 +0200 Subject: [PATCH] refactor: separation of event handling and actions --- MetaBrush.cabal | 6 +- app/Main.hs | 98 ++-- src/app/MetaBrush/Action.hs | 537 ++++++++++++++++++++ src/app/MetaBrush/Context.hs | 149 ++++++ src/app/MetaBrush/Context.hs-boot | 9 + src/app/MetaBrush/Document.hs | 21 +- src/app/MetaBrush/Document/Draw.hs | 6 +- src/app/MetaBrush/Document/Selection.hs | 17 +- src/app/MetaBrush/Event.hs | 638 +++--------------------- src/app/MetaBrush/Render/Document.hs | 11 +- src/app/MetaBrush/UI/FileBar.hs | 77 ++- src/app/MetaBrush/UI/FileBar.hs-boot | 41 ++ src/app/MetaBrush/UI/InfoBar.hs | 84 ++-- src/app/MetaBrush/UI/InfoBar.hs-boot | 25 + src/app/MetaBrush/UI/Menu.hs | 4 +- 15 files changed, 1005 insertions(+), 718 deletions(-) create mode 100644 src/app/MetaBrush/Action.hs create mode 100644 src/app/MetaBrush/Context.hs create mode 100644 src/app/MetaBrush/Context.hs-boot create mode 100644 src/app/MetaBrush/UI/FileBar.hs-boot create mode 100644 src/app/MetaBrush/UI/InfoBar.hs-boot diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 13ed9c0..9f23395 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -96,7 +96,8 @@ executable MetaBrush Main.hs other-modules: - MetaBrush.Asset.Brushes + MetaBrush.Action + , MetaBrush.Asset.Brushes , MetaBrush.Asset.Colours , MetaBrush.Asset.Cursor , MetaBrush.Asset.InfoBar @@ -104,6 +105,7 @@ executable MetaBrush , MetaBrush.Asset.TickBox , MetaBrush.Asset.Tools , MetaBrush.Asset.WindowIcons + , MetaBrush.Context , MetaBrush.Document , MetaBrush.Document.Draw , MetaBrush.Document.Selection @@ -148,6 +150,8 @@ executable MetaBrush ^>= 0.0.1 , haskell-gi-base ^>= 0.24 + , haskus-utils-variant + ^>= 3.0 , lens ^>= 4.19.2 , scientific diff --git a/app/Main.hs b/app/Main.hs index d56be15..9980563 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -12,12 +13,8 @@ module Main -- base import Control.Monad ( void ) -import Data.Foldable - ( for_ ) import Data.Int ( Int32 ) -import Data.Word - ( Word32 ) import System.Exit ( exitSuccess ) @@ -28,6 +25,10 @@ import Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq ( fromList ) +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( empty ) -- directory import qualified System.Directory as Directory @@ -43,9 +44,17 @@ import qualified GI.Gdk as GDK -- gi-gtk import qualified GI.Gtk as GTK +-- haskus-utils-variant +import Haskus.Utils.Variant + ( V ) + -- stm +import qualified Control.Concurrent.STM as STM + ( atomically ) +import qualified Control.Concurrent.STM.TQueue as STM + ( newTQueueIO ) import qualified Control.Concurrent.STM.TVar as STM - ( newTVarIO, readTVarIO ) + ( newTVarIO, readTVar ) -- text import qualified Data.Text as Text @@ -56,28 +65,33 @@ import Math.Bezier.Stroke ( StrokePoint(..) ) import Math.Vector2D ( Point2D(..) ) +import MetaBrush.Action + ( Actions, handleActions ) import MetaBrush.Asset.Brushes ( ellipse, rect ) import MetaBrush.Asset.Colours ( getColours ) import MetaBrush.Asset.Logo ( drawLogo ) +import MetaBrush.Context + ( UIElements(..), Variables(..) + , Modifier(..) + , HoldAction(..), PartialPath(..) + , withCurrentDocument + ) import MetaBrush.Document ( Document(..), Stroke(..) , FocusState(..) , PointData(..), BrushPointData(..) - , currentDocument ) import MetaBrush.Event - ( HoldEvent, PartialPath - , handleEvents - ) + ( handleEvents ) import MetaBrush.Render.Document - ( renderDocument ) + ( renderDocument, blankRender ) import MetaBrush.UI.FileBar - ( createFileBar ) + ( FileBar(..), createFileBar ) import MetaBrush.UI.InfoBar - ( createInfoBar ) + ( InfoBar(..), createInfoBar ) import MetaBrush.UI.Menu ( createMenuBar ) import MetaBrush.UI.Panels @@ -176,12 +190,19 @@ main = do activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) testDocuments mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing - mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing - pressedKeysTVar <- STM.newTVarIO @[ Word32 ] [] + mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing + modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty toolTVar <- STM.newTVarIO @Tool Selection modeTVar <- STM.newTVarIO @Mode Path partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing + -- Put all these stateful variables in a record for conciseness. + let + variables :: Variables + variables = Variables { .. } + + actionTQueue <- STM.newTQueueIO @( V Actions ) + --------------------------------------------------------- -- Initialise GTK @@ -246,7 +267,6 @@ main = do GTK.panedPack2 mainPane panelBox False False viewportGrid <- GTK.gridNew - infoBar <- GTK.boxNew GTK.OrientationHorizontal 0 --------------------------------------------------------- -- Background @@ -291,19 +311,22 @@ main = do void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do -- Get the relevant document information - mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar - for_ mbDoc \ doc -> do - mbMousePos <- STM.readTVarIO mousePosTVar - mbHoldEvent <- STM.readTVarIO mouseHoldTVar - mbPartialPath <- STM.readTVarIO partialPathTVar - mode <- STM.readTVarIO modeTVar - viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea - ( `Cairo.renderWithContext` ctx ) $ + viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea + viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea + mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document { .. } ) -> do + mbMousePos <- STM.readTVar mousePosTVar + mbHoldAction <- STM.readTVar mouseHoldTVar + mbPartialPath <- STM.readTVar partialPathTVar + mode <- STM.readTVar modeTVar + pure $ renderDocument colours mode ( viewportWidth, viewportHeight ) - mbMousePos mbHoldEvent mbPartialPath + mbMousePos mbHoldAction mbPartialPath doc + case mbRender of + Just render -> Cairo.renderWithContext render ctx + Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx + pure True --------------------------------------------------------- @@ -314,19 +337,19 @@ main = do --------------------------------------------------------- -- Info bar - infoBarElements <- createInfoBar colours infoBar + infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours --------------------------------------------------------- -- File bar - fileBar <- + fileBar@( FileBar { fileBarBox } ) <- createFileBar - uniqueSupply activeDocumentTVar openDocumentsTVar - window title viewportDrawingArea infoBarElements + variables + window title viewportDrawingArea infoBar - GTK.boxPackStart mainView fileBar False False 0 + GTK.boxPackStart mainView fileBarBox False False 0 GTK.boxPackStart mainView viewportGrid True True 0 - GTK.boxPackStart mainView infoBar False False 0 + GTK.boxPackStart mainView infoBarArea False False 0 --------------------------------------------------------- -- Panels @@ -336,12 +359,13 @@ main = do --------------------------------------------------------- -- Actions - handleEvents - uniqueSupply - activeDocumentTVar openDocumentsTVar - mousePosTVar mouseHoldTVar pressedKeysTVar - toolTVar modeTVar partialPathTVar - window viewportDrawingArea infoBarElements + let + uiElements :: UIElements + uiElements = UIElements { .. } + + handleEvents uiElements actionTQueue + + void $ GDK.threadsAddIdle 200 ( handleActions actionTQueue uiElements variables ) --------------------------------------------------------- -- GTK main loop diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs new file mode 100644 index 0000000..7baa097 --- /dev/null +++ b/src/app/MetaBrush/Action.hs @@ -0,0 +1,537 @@ +{-# 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, retry ) +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(..) ) + +import Debug.Trace + +-------------------------------------------------------------------------------- + +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 $ STM.flushTQueue actionTQueue + + --actions <- STM.atomically do + -- actions <- STM.flushTQueue actionTQueue + -- if null actions + -- then STM.retry + -- else pure actions + 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 ) diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs new file mode 100644 index 0000000..26b0f86 --- /dev/null +++ b/src/app/MetaBrush/Context.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} + +module MetaBrush.Context + ( UIElements(..), Variables(..) + , LR(..), Modifier(..), modifierKey + , HoldAction(..), PartialPath(..) + , currentDocument, withCurrentDocument, modifyingCurrentDocument + ) + where + +-- base +import Data.Foldable + ( for_ ) +import Data.Word + ( Word32 ) + +-- containers +import Data.Set + ( Set ) +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( insert, lookup ) + +-- gi-gtk +import qualified GI.Gdk as GDK + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- stm +import Control.Concurrent.STM + ( STM ) +import qualified Control.Concurrent.STM.TVar as STM + ( TVar, readTVar, readTVar, writeTVar ) + +-- MetaBrush +import Math.Vector2D + ( Point2D ) +import MetaBrush.Document + ( Document ) +import MetaBrush.Document.Draw + ( DrawAnchor ) +import {-# SOURCE #-} MetaBrush.UI.FileBar + ( FileBar ) +import {-# SOURCE #-} MetaBrush.UI.InfoBar + ( InfoBar ) +import MetaBrush.UI.ToolBar + ( Tool, Mode ) +import MetaBrush.Unique + ( UniqueSupply, Unique ) +import MetaBrush.Util + ( (>>?=) ) + +-------------------------------------------------------------------------------- + +data UIElements + = UIElements + { window :: !GTK.Window + , title :: !GTK.Label + , fileBar :: !FileBar + , viewportDrawingArea :: !GTK.DrawingArea + , infoBar :: !InfoBar + } + +data Variables + = Variables + { uniqueSupply :: !UniqueSupply + , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) + , openDocumentsTVar :: !( STM.TVar ( Map Unique Document ) ) + , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) + , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) + , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) + , toolTVar :: !( STM.TVar Tool ) + , modeTVar :: !( STM.TVar Mode ) + , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) + } + +-------------------------------------------------------------------------------- + +data LR = L | R + deriving stock ( Show, Eq, Ord ) + +data Modifier + = Control LR + | Alt LR + | Shift LR + deriving stock ( Show, Eq, Ord ) + +modifierKey :: Word32 -> Maybe Modifier +modifierKey GDK.KEY_Control_L = Just ( Control L ) +modifierKey GDK.KEY_Control_R = Just ( Control R ) +modifierKey GDK.KEY_Shift_L = Just ( Shift L ) +modifierKey GDK.KEY_Shift_R = Just ( Shift R ) +modifierKey GDK.KEY_Alt_L = Just ( Alt L ) +modifierKey GDK.KEY_Alt_R = Just ( Alt R ) +modifierKey _ = Nothing + +-- | Keep track of a mouse hold action: +-- +-- - start a rectangular selection, +-- - move objects by dragging, +-- - drawing a control point. +data HoldAction + = SelectionHold { holdStartPos :: !( Point2D Double ) } + | DragMoveHold { holdStartPos :: !( Point2D Double ) } + | DrawHold { holdStartPos :: !( Point2D Double ) } + deriving stock Show + +-- | Keep track of a path that is in the middle of being drawn. +data PartialPath + = PartialPath + { partialStartPos :: !( Point2D Double ) + , partialControlPoint :: !( Maybe ( Point2D Double ) ) + , partialPathAnchor :: !DrawAnchor + , firstPoint :: !Bool + } + deriving stock Show + +-------------------------------------------------------------------------------- + +-- | Read the currently active document from the stateful variables. +currentDocument :: Variables -> STM ( Maybe Document ) +currentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) + = STM.readTVar activeDocumentTVar + >>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar ) + +-- | Do something with the currently active document. +-- +-- Does nothing if no document is currently active. +withCurrentDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a ) +withCurrentDocument vars f = traverse f =<< currentDocument vars + +-- | Modify the currently active document. +-- +-- Does nothing if no document is currently active. +modifyingCurrentDocument :: Variables -> ( Document -> STM ( Maybe Document ) ) -> STM () +modifyingCurrentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) f = do + mbUnique <- STM.readTVar activeDocumentTVar + case mbUnique of + Nothing -> pure () + Just unique -> do + docs <- STM.readTVar openDocumentsTVar + for_ ( Map.lookup unique docs ) \ oldDoc -> do + mbNewDoc <- f oldDoc + for_ mbNewDoc \ newDoc -> do + STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs ) diff --git a/src/app/MetaBrush/Context.hs-boot b/src/app/MetaBrush/Context.hs-boot new file mode 100644 index 0000000..2f4046a --- /dev/null +++ b/src/app/MetaBrush/Context.hs-boot @@ -0,0 +1,9 @@ +module MetaBrush.Context + ( UIElements, Variables ) + where + +-------------------------------------------------------------------------------- + +data UIElements + +data Variables diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index fe3ab00..b70f0ce 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -8,7 +8,7 @@ module MetaBrush.Document ( AABB(..) - , Document(..), emptyDocument, currentDocument + , Document(..), emptyDocument , Stroke(..) , PointData(..), BrushPointData(..) , FocusState(..) @@ -21,10 +21,6 @@ import GHC.Generics ( Generic ) -- containers -import Data.Map.Strict - ( Map ) -import qualified Data.Map.Strict as Map - ( lookup ) import Data.Sequence ( Seq ) @@ -42,12 +38,6 @@ import Control.Lens import Data.Text ( Text ) --- stm -import qualified Control.Concurrent.STM as STM - ( atomically ) -import qualified Control.Concurrent.STM.TVar as STM - ( TVar, readTVar ) - -- MetaBrush import Math.Bezier.Stroke ( StrokePoint(..) ) @@ -108,15 +98,6 @@ _selection = field' @"pointData" . typed @FocusState _brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) ) _brush = field' @"pointData" . field' @"brushShape" -currentDocument :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) -> IO ( Maybe Document ) -currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do - mbActive <- STM.readTVar activeDocumentTVar - case mbActive of - Nothing -> pure Nothing - Just unique -> do - docs <- STM.readTVar openDocumentsTVar - pure ( Map.lookup unique docs ) - emptyDocument :: Text -> Unique -> Document emptyDocument docName unique = Document diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index f270113..47b85a8 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -6,7 +6,7 @@ module MetaBrush.Document.Draw ( DrawAnchor(..), anchorsAreComplementary - , getDrawAnchor, addToAnchor + , getOrCreateDrawAnchor, addToAnchor ) where @@ -71,8 +71,8 @@ anchorsAreComplementary ( AnchorAtEnd uniq1 ) ( AnchorAtStart uniq2 ) = True anchorsAreComplementary _ _ = False -getDrawAnchor :: UniqueSupply -> Point2D Double -> Document -> STM ( Document, DrawAnchor, Point2D Double ) -getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = +getOrCreateDrawAnchor :: UniqueSupply -> Point2D Double -> Document -> STM ( Document, DrawAnchor, Point2D Double ) +getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = case ( `runState` Nothing ) $ field' @"strokes" ( traverse updateStroke ) doc of -- Anchor found: use it. ( newDoc, Just ( anchor, anchorPt ) ) -> pure ( newDoc, anchor, anchorPt ) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 5e35149..de46a0d 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -25,8 +25,6 @@ import Data.Functor ( ($>) ) import Data.Functor.Identity ( runIdentity ) -import Data.Word - ( Word32 ) -- acts import Data.Act @@ -42,9 +40,6 @@ import Data.Generics.Product.Fields import Data.Generics.Product.Typed ( HasType ) --- gi-gdk -import qualified GI.Gdk.Constants as GDK - -- lens import Control.Lens ( view, set, over, mapped ) @@ -68,6 +63,8 @@ import Math.Module ( squaredNorm ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) +import MetaBrush.Context + ( Modifier(..) ) import MetaBrush.Document ( Document(..), Stroke(..) , FocusState(..), _selection @@ -93,13 +90,11 @@ instance Semigroup SelectionMode where instance Monoid SelectionMode where mempty = New -selectionMode :: [ Word32 ] -> SelectionMode +selectionMode :: Foldable f => f Modifier -> SelectionMode selectionMode = foldMap \case - GDK.KEY_Alt_L -> Subtract - GDK.KEY_Alt_R -> Subtract - GDK.KEY_Shift_L -> Add - GDK.KEY_Shift_R -> Add - _ -> New + Alt _ -> Subtract + Shift _ -> Subtract + _ -> New -- | Updates the selected objects on a single click selection event. selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index ff37e83..3b0efad 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -1,43 +1,14 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} module MetaBrush.Event - ( handleEvents - , HoldEvent(..), PartialPath(..) - ) + ( handleEvents ) where --- base -import Control.Monad - ( unless, guard ) -import Data.Foldable - ( for_ ) -import Data.Maybe - ( catMaybes ) -import Data.Word - ( Word32 ) - --- acts -import Data.Act - ( Act - ( (•) ) - , Torsor - ( (-->) ) - ) - --- containers -import Data.Map.Strict - ( Map ) -import qualified Data.Map.Strict as Map - ( insert, lookup ) -import Data.Sequence - ( Seq(..) ) -import qualified Data.Sequence as Seq - ( fromList ) +-- haskus-utils-variant +import Haskus.Utils.Variant + ( V, type (:<), type (:<<) ) -- gi-gdk import qualified GI.Gdk as GDK @@ -48,564 +19,87 @@ import qualified GI.Gtk as GTK -- stm import qualified Control.Concurrent.STM as STM ( atomically ) -import qualified Control.Concurrent.STM.TVar as STM - ( TVar, readTVar, readTVarIO, writeTVar, swapTVar ) +import qualified Control.Concurrent.STM.TQueue as STM + ( TQueue ) -- MetaBrush -import Math.Bezier.Stroke - ( StrokePoint(..) ) -import Math.Module - ( (*^) ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) -import MetaBrush.Document - ( Document(..), FocusState(..), PointData(..) ) -import MetaBrush.Document.Draw - ( DrawAnchor(..), getDrawAnchor, addToAnchor, anchorsAreComplementary ) -import MetaBrush.Document.Selection - ( SelectionMode(..), selectionMode - , selectAt, selectRectangle - , dragMoveSelect, translateSelection - , deleteSelected +import MetaBrush.Action + ( Actions + , MouseMove(..), MouseClick(..), MouseRelease(..) + , Scroll(..), KeyboardPress(..), KeyboardRelease(..) + , signalAction, quitEverything ) -import MetaBrush.UI.Coordinates - ( toViewportCoordinates ) -import MetaBrush.UI.InfoBar - ( InfoBar, InfoData(..), updateInfoBar ) -import MetaBrush.UI.ToolBar - ( Tool(..), Mode ) -import MetaBrush.Unique - ( UniqueSupply, Unique ) +import MetaBrush.Context + ( UIElements(..) ) -------------------------------------------------------------------------------- -handleEvents - :: UniqueSupply - -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) - -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] - -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) - -> GTK.Window -> GTK.DrawingArea -> InfoBar - -> IO () -handleEvents - uniqueSupply - activeDocumentTVar openDocumentsTVar - mousePosTVar mouseHoldTVar pressedKeysTVar - toolTVar modeTVar partialPathTVar - window viewportDrawingArea infoBar = do +handleEvents :: Actions :<< action => UIElements -> STM.TQueue ( V action ) -> IO () +handleEvents ( UIElements { window, viewportDrawingArea } ) actionTQueue = do - -- Mouse events - _ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea - ( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea infoBar ) - _ <- GTK.onWidgetScrollEvent viewportDrawingArea - ( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar ) - _ <- GTK.onWidgetButtonPressEvent viewportDrawingArea - ( handleMouseButtonEvent uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea ) - _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea - ( handleMouseButtonRelease uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea ) + -- Mouse events + _ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent actionTQueue ) + _ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent actionTQueue ) + _ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent actionTQueue ) + _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease actionTQueue ) - -- Keyboard events - _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent activeDocumentTVar openDocumentsTVar mousePosTVar pressedKeysTVar toolTVar modeTVar partialPathTVar viewportDrawingArea ) - _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) + -- Keyboard events + _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent actionTQueue ) + _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent actionTQueue ) - -- Window quit - _ <- GTK.onWidgetDestroy window GTK.mainQuit + -- Window quit + _ <- GTK.onWidgetDestroy window ( quitEverything window ) - pure () - --- | Keep track of a mouse hold event: --- --- - start a rectangular selection, --- - move objects by dragging, --- - drawing a control point. -data HoldEvent - = SelectionHold { holdStartPos :: !( Point2D Double ) } - | DragMoveHold { holdStartPos :: !( Point2D Double ) } - | DrawHold { holdStartPos :: !( Point2D Double ) } - deriving stock Show - --- | Keep track of a path that is in the middle of being drawn. -data PartialPath - = PartialPath - { partialStartPos :: !( Point2D Double ) - , partialControlPoint :: !( Maybe ( Point2D Double ) ) - , partialPathAnchor :: !DrawAnchor - , firstPoint :: !Bool - } - deriving stock Show + pure () -------------------------------------------------------------------------------- -- Mouse events. -handleMotionEvent - :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) - -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ] - -> STM.TVar Tool - -> STM.TVar ( Maybe PartialPath ) - -> GTK.DrawingArea -> InfoBar - -> GDK.EventMotion - -> IO Bool -handleMotionEvent - activeDocumentTVar openDocumentsTVar - mousePosTVar pressedKeysTVar - toolTVar - partialPathTVar - viewportDrawingArea infoBar - eventMotion - = do +handleMotionEvent :: MouseMove :< action => STM.TQueue ( V action ) -> GDK.EventMotion -> IO Bool +handleMotionEvent actionTQueue eventMotion = do + x <- GDK.getEventMotionX eventMotion + y <- GDK.getEventMotionY eventMotion + STM.atomically $ signalAction actionTQueue ( MouseMove ( Point2D x y ) ) + pure True - mbActiveDoc <- STM.readTVarIO activeDocumentTVar - for_ mbActiveDoc \ i -> do - docs <- STM.readTVarIO openDocumentsTVar - for_ ( Map.lookup i docs ) \ ( Document { .. } ) -> do +handleScrollEvent :: Scroll :< action => STM.TQueue ( V action ) -> GDK.EventScroll -> IO Bool +handleScrollEvent actionTQueue scrollEvent = do + dx <- GDK.getEventScrollDeltaX scrollEvent + dy <- GDK.getEventScrollDeltaY scrollEvent + x <- GDK.getEventScrollX scrollEvent + y <- GDK.getEventScrollY scrollEvent + STM.atomically $ signalAction actionTQueue ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) + pure False - ---------------------------------------------------------- - -- Update mouse position in info bar on mouse move event. +handleMouseButtonEvent :: MouseClick :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool +handleMouseButtonEvent actionTQueue mouseClickEvent = do + button <- GDK.getEventButtonButton mouseClickEvent + x <- GDK.getEventButtonX mouseClickEvent + y <- GDK.getEventButtonY mouseClickEvent + STM.atomically $ signalAction actionTQueue ( MouseClick button ( Point2D x y ) ) + pure False - x <- GDK.getEventMotionX eventMotion - y <- GDK.getEventMotionY eventMotion - viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - let - toViewport :: Point2D Double -> Point2D Double - toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter - pos :: Point2D Double - pos = toViewport ( Point2D x y ) - infoData :: InfoData - infoData = - InfoData - { zoom = zoomFactor - , mousePos = pos - , topLeftPos = toViewport ( Point2D 0 0 ) - , botRightPos = toViewport ( Point2D viewportWidth viewportHeight ) - } - updateInfoBar infoBar infoData - STM.atomically do - 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 - pressedKeys <- STM.readTVar pressedKeysTVar - mbPartialPath <- STM.readTVar partialPathTVar - case tool of - Pen - | any ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys - , Just pp <- mbPartialPath - -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } ) - _ -> pure () - GTK.widgetQueueDraw viewportDrawingArea - - pure True - -handleScrollEvent - :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) - -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] - -> STM.TVar Tool - -> GTK.DrawingArea -> InfoBar - -> GDK.EventScroll - -> IO Bool -handleScrollEvent - activeDocumentTVar openDocumentsTVar - mousePosTVar _mouseHoldTVar pressedKeysTVar - _toolTVar - viewportDrawingArea infoBar - scrollEvent - = do - - dx <- GDK.getEventScrollDeltaX scrollEvent - dy <- GDK.getEventScrollDeltaY scrollEvent - x <- GDK.getEventScrollX scrollEvent - y <- GDK.getEventScrollY scrollEvent - viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - - unless ( dx == 0 && dy == 0 ) do - mbActiveDoc <- STM.readTVarIO activeDocumentTVar - for_ mbActiveDoc \ i -> do - docs <- STM.readTVarIO openDocumentsTVar - for_ ( Map.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do - pressedKeys <- STM.readTVarIO pressedKeysTVar - 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 ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys - = 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 ( \ key -> key == GDK.KEY_Shift_L || key == GDK.KEY_Shift_R ) pressedKeys - = 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 } - docs' :: Map Unique Document - docs' = Map.insert i newDoc docs - 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 ) - infoData :: InfoData - infoData = InfoData - { zoom = finalZoomFactor - , mousePos = finalMousePos - , topLeftPos = toFinalViewport ( Point2D 0 0 ) - , botRightPos = toFinalViewport ( Point2D viewportWidth viewportHeight ) - } - updateInfoBar infoBar infoData - STM.atomically do - STM.writeTVar openDocumentsTVar docs' - STM.writeTVar mousePosTVar ( Just finalMousePos ) - GTK.widgetQueueDraw viewportDrawingArea - - pure False - -handleMouseButtonEvent - :: UniqueSupply - -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) - -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] - -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) - -> GTK.DrawingArea - -> GDK.EventButton - -> IO Bool -handleMouseButtonEvent - uniqueSupply - activeDocumentTVar openDocumentsTVar - mousePosTVar mouseHoldTVar pressedKeysTVar - toolTVar modeTVar partialPathTVar - viewportDrawingArea - mouseClickEvent - = do - - button <- GDK.getEventButtonButton mouseClickEvent - case button of - - -- Left mouse button. - 1 -> do - mbActiveDoc <- STM.readTVarIO activeDocumentTVar - for_ mbActiveDoc \ i -> do - docs <- STM.readTVarIO openDocumentsTVar - for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do - x <- GDK.getEventButtonX mouseClickEvent - y <- GDK.getEventButtonY mouseClickEvent - viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - let - toViewport :: Point2D Double -> Point2D Double - toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter - pos :: Point2D Double - pos = toViewport ( Point2D x y ) - - STM.atomically do - STM.writeTVar mousePosTVar ( Just pos ) - pressedKeys <- STM.readTVar pressedKeysTVar - 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 pressedKeys of - -- Drag move: not holding shift or alt, click has selected something. - New - | Just newDoc <- dragMoveSelect mode pos doc - -> do - let - newDocs :: Map Unique Document - newDocs = Map.insert i newDoc docs - STM.writeTVar openDocumentsTVar newDocs - STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos ) - -- Rectangular selection. - _ -> - STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) - - -- Pen tool: start or continue a drawing operation. - Pen -> do - mbPartialPath <- STM.readTVar partialPathTVar - case mbPartialPath of - -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). - Nothing -> do - ( newDoc, drawAnchor, anchorPt ) <- getDrawAnchor uniqueSupply pos doc - STM.writeTVar partialPathTVar - ( Just $ PartialPath - { partialStartPos = anchorPt - , partialControlPoint = Nothing - , partialPathAnchor = drawAnchor - , firstPoint = True - } - ) - let - newDocs :: Map Unique Document - newDocs = Map.insert i newDoc docs - STM.writeTVar openDocumentsTVar newDocs - -- Path already started: indicate that we are continuing a path. - Just pp -> - STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) - STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) - 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 () - - pure False - -handleMouseButtonRelease - :: UniqueSupply - -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) - -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] - -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) - -> GTK.DrawingArea - -> GDK.EventButton - -> IO Bool -handleMouseButtonRelease - uniqueSupply - activeDocumentTVar openDocumentsTVar - mousePosTVar mouseHoldTVar pressedKeysTVar - toolTVar modeTVar partialPathTVar - viewportDrawingArea - mouseReleaseEvent - = do - - button <- GDK.getEventButtonButton mouseReleaseEvent - case button of - - -- Left mouse button. - 1 -> do - mbActiveDoc <- STM.readTVarIO activeDocumentTVar - for_ mbActiveDoc \ i -> do - docs <- STM.readTVarIO openDocumentsTVar - for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do - x <- GDK.getEventButtonX mouseReleaseEvent - y <- GDK.getEventButtonY mouseReleaseEvent - viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - let - toViewport :: Point2D Double -> Point2D Double - toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter - pos :: Point2D Double - pos = toViewport ( Point2D x y ) - STM.atomically do - STM.writeTVar mousePosTVar ( Just pos ) - pressedKeys <- STM.readTVar pressedKeysTVar - mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing - tool <- STM.readTVar toolTVar - mode <- STM.readTVar modeTVar - newDoc <- case tool of - - Selection -> do - let - selMode :: SelectionMode - selMode = selectionMode pressedKeys - case mbHoldPos of - Just hold - | DragMoveHold pos0 <- hold - , pos0 /= pos - -> pure $ translateSelection mode ( pos0 --> pos ) doc - | SelectionHold pos0 <- hold - , pos0 /= pos - -> pure $ selectRectangle mode selMode pos0 pos doc - _ -> pure $ 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 doc - -- 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 ) <- getDrawAnchor 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 ( addToAnchor anchor newSegment doc ) - else - if firstPoint - -- Continue current partial path. - then do - STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False ) - pure doc - -- 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 ( addToAnchor anchor newSegment doc ) - - let - newDocs :: Map Unique Document - newDocs = Map.insert i newDoc docs - STM.writeTVar openDocumentsTVar newDocs - GTK.widgetQueueDraw viewportDrawingArea - - -- Other mouse buttons: ignored (for the moment at least). - _ -> pure () - - pure False +handleMouseButtonRelease :: MouseRelease :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool +handleMouseButtonRelease actionTQueue mouseReleaseEvent = do + button <- GDK.getEventButtonButton mouseReleaseEvent + x <- GDK.getEventButtonX mouseReleaseEvent + y <- GDK.getEventButtonY mouseReleaseEvent + STM.atomically $ signalAction actionTQueue ( MouseRelease button ( Point2D x y ) ) + pure False -------------------------------------------------------------------------------- -- Keyboard events. -handleKeyboardPressEvent - :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) - -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ] - -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) - -> GTK.DrawingArea - -> GDK.EventKey - -> IO Bool -handleKeyboardPressEvent - activeDocumentTVar openDocumentsTVar - mousePosTVar pressedKeysTVar - toolTVar modeTVar partialPathTVar - viewportDrawingArea - evt = do - keyCode <- GDK.getEventKeyKeyval evt - STM.atomically do - pressedKeys <- STM.readTVar pressedKeysTVar - STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys ) - case keyCode of - GDK.KEY_Escape -> GTK.mainQuit - 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 - mbActiveDoc <- STM.readTVarIO activeDocumentTVar - for_ mbActiveDoc \ i -> do - docs <- STM.readTVarIO openDocumentsTVar - for_ ( Map.lookup i docs ) \ doc -> do - let - newDoc :: Document - newDoc = deleteSelected mode doc - newDocs :: Map Unique Document - newDocs = Map.insert i newDoc docs - STM.atomically $ STM.writeTVar openDocumentsTVar newDocs - 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" ) - _ -> pure () - pure True - -handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool -handleKeyboardReleaseEvent pressedKeysTVar evt = do +handleKeyboardPressEvent :: KeyboardPress :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool +handleKeyboardPressEvent actionTQueue evt = do keyCode <- GDK.getEventKeyKeyval evt - STM.atomically do - pressedKeys <- STM.readTVar pressedKeysTVar - STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys ) + STM.atomically $ signalAction actionTQueue ( KeyboardPress keyCode ) + pure True + +handleKeyboardReleaseEvent :: KeyboardRelease :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool +handleKeyboardReleaseEvent actionTQueue evt = do + keyCode <- GDK.getEventKeyKeyval evt + STM.atomically $ signalAction actionTQueue ( KeyboardRelease keyCode ) pure True diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 42456e4..ba787fa 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -10,7 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module MetaBrush.Render.Document - ( renderDocument ) + ( renderDocument, blankRender ) where -- base @@ -67,6 +67,8 @@ import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Asset.Colours ( Colours, ColourRecord(..) ) +import MetaBrush.Context + ( HoldAction(..), PartialPath(..) ) import MetaBrush.Document ( Document(..) , Stroke(..), FocusState(..) @@ -75,8 +77,6 @@ import MetaBrush.Document ) import MetaBrush.Document.Selection ( translateSelection ) -import MetaBrush.Event - ( HoldEvent(..), PartialPath(..) ) import MetaBrush.UI.ToolBar ( Mode(..) ) import MetaBrush.Util @@ -104,9 +104,12 @@ toAll action = Compose ( pure action ) -------------------------------------------------------------------------------- +blankRender :: Colours -> Cairo.Render () +blankRender ( Colours { .. } ) = pure () + renderDocument :: Colours -> Mode -> ( Int32, Int32 ) - -> Maybe ( Point2D Double ) -> Maybe HoldEvent -> Maybe PartialPath + -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Document -> Cairo.Render () renderDocument diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index b0e2eff..b674e55 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -1,11 +1,14 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module MetaBrush.UI.FileBar - ( createFileBar ) + ( FileBar(..), createFileBar, newFileTab + , TabLocation(..) + ) where -- base @@ -17,8 +20,6 @@ import Data.Foldable ( for_ ) -- containers -import Data.Map.Strict - ( Map ) import qualified Data.Map.Strict as Map ( lookup, insert ) @@ -29,23 +30,21 @@ import qualified GI.Gtk as GTK import qualified Control.Concurrent.STM as STM ( atomically ) import qualified Control.Concurrent.STM.TVar as STM - ( TVar, writeTVar, readTVarIO, modifyTVar' ) + ( writeTVar, readTVarIO, modifyTVar' ) -- text import Data.Text ( Text ) -- MetaBrush -import Math.Vector2D - ( Point2D(..) ) +import MetaBrush.Context + ( Variables(..) ) import MetaBrush.Document ( Document(..), emptyDocument ) -import MetaBrush.UI.Coordinates - ( toViewportCoordinates ) -import MetaBrush.UI.InfoBar - ( InfoBar, InfoData(..), updateInfoBar ) +import {-# SOURCE #-} MetaBrush.UI.InfoBar + ( InfoBar, updateInfoBar ) import MetaBrush.Unique - ( UniqueSupply, Unique, freshUnique, uniqueText ) + ( Unique, freshUnique, uniqueText ) import MetaBrush.Util ( widgetAddClass, widgetAddClasses , (>>?=), Exists(..) @@ -53,20 +52,27 @@ import MetaBrush.Util -------------------------------------------------------------------------------- +data FileBar + = FileBar + { fileBarBox :: !GTK.Box + , fileTabsBox :: !GTK.Box + , fileBarPhantomRadioButton :: !GTK.RadioButton + } + data TabLocation = AfterCurrentTab | LastTab deriving stock Show newFileTab - :: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) - -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> GTK.Box -> GTK.RadioButton -> InfoBar + :: Variables + -> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar -> Maybe Document -> TabLocation -> IO () newFileTab - uniqueSupply activeDocumentTVar openDocumentsTVar - window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar + vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } ) + window title ( FileBar { fileTabsBox, fileBarPhantomRadioButton } ) viewportArea infoBar mbDoc newTabLoc = do @@ -158,20 +164,7 @@ newFileTab = displayName <> " – MetaBrush" GTK.labelSetText title titleText GTK.setWindowTitle window titleText - viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportArea - viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportArea - let - toViewport :: Point2D Double -> Point2D Double - toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter - infoData :: InfoData - infoData = - InfoData - { zoom = zoomFactor - , mousePos = Point2D 0 0 - , topLeftPos = toViewport ( Point2D 0 0 ) - , botRightPos = toViewport ( Point2D viewportWidth viewportHeight ) - } - updateInfoBar infoBar infoData + updateInfoBar viewportArea infoBar vars GTK.widgetQueueDraw viewportArea else do GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True @@ -186,17 +179,17 @@ newFileTab -- -- Updates the active document when buttons are clicked. createFileBar - :: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) + :: Variables -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar - -> IO GTK.Box + -> IO FileBar createFileBar - uniqueSupply activeDocumentTVar openDocumentsTVar + vars@( Variables { openDocumentsTVar } ) window title viewportArea infoBar = do -- Create file bar: box containing scrollable tabs, and a "+" button after it. - fileBar <- GTK.boxNew GTK.OrientationHorizontal 0 - widgetAddClass fileBar "fileBar" + fileBarBox <- GTK.boxNew GTK.OrientationHorizontal 0 + widgetAddClass fileBarBox "fileBar" fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment ) GTK.scrolledWindowSetPolicy fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever @@ -205,8 +198,8 @@ createFileBar newFileButton <- GTK.buttonNewWithLabel "+" widgetAddClasses newFileButton [ "newFileButton" ] - GTK.boxPackStart fileBar fileTabsScroll True True 0 - GTK.boxPackStart fileBar newFileButton False False 0 + GTK.boxPackStart fileBarBox fileTabsScroll True True 0 + GTK.boxPackStart fileBarBox newFileButton False False 0 fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0 GTK.containerAdd fileTabsScroll fileTabsBox @@ -215,18 +208,22 @@ createFileBar -- Phantom radio button for when no page is selected (e.g. no documents opened yet). fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) + let + fileBar :: FileBar + fileBar = FileBar { .. } + documents <- STM.readTVarIO openDocumentsTVar for_ documents \ doc -> newFileTab - uniqueSupply activeDocumentTVar openDocumentsTVar - window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar + vars + window title fileBar viewportArea infoBar ( Just doc ) LastTab void $ GTK.onButtonClicked newFileButton do newFileTab - uniqueSupply activeDocumentTVar openDocumentsTVar - window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar + vars + window title fileBar viewportArea infoBar Nothing LastTab diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot new file mode 100644 index 0000000..d71bb2a --- /dev/null +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -0,0 +1,41 @@ +module MetaBrush.UI.FileBar + ( FileBar(..), createFileBar, newFileTab + , TabLocation(..) + ) + where + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- MetaBrush +import {-# SOURCE #-} MetaBrush.Context + ( Variables ) +import MetaBrush.Document + ( Document ) +import {-# SOURCE #-} MetaBrush.UI.InfoBar + ( InfoBar ) + +-------------------------------------------------------------------------------- + +data FileBar + = FileBar + { fileBarBox :: !GTK.Box + , fileTabsBox :: !GTK.Box + , fileBarPhantomRadioButton :: !GTK.RadioButton + } + +data TabLocation + = AfterCurrentTab + | LastTab + +createFileBar + :: Variables + -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar + -> IO FileBar + +newFileTab + :: Variables + -> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar + -> Maybe Document + -> TabLocation + -> IO () diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 6a25abd..8a0d335 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -4,11 +4,10 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module MetaBrush.UI.InfoBar - ( InfoBar(..), createInfoBar, updateInfoBar - , InfoData(..) - ) + ( InfoBar(..), createInfoBar, updateInfoBar ) where -- base @@ -18,6 +17,8 @@ import Control.Monad ( void ) import Data.Foldable ( for_ ) +import Data.String + ( IsString ) import Numeric ( showFFloat ) @@ -31,6 +32,12 @@ import qualified GI.Cairo.Render as Cairo -- 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 + ( readTVarIO ) + -- text import qualified Data.Text as Text ( pack ) @@ -44,6 +51,14 @@ import MetaBrush.Asset.Cursor ( drawCursorIcon ) import MetaBrush.Asset.InfoBar ( drawMagnifier, drawTopLeftCornerRect ) +import MetaBrush.Context + ( Variables(..) + , currentDocument + ) +import MetaBrush.Document + ( Document(..) ) +import MetaBrush.UI.Coordinates + ( toViewportCoordinates ) import MetaBrush.Util ( widgetAddClass, widgetAddClasses ) @@ -51,17 +66,11 @@ import MetaBrush.Util data InfoBar = InfoBar - { zoomText :: !GTK.Label -- make this editable + { infoBarArea :: !GTK.Box + , zoomText :: !GTK.Label -- make this editable , cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label } -data InfoData - = InfoData - { zoom :: !Double - , mousePos, topLeftPos, botRightPos :: !( Point2D Double ) - } - deriving stock Show - -- | Add the UI elements for the info bar: -- -- * current zoom level, @@ -69,9 +78,10 @@ data InfoData -- * current viewport extent (top left and bottom right corner coordinates). -- -- Returns the GTK label widgets, so that the information can be updated. -createInfoBar :: Colours -> GTK.Box -> IO InfoBar -createInfoBar colours infoBar = do - widgetAddClasses infoBar [ "infoBar", "monospace", "contrast" ] +createInfoBar :: Colours -> IO InfoBar +createInfoBar colours = do + infoBarArea <- GTK.boxNew GTK.OrientationHorizontal 0 + widgetAddClasses infoBarArea [ "infoBar", "monospace", "contrast" ] zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0 cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 @@ -79,7 +89,7 @@ createInfoBar colours infoBar = do botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do - GTK.boxPackEnd infoBar box False False 0 + GTK.boxPackEnd infoBarArea box False False 0 widgetAddClass box "infoBarBox" ------------- @@ -151,20 +161,36 @@ createInfoBar colours infoBar = do pure ( InfoBar { .. } ) -updateInfoBar :: InfoBar -> InfoData -> IO () -updateInfoBar - ( InfoBar { .. } ) - ( InfoData - { zoom - , mousePos = Point2D mx my - , topLeftPos = Point2D l t - , botRightPos = Point2D r b - } - ) = do - GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoom ) <> "%" ) - GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> fixed 6 2 mx <> "\ny: " <> fixed 6 2 my ) - GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> fixed 6 2 l <> "\ny: " <> fixed 6 2 t ) - GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> fixed 6 2 r <> "\ny: " <> fixed 6 2 b ) +updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO () +updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePosTVar } ) + = do + viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea + viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea + mbDoc <- STM.atomically $ currentDocument vars + let + na :: IsString a => a + na = " n/a" + case mbDoc of + Nothing -> do + GTK.labelSetText zoomText $ na + GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na ) + GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na ) + GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na ) + Just ( Document { zoomFactor, viewportCenter } ) -> do + let + toViewport :: Point2D Double -> Point2D Double + toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter + Point2D l t = toViewport ( Point2D 0 0 ) + Point2D r b = toViewport ( Point2D viewportWidth viewportHeight ) + mbMousePos <- fmap toViewport <$> STM.readTVarIO mousePosTVar + GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" ) + case mbMousePos of + Just ( Point2D mx my ) -> + GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> fixed 6 2 mx <> "\ny: " <> fixed 6 2 my ) + Nothing -> + GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na ) + GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> fixed 6 2 l <> "\ny: " <> fixed 6 2 t ) + GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> fixed 6 2 r <> "\ny: " <> fixed 6 2 b ) fixed :: Int -> Int -> Double -> String fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFloat ( Just digitsAfter ) x "" of diff --git a/src/app/MetaBrush/UI/InfoBar.hs-boot b/src/app/MetaBrush/UI/InfoBar.hs-boot new file mode 100644 index 0000000..bb825d7 --- /dev/null +++ b/src/app/MetaBrush/UI/InfoBar.hs-boot @@ -0,0 +1,25 @@ +module MetaBrush.UI.InfoBar + ( InfoBar(..), createInfoBar, updateInfoBar ) + where + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- MetaBrush +import MetaBrush.Asset.Colours + ( Colours ) +import {-# SOURCE #-} MetaBrush.Context + ( Variables ) + +-------------------------------------------------------------------------------- + +data InfoBar + = InfoBar + { infoBarArea :: !GTK.Box + , zoomText :: !GTK.Label + , cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label + } + +createInfoBar :: Colours -> IO InfoBar + +updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO () diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index d102d52..0b1a612 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -56,6 +56,8 @@ import Control.Monad.IO.Class ( MonadIO(liftIO) ) -- MetaBrush +import MetaBrush.Action + ( quitEverything ) import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Asset.WindowIcons @@ -319,7 +321,7 @@ createMenuBar colours window titleBar = do --------------------------------------------------------- -- Actions - _ <- GTK.onButtonClicked closeButton GTK.mainQuit + _ <- GTK.onButtonClicked closeButton ( quitEverything window ) _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) _ <- GTK.onButtonClicked fullscreenButton do Just gdkWindow <- GTK.widgetGetWindow window