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
(^+^) = (<>)