hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

add selection UI

Browse source
This commit is contained in:
sheaf 2020-08-14 00:47:10 +02:00
parent 8d50c92ca9
commit 91e1431306
15 changed files with 560 additions and 160 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
MetaBrush.cabal
View file

@ -30,6 +30,8 @@ common common
>= 4.13 && < 4.16
, acts
^>= 0.3.1.0
, groups
^>= 0.4.1.0
default-language:
Haskell2010
@ -66,8 +68,6 @@ library
build-depends:
generic-data
>= 0.8.0.0 && < 0.8.4.0
, groups
^>= 0.4.1.0
, groups-generic
^>= 0.1.0.0
@ -92,9 +92,11 @@ executable MetaBrush
, MetaBrush.Asset.Tools
, MetaBrush.Asset.WindowIcons
, MetaBrush.Document
, MetaBrush.Document.Selection
, MetaBrush.Event
, MetaBrush.Render.Document
, MetaBrush.Render.Util
, MetaBrush.Time
, MetaBrush.UI.Coordinates
, MetaBrush.UI.FileBar
, MetaBrush.UI.InfoBar

18
app/Main.hs
View file

@ -58,11 +58,14 @@ import MetaBrush.Asset.Logo
import MetaBrush.Document
( Document(..), AABB(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, Overlay
)
import MetaBrush.Event
( handleEvents )
import MetaBrush.Render.Util
( widgetAddClass, widgetAddClasses )
import MetaBrush.Time
( Time )
import MetaBrush.UI.FileBar
( createFileBar )
import MetaBrush.UI.InfoBar
@ -72,7 +75,7 @@ import MetaBrush.UI.Menu
import MetaBrush.UI.Panels
( createPanelBar )
import MetaBrush.UI.ToolBar
( createToolBar )
( Tool(..), Mode(..), createToolBar )
import MetaBrush.UI.Viewport
( Viewport(..), createViewport )
import qualified Paths_MetaBrush as Cabal
@ -142,7 +145,12 @@ main = do
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe ( Point2D Double, Time ) ) Nothing
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path
overlayTVar <- STM.newTVarIO @( Maybe Overlay ) Nothing
---------------------------------------------------------
-- Initialise GTK
@ -251,7 +259,7 @@ main = do
---------------------------------------------------------
-- Tool bar
_ <- createToolBar colours toolBar
_ <- createToolBar toolTVar modeTVar colours toolBar
---------------------------------------------------------
-- Main viewport
@ -261,6 +269,7 @@ main = do
colours
activeDocumentTVar
openDocumentsTVar
overlayTVar
viewportGrid
---------------------------------------------------------
@ -290,7 +299,10 @@ main = do
-- Actions
handleEvents
activeDocumentTVar openDocumentsTVar pressedKeysTVar
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar
overlayTVar
window viewportDrawingArea infoBarElements
---------------------------------------------------------

7
assets/theme.css
View file

@ -72,7 +72,12 @@
.glass {
color: rgba(156, 231, 255, 0.5);
}
.selection {
color: rgba(161,201,236,0.5)
}
.selectionOutline {
color: rgb(74,150,218);
}
/* Proper CSS styling */

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

@ -51,6 +51,8 @@ data ColourRecord a
, tabScrollbar :: !a
, magnifier :: !a
, glass :: !a
, selection :: !a
, selectionOutline :: !a
}
deriving stock ( Show, Functor, Foldable, Traversable )
@ -90,6 +92,8 @@ colourNames = Colours
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ]
, selection = ColourName "selection" Colour [ GTK.StateFlagsNormal ]
, selectionOutline = ColourName "selectionOutline" Colour [ GTK.StateFlagsNormal ]
}
type Colours = ColourRecord GDK.RGBA

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

@ -72,6 +72,10 @@ data FocusState
| Selected
deriving stock Show
data Overlay
= SelectionRectangle !( Point2D Double ) !( Point2D Double )
deriving stock Show
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar

21
src/app/MetaBrush/Document/Selection.hs Normal file
View file

@ -0,0 +1,21 @@
module MetaBrush.Document.Selection
( selectAt, selectRectangle )
where
-- base
import Data.Word
( Word32 )
-- MetaBrush
import Math.Vector2D
( Point2D(..) )
import MetaBrush.Document
( Document(..) )
--------------------------------------------------------------------------------
selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document
selectAt _ _ doc = doc
selectRectangle :: [ Word32 ] -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle _ _ _ doc = doc

229
src/app/MetaBrush/Event.hs
View file

