From f224c6b7381d4931bf0274f223c46b3bb58598f7 Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 5 Aug 2020 22:23:16 +0200 Subject: [PATCH] add MenuBar --- .gitignore | 6 +- MetaBrush.cabal | 19 +- app/Main.hs | 164 +++++++++++++++-- assets/theme.css | 131 ++++++++++++-- cabal.project | 2 + img/MetaBrush_ui_mockup.svg | 21 ++- src/app/MetaBrush/Asset/Brush.hs | 6 +- src/app/MetaBrush/Asset/Colours.hs | 94 ++++++++++ src/app/MetaBrush/Asset/Logo.hs | 6 +- src/app/MetaBrush/Asset/Magnifier.hs | 5 +- src/app/MetaBrush/Asset/Meta.hs | 4 +- src/app/MetaBrush/Asset/TickBox.hs | 13 +- src/app/MetaBrush/Document.hs | 2 + src/app/MetaBrush/Event.hs | 23 +++ src/app/MetaBrush/Render/Util.hs | 15 +- src/app/MetaBrush/Stroke.hs | 5 +- src/app/MetaBrush/UI/Menu.hs | 252 +++++++++++++++++++++++++++ src/lib/Math/Bezier/Cubic.hs | 29 +-- src/lib/Math/Bezier/Quadratic.hs | 25 +-- src/lib/Math/Module.hs | 22 ++- src/lib/Math/Vector2D.hs | 12 +- 21 files changed, 764 insertions(+), 92 deletions(-) create mode 100644 src/app/MetaBrush/Asset/Colours.hs create mode 100644 src/app/MetaBrush/Event.hs create mode 100644 src/app/MetaBrush/UI/Menu.hs diff --git a/.gitignore b/.gitignore index cf9a69b..e095b87 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,9 @@ dist-newstyle/ +cabal.project.local + assets/*.svg assets/*/ + *.txt -cabal.project.local +*.md +*.html diff --git a/MetaBrush.cabal b/MetaBrush.cabal index bc58122..a638a16 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -3,11 +3,13 @@ name: MetaBrush version: 0.1.0.0 synopsis: GUI for brush calligraphy. category: Calligraphy, Font, Geometry, Graphics, GUI -license: BSD-3-Clause +license: NONE homepage: https://gitlab.com/sheaf/MetaBrush build-type: Simple +data-dir: + assets data-files: - assets/theme.css + theme.css description: MetaBrush is a GUI for brush calligraphy based on Bézier curves. @@ -39,6 +41,7 @@ common common -fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-missing-deriving-strategies + -fno-warn-unticked-promoted-constructors library @@ -68,6 +71,9 @@ library executable MetaBrush + import: + common + hs-source-dirs: src/app , app @@ -77,14 +83,17 @@ executable MetaBrush other-modules: MetaBrush.Asset.Brush + , MetaBrush.Asset.Colours , MetaBrush.Asset.Logo , MetaBrush.Asset.Magnifier , MetaBrush.Asset.Meta , MetaBrush.Asset.TickBox , MetaBrush.Asset.WindowIcons , MetaBrush.Document + , MetaBrush.Event , MetaBrush.Render.Util , MetaBrush.Stroke + , MetaBrush.UI.Menu , Paths_MetaBrush autogen-modules: @@ -95,8 +104,14 @@ executable MetaBrush build-depends: MetaBrush + , directory + >= 1.3.4.0 && < 1.4 + , generic-lens + >= 1.2.0.1 && < 2.0 , gi-gdk >= 3.0.22 && < 3.1 + , gi-gio + >= 2.0.27 && < 2.1 , gi-glib >= 2.0.23 && < 2.1 , gi-gtk diff --git a/app/Main.hs b/app/Main.hs index 8b575ae..e48b32c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,22 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + module Main ( main ) where +-- base +import Data.Int + ( Int32 ) +import System.Exit + ( exitSuccess ) + +-- directory +import qualified System.Directory as Directory + ( canonicalizePath ) + -- gi-cairo-connector import qualified GI.Cairo.Render.Connector as Cairo ( renderWithContext ) @@ -12,8 +27,22 @@ import qualified GI.Gdk as GDK -- gi-gtk import qualified GI.Gtk as GTK +-- text +import qualified Data.Text as Text + ( pack ) + -- MetaBrush -import Paths_MetaBrush +import MetaBrush.Asset.Colours + ( ColourRecord(..), colours ) +import MetaBrush.Asset.Logo + ( drawLogo ) +import MetaBrush.Event + ( handleKeyboardPressEvent, handleKeyboardReleaseEvent ) +import MetaBrush.Render.Util + ( widgetAddClass, widgetAddClasses ) +import MetaBrush.UI.Menu + ( newMenuBar ) +import qualified Paths_MetaBrush as Cabal ( getDataFileName ) -------------------------------------------------------------------------------- @@ -27,7 +56,7 @@ main = do _ <- GTK.init Nothing Just screen <- GDK.screenGetDefault - themePath <- getDataFileName "theme.css" + themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" ) cssProvider <- GTK.cssProviderNew GTK.cssProviderLoadFromPath cssProvider themePath GTK.styleContextAddProviderForScreen screen cssProvider 1000 @@ -36,13 +65,13 @@ main = do windowWidgetPath <- GTK.widgetGetPath window widgetAddClass window "window" GTK.setWindowResizable window True - GTK.setWindowDecorated window False + GTK.setWindowDecorated window True GTK.setWindowTitle window "MetaBrush" GTK.windowSetDefaultSize window 800 600 let baseMinWidth, baseMinHeight :: Int32 - baseMinWidth = 320 + baseMinWidth = 480 baseMinHeight = 240 windowGeometry <- GDK.newZeroGeometry @@ -52,14 +81,16 @@ main = do ( Just windowGeometry ) [ GDK.WindowHintsMinSize ] + Colours { .. } <- colours windowWidgetPath + --------------------------------------------------------- -- Create base UI elements baseOverlay <- GTK.overlayNew - GT.setContainerChild window baseOverlay + GTK.setContainerChild window baseOverlay uiGrid <- GTK.gridNew - GTK.overlaySetChild baseOverlay uiGrid + GTK.setContainerChild baseOverlay uiGrid logo <- GTK.boxNew GTK.OrientationVertical 0 titleBar <- GTK.boxNew GTK.OrientationHorizontal 0 @@ -77,15 +108,124 @@ main = do GTK.gridAttach uiGrid panelGrid 3 2 1 2 GTK.gridAttach uiGrid infoBar 2 3 1 1 - -------------------------------------- + --------------------------------------------------------- + -- Background + + widgetAddClass uiGrid "bg" + + --------------------------------------------------------- + -- Logo + + widgetAddClass logo "logo" + + logoArea <- GTK.drawingAreaNew + GTK.boxPackStart logo logoArea True True 0 + + _ <- GTK.onWidgetDraw logoArea + $ Cairo.renderWithContext + ( drawLogo logo_base logo_highlight logo_base ) + + --------------------------------------------------------- + -- Title bar + + widgetAddClass titleBar "titleBar" + + ( menuBar, _menu ) <- newMenuBar + widgetAddClasses menuBar [ "text", "plain" ] + + GTK.boxPackStart titleBar menuBar False False 0 + + title <- GTK.labelNew ( Just "● New Document – MetaBrush" ) + widgetAddClasses title [ "text", "title", "plain" ] + GTK.labelSetJustify title GTK.JustificationCenter + GTK.widgetSetHalign title GTK.AlignCenter + GTK.boxPackStart titleBar title True True 0 + + --------------------------------------------------------- + -- Tool bar + + widgetAddClass toolBar "toolBar" + + --------------------------------------------------------- + -- File bar + + widgetAddClass fileBar "fileBar" + + --------------------------------------------------------- + -- Main viewport + + widgetAddClass mainView "viewport_bg" + + rvRulerCorner <- GTK.revealerNew + rvLeftRuler <- GTK.revealerNew + rvTopRuler <- GTK.revealerNew + viewport <- GTK.drawingAreaNew + + GTK.gridAttach mainView rvRulerCorner 0 0 1 1 + GTK.gridAttach mainView rvLeftRuler 0 1 1 1 + GTK.gridAttach mainView rvTopRuler 1 0 1 1 + GTK.gridAttach mainView viewport 1 1 1 1 + + 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 viewport True + GTK.widgetSetVexpand viewport True + + --------------------------------------------------------- + -- Panels + + widgetAddClass panelGrid "panels" + + --------------------------------------------------------- + -- Info bar + + widgetAddClass infoBar "infoBar" + + --------------------------------------------------------- -- Actions - GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask] - _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent ) - _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent ) + --------------------------------------------------------- + -- GTK main loop - _ <- GTK.onWidgetDestroy window ( quitAll actionTVar ) - _ <- GTK.onButtonClicked quitIconButton ( quitAll actionTVar ) + GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask] + _ <- GTK.onWidgetKeyPressEvent window handleKeyboardPressEvent + _ <- GTK.onWidgetKeyReleaseEvent window handleKeyboardReleaseEvent + _ <- GTK.onWidgetDestroy window GTK.mainQuit GTK.widgetShowAll window GTK.main + + exitSuccess diff --git a/assets/theme.css b/assets/theme.css index 11a66f4..2f89dbb 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -2,87 +2,182 @@ all: unset; } +.window { + -GtkWidget-window-dragging: true; +} + /* Window background colour */ .bg { - color: #292828 + background-color: rgb(41, 40, 40); } /* Viewport background colour */ .viewport_bg { - color: #ecdfd2 + background-color: rgb(236, 223, 210); } /* Basic text colour */ .plain { - color: #d4be98 + color: rgb(212, 190, 152); } /* Basic text font */ .text { - font-family: "Lato", "Roboto", "Helvetica", sans-serif + font-family: "Lato", "Roboto", "Helvetica", sans-serif; } /* Monospace font */ .monospace { - font-family: "Fira Code", "Inconsolata", "Courier", "Courier New", monospace + font-family: "Fira Code", "Inconsolata", "Courier", "Courier New", monospace; } /* High-constrast text colour */ .contrast { - color: #f7f4ef + color: rgb(247, 244, 239); } /* Active (highlighting) colour */ .highlight { - color: #eadfcc + color: #eadfcc; +} + +/* Logo area */ +.logo { + padding-left: 2px; + padding-top: 0px; } /* Logo base colour */ .logo_base { - color: #f7f4ef + color: rgb(234, 223, 204); } /* Logo highlight colour */ .logo_highlight { - color: #f5881bff + color: rgb(245, 136, 27); } /* Viewport scrollbar colour */ .viewport_scrollbar { - color: #28272793 + color: rgba(40, 39, 39, 0.66); } /* Tab scrollbar colour */ .tab_scrollbar { - color: #302d2693 + color: rgba(48, 45, 38, 0.66); } -/* Ruler colour */ +/* Rulers */ .ruler { - color: #ede29a + background-color: rgb(237, 226, 154); + min-width: 16px; + min-height: 16px; + background-size: 16px 16px; } /* Magnifying glass base colour */ .magnifier { - color: #ecdfd2 + color: rgb(236, 223, 210); } /* Magnifying glass glass colour */ .glass { - color: #9ce7ff72 + color: rgba(156, 231, 255, 0.5); } /* Cursor colour */ .cursor { - color: #f7f4ef + color: rgb(247, 244, 239); } /* Bézier path point colour */ .point { - color: #8183f1 + color: rgb(129, 131, 241); } /* Bézier control point colour */ .control { - color: #a1dde9 + color: rgb(161, 221, 233); +} + +/* Title bar */ +.titleBar { + min-height: 20px; + font-size: 11px; +} + +/* Title bar */ +.titleBar > * :hover { + background-color: rgb(72,70,61); +} + +.menuItem { + background-color: rgb(41, 40, 40); + margin-left: 2px; + padding-left: 8px; + padding-right: 8px; + margin-left: 0px; + border-top: 2px solid rgb(41, 40, 40); +} + +.menuItem:hover { + border-top: 2px solid rgb(234,223,204); + background-color: rgb(72,70,61); +} + +/* Menu drop shadow */ +.menuItem > * > * { + box-shadow: 2px 2px 4px 0px rgba(28,25,25,0.5); + border: 1px solid rgb(28,25,25); + border-top: 1px solid rgb(72,70,61); +} + +.submenuItem { + padding-top: 4px; + padding-bottom: 4px; + padding-left: 8px; + padding-right: 8px; + background-color: rgb(41, 40, 40); + border-left: 2px solid rgb(41, 40, 40); +} + +.submenuSeparator { + background-color: rgb(28,25,25); + padding-top: 1px; +} + +.submenuItem:hover { + border-left: 2px solid rgb(234,223,204); +} + +.title { + font-size: 12px; +} + +/* Tool bar */ +.toolBar { + min-width: 60px; +} + +/* File bar */ +.fileBar { + min-height: 25px; + font-size: 10px; +} + +/* Panels */ +.panels { + min-width: 160px; + font-size: 12px; +} + +/* Info bar */ +.infoBar { + min-height: 40px; + font-size: 10px; + -GtkWidget-window-dragging: true; +} + +.submenuItem:disabled { + color: rgb(149,149,149); } diff --git a/cabal.project b/cabal.project index 7c20422..be0cafa 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,5 @@ +packages: . + constraints: acts -finitary , haskell-gi >= 0.24 diff --git a/img/MetaBrush_ui_mockup.svg b/img/MetaBrush_ui_mockup.svg index c36aca0..bffeb7f 100644 --- a/img/MetaBrush_ui_mockup.svg +++ b/img/MetaBrush_ui_mockup.svg @@ -35,6 +35,7 @@ + + diff --git a/src/app/MetaBrush/Asset/Brush.hs b/src/app/MetaBrush/Asset/Brush.hs index a7e2aa9..eb8fee4 100644 --- a/src/app/MetaBrush/Asset/Brush.hs +++ b/src/app/MetaBrush/Asset/Brush.hs @@ -15,11 +15,11 @@ import MetaBrush.Render.Util -------------------------------------------------------------------------------- -- | Calligraphy brush icon. Width = 29, height = 29. -drawBrush :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render () +drawBrush :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool drawBrush brushColour bodyColour loopColour = do -- Loop - Cairo.setLineWidth 0.2 + Cairo.setLineWidth 1 withRGBA loopColour Cairo.setSourceRGBA Cairo.newPath Cairo.moveTo 23.144531 6.199219 @@ -58,3 +58,5 @@ drawBrush brushColour bodyColour loopColour = do Cairo.curveTo 10.339844 19.335938 10.339844 19.335938 10.339844 19.335938 Cairo.closePath Cairo.fillPreserve + + pure True diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs new file mode 100644 index 0000000..43a9a8c --- /dev/null +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module MetaBrush.Asset.Colours + ( ColourRecord(..), ColourType + , colours + ) + where + +-- base +import Data.Traversable + ( for ) + +-- gi-gdk +import qualified GI.Gdk as GDK + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- text +import Data.Text + ( Text ) + +-------------------------------------------------------------------------------- + +data ColourRecord a + = Colours + { bg :: !a + , viewport_bg :: !a + , plain :: !a + , contrast :: !a + , highlight :: !a + , logo_base :: !a + , logo_highlight :: !a + , viewport_scrollbar :: !a + , tab_scrollbar :: !a + , ruler :: !a + , magnifier :: !a + , glass :: !a + , cursor :: !a + , point :: !a + , control :: !a + } + deriving stock ( Show, Functor, Foldable, Traversable ) + +data ColourType + = Color + | BackgroundColor + deriving stock Show + +data ColourName + = ColourName + { colourName :: !Text + , colourType :: !ColourType + , stateFlags :: ![ GTK.StateFlags ] + } + deriving stock Show + +colourNames :: ColourRecord ColourName +colourNames = Colours + { bg = ColourName "bg" BackgroundColor [ GTK.StateFlagsNormal ] + , viewport_bg = ColourName "viewport_bg" BackgroundColor [ GTK.StateFlagsNormal ] + , plain = ColourName "plain" Color [ GTK.StateFlagsNormal ] + , contrast = ColourName "contrast" Color [ GTK.StateFlagsNormal ] + , highlight = ColourName "highlight" Color [ GTK.StateFlagsNormal ] + , logo_base = ColourName "logo_base" Color [ GTK.StateFlagsNormal ] + , logo_highlight = ColourName "logo_highlight" Color [ GTK.StateFlagsNormal ] + , viewport_scrollbar = ColourName "viewport_scrollbar" Color [ GTK.StateFlagsNormal ] + , tab_scrollbar = ColourName "tab_scrollbar" Color [ GTK.StateFlagsNormal ] + , ruler = ColourName "ruler" BackgroundColor [ GTK.StateFlagsNormal ] + , magnifier = ColourName "magnifier" Color [ GTK.StateFlagsNormal ] + , glass = ColourName "glass" Color [ GTK.StateFlagsNormal ] + , cursor = ColourName "cursor" Color [ GTK.StateFlagsNormal ] + , point = ColourName "point" Color [ GTK.StateFlagsNormal ] + , control = ColourName "control" Color [ GTK.StateFlagsNormal ] + } + +type Colours = ColourRecord GDK.RGBA + +colours :: GTK.WidgetPath -> IO Colours +colours windowWidgetPath = for colourNames \ ( ColourName { .. } ) -> do + style <- GTK.styleContextNew + GTK.styleContextSetPath style windowWidgetPath + GTK.styleContextAddClass style colourName + case colourType of + BackgroundColor -> GTK.styleContextGetBackgroundColor style stateFlags + Color -> GTK.styleContextGetColor style stateFlags diff --git a/src/app/MetaBrush/Asset/Logo.hs b/src/app/MetaBrush/Asset/Logo.hs index e1ceee8..1881ad9 100644 --- a/src/app/MetaBrush/Asset/Logo.hs +++ b/src/app/MetaBrush/Asset/Logo.hs @@ -15,11 +15,11 @@ import MetaBrush.Render.Util -------------------------------------------------------------------------------- -- | MetaBrush logo. Width = 29, height = 29. -drawLogo :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render () +drawLogo :: GDK.RGBA -> GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool drawLogo brushColour bodyColour loopColour = do -- Loop - Cairo.setLineWidth 0.2 + Cairo.setLineWidth 1 withRGBA loopColour Cairo.setSourceRGBA Cairo.newPath Cairo.moveTo 17.480469 7.847656 @@ -79,3 +79,5 @@ drawLogo brushColour bodyColour loopColour = do Cairo.curveTo 7.199219 18.394531 7.199219 18.394531 7.199219 18.394531 Cairo.closePath Cairo.fillPreserve + + pure True diff --git a/src/app/MetaBrush/Asset/Magnifier.hs b/src/app/MetaBrush/Asset/Magnifier.hs index c1ed128..084f03f 100644 --- a/src/app/MetaBrush/Asset/Magnifier.hs +++ b/src/app/MetaBrush/Asset/Magnifier.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NegativeLiterals #-} + module MetaBrush.Asset.Magnifier ( drawMagnifier ) where @@ -15,7 +17,7 @@ import MetaBrush.Render.Util -------------------------------------------------------------------------------- -- | Magnifying glass icon. Width = 19, height = 25. -drawMagnifier :: GDK.RGBA -> GDK.RGBA -> Cairo.Render () +drawMagnifier :: GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool drawMagnifier magnifierColour glassColour = do -- Magnifying glass. @@ -58,3 +60,4 @@ drawMagnifier magnifierColour glassColour = do Cairo.setFillRule Cairo.FillRuleWinding Cairo.fillPreserve + pure True diff --git a/src/app/MetaBrush/Asset/Meta.hs b/src/app/MetaBrush/Asset/Meta.hs index d44f537..fa2b272 100644 --- a/src/app/MetaBrush/Asset/Meta.hs +++ b/src/app/MetaBrush/Asset/Meta.hs @@ -15,7 +15,7 @@ import MetaBrush.Render.Util -------------------------------------------------------------------------------- -- | MetaParameter icon. Width = 29, height = 29. -drawMeta :: GDK.RGBA -> Cairo.Render () +drawMeta :: GDK.RGBA -> Cairo.Render Bool drawMeta metaColour = do withRGBA metaColour Cairo.setSourceRGBA Cairo.newPath @@ -40,3 +40,5 @@ drawMeta metaColour = do Cairo.curveTo 16.140625 11.976563 16.140625 11.976563 16.140625 11.976563 Cairo.closePath Cairo.fillPreserve + + pure True diff --git a/src/app/MetaBrush/Asset/TickBox.hs b/src/app/MetaBrush/Asset/TickBox.hs index 8f49a7c..7251d4f 100644 --- a/src/app/MetaBrush/Asset/TickBox.hs +++ b/src/app/MetaBrush/Asset/TickBox.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NegativeLiterals #-} + module MetaBrush.Asset.TickBox ( drawBox, drawTickedBox ) where @@ -15,9 +17,9 @@ import MetaBrush.Render.Util -------------------------------------------------------------------------------- -- | Non-ticked box. Width = 14, height = 12. -drawBox :: GDK.RGBA -> Cairo.Render () +drawBox :: GDK.RGBA -> Cairo.Render Bool drawBox boxColour = do - withRGBA loopColour Cairo.setSourceRGBA + withRGBA boxColour Cairo.setSourceRGBA Cairo.newPath Cairo.moveTo 2.015625 0.769531 @@ -43,8 +45,11 @@ drawBox boxColour = do Cairo.setFillRule Cairo.FillRuleWinding Cairo.fillPreserve + pure True + + -- | Ticked box. Width = 14, height = 12. -drawTickedBox :: GDK.RGBA -> GDK.RGBA -> Cairo.Render () +drawTickedBox :: GDK.RGBA -> GDK.RGBA -> Cairo.Render Bool drawTickedBox boxColour tickColour = do -- Box @@ -94,3 +99,5 @@ drawTickedBox boxColour tickColour = do Cairo.curveTo 13.835938 0.0351563 13.632813 -0.0195313 13.421875 0.0078125 Cairo.closePath Cairo.fillPreserve + + pure True diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index ef56466..e6ca575 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -2,6 +2,7 @@ module MetaBrush.Document where -------------------------------------------------------------------------------- +{- data Document = Document { displayName :: !Text @@ -10,3 +11,4 @@ data Document , viewport :: !AABB , strokes :: !(Set Stroke) } +-} \ No newline at end of file diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs new file mode 100644 index 0000000..4da5e5b --- /dev/null +++ b/src/app/MetaBrush/Event.hs @@ -0,0 +1,23 @@ +module MetaBrush.Event + ( handleKeyboardPressEvent + , handleKeyboardReleaseEvent + ) + where + +-- gi-gdk +import qualified GI.Gdk as GDK + +-- gi-gtk +import qualified GI.Gtk as GTK + +-------------------------------------------------------------------------------- + +handleKeyboardPressEvent, handleKeyboardReleaseEvent :: GDK.EventKey -> IO Bool +handleKeyboardPressEvent evt = do + keyCode <- GDK.getEventKeyKeyval evt + case keyCode of + -- escape + 0xff1b -> GTK.mainQuit + _ -> pure () + pure True +handleKeyboardReleaseEvent _ = pure True diff --git a/src/app/MetaBrush/Render/Util.hs b/src/app/MetaBrush/Render/Util.hs index b018dc3..3ee75a7 100644 --- a/src/app/MetaBrush/Render/Util.hs +++ b/src/app/MetaBrush/Render/Util.hs @@ -1,24 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MonoLocalBinds #-} + module MetaBrush.Render.Util ( withRGBA, showRGBA - , widgetAddClasses, widgetAddClass ) + , widgetAddClasses, widgetAddClass + ) where -- base +import Data.Foldable + ( for_ ) import GHC.Stack ( HasCallStack ) -- gi-gdk import qualified GI.Gdk as GDK +-- gi-gtk +import qualified GI.Gtk as GTK + -- text import Data.Text ( Text ) -import qualified Data.Text as Text - ( pack ) -- transformers import Control.Monad.IO.Class - ( MonadIO(liftIO) ) + ( MonadIO ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Stroke.hs b/src/app/MetaBrush/Stroke.hs index 743301d..201463c 100644 --- a/src/app/MetaBrush/Stroke.hs +++ b/src/app/MetaBrush/Stroke.hs @@ -2,10 +2,13 @@ module MetaBrush.Stroke where -------------------------------------------------------------------------------- +{- data StrokePoint = StrokePoint { center :: Point2D Double , newtype Stroke = - Stroke { strokePoints :: Seq ( \ No newline at end of file + Stroke { strokePoints :: Seq ( + +-} \ No newline at end of file diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs new file mode 100644 index 0000000..5fa844c --- /dev/null +++ b/src/app/MetaBrush/UI/Menu.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module MetaBrush.UI.Menu + ( newMenuBar + , Menu(..) + , FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..) + , ResourceType(..) + , MenuItem(..) + ) + where + +-- base +import Control.Monad + ( unless ) +import Data.Foldable + ( for_ ) +import Data.Kind + ( Type ) +import GHC.Generics + ( Generic ) + +-- generic-lens +import Data.Generics.Product.Constraints + ( HasConstraints(constraints) ) + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.IO.Class + ( MonadIO(liftIO) ) + +-- MetaBrush +import MetaBrush.Render.Util + ( widgetAddClasses ) + +-------------------------------------------------------------------------------- +-- Types for describing menu items. + +data ResourceType + = Description + | Object + +data family MenuItem ( submenu :: ResourceType -> Type ) ( r :: ResourceType ) +data instance MenuItem submenu Description + = MenuItemDescription + { menuItemLabel :: !Text + , menuItemClasses :: ![ Text ] + , menuItemAction :: !( Maybe Text ) + , submenuDescription :: !( submenu Description ) + } +data instance MenuItem submenu Object + = MenuItem + { menuItem :: !GTK.MenuItem + , menuItemSubmenu :: !( submenu Object ) + } + +data family Separator ( r :: ResourceType ) +data instance Separator Description + = SeparatorDescription + { separatorClasses :: ![ Text ] } +data instance Separator Object + = Separator + { separatorItem :: !GTK.MenuItem } + +data NoSubresource ( k :: ResourceType ) = NoSubresource + +-------------------------------------------------------------------------------- +-- Menu used in MetaBrush. + +-- Types. + +data Menu ( rt :: ResourceType ) + = Menu + { file :: !( MenuItem FileMenu rt ) + , edit :: !( MenuItem EditMenu rt ) + , view :: !( MenuItem ViewMenu rt ) + , help :: !( MenuItem HelpMenu rt ) + } + deriving stock Generic + +data FileMenu ( rt :: ResourceType ) + = FileMenu + { new :: !( MenuItem NoSubresource rt ) + , open :: !( MenuItem NoSubresource rt ) + , save :: !( MenuItem NoSubresource rt ) + , saveAs :: !( MenuItem NoSubresource rt ) + , close :: !( MenuItem NoSubresource rt ) + , quit :: !( MenuItem NoSubresource rt ) + } + deriving stock Generic + +data EditMenu ( rt :: ResourceType ) + = EditMenu + { undo :: !( MenuItem NoSubresource rt ) + , redo :: !( MenuItem NoSubresource rt ) + , history :: !( MenuItem NoSubresource rt ) + , editSep1 :: !( Separator rt ) + , cut :: !( MenuItem NoSubresource rt ) + , copy :: !( MenuItem NoSubresource rt ) + , paste :: !( MenuItem NoSubresource rt ) + , duplicate :: !( MenuItem NoSubresource rt ) + , editSep2 :: !( Separator rt ) + , preferences :: !( MenuItem NoSubresource rt ) + } + deriving stock Generic + +data ViewMenu ( rt :: ResourceType ) + = ViewMenu + { navigator :: !( MenuItem NoSubresource rt ) + , viewSep1 :: !( Separator rt ) + , strokes :: !( MenuItem NoSubresource rt ) + , brushes :: !( MenuItem NoSubresource rt ) + , metaparameters :: !( MenuItem NoSubresource rt ) + , viewSep2 :: !( Separator rt ) + , transform :: !( MenuItem NoSubresource rt ) + } + deriving stock Generic + +data HelpMenu ( rt :: ResourceType ) + = HelpMenu + { about :: !( MenuItem NoSubresource rt ) } + deriving stock Generic + +-- Descriptions. + +menuDescription :: Menu Description +menuDescription + = Menu + { file = MenuItemDescription "File" [ "menuItem", "file" ] Nothing fileMenuDescription + , edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] Nothing editMenuDescription + , view = MenuItemDescription "View" [ "menuItem", "view" ] Nothing viewMenuDescription + , help = MenuItemDescription "Help" [ "menuItem", "help" ] Nothing helpMenuDescription + } + +fileMenuDescription :: FileMenu Description +fileMenuDescription + = FileMenu + { new = MenuItemDescription "New" [ "submenuItem" ] Nothing NoSubresource + , open = MenuItemDescription "Open" [ "submenuItem" ] Nothing NoSubresource + , save = MenuItemDescription "Save" [ "submenuItem" ] Nothing NoSubresource + , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] Nothing NoSubresource + , close = MenuItemDescription "Close" [ "submenuItem" ] Nothing NoSubresource + , quit = MenuItemDescription "Quit" [ "submenuItem" ] Nothing NoSubresource + } + +editMenuDescription :: EditMenu Description +editMenuDescription + = EditMenu + { undo = MenuItemDescription "Undo" [ "submenuItem" ] Nothing NoSubresource + , redo = MenuItemDescription "Redo" [ "submenuItem" ] Nothing NoSubresource + , history = MenuItemDescription "History" [ "submenuItem" ] Nothing NoSubresource + , editSep1 = SeparatorDescription [ "submenuSeparator" ] + , cut = MenuItemDescription "Cut" [ "submenuItem" ] Nothing NoSubresource + , copy = MenuItemDescription "Copy" [ "submenuItem" ] Nothing NoSubresource + , paste = MenuItemDescription "Paste" [ "submenuItem" ] Nothing NoSubresource + , duplicate = MenuItemDescription "Duplicate" [ "submenuItem" ] Nothing NoSubresource + , editSep2 = SeparatorDescription [ "submenuSeparator" ] + , preferences = MenuItemDescription "Preferences" [ "submenuItem" ] Nothing NoSubresource + } + +viewMenuDescription :: ViewMenu Description +viewMenuDescription + = ViewMenu + { navigator = MenuItemDescription "Navigator" [ "submenuItem" ] Nothing NoSubresource + , viewSep1 = SeparatorDescription [ "submenuSeparator" ] + , strokes = MenuItemDescription "Strokes" [ "submenuItem" ] Nothing NoSubresource + , brushes = MenuItemDescription "Brushes" [ "submenuItem" ] Nothing NoSubresource + , metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] Nothing NoSubresource + , viewSep2 = SeparatorDescription [ "submenuSeparator" ] + , transform = MenuItemDescription "Transform" [ "submenuItem" ] Nothing NoSubresource + } + +helpMenuDescription :: HelpMenu Description +helpMenuDescription + = HelpMenu + { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] Nothing NoSubresource } + +-------------------------------------------------------------------------------- +-- Creating a GTK menu bar from a menu description. + +newMenuItem :: MonadIO m => MenuItem submenu Description -> m GTK.MenuItem +newMenuItem ( MenuItemDescription { .. } ) = do + menuItem <- GTK.menuItemNewWithLabel menuItemLabel + -- Could set accelerator labels... + unless ( null menuItemClasses ) do + widgetAddClasses menuItem menuItemClasses + for_ menuItemAction \ actionName -> do + GTK.actionableSetActionName menuItem ( Just actionName ) + pure menuItem + +class CreateMenuItem desc res | desc -> res, res -> desc where + createMenuItem :: MonadIO m => ( GTK.MenuItem -> m () ) -> desc -> m res +instance {-# OVERLAPPING #-} CreateMenuItem ( MenuItem NoSubresource Description ) ( MenuItem NoSubresource Object ) where + createMenuItem attachToParent menuItemDescription = do + menuItem <- newMenuItem menuItemDescription + attachToParent menuItem + pure + MenuItem + { menuItem = menuItem + , menuItemSubmenu = NoSubresource + } +instance ( HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) ) + => CreateMenuItem ( MenuItem submenu Description ) ( MenuItem submenu Object ) + where + createMenuItem attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do + menuItem <- newMenuItem menuItemDescription + submenu <- GTK.menuNew + submenuItems <- + constraints @CreateMenuItem + ( createMenuItem ( GTK.menuShellAppend submenu ) ) + submenuDescription + GTK.menuItemSetSubmenu menuItem ( Just submenu ) + attachToParent menuItem + pure + MenuItem + { menuItem = menuItem + , menuItemSubmenu = submenuItems + } +instance CreateMenuItem ( Separator Description ) ( Separator Object ) where + createMenuItem attachToParent ( SeparatorDescription { .. } ) = do + separator <- GTK.separatorMenuItemNew + unless ( null separatorClasses ) do + widgetAddClasses separator separatorClasses + sep <- liftIO ( GTK.unsafeCastTo GTK.MenuItem separator ) + attachToParent sep + pure ( Separator { separatorItem = sep } ) + +newMenuBar :: MonadIO m => m ( GTK.MenuBar, Menu Object ) +newMenuBar = do + menuBar <- GTK.menuBarNew + menu <- + constraints @CreateMenuItem + ( createMenuItem ( GTK.menuShellAppend menuBar ) ) + menuDescription + pure ( menuBar, menu ) diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index d4f742e..e74d871 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/lib/Math/Bezier/Cubic.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module Math.Bezier.Cubic ( Bezier(..) @@ -20,9 +23,7 @@ import GHC.Generics -- acts import Data.Act - ( Act - ( (•) ) - , Torsor + ( Torsor ( (-->) ) ) @@ -56,8 +57,8 @@ instance Module r p => Module r ( Bezier p ) where bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p bezier ( Bezier { .. } ) t = lerp @v t - ( Quadratic.bezier ( Quadratic.Bezier p0 p1 p2 ) t ) - ( Quadratic.bezier ( Quadratic.Bezier p1 p2 p3 ) t ) + ( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t ) + ( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t ) -- | Derivative of cubic Bézier curve. bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index b315eb6..ba651cc 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/lib/Math/Bezier/Quadratic.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module Math.Bezier.Quadratic ( Bezier(..) @@ -20,9 +23,7 @@ import GHC.Generics -- acts import Data.Act - ( Act - ( (•) ) - , Torsor + ( Torsor ( (-->) ) ) diff --git a/src/lib/Math/Module.hs b/src/lib/Math/Module.hs index c78613d..f0c3cac 100644 --- a/src/lib/Math/Module.hs +++ b/src/lib/Math/Module.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} module Math.Module ( Module(..) @@ -10,7 +11,9 @@ module Math.Module -- acts import Data.Act - ( Torsor + ( Act + ( (•) ) + , Torsor ( (-->) ) ) @@ -19,7 +22,7 @@ import Data.Act infixl 6 ^+^, ^-^ infix 8 ^*, *^ -class Num r => Module r m where +class Num r => Module r m | m -> r where {-# MINIMAL (^+^), ( (^*) | (*^) ) #-} @@ -32,10 +35,5 @@ class Num r => Module r m where (^*) = flip (*^) m ^-^ n = m ^+^ (-1) *^ n -instance Num a => Module a a where - (^+^) = (+) - (*^) = (*) - (^*) = (*) - -lerp :: forall v r p. ( Module r v , Torsor v p ) => r -> p -> p -> p -lerp t p0 p1 = ( t *^ ( p0 --> p1 ) ) • p0 \ No newline at end of file +lerp :: forall v r p. ( Module r v, Torsor v p ) => r -> p -> p -> p +lerp t p0 p1 = ( t *^ ( p0 --> p1 :: v ) ) • p0 diff --git a/src/lib/Math/Vector2D.hs b/src/lib/Math/Vector2D.hs index d74a448..2dffe56 100644 --- a/src/lib/Math/Vector2D.hs +++ b/src/lib/Math/Vector2D.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,6 +12,8 @@ module Math.Vector2D where -- base +import Data.Monoid + ( Sum(..) ) import GHC.Generics ( Generic ) @@ -19,13 +22,17 @@ import Data.Act ( Act, Torsor ) -- generic-data -import Data.Generic +import Generic.Data ( GenericProduct(..) ) -- groups import Data.Group ( Group ( invert ) ) +-- groups-generic +import Data.Group.Generics + ( ) + -- MetaBrush import Math.Module ( Module (..) ) @@ -38,10 +45,9 @@ data Point2D a = Point2D !a !a via Vector2D a newtype Vector2D a = Vector2D { tip :: Point2D a } - deriving stock Show + deriving stock ( Show, Functor, Foldable, Traversable ) deriving ( Semigroup, Monoid, Group ) via GenericProduct ( Point2D ( Sum a ) ) - deriving newtype ( Functor, Foldable, Traversable ) instance Num a => Module a ( Vector2D a ) where (^+^) = (<>)