From 91e14313068f94a8c19fe9a9c8187bb04ca85b21 Mon Sep 17 00:00:00 2001 From: sheaf Date: Fri, 14 Aug 2020 00:47:10 +0200 Subject: [PATCH] add selection UI --- MetaBrush.cabal | 6 +- app/Main.hs | 24 +- assets/theme.css | 7 +- src/app/MetaBrush/Asset/Colours.hs | 4 + src/app/MetaBrush/Document.hs | 4 + src/app/MetaBrush/Document/Selection.hs | 21 ++ src/app/MetaBrush/Event.hs | 399 +++++++++++++++++------- src/app/MetaBrush/Render/Document.hs | 35 ++- src/app/MetaBrush/Time.hs | 75 +++++ src/app/MetaBrush/UI/Coordinates.hs | 45 ++- src/app/MetaBrush/UI/ToolBar.hs | 48 ++- src/app/MetaBrush/UI/Viewport.hs | 12 +- src/lib/Math/Bezier/Cubic.hs | 8 +- src/lib/Math/Module.hs | 28 +- src/lib/Math/Vector2D.hs | 4 +- 15 files changed, 560 insertions(+), 160 deletions(-) create mode 100644 src/app/MetaBrush/Document/Selection.hs create mode 100644 src/app/MetaBrush/Time.hs diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 4d0ea3c..f2fcde0 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -30,6 +30,8 @@ common common >= 4.13 && < 4.16 , acts ^>= 0.3.1.0 + , groups + ^>= 0.4.1.0 default-language: Haskell2010 @@ -66,8 +68,6 @@ library build-depends: generic-data >= 0.8.0.0 && < 0.8.4.0 - , groups - ^>= 0.4.1.0 , groups-generic ^>= 0.1.0.0 @@ -92,9 +92,11 @@ executable MetaBrush , MetaBrush.Asset.Tools , MetaBrush.Asset.WindowIcons , MetaBrush.Document + , MetaBrush.Document.Selection , MetaBrush.Event , MetaBrush.Render.Document , MetaBrush.Render.Util + , MetaBrush.Time , MetaBrush.UI.Coordinates , MetaBrush.UI.FileBar , MetaBrush.UI.InfoBar diff --git a/app/Main.hs b/app/Main.hs index 344ba9b..c14d96a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -58,11 +58,14 @@ import MetaBrush.Asset.Logo import MetaBrush.Document ( Document(..), AABB(..) , Stroke(..), StrokePoint(..), PointType(..), FocusState(..) + , Overlay ) import MetaBrush.Event ( handleEvents ) import MetaBrush.Render.Util ( widgetAddClass, widgetAddClasses ) +import MetaBrush.Time + ( Time ) import MetaBrush.UI.FileBar ( createFileBar ) import MetaBrush.UI.InfoBar @@ -72,7 +75,7 @@ import MetaBrush.UI.Menu import MetaBrush.UI.Panels ( createPanelBar ) import MetaBrush.UI.ToolBar - ( createToolBar ) + ( Tool(..), Mode(..), createToolBar ) import MetaBrush.UI.Viewport ( Viewport(..), createViewport ) import qualified Paths_MetaBrush as Cabal @@ -140,9 +143,14 @@ main = do --------------------------------------------------------- -- Initialise state - activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing - openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments - pressedKeysTVar <- STM.newTVarIO @[ Word32 ] [] + activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing + openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments + mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing + mouseHoldTVar <- STM.newTVarIO @( Maybe ( Point2D Double, Time ) ) Nothing + pressedKeysTVar <- STM.newTVarIO @[ Word32 ] [] + toolTVar <- STM.newTVarIO @Tool Selection + modeTVar <- STM.newTVarIO @Mode Path + overlayTVar <- STM.newTVarIO @( Maybe Overlay ) Nothing --------------------------------------------------------- -- Initialise GTK @@ -251,7 +259,7 @@ main = do --------------------------------------------------------- -- Tool bar - _ <- createToolBar colours toolBar + _ <- createToolBar toolTVar modeTVar colours toolBar --------------------------------------------------------- -- Main viewport @@ -261,6 +269,7 @@ main = do colours activeDocumentTVar openDocumentsTVar + overlayTVar viewportGrid --------------------------------------------------------- @@ -290,7 +299,10 @@ main = do -- Actions handleEvents - activeDocumentTVar openDocumentsTVar pressedKeysTVar + activeDocumentTVar openDocumentsTVar + mousePosTVar mouseHoldTVar pressedKeysTVar + toolTVar modeTVar + overlayTVar window viewportDrawingArea infoBarElements --------------------------------------------------------- diff --git a/assets/theme.css b/assets/theme.css index 0ace876..22bef04 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -72,7 +72,12 @@ .glass { color: rgba(156, 231, 255, 0.5); } - +.selection { + color: rgba(161,201,236,0.5) +} +.selectionOutline { + color: rgb(74,150,218); +} /* Proper CSS styling */ diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index 538ee21..83fa322 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -51,6 +51,8 @@ data ColourRecord a , tabScrollbar :: !a , magnifier :: !a , glass :: !a + , selection :: !a + , selectionOutline :: !a } deriving stock ( Show, Functor, Foldable, Traversable ) @@ -90,6 +92,8 @@ colourNames = Colours , tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ] , glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ] + , selection = ColourName "selection" Colour [ GTK.StateFlagsNormal ] + , selectionOutline = ColourName "selectionOutline" Colour [ GTK.StateFlagsNormal ] } type Colours = ColourRecord GDK.RGBA diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index bb75cf6..dfc31ac 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -72,6 +72,10 @@ data FocusState | Selected deriving stock Show +data Overlay + = SelectionRectangle !( Point2D Double ) !( Point2D Double ) + deriving stock Show + currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document ) currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do mbActive <- STM.readTVar activeDocumentTVar diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs new file mode 100644 index 0000000..479af12 --- /dev/null +++ b/src/app/MetaBrush/Document/Selection.hs @@ -0,0 +1,21 @@ +module MetaBrush.Document.Selection + ( selectAt, selectRectangle ) + where + +-- base +import Data.Word + ( Word32 ) + +-- MetaBrush +import Math.Vector2D + ( Point2D(..) ) +import MetaBrush.Document + ( Document(..) ) + +-------------------------------------------------------------------------------- + +selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document +selectAt _ _ doc = doc + +selectRectangle :: [ Word32 ] -> Point2D Double -> Point2D Double -> Document -> Document +selectRectangle _ _ _ doc = doc diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index cfc72eb..e0b3f56 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -11,9 +11,6 @@ import Control.Monad ( unless ) import Data.Foldable ( for_ ) --- base -import Data.Semigroup - ( Arg(..), Min(..) ) import Data.Word ( Word32 ) @@ -38,10 +35,12 @@ import qualified GI.Gdk as GDK import qualified GI.Gtk as GTK -- stm +import Control.Concurrent.STM + ( STM ) import qualified Control.Concurrent.STM as STM ( atomically ) import qualified Control.Concurrent.STM.TVar as STM - ( TVar, readTVar, readTVarIO, writeTVar ) + ( TVar, readTVar, readTVarIO, writeTVar, swapTVar ) -- MetaBrush import Math.Module @@ -49,139 +48,311 @@ import Math.Module import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Document - ( Document(..), currentDocument ) + ( Document(..), Overlay(..) ) +import MetaBrush.Document.Selection + ( selectAt, selectRectangle ) +import MetaBrush.Time + ( Time, monotonicTime, DTime(DSeconds) ) import MetaBrush.UI.Coordinates - ( closestPoint, toViewportCoordinates ) + ( toViewportCoordinates ) import MetaBrush.UI.InfoBar ( InfoBar, InfoData(..), updateInfoBar ) +import MetaBrush.UI.ToolBar + ( Tool(..), Mode ) -------------------------------------------------------------------------------- -handleEvents :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.Window -> GTK.DrawingArea -> InfoBar -> IO () -handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewportDrawingArea infoBar = do +handleEvents + :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) + -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ] + -> STM.TVar Tool -> STM.TVar Mode + -> STM.TVar ( Maybe Overlay ) + -> GTK.Window -> GTK.DrawingArea -> InfoBar + -> IO () +handleEvents + activeDocumentTVar openDocumentsTVar + mousePosTVar mouseHoldTVar pressedKeysTVar + toolTVar _modeTVar + overlayTVar + window viewportDrawingArea infoBar = do - -- Mouse events - _ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea - ( handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar ) - _ <- GTK.onWidgetScrollEvent viewportDrawingArea - ( handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar ) + -- Mouse events + _ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea + ( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar ) + _ <- GTK.onWidgetScrollEvent viewportDrawingArea + ( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea infoBar ) + _ <- GTK.onWidgetButtonPressEvent viewportDrawingArea + ( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea ) + _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea + ( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea ) - -- Keyboard events - _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar ) - _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) + -- Keyboard events + _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar ) + _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) - -- Window quit - _ <- GTK.onWidgetDestroy window GTK.mainQuit + -- Window quit + _ <- GTK.onWidgetDestroy window GTK.mainQuit - pure () + pure () -------------------------------------------------------------------------------- -- Mouse events. -handleMotionEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> GTK.DrawingArea -> InfoBar -> GDK.EventMotion -> IO Bool -handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar eventMotion = do - - mbActiveDoc <- STM.readTVarIO activeDocumentTVar - for_ mbActiveDoc \ i -> do - docs <- STM.readTVarIO openDocumentsTVar - for_ ( IntMap.lookup i docs ) \ doc@( Document { .. } ) -> do - - ---------------------------------------------------------- - -- Update mouse position in info bar on mouse move event. - - 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 - - pure True +handleMotionEvent + :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) + -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) + -> STM.TVar Tool + -> STM.TVar ( Maybe Overlay ) + -> GTK.DrawingArea -> InfoBar + -> GDK.EventMotion + -> IO Bool +handleMotionEvent + activeDocumentTVar openDocumentsTVar + mousePosTVar mouseHoldTVar + toolTVar + overlayTVar + viewportDrawingArea infoBar + eventMotion + = do -handleScrollEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.DrawingArea -> InfoBar -> GDK.EventScroll -> IO Bool -handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar 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_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do - pressedKeys <- STM.readTVarIO pressedKeysTVar + for_ ( IntMap.lookup i docs ) \ ( Document { .. } ) -> do + + ---------------------------------------------------------- + -- Update mouse position in info bar on mouse move event. + + 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 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 == Control_L || 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 == Shift_L || key == Shift_R ) pressedKeys - = let - newCenter :: Point2D Double - newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • oldCenter - in doc { viewportCenter = newCenter } - -- Vertical scrolling. - | otherwise - = let - newCenter :: Point2D Double - newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • oldCenter - in doc { viewportCenter = newCenter } - docs' :: IntMap Document - docs' = IntMap.insert i newDoc docs - STM.atomically ( STM.writeTVar openDocumentsTVar docs' ) + 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 ) + + ---------------------------------------------------------- + -- Tool dependent updating. + updateOverlay mouseHoldTVar toolTVar overlayTVar pos + + GTK.widgetQueueDraw viewportDrawingArea - let - newZoomFactor :: Double - newZoomFactor = zoomFactor newDoc - newCenter :: Point2D Double - newCenter = viewportCenter newDoc - toNewViewport :: Point2D Double -> Point2D Double - toNewViewport = toViewportCoordinates newZoomFactor ( viewportWidth, viewportHeight ) newCenter - infoData :: InfoData - infoData = InfoData - { zoom = zoomFactor newDoc - , mousePos - , topLeftPos = toNewViewport ( Point2D 0 0 ) - , botRightPos = toNewViewport ( Point2D viewportWidth viewportHeight ) - } - updateInfoBar infoBar infoData + pure True - pure False +handleScrollEvent + :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) + -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ] + -> STM.TVar Tool -> STM.TVar ( Maybe Overlay ) + -> GTK.DrawingArea -> InfoBar + -> GDK.EventScroll + -> IO Bool +handleScrollEvent + activeDocumentTVar openDocumentsTVar + mousePosTVar mouseHoldTVar pressedKeysTVar + toolTVar overlayTVar + 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_ ( IntMap.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 == Control_L || 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 == Shift_L || key == Shift_R ) pressedKeys + = let + newCenter :: Point2D Double + newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • oldCenter + in doc { viewportCenter = newCenter } + -- Vertical scrolling. + | otherwise + = let + newCenter :: Point2D Double + newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • oldCenter + in doc { viewportCenter = newCenter } + docs' :: IntMap Document + docs' = IntMap.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 ) + updateOverlay mouseHoldTVar toolTVar overlayTVar finalMousePos + GTK.widgetQueueDraw viewportDrawingArea + + pure False + +handleMouseButtonEvent + :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) + -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ] + -> GTK.DrawingArea + -> GDK.EventButton + -> IO Bool +handleMouseButtonEvent + activeDocumentTVar openDocumentsTVar + mousePosTVar mouseHoldTVar _pressedKeysTVar + 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_ ( IntMap.lookup i docs ) \ ( 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 ) + time <- monotonicTime + STM.atomically do + STM.writeTVar mousePosTVar ( Just pos ) + STM.writeTVar mouseHoldTVar ( Just ( pos, time ) ) + _ -> pure () + + pure False + +handleMouseButtonRelease + :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) + -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ] + -> STM.TVar Tool + -> STM.TVar ( Maybe Overlay ) + -> GTK.DrawingArea + -> GDK.EventButton + -> IO Bool +handleMouseButtonRelease + activeDocumentTVar openDocumentsTVar + mousePosTVar mouseHoldTVar pressedKeysTVar + toolTVar + overlayTVar + 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_ ( IntMap.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 ) + t <- monotonicTime + STM.atomically do + pressedKeys <- STM.readTVar pressedKeysTVar + mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing + STM.writeTVar overlayTVar Nothing + tool <- STM.readTVar toolTVar + let + newDoc :: Document + newDoc = case tool of + Selection + | Just ( pos0, t0 ) <- mbHoldPos + , pos0 /= pos + , ( t0 --> t ) > DSeconds 0.3 + -> selectRectangle pressedKeys pos0 pos doc + | otherwise + -> selectAt pressedKeys pos doc + Pen -> doc -- TODO + newDocs :: IntMap Document + newDocs = IntMap.insert i newDoc docs + STM.writeTVar openDocumentsTVar newDocs + STM.writeTVar mousePosTVar ( Just pos ) + GTK.widgetQueueDraw viewportDrawingArea + + -- any other mouse button: no action (for the moment) + _ -> pure () + + pure False + +updateOverlay :: STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar Tool -> STM.TVar ( Maybe Overlay ) -> Point2D Double -> STM () +updateOverlay mouseHoldTVar toolTVar overlayTVar p = do + tool <- STM.readTVar toolTVar + case tool of + -- Draw selection rectangle if performing a selection. + Selection -> do + mbHold <- STM.readTVar mouseHoldTVar + case mbHold of + Just ( p0, _ ) -> STM.writeTVar overlayTVar ( Just ( SelectionRectangle p0 p ) ) + Nothing -> STM.writeTVar overlayTVar Nothing + -- Pen tool: show preview (TODO). + Pen -> STM.writeTVar overlayTVar Nothing -------------------------------------------------------------------------------- -- Keyboard events. diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 4f02cc2..e4a7d14 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -11,7 +11,7 @@ module MetaBrush.Render.Document -- base import Data.Foldable - ( traverse_ ) + ( for_, traverse_ ) import Data.Functor.Compose ( Compose(..) ) import Data.Int @@ -32,6 +32,7 @@ import MetaBrush.Asset.Colours import MetaBrush.Document ( Document(..) , Stroke(..), StrokePoint(..), PointType(..), FocusState(..) + , Overlay(..) ) import MetaBrush.Render.Util ( withRGBA ) @@ -55,8 +56,8 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints -------------------------------------------------------------------------------- -renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render () -renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do +renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render () +renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do Cairo.save Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight ) @@ -64,9 +65,10 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente Cairo.translate ( -cx ) ( -cy ) let - Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes - renderPaths - renderPoints + Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes + rdrPaths + rdrPoints + for_ mbOverlay ( renderOverlay cols zoomFactor ) Cairo.restore @@ -244,3 +246,24 @@ drawCubicBezier ( Colours { path } ) zoom Cairo.stroke Cairo.restore + + +renderOverlay :: Colours -> Double -> Overlay -> Cairo.Render () +renderOverlay ( Colours { .. } ) zoom ( SelectionRectangle ( Point2D x0 y0 ) ( Point2D x1 y1 ) ) = do + + Cairo.save + + Cairo.moveTo x0 y0 + Cairo.lineTo x1 y0 + Cairo.lineTo x1 y1 + Cairo.lineTo x0 y1 + Cairo.closePath + + Cairo.setLineWidth ( 1 / zoom ) + withRGBA selection Cairo.setSourceRGBA + Cairo.fillPreserve + + withRGBA selectionOutline Cairo.setSourceRGBA + Cairo.stroke + + Cairo.restore diff --git a/src/app/MetaBrush/Time.hs b/src/app/MetaBrush/Time.hs new file mode 100644 index 0000000..5a87e3f --- /dev/null +++ b/src/app/MetaBrush/Time.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} + +module MetaBrush.Time + ( Time(..), DTime(DSeconds, ..), dSeconds + , pprSeconds + , monotonicTime + ) + where + +-- base +import Data.Int + ( Int64 ) +import Data.Semigroup + ( Sum(..) ) + +-- acts +import Data.Act + ( Act, Torsor ) + +-- gi-glib +import qualified GI.GLib.Functions as GLib + ( getMonotonicTime ) + +-- groups +import Data.Group + ( Group ) + +-- transformers +import Control.Monad.IO.Class + ( MonadIO ) + +-------------------------------------------------------------------------------- + +newtype Time = Seconds { seconds :: Double } + deriving newtype ( Eq, Ord ) + deriving stock Show + deriving ( Act DTime, Torsor DTime ) + via DTime + +newtype DTime = DTime { dTime :: Time } + deriving stock Show + deriving newtype ( Eq, Ord ) + deriving ( Semigroup, Monoid, Group ) + via ( Sum Double ) + +{-# COMPLETE DSeconds #-} +pattern DSeconds :: Double -> DTime +pattern DSeconds secs = DTime ( Seconds secs ) + +dSeconds :: DTime -> Double +dSeconds ( DSeconds secs ) = secs + +pprSeconds :: ( String, String, String ) -> Time -> String +pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute + where + pm :: String + pm + | secs <= (-1) = "-" + | otherwise = "" + h, r, m, s :: Int64 + (h,r) = ( round $ abs secs ) `divMod` 3600 + (m,s) = r `divMod` 60 + fixed2 :: String -> String + fixed2 [] = "00" + fixed2 [x] = ['0', x] + fixed2 xs = xs + absolute + | h > 0 = show h <> h_name <> fixed2 (show m) <> m_name <> fixed2 (show s) <> s_name + | m > 0 = show m <> m_name <> fixed2 (show s) <> s_name + | otherwise = show s <> s_name + +monotonicTime :: MonadIO m => m Time +monotonicTime = Seconds . ( * 1e-6 ) . fromIntegral <$> GLib.getMonotonicTime diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 2520ca7..c64dbab 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -18,14 +18,16 @@ import Data.Act ) -- MetaBrush +import qualified Math.Bezier.Cubic as Cubic + ( Bezier(..), closestPoint ) import qualified Math.Bezier.Quadratic as Quadratic ( Bezier(..), closestPoint ) import Math.Module - ( (*^), squaredNorm ) + ( (*^), squaredNorm, closestPointToLine ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Document - ( Stroke(..) ) + ( Stroke(..), StrokePoint(..), PointType(..) ) -------------------------------------------------------------------------------- @@ -36,15 +38,32 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente • viewportCenter -- | Find the closest point in a set of strokes. -closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Point2D Double ) -closestPoint = undefined -{- -closestPoint c ( Stroke pts ) = go pts +closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) ) +closestPoint c ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } ) = go pt0 pts where - go :: [ Point2D Double ] -> ArgMin Double ( Point2D Double ) - go [] = error "'closestPoint': empty stroke" - go [p] = Min ( Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) p ) - go (p0:p1:p2:ps) - = fmap ( fmap snd ) ( Quadratic.closestPoint @(Vector2D Double) ( Quadratic.Bezier { .. } ) c ) - <> go (p2:ps) --} \ No newline at end of file + res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) ) + res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p ) + go :: StrokePoint -> [ StrokePoint ] -> ArgMin Double ( Maybe ( Point2D Double ) ) + go p0 [] = res ( strokePoint p0 ) + -- Line. + go p0 ( p1 : ps ) + | PathPoint <- pointType p1 + = res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) ) + <> go p1 ps + -- Quadratic Bézier curve. + go p0 ( p1 : p2 : ps ) + | ControlPoint <- pointType p1 + , PathPoint <- pointType p2 + = fmap ( fmap ( Just . snd ) ) + ( Quadratic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Quadratic.Bezier { .. } ) c ) + <> go p2 ps + -- Cubic Bézier curve. + go p0 ( p1 : p2 : p3 : ps ) + | ControlPoint <- pointType p1 + , ControlPoint <- pointType p1 + , PathPoint <- pointType p3 + = fmap ( fmap ( Just . snd ) ) + ( Cubic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Cubic.Bezier { .. } ) c ) + <> go p3 ps + go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 : ps ) +closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index c3802ba..f9acbe4 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module MetaBrush.UI.ToolBar - ( ToolBar(..), createToolBar ) + ( Tool(..), Mode(..) + , ToolBar(..), createToolBar + ) where -- base @@ -20,6 +23,12 @@ import qualified GI.Cairo.Render.Connector 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 + ( TVar, writeTVar ) + -- MetaBrush import MetaBrush.Asset.Colours ( Colours ) @@ -32,6 +41,17 @@ import MetaBrush.Render.Util -------------------------------------------------------------------------------- +data Tool + = Selection + | Pen + deriving stock Show + +data Mode + = Path + | Brush + | Meta + deriving stock Show + data ToolBar = ToolBar { selectionTool :: !GTK.RadioButton @@ -41,8 +61,8 @@ data ToolBar , metaTool :: !GTK.RadioButton } -createToolBar :: Colours -> GTK.Box -> IO ToolBar -createToolBar colours toolBar = do +createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.Box -> IO ToolBar +createToolBar toolTVar modeTVar colours toolBar = do widgetAddClass toolBar "toolBar" @@ -52,11 +72,23 @@ createToolBar colours toolBar = do selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool ) + _ <- GTK.onButtonClicked selectionTool + ( STM.atomically $ STM.writeTVar toolTVar Selection ) + _ <- GTK.onButtonClicked penTool + ( STM.atomically $ STM.writeTVar toolTVar Pen ) + + toolSep1 <- GTK.boxNew GTK.OrientationVertical 0 + pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) - toolSep1 <- GTK.boxNew GTK.OrientationVertical 0 + _ <- GTK.onButtonClicked pathTool + ( STM.atomically $ STM.writeTVar modeTVar Path ) + _ <- GTK.onButtonClicked brushTool + ( STM.atomically $ STM.writeTVar modeTVar Brush ) + _ <- GTK.onButtonClicked metaTool + ( STM.atomically $ STM.writeTVar modeTVar Meta ) GTK.boxPackStart toolBar selectionTool True True 0 GTK.boxPackStart toolBar penTool True True 0 diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 0cdb5a1..753fed2 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -30,13 +30,15 @@ import qualified GI.Gtk as GTK -- stm import qualified Control.Concurrent.STM.TVar as STM - ( TVar ) + ( TVar, readTVarIO ) -- MetaBrush import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Document - ( Document(..), currentDocument ) + ( Document(..), currentDocument + , Overlay + ) import MetaBrush.Render.Document ( renderDocument ) import MetaBrush.Render.Util @@ -53,9 +55,10 @@ createViewport :: Colours -> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) + -> STM.TVar ( Maybe Overlay ) -> GTK.Grid -> IO Viewport -createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do +createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do widgetAddClass viewportGrid "viewport" @@ -142,11 +145,12 @@ createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do -- Get the relevant document information mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar + mbOverlay <- STM.readTVarIO overlayTVar for_ mbDoc \ doc -> do ( `Cairo.renderWithContext` ctx ) $ do viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea - renderDocument colours ( viewportWidth, viewportHeight ) doc + renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay pure True pure ( Viewport { .. } ) diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index 6c3f14f..38c6888 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/lib/Math/Bezier/Cubic.hs @@ -20,6 +20,8 @@ module Math.Bezier.Cubic -- base import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Semigroup + ( ArgMin, Min(..), Arg(..) ) import GHC.Generics ( Generic ) @@ -82,7 +84,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 ) pt = lerp @v t q2 r1 -- | Finds the closest point to a given point on a cubic Bézier curve. -closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ( r, p ) +closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p ) closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots ) where roots :: [ r ] @@ -102,14 +104,14 @@ closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots ) a4 = 5 * v'' ^.^ v''' a5 = squaredNorm v''' - pickClosest :: NonEmpty r -> ( r, p ) + pickClosest :: NonEmpty r -> ArgMin r ( r, p ) pickClosest ( s :| ss ) = go s q nm0 ss where q :: p q = bezier @v pts s nm0 :: r nm0 = squaredNorm ( c --> q :: v ) - go t p _ [] = ( t, p ) + go t p nm [] = Min ( Arg nm ( t, p ) ) go t p nm ( t' : ts ) | nm' < nm = go t' p' nm' ts | otherwise = go t p nm ts diff --git a/src/lib/Math/Module.hs b/src/lib/Math/Module.hs index 96c8ca1..fca6d9f 100644 --- a/src/lib/Math/Module.hs +++ b/src/lib/Math/Module.hs @@ -6,6 +6,7 @@ module Math.Module ( Module(..), lerp , Inner(..), squaredNorm + , proj, projC, closestPointToLine ) where @@ -44,5 +45,30 @@ class Module r m => Inner r m where (^.^) :: m -> m -> r -- | Squared norm of a vector, computed using the inner product. -squaredNorm :: Inner r m => m -> r +squaredNorm :: forall m r. Inner r m => m -> r squaredNorm v = v ^.^ v + +-- | Projects the first argument onto the second. +proj :: forall m r. ( Inner r m, Fractional r ) => m -> m -> m +proj x y = projC x y *^ y + +-- | Projection constant: how far along the projection of the first vector lands along the second vector. +projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r +projC x y = x ^.^ y / squaredNorm y + +closestPointToLine + :: forall v r p + . ( Inner r v, Torsor v p, Fractional r, Ord r ) + => p -> p -> p -> p +closestPointToLine c p0 p1 + | t <= 0 + = p0 + | t >= 1 + = p1 + | otherwise + = ( t *^ v01 ) • p0 + where + v01 :: v + v01 = p0 --> p1 + t :: r + t = projC ( p0 --> c ) v01 diff --git a/src/lib/Math/Vector2D.hs b/src/lib/Math/Vector2D.hs index 13fed86..1f2accc 100644 --- a/src/lib/Math/Vector2D.hs +++ b/src/lib/Math/Vector2D.hs @@ -37,12 +37,12 @@ import Math.Module -------------------------------------------------------------------------------- data Point2D a = Point2D !a !a - deriving stock ( Show, Generic, Functor, Foldable, Traversable ) + deriving stock ( Show, Eq, Generic, Functor, Foldable, Traversable ) deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) ) via Vector2D a newtype Vector2D a = Vector2D { tip :: Point2D a } - deriving stock ( Show, Functor, Foldable, Traversable ) + deriving stock ( Show, Eq, Functor, Foldable, Traversable ) deriving ( Semigroup, Monoid, Group ) via GenericProduct ( Point2D ( Sum a ) )