@ -11,9 +11,6 @@ import Control.Monad
( unless )
import Data.Foldable
( for_ )
-- base
import Data.Semigroup
( Arg(..), Min(..) )
import Data.Word
( Word32 )
@ -38,10 +35,12 @@ import qualified GI.Gdk as GDK
import qualified GI.Gtk as GTK
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar, readTVarIO, writeTVar )
( TVar, readTVar, readTVarIO, writeTVar, swapTVar )
-- MetaBrush
import Math.Module
@ -49,22 +48,43 @@ import Math.Module
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), currentDocument )
( Document(..), Overlay(..) )
import MetaBrush.Document.Selection
( selectAt, selectRectangle )
import MetaBrush.Time
( Time, monotonicTime, DTime(DSeconds) )
import MetaBrush.UI.Coordinates
( closestPoint, toViewportCoordinates )
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar )
import MetaBrush.UI.ToolBar
( Tool(..), Mode )
--------------------------------------------------------------------------------
handleEvents :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.Window -> GTK.DrawingArea -> InfoBar -> IO ()
handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewportDrawingArea infoBar = do
handleEvents
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode
-> STM.TVar ( Maybe Overlay )
-> GTK.Window -> GTK.DrawingArea -> InfoBar
-> IO ()
handleEvents
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar _modeTVar
overlayTVar
window viewportDrawingArea infoBar = do
-- Mouse events
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
( handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar )
( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
( handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar )
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea )
-- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
@ -78,13 +98,27 @@ handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewpor
--------------------------------------------------------------------------------
-- Mouse events.
handleMotionEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> GTK.DrawingArea -> InfoBar -> GDK.EventMotion -> IO Bool
handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar eventMotion = do
handleMotionEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )
-> STM.TVar Tool
-> STM.TVar ( Maybe Overlay )
-> GTK.DrawingArea -> InfoBar
-> GDK.EventMotion
-> IO Bool
handleMotionEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar
toolTVar
overlayTVar
viewportDrawingArea infoBar
eventMotion
= do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc@( Document { .. } ) -> do
for_ ( IntMap.lookup i docs ) \ ( Document { .. } ) -> do
----------------------------------------------------------
-- Update mouse position in info bar on mouse move event.
@ -107,11 +141,32 @@ handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoB
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
}
updateInfoBar infoBar infoData
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
----------------------------------------------------------
-- Tool dependent updating.
updateOverlay mouseHoldTVar toolTVar overlayTVar pos
GTK.widgetQueueDraw viewportDrawingArea
pure True
handleScrollEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.DrawingArea -> InfoBar -> GDK.EventScroll -> IO Bool
handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar scrollEvent = do
handleScrollEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe Overlay )
-> GTK.DrawingArea -> InfoBar
-> GDK.EventScroll
-> IO Bool
handleScrollEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar overlayTVar
viewportDrawingArea infoBar
scrollEvent
= do
dx <- GDK.getEventScrollDeltaX scrollEvent
dy <- GDK.getEventScrollDeltaY scrollEvent
@ -162,27 +217,143 @@ handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportD
in doc { viewportCenter = newCenter }
docs' :: IntMap Document
docs' = IntMap.insert i newDoc docs
STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
GTK.widgetQueueDraw viewportDrawingArea
let
newZoomFactor :: Double
newZoomFactor = zoomFactor newDoc
newCenter :: Point2D Double
newCenter = viewportCenter newDoc
toNewViewport :: Point2D Double -> Point2D Double
toNewViewport = toViewportCoordinates newZoomFactor ( viewportWidth, viewportHeight ) newCenter
finalZoomFactor :: Double
finalZoomFactor = zoomFactor newDoc
finalCenter :: Point2D Double
finalCenter = viewportCenter newDoc
toFinalViewport :: Point2D Double -> Point2D Double
toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
finalMousePos :: Point2D Double
finalMousePos = toFinalViewport ( Point2D x y )
infoData :: InfoData
infoData = InfoData
{ zoom = zoomFactor newDoc
, mousePos
, topLeftPos = toNewViewport ( Point2D 0 0 )
, botRightPos = toNewViewport ( Point2D viewportWidth viewportHeight )
{ zoom = finalZoomFactor
, mousePos = finalMousePos
, topLeftPos = toFinalViewport ( Point2D 0 0 )
, botRightPos = toFinalViewport ( Point2D viewportWidth viewportHeight )
}
updateInfoBar infoBar infoData
STM.atomically do
STM.writeTVar openDocumentsTVar docs'
STM.writeTVar mousePosTVar ( Just finalMousePos )
updateOverlay mouseHoldTVar toolTVar overlayTVar finalMousePos
GTK.widgetQueueDraw viewportDrawingArea
pure False
handleMouseButtonEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
handleMouseButtonEvent
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar _pressedKeysTVar
viewportDrawingArea
mouseClickEvent
= do
button <- GDK.getEventButtonButton mouseClickEvent
case button of
-- left mouse button
1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ ( Document { zoomFactor, viewportCenter } ) -> do
x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY mouseClickEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
time <- monotonicTime
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
STM.writeTVar mouseHoldTVar ( Just ( pos, time ) )
_ -> pure ()
pure False
handleMouseButtonRelease
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool
-> STM.TVar ( Maybe Overlay )
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
handleMouseButtonRelease
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar
overlayTVar
viewportDrawingArea
mouseReleaseEvent
= do
button <- GDK.getEventButtonButton mouseReleaseEvent
case button of
-- left mouse button
1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
x <- GDK.getEventButtonX mouseReleaseEvent
y <- GDK.getEventButtonY mouseReleaseEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
t <- monotonicTime
STM.atomically do
pressedKeys <- STM.readTVar pressedKeysTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
STM.writeTVar overlayTVar Nothing
tool <- STM.readTVar toolTVar
let
newDoc :: Document
newDoc = case tool of
Selection
| Just ( pos0, t0 ) <- mbHoldPos
, pos0 /= pos
, ( t0 --> t ) > DSeconds 0.3
-> selectRectangle pressedKeys pos0 pos doc
| otherwise
-> selectAt pressedKeys pos doc
Pen -> doc -- TODO
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mousePosTVar ( Just pos )
GTK.widgetQueueDraw viewportDrawingArea
-- any other mouse button: no action (for the moment)
_ -> pure ()
pure False
updateOverlay :: STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar Tool -> STM.TVar ( Maybe Overlay ) -> Point2D Double -> STM ()
updateOverlay mouseHoldTVar toolTVar overlayTVar p = do
tool <- STM.readTVar toolTVar
case tool of
-- Draw selection rectangle if performing a selection.
Selection -> do
mbHold <- STM.readTVar mouseHoldTVar
case mbHold of
Just ( p0, _ ) -> STM.writeTVar overlayTVar ( Just ( SelectionRectangle p0 p ) )
Nothing -> STM.writeTVar overlayTVar Nothing
-- Pen tool: show preview (TODO).
Pen -> STM.writeTVar overlayTVar Nothing
--------------------------------------------------------------------------------
-- Keyboard events.

35
src/app/MetaBrush/Render/Document.hs
View file

@ -11,7 +11,7 @@ module MetaBrush.Render.Document
-- base
import Data.Foldable
( traverse_ )
( for_, traverse_ )
import Data.Functor.Compose
( Compose(..) )
import Data.Int
@ -32,6 +32,7 @@ import MetaBrush.Asset.Colours
import MetaBrush.Document
( Document(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, Overlay(..)
)
import MetaBrush.Render.Util
( withRGBA )
@ -55,8 +56,8 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
--------------------------------------------------------------------------------
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render ()
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render ()
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do
Cairo.save
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
@ -64,9 +65,10 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente
Cairo.translate ( -cx ) ( -cy )
let
Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes
renderPaths
renderPoints
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes
rdrPaths
rdrPoints
for_ mbOverlay ( renderOverlay cols zoomFactor )
Cairo.restore
@ -244,3 +246,24 @@ drawCubicBezier ( Colours { path } ) zoom
Cairo.stroke
Cairo.restore
renderOverlay :: Colours -> Double -> Overlay -> Cairo.Render ()
renderOverlay ( Colours { .. } ) zoom ( SelectionRectangle ( Point2D x0 y0 ) ( Point2D x1 y1 ) ) = do
Cairo.save
Cairo.moveTo x0 y0
Cairo.lineTo x1 y0
Cairo.lineTo x1 y1
Cairo.lineTo x0 y1
Cairo.closePath
Cairo.setLineWidth ( 1 / zoom )
withRGBA selection Cairo.setSourceRGBA
Cairo.fillPreserve
withRGBA selectionOutline Cairo.setSourceRGBA
Cairo.stroke
Cairo.restore

75
src/app/MetaBrush/Time.hs Normal file
View file

@ -0,0 +1,75 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
module MetaBrush.Time
( Time(..), DTime(DSeconds, ..), dSeconds
, pprSeconds
, monotonicTime
)
where
-- base
import Data.Int
( Int64 )
import Data.Semigroup
( Sum(..) )
-- acts
import Data.Act
( Act, Torsor )
-- gi-glib
import qualified GI.GLib.Functions as GLib
( getMonotonicTime )
-- groups
import Data.Group
( Group )
-- transformers
import Control.Monad.IO.Class
( MonadIO )
--------------------------------------------------------------------------------
newtype Time = Seconds { seconds :: Double }
deriving newtype ( Eq, Ord )
deriving stock Show
deriving ( Act DTime, Torsor DTime )
via DTime
newtype DTime = DTime { dTime :: Time }
deriving stock Show
deriving newtype ( Eq, Ord )
deriving ( Semigroup, Monoid, Group )
via ( Sum Double )
{-# COMPLETE DSeconds #-}
pattern DSeconds :: Double -> DTime
pattern DSeconds secs = DTime ( Seconds secs )
dSeconds :: DTime -> Double
dSeconds ( DSeconds secs ) = secs
pprSeconds :: ( String, String, String ) -> Time -> String
pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute
where
pm :: String
pm
| secs <= (-1) = "-"
| otherwise = ""
h, r, m, s :: Int64
(h,r) = ( round $ abs secs ) `divMod` 3600
(m,s) = r `divMod` 60
fixed2 :: String -> String
fixed2 [] = "00"
fixed2 [x] = ['0', x]
fixed2 xs = xs
absolute
| h > 0 = show h <> h_name <> fixed2 (show m) <> m_name <> fixed2 (show s) <> s_name
| m > 0 = show m <> m_name <> fixed2 (show s) <> s_name
| otherwise = show s <> s_name
monotonicTime :: MonadIO m => m Time
monotonicTime = Seconds . ( * 1e-6 ) . fromIntegral <$> GLib.getMonotonicTime

45
src/app/MetaBrush/UI/Coordinates.hs
View file

@ -18,14 +18,16 @@ import Data.Act
)
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint )
import Math.Module
( (*^), squaredNorm )
( (*^), squaredNorm, closestPointToLine )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Stroke(..) )
( Stroke(..), StrokePoint(..), PointType(..) )
--------------------------------------------------------------------------------
@ -36,15 +38,32 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
• viewportCenter
-- | Find the closest point in a set of strokes.
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Point2D Double )
closestPoint = undefined
{-
closestPoint c ( Stroke pts ) = go pts
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
closestPoint c ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } ) = go pt0 pts
where
go :: [ Point2D Double ] -> ArgMin Double ( Point2D Double )
go [] = error "'closestPoint': empty stroke"
go [p] = Min ( Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) p )
go (p0:p1:p2:ps)
= fmap ( fmap snd ) ( Quadratic.closestPoint @(Vector2D Double) ( Quadratic.Bezier { .. } ) c )
<> go (p2:ps)
-}
res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
go :: StrokePoint -> [ StrokePoint ] -> ArgMin Double ( Maybe ( Point2D Double ) )
go p0 [] = res ( strokePoint p0 )
-- Line.
go p0 ( p1 : ps )
| PathPoint <- pointType p1
= res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) )
<> go p1 ps
-- Quadratic Bézier curve.
go p0 ( p1 : p2 : ps )
| ControlPoint <- pointType p1
, PathPoint <- pointType p2
= fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Quadratic.Bezier { .. } ) c )
<> go p2 ps
-- Cubic Bézier curve.
go p0 ( p1 : p2 : p3 : ps )
| ControlPoint <- pointType p1
, ControlPoint <- pointType p1
, PathPoint <- pointType p3
= fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Cubic.Bezier { .. } ) c )
<> go p3 ps
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 : ps )
closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing

