diff --git a/MetaBrush.cabal b/MetaBrush.cabal index cc194cc..26fad70 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -94,7 +94,13 @@ executable MetaBrush , MetaBrush.Event , MetaBrush.Render.Document , MetaBrush.Render.Util + , MetaBrush.UI.Coordinates + , MetaBrush.UI.FileBar + , MetaBrush.UI.InfoBar , MetaBrush.UI.Menu + , MetaBrush.UI.Panels + , MetaBrush.UI.ToolBar + , MetaBrush.UI.Viewport , Paths_MetaBrush autogen-modules: diff --git a/app/Main.hs b/app/Main.hs index 29ad652..0e02bac 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,9 +1,6 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -15,9 +12,7 @@ module Main -- base import Control.Monad - ( void, unless ) -import Data.Foldable - ( for_ ) + ( void ) import Data.Int ( Int32 ) import Data.Word @@ -25,17 +20,11 @@ import Data.Word import System.Exit ( exitSuccess ) --- acts -import Data.Act - ( Act - ( (•) ) - ) - -- containers import Data.IntMap.Strict ( IntMap ) import qualified Data.IntMap.Strict as IntMap - ( fromList, lookup, insert, traverseWithKey ) + ( fromList ) -- directory import qualified System.Directory as Directory @@ -45,9 +34,6 @@ import qualified System.Directory as Directory import qualified GI.Cairo.Render.Connector as Cairo ( renderWithContext ) --- gi-cairo-render -import qualified GI.Cairo.Render as Cairo - -- gi-gdk import qualified GI.Gdk as GDK @@ -55,48 +41,43 @@ import qualified GI.Gdk as GDK import qualified GI.Gtk as GTK -- stm -import qualified Control.Concurrent.STM as STM - ( atomically ) import qualified Control.Concurrent.STM.TVar as STM - ( newTVarIO, writeTVar, readTVarIO ) + ( newTVarIO ) -- text import qualified Data.Text as Text ( pack ) -- MetaBrush -import Math.Module - ( (*^) ) import Math.Vector2D - ( Point2D(..), Vector2D(..) ) + ( Point2D(..) ) import MetaBrush.Asset.Colours ( getColours ) -import MetaBrush.Asset.Cursor - ( drawCursorIcon ) -import MetaBrush.Asset.InfoBar - ( drawMagnifier, drawTopLeftCornerRect ) import MetaBrush.Asset.Logo ( drawLogo ) -import MetaBrush.Asset.Tools - ( drawBrush, drawMeta, drawPath, drawPen ) -import MetaBrush.Asset.WindowIcons - ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) import MetaBrush.Document ( Document(..) , AABB(..) , Stroke(..) ) import MetaBrush.Event - ( handleKeyboardPressEvent, handleKeyboardReleaseEvent - , pattern Control_L, pattern Control_R - , pattern Shift_L, pattern Shift_R - ) -import MetaBrush.Render.Document - ( renderDocument ) + ( handleKeyboardPressEvent, handleKeyboardReleaseEvent ) import MetaBrush.Render.Util ( widgetAddClass, widgetAddClasses ) +import MetaBrush.UI.Coordinates + ( keepViewportCoordinatesUpdated ) +import MetaBrush.UI.FileBar + ( createFileBar ) +import MetaBrush.UI.InfoBar + ( createInfoBar ) import MetaBrush.UI.Menu - ( newMenuBar ) + ( createMenuBar ) +import MetaBrush.UI.Panels + ( createPanelBar ) +import MetaBrush.UI.ToolBar + ( createToolBar ) +import MetaBrush.UI.Viewport + ( Viewport(..), createViewport ) import qualified Paths_MetaBrush as Cabal ( getDataFileName ) @@ -109,7 +90,11 @@ testDocuments = IntMap.fromList { displayName = "Document 1" , filePath = Nothing , unsavedChanges = False - , strokes = [ Stroke [ Point2D 10 10, Point2D 30 30, Point2D 40 70 ] ] + , strokes = [ Stroke [ Point2D 0 0 ] + , Stroke [ Point2D 100 0, Point2D 105 0, Point2D 110 0 ] + , Stroke [ Point2D 0 100 ] + , Stroke [ Point2D 100 100, Point2D 105 105, Point2D 110 100 ] + ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , viewportCenter = Point2D 50 50 , zoomFactor = 1 @@ -230,488 +215,64 @@ main = do ------------ -- Menu bar - ( menuBar, _menu ) <- newMenuBar - widgetAddClasses menuBar [ "menuBar", "text", "plain" ] - GTK.boxPackStart titleBar menuBar False False 0 + _ <- createMenuBar colours window titleBar - -- TODO: this is a bit of a workaround to add hover highlight to top-level menu items. - -- Activating a menu somehow sets the "hover" setting, - -- so instead we use the "selected" setting for actual hover highlighting. - topLevelMenuItems <- GTK.containerGetChildren menuBar - for_ topLevelMenuItems \ topLevelMenuItem -> do - void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do - flags <- GTK.widgetGetStateFlags topLevelMenuItem - GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True - pure False - void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do - flags <- GTK.widgetGetStateFlags topLevelMenuItem - GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True - pure False + ------------ + -- Title - windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0 - widgetAddClasses windowIcons [ "windowIcon" ] - GTK.boxPackEnd titleBar windowIcons False False 0 - - title <- GTK.labelNew ( Just "● New Document (1) – MetaBrush" ) + title <- GTK.labelNew ( Just "MetaBrush" ) widgetAddClasses title [ "text", "title", "plain" ] GTK.boxSetCenterWidget titleBar ( Just title ) - minimiseButton <- GTK.buttonNew - fullscreenButton <- GTK.buttonNew - closeButton <- GTK.buttonNew - - GTK.boxPackStart windowIcons minimiseButton True True 0 - GTK.boxPackStart windowIcons fullscreenButton True True 0 - GTK.boxPackStart windowIcons closeButton True True 0 - - minimiseArea <- GTK.drawingAreaNew - fullscreenArea <- GTK.drawingAreaNew - closeArea <- GTK.drawingAreaNew - - GTK.containerAdd minimiseButton minimiseArea - GTK.containerAdd fullscreenButton fullscreenArea - GTK.containerAdd closeButton closeArea - - void $ GTK.onWidgetDraw minimiseArea - $ Cairo.renderWithContext - ( drawMinimise colours ) - - void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do - Just gdkWindow <- GTK.widgetGetWindow window - windowState <- GDK.windowGetState gdkWindow - if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState - then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext - else Cairo.renderWithContext ( drawMaximise colours ) cairoContext - - void $ GTK.onWidgetDraw closeArea - $ Cairo.renderWithContext - ( drawClose colours ) - - for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do - widgetAddClass button "windowIcon" - - widgetAddClass closeButton "closeWindowIcon" - --------------------------------------------------------- -- Tool bar - widgetAddClass toolBar "toolBar" + _ <- createToolBar colours toolBar - GTK.widgetSetValign toolBar GTK.AlignStart - GTK.widgetSetVexpand toolBar True - - selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) - penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool ) - - pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) - brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) - metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) - - toolSep1 <- GTK.boxNew GTK.OrientationVertical 0 - - GTK.boxPackStart toolBar selectionTool True True 0 - GTK.boxPackStart toolBar penTool True True 0 - GTK.boxPackStart toolBar toolSep1 True True 0 - GTK.boxPackStart toolBar pathTool True True 0 - GTK.boxPackStart toolBar brushTool True True 0 - GTK.boxPackStart toolBar metaTool True True 0 - - for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do - GTK.toggleButtonSetMode tool False -- don't display radio indicator - widgetAddClass tool "toolItem" - - widgetAddClass toolSep1 "toolBarSeparator" - - GTK.widgetSetTooltipText selectionTool ( Just "Select" ) - GTK.widgetSetTooltipText penTool ( Just "Draw" ) - GTK.widgetSetTooltipText pathTool ( Just "Brush path" ) - GTK.widgetSetTooltipText brushTool ( Just "Brushes" ) - GTK.widgetSetTooltipText metaTool ( Just "Meta-parameters" ) - - selectionToolArea <- GTK.drawingAreaNew - penToolArea <- GTK.drawingAreaNew - pathToolArea <- GTK.drawingAreaNew - brushToolArea <- GTK.drawingAreaNew - metaToolArea <- GTK.drawingAreaNew - - GTK.containerAdd selectionTool selectionToolArea - GTK.containerAdd penTool penToolArea - GTK.containerAdd pathTool pathToolArea - GTK.containerAdd brushTool brushToolArea - GTK.containerAdd metaTool metaToolArea - - void $ GTK.onWidgetDraw selectionToolArea - $ Cairo.renderWithContext - ( drawCursorIcon colours ) - - void $ GTK.onWidgetDraw penToolArea - $ Cairo.renderWithContext - ( drawPen colours ) - - void $ GTK.onWidgetDraw pathToolArea - $ Cairo.renderWithContext - ( drawPath colours ) - - void $ GTK.onWidgetDraw brushToolArea - $ Cairo.renderWithContext - ( drawBrush colours ) - - void $ GTK.onWidgetDraw metaToolArea - $ Cairo.renderWithContext - ( drawMeta colours ) - ---------------------------------------------------------- + --------------------------------------------------------- -- Main viewport - widgetAddClass viewportGrid "viewport" - - rvRulerCorner <- GTK.revealerNew - rvLeftRuler <- GTK.revealerNew - rvTopRuler <- GTK.revealerNew - viewportOverlay <- GTK.overlayNew - - GTK.gridAttach viewportGrid rvRulerCorner 0 0 1 1 - GTK.gridAttach viewportGrid rvLeftRuler 0 1 1 1 - GTK.gridAttach viewportGrid rvTopRuler 1 0 1 1 - GTK.gridAttach viewportGrid viewportOverlay 1 1 1 1 - - ---------- - -- Rulers - - rulerCorner <- GTK.boxNew GTK.OrientationVertical 0 - leftRuler <- GTK.boxNew GTK.OrientationVertical 0 - topRuler <- GTK.boxNew GTK.OrientationHorizontal 0 - - GTK.containerAdd rvRulerCorner rulerCorner - GTK.containerAdd rvLeftRuler leftRuler - GTK.containerAdd rvTopRuler topRuler - - widgetAddClass rulerCorner "ruler" - widgetAddClass leftRuler "ruler" - widgetAddClass topRuler "ruler" - - GTK.revealerSetRevealChild rvRulerCorner True - GTK.revealerSetRevealChild rvLeftRuler True - GTK.revealerSetRevealChild rvTopRuler True - - GTK.revealerSetTransitionType rvRulerCorner GTK.RevealerTransitionTypeSlideLeft - GTK.revealerSetTransitionType rvLeftRuler GTK.RevealerTransitionTypeSlideLeft - GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp - - rulerCornerArea <- GTK.drawingAreaNew - GTK.boxPackStart rulerCorner rulerCornerArea True True 0 - - leftRulerArea <- GTK.drawingAreaNew - GTK.boxPackStart leftRuler leftRulerArea True True 0 - - topRulerArea <- GTK.drawingAreaNew - GTK.boxPackStart topRuler topRulerArea True True 0 - - GTK.widgetSetHexpand rulerCorner False - GTK.widgetSetVexpand rulerCorner False - GTK.widgetSetHexpand leftRuler False - GTK.widgetSetVexpand leftRuler True - GTK.widgetSetHexpand topRuler True - GTK.widgetSetVexpand topRuler False - GTK.widgetSetHexpand viewportOverlay True - GTK.widgetSetVexpand viewportOverlay True - - viewportArea <- GTK.drawingAreaNew - GTK.setContainerChild viewportOverlay viewportArea - - ----------------- - -- Viewport scrolling - - viewportScrollbarGrid <- GTK.gridNew - GTK.overlayAddOverlay viewportOverlay viewportScrollbarGrid - GTK.overlaySetOverlayPassThrough viewportOverlay viewportScrollbarGrid True - - viewportHScrollbar <- GTK.scrollbarNew GTK.OrientationHorizontal ( Nothing @GTK.Adjustment ) - viewportVScrollbar <- GTK.scrollbarNew GTK.OrientationVertical ( Nothing @GTK.Adjustment ) - GTK.widgetSetValign viewportHScrollbar GTK.AlignEnd - GTK.widgetSetHalign viewportVScrollbar GTK.AlignEnd - GTK.widgetSetVexpand viewportVScrollbar True - GTK.widgetSetHexpand viewportHScrollbar True - GTK.gridAttach viewportScrollbarGrid viewportHScrollbar 0 1 1 1 - GTK.gridAttach viewportScrollbarGrid viewportVScrollbar 1 0 1 1 - widgetAddClass viewportHScrollbar "viewportScrollbar" - widgetAddClass viewportVScrollbar "viewportScrollbar" - - void $ GTK.onWidgetScrollEvent viewportArea \ scrollEvent -> do - - dx <- GDK.getEventScrollDeltaX scrollEvent - dy <- GDK.getEventScrollDeltaY scrollEvent - --GDK.getEventScrollDirection scrollEvent - --GDK.getEventScrollType scrollEvent - --GDK.getEventScrollX scrollEvent - --GDK.getEventScrollY scrollEvent - - 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, zoomFactor } ) ) -> do - pressedKeys <- STM.readTVarIO pressedKeysTVar - let - newDoc :: Document - newDoc - -- Zooming using 'Control'. - | any ( \ key -> key == Control_L || key == Control_R ) pressedKeys - = let - newZoomFactor :: Double - newZoomFactor - | dy > 0 - = max 0.0078125 ( zoomFactor / 2 ) - | otherwise - = zoomFactor * 2 - in doc { zoomFactor = newZoomFactor } - -- 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 / zoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • viewportCenter - in doc { viewportCenter = newCenter } - -- Vertical scrolling. - | otherwise - = let - newCenter :: Point2D Double - newCenter = ( ( 25 / zoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • viewportCenter - in doc { viewportCenter = newCenter } - docs' :: IntMap Document - docs' = IntMap.insert i newDoc docs - STM.atomically ( STM.writeTVar openDocumentsTVar docs' ) - GTK.widgetQueueDraw viewportArea - pure True - - ----------------- - -- Rendering - - void $ GTK.onWidgetDraw viewportArea \ctx -> do - -- Get the relevant document information - mbActiveDoc <- STM.readTVarIO activeDocumentTVar - for_ mbActiveDoc \ i -> do - docs <- STM.readTVarIO openDocumentsTVar - for_ ( IntMap.lookup i docs ) \ doc -> do - ( `Cairo.renderWithContext` ctx ) $ do - viewportWidth <- GTK.widgetGetAllocatedWidth viewportArea - viewportHeight <- GTK.widgetGetAllocatedHeight viewportArea - renderDocument colours ( viewportWidth, viewportHeight ) doc - pure True - - --------------------------------------------------------- - -- File bar - - widgetAddClass fileBar "fileBar" - - fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0 - GTK.containerAdd fileBar fileTabs - widgetAddClasses fileTabs [ "fileBar", "plain", "text" ] - - fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) - - -- TODO: currently using static list of documents. - -- Need to dynamically update this widget as the user opens/closes documents. - fileButtons <- ( `IntMap.traverseWithKey` testDocuments ) \ i ( Document { displayName, unsavedChanges } ) -> do - -- File tab elements. - pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) displayName - GTK.toggleButtonSetMode pgButton False -- don't display radio indicator - closeFileButton <- GTK.buttonNewWithLabel "x" - - -- Create box for file tab elements. - tab <- GTK.boxNew GTK.OrientationHorizontal 0 - widgetAddClasses tab [ "fileBarTab" ] - GTK.boxPackStart fileTabs tab False False 0 - GTK.boxPackStart tab pgButton True True 0 - GTK.boxPackStart tab closeFileButton False False 0 - - widgetAddClasses pgButton [ "fileBarTabButton" ] - widgetAddClasses closeFileButton [ "fileBarCloseButton" ] - - -- Make both file tab elements activate styling on the whole tab - -- (e.g. hovering over the close file button should highlight the whole tab). - void $ GTK.onButtonClicked pgButton do - isActive <- GTK.toggleButtonGetActive pgButton - flags <- GTK.widgetGetStateFlags tab - if isActive - then do - GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True - STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) ) - GTK.widgetQueueDraw viewportArea - else - GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True - -{- - void $ GTK.onButtonClicked closeFileButton do - closeFileDialog ... --} - - for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do - void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do - flags <- GTK.widgetGetStateFlags tab - GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True - pure False - void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do - flags <- GTK.widgetGetStateFlags tab - GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True - pure False - - pure pgButton - - GTK.scrolledWindowSetPolicy fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever - GTK.scrolledWindowSetOverlayScrolling fileBar True - - --------------------------------------------------------- - -- Panels - - widgetAddClass panelBox "panels" - - pane1 <- GTK.panedNew GTK.OrientationVertical - GTK.boxPackStart panelBox pane1 True True 0 - - panels1 <- GTK.notebookNew - panels2 <- GTK.notebookNew - - GTK.notebookSetGroupName panels1 ( Just "Panel" ) - GTK.notebookSetGroupName panels2 ( Just "Panel" ) - - GTK.panedPack1 pane1 panels1 True True - GTK.panedPack2 pane1 panels2 True True - - strokesPanel <- GTK.boxNew GTK.OrientationVertical 0 - brushesPanel <- GTK.boxNew GTK.OrientationVertical 0 - transformPanel <- GTK.boxNew GTK.OrientationVertical 0 - - strokesTab <- GTK.labelNew ( Just "Strokes" ) - brushesTab <- GTK.labelNew ( Just "Brushes" ) - transformTab <- GTK.labelNew ( Just "Transform" ) - - for_ [ strokesTab, brushesTab, transformTab ] \ tab -> do - widgetAddClasses tab [ "plain", "text", "panelTab" ] - - for_ [ strokesPanel, brushesPanel, transformPanel ] \ panel -> do - widgetAddClass panel "panel" - - void $ GTK.notebookAppendPage panels1 strokesPanel ( Just strokesTab ) - void $ GTK.notebookAppendPage panels1 brushesPanel ( Just brushesTab ) - - void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab ) - - GTK.notebookSetTabReorderable panels1 strokesPanel True - GTK.notebookSetTabDetachable panels1 strokesPanel True - GTK.notebookSetTabReorderable panels1 brushesPanel True - GTK.notebookSetTabDetachable panels1 brushesPanel True - - GTK.notebookSetTabReorderable panels2 transformPanel True - GTK.notebookSetTabDetachable panels2 transformPanel True - - strokesContent <- GTK.labelNew ( Just "Strokes tab content..." ) - brushesContent <- GTK.labelNew ( Just "Brushes tab content..." ) - transformContent <- GTK.labelNew ( Just "Transform tab content..." ) - - GTK.boxPackStart strokesPanel strokesContent True True 0 - GTK.boxPackStart brushesPanel brushesContent True True 0 - GTK.boxPackStart transformPanel transformContent True True 0 + Viewport { viewportDrawingArea } <- + createViewport + colours + activeDocumentTVar + openDocumentsTVar + viewportGrid --------------------------------------------------------- -- Info bar - widgetAddClasses infoBar [ "infoBar", "monospace", "contrast" ] + infoBarElements <- createInfoBar colours infoBar - zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0 - cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 - topLeftPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 - botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 + keepViewportCoordinatesUpdated + activeDocumentTVar + openDocumentsTVar + pressedKeysTVar + infoBarElements + viewportDrawingArea - for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do - GTK.boxPackEnd infoBar box False False 0 - widgetAddClass box "infoBarBox" + --------------------------------------------------------- + -- File bar - ------------- - -- Magnifier + _ <- + createFileBar + activeDocumentTVar + openDocumentsTVar + window + title + viewportDrawingArea + fileBar - magnifierArea <- GTK.drawingAreaNew - zoomText <- GTK.labelNew ( Just "300%" ) + --------------------------------------------------------- + -- Panels - GTK.boxPackStart zoomBox magnifierArea True True 0 - GTK.boxPackStart zoomBox zoomText True True 0 - - void $ GTK.onWidgetDraw magnifierArea \ctx -> - ( `Cairo.renderWithContext` ctx ) $ do - Cairo.scale 0.9 0.9 - Cairo.translate 14 10 - drawMagnifier colours - - ------------------- - -- Cursor position - - cursorPosArea <- GTK.drawingAreaNew - cursorPosText <- GTK.labelNew ( Just "x: 212.12 px\ny: 120.23 px" ) - - GTK.boxPackStart cursorPosBox cursorPosArea False False 0 - GTK.boxPackStart cursorPosBox cursorPosText False False 0 - - void $ GTK.onWidgetDraw cursorPosArea \ctx -> - ( `Cairo.renderWithContext` ctx ) $ do - Cairo.scale 0.75 0.75 - Cairo.translate 10 7 - drawCursorIcon colours - - --------------------- - -- Top left position - - topLeftPosArea <- GTK.drawingAreaNew - topLeftPosText <- GTK.labelNew ( Just "x: 212.12 px\ny: 120.23 px" ) - - GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0 - GTK.boxPackStart topLeftPosBox topLeftPosText False False 0 - - void $ GTK.onWidgetDraw topLeftPosArea - $ Cairo.renderWithContext - ( drawTopLeftCornerRect colours ) - - ------------------------- - -- Bottom right position - - botRightPosArea <- GTK.drawingAreaNew - botRightPosText <- GTK.labelNew ( Just "x: 212.12 px\ny: 120.23 px" ) - - GTK.boxPackStart botRightPosBox botRightPosArea False False 0 - GTK.boxPackStart botRightPosBox botRightPosText False False 0 - - void $ GTK.onWidgetDraw botRightPosArea \ctx -> - ( `Cairo.renderWithContext` ctx ) $ do - Cairo.scale -1 -1 - Cairo.translate -40 -40 - drawTopLeftCornerRect colours - - ------------------------- - - for_ [ magnifierArea, cursorPosArea, topLeftPosArea, botRightPosArea ] \ area -> do - widgetAddClass area "infoBarIcon" - GTK.widgetSetSizeRequest area 40 40 -- not sure why this is needed...? - - for_ [ zoomText, cursorPosText, topLeftPosText, botRightPosText ] \ info -> do - widgetAddClass info "infoBarInfo" + createPanelBar panelBox --------------------------------------------------------- -- Actions GTK.widgetAddEvents window [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ] - GTK.widgetAddEvents viewportArea - [ GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask ] - - _ <- GTK.onButtonClicked closeButton GTK.mainQuit - _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) - _ <- GTK.onButtonClicked fullscreenButton do - Just gdkWindow <- GTK.widgetGetWindow window - windowState <- GDK.windowGetState gdkWindow - if GDK.WindowStateFullscreen `elem` windowState - then GTK.windowUnfullscreen window - else - if GDK.WindowStateMaximized `elem` windowState - then GTK.windowUnmaximize window - else GTK.windowMaximize window _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar ) _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) @@ -724,9 +285,3 @@ main = do GTK.main exitSuccess - ---------------------------------------------------------- --- Utils. - -data Exists c where - Exists :: c a => a -> Exists c diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index 8e7c3bc..d08f610 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -1,6 +1,4 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 85c990e..9a031df 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -1,12 +1,25 @@ -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE MultiParamTypeClasses #-} module MetaBrush.Document where +-- containers +import Data.IntMap.Strict + ( IntMap ) +import qualified Data.IntMap.Strict as IntMap + ( lookup ) + -- text 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.Vector2D ( Point2D ) @@ -36,3 +49,13 @@ data Stroke = Stroke { strokePoints :: ![ 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 + case mbActive of + Nothing -> pure Nothing + Just i -> do + docs <- STM.readTVar openDocumentsTVar + pure ( IntMap.lookup i docs ) diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs new file mode 100644 index 0000000..3f212cf --- /dev/null +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module MetaBrush.UI.Coordinates + ( keepViewportCoordinatesUpdated ) + where + +-- base +import Control.Monad + ( unless, void ) +import Data.Foldable + ( for_ ) +import Data.Word + ( Word32 ) + +-- acts +import Data.Act + ( Act + ( (•) ) + , Torsor + ( (-->) ) + ) + +-- containers +import Data.IntMap.Strict + ( IntMap ) +import qualified Data.IntMap.Strict as IntMap + ( insert, lookup ) + +-- gi-gdk +import qualified GI.Gdk as GDK + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- stm +import qualified Control.Concurrent.STM as STM + ( atomically ) +import qualified Control.Concurrent.STM.TVar as STM + ( TVar, readTVarIO, writeTVar ) + +-- MetaBrush +import Math.Module + ( (*^) ) +import Math.Vector2D + ( Point2D(..), Vector2D(..) ) +import MetaBrush.Document + ( Document(..), currentDocument ) +import MetaBrush.Event + ( pattern Control_L, pattern Control_R + , pattern Shift_L, pattern Shift_R + ) +import MetaBrush.UI.InfoBar + ( InfoBar, InfoData(..), updateInfoBar ) + +-------------------------------------------------------------------------------- + +-- | Updates viewport coordinates on mouse motion / mouse scroll. +-- +-- * On a scroll event, modifies the viewport coordinates as required. +-- * On a scroll event or a mouse motion event, updates the info bar coordinate display. +keepViewportCoordinatesUpdated + :: STM.TVar ( Maybe Int ) + -> STM.TVar ( IntMap Document ) + -> STM.TVar [ Word32 ] + -> InfoBar + -> GTK.DrawingArea + -> IO () +keepViewportCoordinatesUpdated + activeDocumentTVar + openDocumentsTVar + pressedKeysTVar + infoBar + viewportDrawingArea = do + + ----------------------------------------------------------------- + -- Update mouse position on mouse move event. + + void $ GTK.onWidgetMotionNotifyEvent viewportDrawingArea \ eventMotion -> do + mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar + infoData <- case mbDoc of + Nothing -> + pure $ + InfoData + { zoom = 1 + , mousePos = Point2D 0 0 + , topLeftPos = Point2D 0 0 + , botRightPos = Point2D 0 0 + } + Just ( Document { .. } ) -> do + 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 + pure $ + InfoData + { zoom = zoomFactor + , mousePos = toViewport ( Point2D x y ) + , topLeftPos = toViewport ( Point2D 0 0 ) + , botRightPos = toViewport ( Point2D viewportWidth viewportHeight ) + } + + updateInfoBar infoBar infoData + pure False + + ----------------------------------------------------------------- + -- Update coordinates on scroll event. + + void $ GTK.onWidgetScrollEvent viewportDrawingArea \ 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 / 2 ) + | otherwise + = oldZoomFactor * 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' ) + 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 + + +toViewportCoordinates :: Double -> ( Double, Double ) -> Point2D Double -> Point2D Double -> Point2D Double +toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( Point2D x y ) + = ( recip zoomFactor *^ ( Point2D ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> Point2D x y :: Vector2D Double ) ) + • viewportCenter diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs new file mode 100644 index 0000000..daf4361 --- /dev/null +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module MetaBrush.UI.FileBar + ( createFileBar ) + where + +-- base +import Control.Monad + ( void ) +import Data.Foldable + ( for_ ) + +-- containers +import Data.IntMap.Strict + ( IntMap ) +import qualified Data.IntMap.Strict as IntMap + ( lookup, traverseWithKey ) + +-- 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, readTVarIO ) + +-- text +import Data.Text + ( Text ) + +-- MetaBrush +import MetaBrush.Document + ( Document(..) ) +import MetaBrush.Render.Util + ( widgetAddClass, widgetAddClasses ) + +-------------------------------------------------------------------------------- + +-- | Add the file bar: tabs allowing selection of the active document. +createFileBar + :: STM.TVar ( Maybe Int ) + -> STM.TVar ( IntMap Document ) + -> GTK.Window + -> GTK.Label + -> GTK.DrawingArea + -> GTK.ScrolledWindow + -> IO ( IntMap GTK.RadioButton ) +createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fileBar = do + + widgetAddClass fileBar "fileBar" + + fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0 + GTK.containerAdd fileBar fileTabs + widgetAddClasses fileTabs [ "fileBar", "plain", "text" ] + + fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) + + -- TODO: currently using static list of documents. + -- Need to dynamically update this widget as the user opens/closes documents. + documents <- STM.readTVarIO openDocumentsTVar + fileButtons <- ( `IntMap.traverseWithKey` documents ) \ i ( Document { displayName, unsavedChanges } ) -> do + -- File tab elements. + pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) displayName + GTK.toggleButtonSetMode pgButton False -- don't display radio indicator + closeFileButton <- GTK.buttonNewWithLabel "x" + + -- Create box for file tab elements. + tab <- GTK.boxNew GTK.OrientationHorizontal 0 + widgetAddClasses tab [ "fileBarTab" ] + GTK.boxPackStart fileTabs tab False False 0 + GTK.boxPackStart tab pgButton True True 0 + GTK.boxPackStart tab closeFileButton False False 0 + + widgetAddClasses pgButton [ "fileBarTabButton" ] + widgetAddClasses closeFileButton [ "fileBarCloseButton" ] + + -- Make both file tab elements activate styling on the whole tab + -- (e.g. hovering over the close file button should highlight the whole tab). + void $ GTK.onButtonClicked pgButton do + isActive <- GTK.toggleButtonGetActive pgButton + flags <- GTK.widgetGetStateFlags tab + if isActive + then do + GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True + STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) ) + GTK.widgetQueueDraw viewportArea + mbActiveDoc <- IntMap.lookup i <$> STM.readTVarIO openDocumentsTVar + case mbActiveDoc of + Nothing -> do + GTK.labelSetText title "MetaBrush" + GTK.setWindowTitle window "MetaBrush" + Just ( Document { displayName, unsavedChanges } ) -> do + let + titleText :: Text + titleText + | unsavedChanges + = "● " <> displayName <> " – MetaBrush" + | otherwise + = displayName <> " – MetaBrush" + GTK.labelSetText title titleText + GTK.setWindowTitle window titleText + else do + GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True + GTK.labelSetText title "MetaBrush" + GTK.setWindowTitle window "MetaBrush" + +{- + void $ GTK.onButtonClicked closeFileButton do + closeFileDialog ... +-} + + for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do + void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do + flags <- GTK.widgetGetStateFlags tab + GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True + pure False + void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do + flags <- GTK.widgetGetStateFlags tab + GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True + pure False + + pure pgButton + + GTK.scrolledWindowSetPolicy fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever + GTK.scrolledWindowSetOverlayScrolling fileBar True + + pure fileButtons + +--------------------------------------------------------- +-- Util. + +data Exists c where + Exists :: c a => a -> Exists c diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs new file mode 100644 index 0000000..2302c95 --- /dev/null +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module MetaBrush.UI.InfoBar + ( InfoBar(..), createInfoBar, updateInfoBar + , InfoData(..) + ) + where + +-- base +import Control.Monad + ( void ) +import Data.Foldable + ( for_ ) + +-- gi-cairo-connector +import qualified GI.Cairo.Render.Connector as Cairo + ( renderWithContext ) + +-- gi-cairo-render +import qualified GI.Cairo.Render as Cairo + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- text +import qualified Data.Text as Text + ( pack ) + +-- MetaBrush +import Math.Vector2D + ( Point2D(..), Vector2D(..) ) +import MetaBrush.Asset.Colours + ( Colours ) +import MetaBrush.Asset.Cursor + ( drawCursorIcon ) +import MetaBrush.Asset.InfoBar + ( drawMagnifier, drawTopLeftCornerRect ) +import MetaBrush.Render.Util + ( widgetAddClass, widgetAddClasses ) + +-------------------------------------------------------------------------------- + +data InfoBar + = InfoBar + { zoomText :: !GTK.Label -- make this editable + , cursorPosText :: !GTK.Label + , topLeftPosText :: !GTK.Label + , botRightPosText :: !GTK.Label + } + +data InfoData + = InfoData + { zoom :: !Double + , mousePos :: !( Point2D Double ) + , topLeftPos :: !( Point2D Double ) + , botRightPos :: !( Point2D Double ) + } + deriving stock Show + +-- | Add the UI elements for the info bar: +-- +-- * current zoom level, +-- * current cursor position, +-- * 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" ] + + zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0 + cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 + topLeftPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 + botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 + + for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do + GTK.boxPackEnd infoBar box False False 0 + widgetAddClass box "infoBarBox" + + ------------- + -- Magnifier + + magnifierArea <- GTK.drawingAreaNew + zoomText <- GTK.labelNew ( Just "100%" ) + + GTK.boxPackStart zoomBox magnifierArea True True 0 + GTK.boxPackStart zoomBox zoomText True True 0 + + void $ GTK.onWidgetDraw magnifierArea \ ctx -> + ( `Cairo.renderWithContext` ctx ) $ do + Cairo.scale 0.9 0.9 + Cairo.translate 14 10 + drawMagnifier colours + + ------------------- + -- Cursor position + + cursorPosArea <- GTK.drawingAreaNew + cursorPosText <- GTK.labelNew ( Just "x: 50.00 px\ny: 50.00 px" ) + + GTK.boxPackStart cursorPosBox cursorPosArea False False 0 + GTK.boxPackStart cursorPosBox cursorPosText False False 0 + + void $ GTK.onWidgetDraw cursorPosArea \ ctx -> + ( `Cairo.renderWithContext` ctx ) $ do + Cairo.scale 0.75 0.75 + Cairo.translate 10 7 + drawCursorIcon colours + + --------------------- + -- Top left position + + topLeftPosArea <- GTK.drawingAreaNew + topLeftPosText <- GTK.labelNew ( Just "x: 0.00 px\ny: 0.00 px" ) + + GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0 + GTK.boxPackStart topLeftPosBox topLeftPosText False False 0 + + void $ GTK.onWidgetDraw topLeftPosArea + $ Cairo.renderWithContext + ( drawTopLeftCornerRect colours ) + + ------------------------- + -- Bottom right position + + botRightPosArea <- GTK.drawingAreaNew + botRightPosText <- GTK.labelNew ( Just "x: 100.00 px\ny: 100.00 px" ) + + GTK.boxPackStart botRightPosBox botRightPosArea False False 0 + GTK.boxPackStart botRightPosBox botRightPosText False False 0 + + void $ GTK.onWidgetDraw botRightPosArea \ ctx -> + ( `Cairo.renderWithContext` ctx ) $ do + Cairo.scale -1 -1 + Cairo.translate -40 -40 + drawTopLeftCornerRect colours + + ------------------------- + + for_ [ magnifierArea, cursorPosArea, topLeftPosArea, botRightPosArea ] \ area -> do + widgetAddClass area "infoBarIcon" + GTK.widgetSetSizeRequest area 40 40 -- not sure why this is needed...? + + for_ [ zoomText, cursorPosText, topLeftPosText, botRightPosText ] \ info -> do + widgetAddClass info "infoBarInfo" + + 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 ( show ( 100 * zoom ) <> "%" ) + GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> show mx <> "\ny: " <> show my ) + GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> show l <> "\ny: " <> show t ) + GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> show r <> "\ny: " <> show b ) + diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 51c8703..bc89344 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} @@ -18,12 +19,13 @@ module MetaBrush.UI.Menu , FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..) , ResourceType(..) , MenuItem(..) + , createMenuBar ) where -- base import Control.Monad - ( unless ) + ( void, unless ) import Data.Foldable ( for_ ) import Data.Kind @@ -35,6 +37,13 @@ import GHC.Generics import Data.Generics.Product.Constraints ( HasConstraints(constraints) ) +-- gi-cairo-connector +import qualified GI.Cairo.Render.Connector as Cairo + ( renderWithContext ) + +-- gi-gdk +import qualified GI.Gdk as GDK + -- gi-gtk import qualified GI.Gtk as GTK @@ -47,8 +56,12 @@ import Control.Monad.IO.Class ( MonadIO(liftIO) ) -- MetaBrush +import MetaBrush.Asset.Colours + ( Colours ) +import MetaBrush.Asset.WindowIcons + ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) import MetaBrush.Render.Util - ( widgetAddClasses ) + ( widgetAddClass, widgetAddClasses ) -------------------------------------------------------------------------------- -- Types for describing menu items. @@ -252,3 +265,86 @@ newMenuBar = do ( createMenuItem ( GTK.menuShellAppend menuBar ) ) menuDescription pure ( menuBar, menu ) + +-------------------------------------------------------------------------------- +-- Creating the menu bar from its declarative specification. + +-- | Add the menu bar to the given box (title bar box). +createMenuBar :: Colours -> GTK.Window -> GTK.Box -> IO ( Menu Object ) +createMenuBar colours window titleBar = do + ( menuBar, menu ) <- newMenuBar + widgetAddClasses menuBar [ "menuBar", "text", "plain" ] + GTK.boxPackStart titleBar menuBar False False 0 + + -- TODO: this is a bit of a workaround to add hover highlight to top-level menu items. + -- Activating a menu somehow sets the "hover" setting, + -- so instead we use the "selected" setting for actual hover highlighting. + topLevelMenuItems <- GTK.containerGetChildren menuBar + for_ topLevelMenuItems \ topLevelMenuItem -> do + void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do + flags <- GTK.widgetGetStateFlags topLevelMenuItem + GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True + pure False + void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do + flags <- GTK.widgetGetStateFlags topLevelMenuItem + GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True + pure False + + windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0 + widgetAddClasses windowIcons [ "windowIcon" ] + GTK.boxPackEnd titleBar windowIcons False False 0 + + minimiseButton <- GTK.buttonNew + fullscreenButton <- GTK.buttonNew + closeButton <- GTK.buttonNew + + GTK.boxPackStart windowIcons minimiseButton True True 0 + GTK.boxPackStart windowIcons fullscreenButton True True 0 + GTK.boxPackStart windowIcons closeButton True True 0 + + minimiseArea <- GTK.drawingAreaNew + fullscreenArea <- GTK.drawingAreaNew + closeArea <- GTK.drawingAreaNew + + GTK.containerAdd minimiseButton minimiseArea + GTK.containerAdd fullscreenButton fullscreenArea + GTK.containerAdd closeButton closeArea + + void $ GTK.onWidgetDraw minimiseArea + $ Cairo.renderWithContext + ( drawMinimise colours ) + + void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do + Just gdkWindow <- GTK.widgetGetWindow window + windowState <- GDK.windowGetState gdkWindow + if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState + then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext + else Cairo.renderWithContext ( drawMaximise colours ) cairoContext + + void $ GTK.onWidgetDraw closeArea + $ Cairo.renderWithContext + ( drawClose colours ) + + for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do + widgetAddClass button "windowIcon" + + widgetAddClass closeButton "closeWindowIcon" + + --------------------------------------------------------- + -- Actions + + _ <- GTK.onButtonClicked closeButton GTK.mainQuit + _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) + _ <- GTK.onButtonClicked fullscreenButton do + Just gdkWindow <- GTK.widgetGetWindow window + windowState <- GDK.windowGetState gdkWindow + if GDK.WindowStateFullscreen `elem` windowState + then GTK.windowUnfullscreen window + else + if GDK.WindowStateMaximized `elem` windowState + then GTK.windowUnmaximize window + else GTK.windowMaximize window + + --------------------------------------------------------- + + pure menu diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs new file mode 100644 index 0000000..12ba853 --- /dev/null +++ b/src/app/MetaBrush/UI/Panels.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +module MetaBrush.UI.Panels + ( createPanelBar ) + where + +-- base +import Control.Monad + ( void ) +import Data.Foldable + ( for_ ) + +-- gi-cairo-connector +import qualified GI.Cairo.Render.Connector as Cairo + ( renderWithContext ) + +-- gi-cairo-render +import qualified GI.Cairo.Render as Cairo + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- MetaBrush +import MetaBrush.Asset.Colours + ( Colours ) +import MetaBrush.Render.Util + ( widgetAddClass, widgetAddClasses ) + +-------------------------------------------------------------------------------- + +-- | Creates the right hand side panel UI. +createPanelBar :: GTK.Box -> IO () +createPanelBar panelBox = do + + widgetAddClass panelBox "panels" + + pane1 <- GTK.panedNew GTK.OrientationVertical + GTK.boxPackStart panelBox pane1 True True 0 + + panels1 <- GTK.notebookNew + panels2 <- GTK.notebookNew + + GTK.notebookSetGroupName panels1 ( Just "Panel" ) + GTK.notebookSetGroupName panels2 ( Just "Panel" ) + + GTK.panedPack1 pane1 panels1 True True + GTK.panedPack2 pane1 panels2 True True + + strokesPanel <- GTK.boxNew GTK.OrientationVertical 0 + brushesPanel <- GTK.boxNew GTK.OrientationVertical 0 + transformPanel <- GTK.boxNew GTK.OrientationVertical 0 + + strokesTab <- GTK.labelNew ( Just "Strokes" ) + brushesTab <- GTK.labelNew ( Just "Brushes" ) + transformTab <- GTK.labelNew ( Just "Transform" ) + + for_ [ strokesTab, brushesTab, transformTab ] \ tab -> do + widgetAddClasses tab [ "plain", "text", "panelTab" ] + + for_ [ strokesPanel, brushesPanel, transformPanel ] \ panel -> do + widgetAddClass panel "panel" + + void $ GTK.notebookAppendPage panels1 strokesPanel ( Just strokesTab ) + void $ GTK.notebookAppendPage panels1 brushesPanel ( Just brushesTab ) + + void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab ) + + GTK.notebookSetTabReorderable panels1 strokesPanel True + GTK.notebookSetTabDetachable panels1 strokesPanel True + GTK.notebookSetTabReorderable panels1 brushesPanel True + GTK.notebookSetTabDetachable panels1 brushesPanel True + + GTK.notebookSetTabReorderable panels2 transformPanel True + GTK.notebookSetTabDetachable panels2 transformPanel True + + strokesContent <- GTK.labelNew ( Just "Strokes tab content..." ) + brushesContent <- GTK.labelNew ( Just "Brushes tab content..." ) + transformContent <- GTK.labelNew ( Just "Transform tab content..." ) + + GTK.boxPackStart strokesPanel strokesContent True True 0 + GTK.boxPackStart brushesPanel brushesContent True True 0 + GTK.boxPackStart transformPanel transformContent True True 0 + + pure () diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs new file mode 100644 index 0000000..c3802ba --- /dev/null +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module MetaBrush.UI.ToolBar + ( ToolBar(..), createToolBar ) + where + +-- base +import Control.Monad + ( void ) +import Data.Foldable + ( for_ ) + +-- gi-cairo-connector +import qualified GI.Cairo.Render.Connector as Cairo + ( renderWithContext ) + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- MetaBrush +import MetaBrush.Asset.Colours + ( Colours ) +import MetaBrush.Asset.Cursor + ( drawCursorIcon ) +import MetaBrush.Asset.Tools + ( drawBrush, drawMeta, drawPath, drawPen ) +import MetaBrush.Render.Util + ( widgetAddClass ) + +-------------------------------------------------------------------------------- + +data ToolBar + = ToolBar + { selectionTool :: !GTK.RadioButton + , penTool :: !GTK.RadioButton + , pathTool :: !GTK.RadioButton + , brushTool :: !GTK.RadioButton + , metaTool :: !GTK.RadioButton + } + +createToolBar :: Colours -> GTK.Box -> IO ToolBar +createToolBar colours toolBar = do + + widgetAddClass toolBar "toolBar" + + GTK.widgetSetValign toolBar GTK.AlignStart + GTK.widgetSetVexpand toolBar True + + selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) + penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool ) + + pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) + brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) + metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) + + toolSep1 <- GTK.boxNew GTK.OrientationVertical 0 + + GTK.boxPackStart toolBar selectionTool True True 0 + GTK.boxPackStart toolBar penTool True True 0 + GTK.boxPackStart toolBar toolSep1 True True 0 + GTK.boxPackStart toolBar pathTool True True 0 + GTK.boxPackStart toolBar brushTool True True 0 + GTK.boxPackStart toolBar metaTool True True 0 + + for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do + GTK.toggleButtonSetMode tool False -- don't display radio indicator + widgetAddClass tool "toolItem" + + widgetAddClass toolSep1 "toolBarSeparator" + + GTK.widgetSetTooltipText selectionTool ( Just "Select" ) + GTK.widgetSetTooltipText penTool ( Just "Draw" ) + GTK.widgetSetTooltipText pathTool ( Just "Brush path" ) + GTK.widgetSetTooltipText brushTool ( Just "Brushes" ) + GTK.widgetSetTooltipText metaTool ( Just "Meta-parameters" ) + + selectionToolArea <- GTK.drawingAreaNew + penToolArea <- GTK.drawingAreaNew + pathToolArea <- GTK.drawingAreaNew + brushToolArea <- GTK.drawingAreaNew + metaToolArea <- GTK.drawingAreaNew + + GTK.containerAdd selectionTool selectionToolArea + GTK.containerAdd penTool penToolArea + GTK.containerAdd pathTool pathToolArea + GTK.containerAdd brushTool brushToolArea + GTK.containerAdd metaTool metaToolArea + + void $ GTK.onWidgetDraw selectionToolArea + $ Cairo.renderWithContext + ( drawCursorIcon colours ) + + void $ GTK.onWidgetDraw penToolArea + $ Cairo.renderWithContext + ( drawPen colours ) + + void $ GTK.onWidgetDraw pathToolArea + $ Cairo.renderWithContext + ( drawPath colours ) + + void $ GTK.onWidgetDraw brushToolArea + $ Cairo.renderWithContext + ( drawBrush colours ) + + void $ GTK.onWidgetDraw metaToolArea + $ Cairo.renderWithContext + ( drawMeta colours ) + + pure ( ToolBar { .. } ) diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs new file mode 100644 index 0000000..06c0714 --- /dev/null +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module MetaBrush.UI.Viewport + ( Viewport(..), createViewport ) + where + +-- base +import Control.Monad + ( void ) +import Data.Foldable + ( for_ ) + +-- containers +import Data.IntMap.Strict + ( IntMap ) + +-- gi-cairo-connector +import qualified GI.Cairo.Render.Connector as Cairo + ( renderWithContext ) + +-- gi-gdk +import qualified GI.Gdk as GDK + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- stm +import qualified Control.Concurrent.STM.TVar as STM + ( TVar ) + +-- MetaBrush +import MetaBrush.Asset.Colours + ( Colours ) +import MetaBrush.Document + ( Document(..), currentDocument ) +import MetaBrush.Render.Document + ( renderDocument ) +import MetaBrush.Render.Util + ( widgetAddClass ) + +-------------------------------------------------------------------------------- + +data Viewport + = Viewport + { viewportDrawingArea :: !GTK.DrawingArea + } + +createViewport + :: Colours + -> STM.TVar ( Maybe Int ) + -> STM.TVar ( IntMap Document ) + -> GTK.Grid + -> IO Viewport +createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do + + widgetAddClass viewportGrid "viewport" + + rvRulerCorner <- GTK.revealerNew + rvLeftRuler <- GTK.revealerNew + rvTopRuler <- GTK.revealerNew + viewportOverlay <- GTK.overlayNew + + GTK.gridAttach viewportGrid rvRulerCorner 0 0 1 1 + GTK.gridAttach viewportGrid rvLeftRuler 0 1 1 1 + GTK.gridAttach viewportGrid rvTopRuler 1 0 1 1 + GTK.gridAttach viewportGrid viewportOverlay 1 1 1 1 + + ---------- + -- Rulers + + rulerCorner <- GTK.boxNew GTK.OrientationVertical 0 + leftRuler <- GTK.boxNew GTK.OrientationVertical 0 + topRuler <- GTK.boxNew GTK.OrientationHorizontal 0 + + GTK.containerAdd rvRulerCorner rulerCorner + GTK.containerAdd rvLeftRuler leftRuler + GTK.containerAdd rvTopRuler topRuler + + widgetAddClass rulerCorner "ruler" + widgetAddClass leftRuler "ruler" + widgetAddClass topRuler "ruler" + + GTK.revealerSetRevealChild rvRulerCorner True + GTK.revealerSetRevealChild rvLeftRuler True + GTK.revealerSetRevealChild rvTopRuler True + + GTK.revealerSetTransitionType rvRulerCorner GTK.RevealerTransitionTypeSlideLeft + GTK.revealerSetTransitionType rvLeftRuler GTK.RevealerTransitionTypeSlideLeft + GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp + + rulerCornerArea <- GTK.drawingAreaNew + GTK.boxPackStart rulerCorner rulerCornerArea True True 0 + + leftRulerArea <- GTK.drawingAreaNew + GTK.boxPackStart leftRuler leftRulerArea True True 0 + + topRulerArea <- GTK.drawingAreaNew + GTK.boxPackStart topRuler topRulerArea True True 0 + + GTK.widgetSetHexpand rulerCorner False + GTK.widgetSetVexpand rulerCorner False + GTK.widgetSetHexpand leftRuler False + GTK.widgetSetVexpand leftRuler True + GTK.widgetSetHexpand topRuler True + GTK.widgetSetVexpand topRuler False + GTK.widgetSetHexpand viewportOverlay True + GTK.widgetSetVexpand viewportOverlay True + + viewportDrawingArea <- GTK.drawingAreaNew + GTK.setContainerChild viewportOverlay viewportDrawingArea + GTK.widgetAddEvents viewportDrawingArea + [ GDK.EventMaskPointerMotionMask + , GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask + ] + + ----------------- + -- Viewport scrolling + + viewportScrollbarGrid <- GTK.gridNew + GTK.overlayAddOverlay viewportOverlay viewportScrollbarGrid + GTK.overlaySetOverlayPassThrough viewportOverlay viewportScrollbarGrid True + + viewportHScrollbar <- GTK.scrollbarNew GTK.OrientationHorizontal ( Nothing @GTK.Adjustment ) + viewportVScrollbar <- GTK.scrollbarNew GTK.OrientationVertical ( Nothing @GTK.Adjustment ) + GTK.widgetSetValign viewportHScrollbar GTK.AlignEnd + GTK.widgetSetHalign viewportVScrollbar GTK.AlignEnd + GTK.widgetSetVexpand viewportVScrollbar True + GTK.widgetSetHexpand viewportHScrollbar True + GTK.gridAttach viewportScrollbarGrid viewportHScrollbar 0 1 1 1 + GTK.gridAttach viewportScrollbarGrid viewportVScrollbar 1 0 1 1 + widgetAddClass viewportHScrollbar "viewportScrollbar" + widgetAddClass viewportVScrollbar "viewportScrollbar" + + ----------------- + -- Rendering + + void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do + -- Get the relevant document information + mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar + for_ mbDoc \ doc -> do + ( `Cairo.renderWithContext` ctx ) $ do + viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea + viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea + renderDocument colours ( viewportWidth, viewportHeight ) doc + pure True + + pure ( Viewport { .. } ) diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index 7b2d3f8..503f816 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/lib/Math/Bezier/Cubic.hs @@ -1,6 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index 8a4cbe5..735145a 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/lib/Math/Bezier/Quadratic.hs @@ -1,6 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} diff --git a/src/lib/Math/Vector2D.hs b/src/lib/Math/Vector2D.hs index 2dffe56..d82c0ce 100644 --- a/src/lib/Math/Vector2D.hs +++ b/src/lib/Math/Vector2D.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Math.Vector2D ( Point2D(..), Vector2D(..) )