hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

add MenuBar

Browse source
This commit is contained in:
sheaf 2020-08-05 22:23:16 +02:00
parent c9e702e660
commit f224c6b738
21 changed files with 764 additions and 92 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
.gitignore vendored
View file

@ -1,5 +1,9 @@
dist-newstyle/
cabal.project.local
assets/*.svg
assets/*/
*.txt
cabal.project.local
*.md
*.html

19
MetaBrush.cabal
View file

@ -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

164
app/Main.hs
View file

@ -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

131
assets/theme.css
View file

@ -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);
}

2
cabal.project
View file

@ -1,3 +1,5 @@
packages: .
constraints:
acts -finitary
, haskell-gi >= 0.24

21
img/MetaBrush_ui_mockup.svg
View file

@ -35,6 +35,7 @@
</linearGradient>
</defs>
<sodipodi:namedview
inkscape:lockguides="false"
inkscape:document-rotation="0"
fit-margin-bottom="0"
fit-margin-right="0"
@ -46,7 +47,7 @@
objecttolerance="1"
inkscape:window-maximized="1"
inkscape:window-y="115"
inkscape:window-x="2552"
inkscape:window-x="-8"
inkscape:window-height="1377"
inkscape:window-width="2560"
inkscape:guide-bbox="true"
@ -54,9 +55,9 @@
showgrid="false"
inkscape:current-layer="layer1"
inkscape:document-units="mm"
inkscape:cy="849.74823"
inkscape:cx="768.55909"
inkscape:zoom="16"
inkscape:cy="421.74309"
inkscape:cx="750.76483"
inkscape:zoom="1"
inkscape:pageshadow="2"
inkscape:pageopacity="0.0"
borderopacity="1.0"
@ -5524,5 +5525,17 @@
d="M 745.71289 847.36133 C 742.67337 847.25537 739.67408 848.77547 738.02148 851.58008 C 735.81903 855.31789 737.00422 860.22415 740.31836 862.83789 C 740.09434 863.25648 739.39877 864.56411 738.68359 864.1582 C 738.41428 864.00535 737.96229 864.29658 737.67188 864.80859 L 733.96289 871.19141 C 733.67359 871.70474 733.85258 872.35441 734.36328 872.64453 L 736.30078 873.74414 C 736.81328 874.03475 737.46322 873.85271 737.75391 873.3418 L 741.44922 866.78125 C 741.7402 866.26988 741.6576 865.91122 741.39258 865.75195 C 740.70108 865.33646 741.49263 864.19842 741.77148 863.70898 C 745.70555 865.47578 750.55309 864.08509 752.79297 860.2832 C 755.19674 856.20376 753.8392 850.94869 749.75977 848.54492 C 748.48506 847.79371 747.09449 847.40949 745.71289 847.36133 z M 745.40234 848.82227 A 7.1095623 7.1095623 0 0 1 752.29102 854.15234 A 7.1095623 7.1095623 0 0 1 747.18555 862.81445 A 7.1095623 7.1095623 0 0 1 738.52344 857.71094 A 7.1095623 7.1095623 0 0 1 743.62695 849.04688 A 7.1095623 7.1095623 0 0 1 745.40234 848.82227 z "
style="fill:#ecdfd2;fill-opacity:1;stroke-width:0.0701341"
id="path2" />
<path
sodipodi:nodetypes="ccc"
id="path4212"
d="m -137.37613,-191.90754 -0.92604,0.66146 0.95911,0.62838"
style="fill:none;stroke:#000000;stroke-width:0.264583px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" />
<path
inkscape:transform-center-y="0.080851403"
inkscape:transform-center-x="0.064642359"
style="display:inline;fill:none;stroke:#000000;stroke-width:0.264583px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="m -135.45938,-192.29552 -0.66146,-0.92604 -0.62838,0.95911"
id="path4212-4"
sodipodi:nodetypes="ccc" />
</g>
</svg>

Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 236 KiB

After

Width:  |  Height:  |  Size: 237 KiB

6
src/app/MetaBrush/Asset/Brush.hs
View file

@ -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

94
src/app/MetaBrush/Asset/Colours.hs Normal file
View file

@ -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

6
src/app/MetaBrush/Asset/Logo.hs
View file

@ -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

5
src/app/MetaBrush/Asset/Magnifier.hs
View file

@ -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

4
src/app/MetaBrush/Asset/Meta.hs
View file

@ -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

13
src/app/MetaBrush/Asset/TickBox.hs
View file

@ -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

2
src/app/MetaBrush/Document.hs
View file

@ -2,6 +2,7 @@ module MetaBrush.Document where
--------------------------------------------------------------------------------
{-
data Document
= Document
{ displayName :: !Text
@ -10,3 +11,4 @@ data Document
, viewport :: !AABB
, strokes :: !(Set Stroke)
}
-}

23
src/app/MetaBrush/Event.hs Normal file
View file

@ -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

15
src/app/MetaBrush/Render/Util.hs
View file

@ -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 )
--------------------------------------------------------------------------------

5
src/app/MetaBrush/Stroke.hs
View file

@ -2,10 +2,13 @@ module MetaBrush.Stroke where
--------------------------------------------------------------------------------
{-
data StrokePoint
= StrokePoint
{ center :: Point2D Double
,
newtype Stroke =
Stroke { strokePoints :: Seq (
Stroke { strokePoints :: Seq (
-}

252
src/app/MetaBrush/UI/Menu.hs Normal file
View file

@ -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 )

29
src/lib/Math/Bezier/Cubic.hs
View file

@ -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

25
src/lib/Math/Bezier/Quadratic.hs
View file

@ -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
( (-->) )
)

22
src/lib/Math/Module.hs
View file

@ -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
lerp :: forall v r p. ( Module r v, Torsor v p ) => r -> p -> p -> p
lerp t p0 p1 = ( t *^ ( p0 --> p1 :: v ) ) • p0

12
src/lib/Math/Vector2D.hs
View file

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