40
src/app/MetaBrush/UI/ToolBar.hs
View file

@ -1,10 +1,13 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.ToolBar
( ToolBar(..), createToolBar )
( Tool(..), Mode(..)
, ToolBar(..), createToolBar
)
where
-- base
@ -20,6 +23,12 @@ import qualified GI.Cairo.Render.Connector as Cairo
-- gi-gtk
import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, writeTVar )
-- MetaBrush
import MetaBrush.Asset.Colours
( Colours )
@ -32,6 +41,17 @@ import MetaBrush.Render.Util
--------------------------------------------------------------------------------
data Tool
= Selection
| Pen
deriving stock Show
data Mode
= Path
| Brush
| Meta
deriving stock Show
data ToolBar
= ToolBar
{ selectionTool :: !GTK.RadioButton
@ -41,8 +61,8 @@ data ToolBar
, metaTool :: !GTK.RadioButton
}
createToolBar :: Colours -> GTK.Box -> IO ToolBar
createToolBar colours toolBar = do
createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.Box -> IO ToolBar
createToolBar toolTVar modeTVar colours toolBar = do
widgetAddClass toolBar "toolBar"
@ -52,11 +72,23 @@ createToolBar colours toolBar = do
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool )
_ <- GTK.onButtonClicked selectionTool
( STM.atomically $ STM.writeTVar toolTVar Selection )
_ <- GTK.onButtonClicked penTool
( STM.atomically $ STM.writeTVar toolTVar Pen )
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
_ <- GTK.onButtonClicked pathTool
( STM.atomically $ STM.writeTVar modeTVar Path )
_ <- GTK.onButtonClicked brushTool
( STM.atomically $ STM.writeTVar modeTVar Brush )
_ <- GTK.onButtonClicked metaTool
( STM.atomically $ STM.writeTVar modeTVar Meta )
GTK.boxPackStart toolBar selectionTool True True 0
GTK.boxPackStart toolBar penTool True True 0

