mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
update infobar, mouse focus zoom, module refactor
This commit is contained in:
sheaf
parent
9fc7b8acb3
commit
07f9981c41
|
|
@ -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:
|
||||
|
|
|
|||
555
app/Main.hs
555
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
191
src/app/MetaBrush/UI/Coordinates.hs
Normal file
191
src/app/MetaBrush/UI/Coordinates.hs
Normal file
|
|
@ -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
|
||||
139
src/app/MetaBrush/UI/FileBar.hs
Normal file
139
src/app/MetaBrush/UI/FileBar.hs
Normal file
|
|
@ -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
|
||||
169
src/app/MetaBrush/UI/InfoBar.hs
Normal file
169
src/app/MetaBrush/UI/InfoBar.hs
Normal file
|
|
@ -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 )
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
85
src/app/MetaBrush/UI/Panels.hs
Normal file
85
src/app/MetaBrush/UI/Panels.hs
Normal file
|
|
@ -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 ()
|
||||
112
src/app/MetaBrush/UI/ToolBar.hs
Normal file
112
src/app/MetaBrush/UI/ToolBar.hs
Normal file
|
|
@ -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 { .. } )
|
||||
151
src/app/MetaBrush/UI/Viewport.hs
Normal file
151
src/app/MetaBrush/UI/Viewport.hs
Normal file
|
|
@ -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 { .. } )
|
||||
|
|
@ -1,6 +1,4 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
|
|
|||
|
|
@ -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(..) )
|
||||
|
|
|
|||
Loading…
Reference in a new issue