12
src/app/MetaBrush/UI/Viewport.hs
View file

@ -30,13 +30,15 @@ import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM.TVar as STM
( TVar )
( TVar, readTVarIO )
-- MetaBrush
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Document
( Document(..), currentDocument )
( Document(..), currentDocument
, Overlay
)
import MetaBrush.Render.Document
( renderDocument )
import MetaBrush.Render.Util
@ -53,9 +55,10 @@ createViewport
:: Colours
-> STM.TVar ( Maybe Int )
-> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe Overlay )
-> GTK.Grid
-> IO Viewport
createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do
createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
widgetAddClass viewportGrid "viewport"
@ -142,11 +145,12 @@ createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do
void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do
-- Get the relevant document information
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
mbOverlay <- STM.readTVarIO overlayTVar
for_ mbDoc \ doc -> do
( `Cairo.renderWithContext` ctx ) $ do
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
renderDocument colours ( viewportWidth, viewportHeight ) doc
renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay
pure True
pure ( Viewport { .. } )

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

@ -20,6 +20,8 @@ module Math.Bezier.Cubic
-- base
import Data.List.NonEmpty
( NonEmpty(..) )
import Data.Semigroup
( ArgMin, Min(..), Arg(..) )
import GHC.Generics
( Generic )
@ -82,7 +84,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
pt = lerp @v t q2 r1
-- | Finds the closest point to a given point on a cubic Bézier curve.
closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ( r, p )
closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p )
closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
where
roots :: [ r ]
@ -102,14 +104,14 @@ closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
a4 = 5 * v'' ^.^ v'''
a5 = squaredNorm v'''
pickClosest :: NonEmpty r -> ( r, p )
pickClosest :: NonEmpty r -> ArgMin r ( r, p )
pickClosest ( s :| ss ) = go s q nm0 ss
where
q :: p
q = bezier @v pts s
nm0 :: r
nm0 = squaredNorm ( c --> q :: v )
go t p _ [] = ( t, p )
go t p nm [] = Min ( Arg nm ( t, p ) )
go t p nm ( t' : ts )
| nm' < nm = go t' p' nm' ts
| otherwise = go t p nm ts

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

@ -6,6 +6,7 @@
module Math.Module
( Module(..), lerp
, Inner(..), squaredNorm
, proj, projC, closestPointToLine
)
where
@ -44,5 +45,30 @@ class Module r m => Inner r m where
(^.^) :: m -> m -> r
-- | Squared norm of a vector, computed using the inner product.
squaredNorm :: Inner r m => m -> r
squaredNorm :: forall m r. Inner r m => m -> r
squaredNorm v = v ^.^ v
-- | Projects the first argument onto the second.
proj :: forall m r. ( Inner r m, Fractional r ) => m -> m -> m
proj x y = projC x y *^ y
-- | Projection constant: how far along the projection of the first vector lands along the second vector.
projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
projC x y = x ^.^ y / squaredNorm y
closestPointToLine
:: forall v r p
. ( Inner r v, Torsor v p, Fractional r, Ord r )
=> p -> p -> p -> p
closestPointToLine c p0 p1
| t <= 0
= p0
| t >= 1
= p1
| otherwise
= ( t *^ v01 ) • p0
where
v01 :: v
v01 = p0 --> p1
t :: r
t = projC ( p0 --> c ) v01

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

@ -37,12 +37,12 @@ import Math.Module
--------------------------------------------------------------------------------
data Point2D a = Point2D !a !a
deriving stock ( Show, Generic, Functor, Foldable, Traversable )
deriving stock ( Show, Eq, Generic, Functor, Foldable, Traversable )
deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
via Vector2D a
newtype Vector2D a = Vector2D { tip :: Point2D a }
deriving stock ( Show, Functor, Foldable, Traversable )
deriving stock ( Show, Eq, Functor, Foldable, Traversable )
deriving ( Semigroup, Monoid, Group )
via GenericProduct ( Point2D ( Sum a ) )