From e3d920573d12a25cbd6f7b62cb9bf349a61592fe Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 14 Sep 2020 06:03:45 +0200 Subject: [PATCH] add debug mode to visualise fitting algorithm --- app/Main.hs | 18 ++- assets/theme.css | 14 +- src/app/MetaBrush/Asset/Colours.hs | 3 +- src/app/MetaBrush/Asset/Tools.hs | 210 ++++++++++++++++++++++++++- src/app/MetaBrush/Context.hs | 3 +- src/app/MetaBrush/Render/Document.hs | 100 +++++++++++-- src/app/MetaBrush/UI/Panels.hs | 11 +- src/app/MetaBrush/UI/ToolBar.hs | 36 ++++- src/app/MetaBrush/UI/ToolBar.hs-boot | 25 ++++ src/lib/Math/Bezier/Cubic/Fit.hs | 38 ++++- src/lib/Math/Bezier/Stroke.hs | 48 +++--- 11 files changed, 430 insertions(+), 76 deletions(-) create mode 100644 src/app/MetaBrush/UI/ToolBar.hs-boot diff --git a/app/Main.hs b/app/Main.hs index d5c6c18..8d3d39f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -207,17 +207,18 @@ main = do modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty toolTVar <- STM.newTVarIO @Tool Selection modeTVar <- STM.newTVarIO @Mode Path + debugTVar <- STM.newTVarIO @Bool False partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty showGuidesTVar <- STM.newTVarIO @Bool True maxHistorySizeTVar <- STM.newTVarIO @Int 1000 fitParametersTVar <- STM.newTVarIO @FitParameters ( FitParameters - { maxSubdiv = 2 - , nbSegments = 13 - , dist_tol = 2e-3 - , t_tol = 5e-4 - , maxIters = 500 + { maxSubdiv = 3 + , nbSegments = 30 + , dist_tol = 5e-4 + , t_tol = 1e-4 + , maxIters = 100 } ) @@ -243,7 +244,7 @@ main = do GTK.setWindowResizable window True GTK.setWindowDecorated window False GTK.setWindowTitle window "MetaBrush" - GTK.windowSetDefaultSize window 800 600 + GTK.windowSetDefaultSize window 1024 768 GTK.widgetAddEvents window [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ] @@ -336,11 +337,12 @@ main = do mbHoldAction <- STM.readTVar mouseHoldTVar mbPartialPath <- STM.readTVar partialPathTVar mode <- STM.readTVar modeTVar + debug <- STM.readTVar debugTVar showGuides <- STM.readTVar showGuidesTVar fitParameters <- STM.readTVar fitParametersTVar pure do renderDocument - colours fitParameters mode ( viewportWidth, viewportHeight ) + colours fitParameters mode debug ( viewportWidth, viewportHeight ) mbMousePos mbHoldAction mbPartialPath doc renderRuler @@ -378,7 +380,7 @@ main = do --------------------------------------------------------- -- Tool bar - _ <- createToolBar toolTVar modeTVar colours viewportDrawingArea toolBar + _ <- createToolBar variables colours viewportDrawingArea toolBar --------------------------------------------------------- -- Info bar diff --git a/assets/theme.css b/assets/theme.css index 42c0fb4..4bb24ec 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -78,6 +78,12 @@ .tabScrollbar { background-color: rgba(48, 45, 38, 0.66); } +.ruler { + background-color: rgb(237, 226, 154); + min-width: 16px; + min-height: 16px; + background-size: 16px 16px; +} .rulerTick { color: black; } @@ -151,13 +157,6 @@ tooltip { /* Rulers */ -.ruler { - background-color: rgb(237, 226, 154); - min-width: 16px; - min-height: 16px; - background-size: 16px 16px; -} - .leftRuler { border-right: 1px solid black; min-width: 16px; @@ -435,6 +434,7 @@ tooltip { .panel { background-color: rgb(72,70,61); + min-height: 20px; } /* Info bar */ diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index 47eac0e..ca2fc53 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -37,7 +37,7 @@ data ColourRecord a , path, brush, brushStroke, brushCenter , pointHover, pointSelected , viewport, viewportScrollbar, tabScrollbar - , guide, rulerTick, magnifier, glass + , guide, rulerBg, rulerTick, magnifier, glass , selected, selectedOutline :: !a } deriving stock ( Show, Functor, Foldable, Traversable ) @@ -80,6 +80,7 @@ colourNames = Colours , viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ] , viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] + , rulerBg = ColourName "ruler" BackgroundColour [ GTK.StateFlagsNormal ] , rulerTick = ColourName "rulerTick" Colour [ GTK.StateFlagsNormal ] , guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ] , magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ] diff --git a/src/app/MetaBrush/Asset/Tools.hs b/src/app/MetaBrush/Asset/Tools.hs index 7da0f22..bc06160 100644 --- a/src/app/MetaBrush/Asset/Tools.hs +++ b/src/app/MetaBrush/Asset/Tools.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} module MetaBrush.Asset.Tools - ( drawBrush, drawMeta, drawPath, drawPen ) + ( drawBrush, drawBug, drawMeta, drawPath, drawPen ) where -- gi-cairo-render @@ -31,7 +31,7 @@ drawBrush ( Colours { base, splash } ) = do Cairo.setLineWidth 1 withRGBA base Cairo.setSourceRGBA - Cairo.strokePreserve + Cairo.stroke -- Brush body @@ -48,7 +48,7 @@ drawBrush ( Colours { base, splash } ) = do Cairo.closePath withRGBA splash Cairo.setSourceRGBA - Cairo.fillPreserve + Cairo.fill -- Brush tip Cairo.newPath @@ -63,7 +63,7 @@ drawBrush ( Colours { base, splash } ) = do Cairo.closePath withRGBA base Cairo.setSourceRGBA - Cairo.fillPreserve + Cairo.fill pure True @@ -94,7 +94,7 @@ drawMeta ( Colours { splash } ) = do Cairo.closePath withRGBA splash Cairo.setSourceRGBA - Cairo.fillPreserve + Cairo.fill pure True @@ -204,7 +204,7 @@ drawPen ( Colours { base, splash } ) = do Cairo.curveTo 21.449219 27.46875 21.308594 26.394531 21.308594 26.394531 Cairo.curveTo 21.179688 22.230469 24.476563 16.863281 24.476563 16.863281 Cairo.closePath - Cairo.fillPreserve + Cairo.fill withRGBA splash Cairo.setSourceRGBA Cairo.newPath @@ -219,6 +219,200 @@ drawPen ( Colours { base, splash } ) = do Cairo.lineTo 26.640625 13.464844 Cairo.lineTo 28.875 9.597656 Cairo.closePath - Cairo.fillPreserve + Cairo.fill - pure True \ No newline at end of file + pure True + + +-- | Bug icon. Width = 40, height = 40. +drawBug :: Colours -> Cairo.Render Bool +drawBug ( Colours {..} ) = do + + withRGBA splash Cairo.setSourceRGBA + + -- Main butterfly shape (fill). + Cairo.newPath + Cairo.moveTo 16.996094 23.980469 + Cairo.curveTo 16.996094 23.980469 16.222656 26.507813 15.796875 28.203125 + Cairo.curveTo 15.4375 29.644531 15.527344 31.308594 16.335938 32.453125 + Cairo.curveTo 16.8125 33.128906 17.414063 33.683594 18.234375 33.613281 + Cairo.curveTo 20.246094 33.441406 23.480469 32.308594 25.085938 31.679688 + Cairo.curveTo 25.648438 31.457031 26.0625 30.730469 25.542969 29.425781 + Cairo.curveTo 25.023438 28.117188 23.886719 26.554688 23.886719 26.554688 + Cairo.curveTo 24.746094 27.292969 25.777344 28.53125 26.8125 28.6875 + Cairo.curveTo 27.351563 28.769531 29.625 28.847656 30.128906 28.632813 + Cairo.curveTo 32.265625 27.71875 33.246094 26.621094 34.417969 25.539063 + Cairo.curveTo 35.289063 24.730469 35.078125 23.976563 34.5625 23.472656 + Cairo.curveTo 34.511719 23.421875 34.453125 23.371094 34.394531 23.324219 + Cairo.curveTo 28.414063 18.578125 20.386719 21.746094 20.386719 21.746094 + Cairo.lineTo 19.09375 20.449219 + Cairo.curveTo 19.09375 20.449219 22.257813 12.421875 17.511719 6.441406 + Cairo.curveTo 17.464844 6.382813 17.417969 6.328125 17.363281 6.273438 + Cairo.curveTo 16.859375 5.761719 16.105469 5.546875 15.296875 6.421875 + Cairo.curveTo 14.214844 7.589844 13.117188 8.574219 12.207031 10.710938 + Cairo.curveTo 11.992188 11.210938 12.066406 13.484375 12.148438 14.023438 + Cairo.curveTo 12.308594 15.058594 13.546875 16.09375 14.28125 16.949219 + Cairo.curveTo 14.28125 16.949219 12.722656 15.8125 11.410156 15.292969 + Cairo.curveTo 10.105469 14.777344 9.378906 15.1875 9.160156 15.75 + Cairo.curveTo 8.53125 17.355469 7.394531 20.589844 7.222656 22.601563 + Cairo.curveTo 7.152344 23.421875 7.707031 24.027344 8.382813 24.5 + Cairo.curveTo 9.527344 25.308594 11.191406 25.398438 12.632813 25.039063 + Cairo.curveTo 14.328125 24.613281 16.855469 23.839844 16.855469 23.839844 + Cairo.closePath + Cairo.fill + + -- Wing highlights. + withRGBA viewport Cairo.setSourceRGBA + + Cairo.newPath + Cairo.moveTo 14.78125 17.980469 + Cairo.curveTo 14.78125 17.980469 8.765625 17.734375 8.136719 19.316406 + Cairo.curveTo 8.488281 17.304688 9.316406 15.464844 9.316406 15.464844 + Cairo.curveTo 12.179688 14.21875 13.199219 16.65625 14.78125 17.980469 + Cairo.closePath + Cairo.fill + + Cairo.newPath + Cairo.moveTo 22.917969 26.117188 + Cairo.curveTo 22.917969 26.117188 23.164063 32.132813 21.582031 32.761719 + Cairo.curveTo 23.59375 32.410156 25.433594 31.578125 25.433594 31.578125 + Cairo.curveTo 26.679688 28.71875 24.238281 27.695313 22.917969 26.117188 + Cairo.closePath + Cairo.moveTo 22.917969 26.117188 + Cairo.fill + + Cairo.newPath + Cairo.moveTo 21.308594 24.167969 + Cairo.lineTo 19.574219 22.433594 + Cairo.curveTo 23.222656 20.144531 30.460938 20.058594 34.640625 23.632813 + Cairo.curveTo 35.484375 24.4375 34.882813 25.175781 34.027344 25.902344 + Cairo.curveTo 32.550781 23.214844 24.875 20.945313 21.308594 24.167969 + Cairo.closePath + Cairo.moveTo 21.308594 24.167969 + Cairo.fill + + Cairo.newPath + Cairo.moveTo 18.375 33.636719 + Cairo.lineTo 18.523438 23.6875 + Cairo.lineTo 17.152344 22.3125 + Cairo.lineTo 7.199219 22.460938 + Cairo.curveTo 8.683594 26.9375 13.039063 24.925781 16.988281 23.828125 + Cairo.curveTo 15.542969 28.855469 15.066406 33.492188 18.375 33.636719 + Cairo.closePath + Cairo.fill + + Cairo.newPath + Cairo.moveTo 16.734375 19.59375 + Cairo.lineTo 18.46875 21.328125 + Cairo.curveTo 20.757813 17.679688 20.84375 10.441406 17.269531 6.261719 + Cairo.curveTo 16.464844 5.417969 15.726563 6.019531 15 6.875 + Cairo.curveTo 17.6875 8.351563 19.957031 16.027344 16.734375 19.59375 + Cairo.closePath + Cairo.fill + + + -- Inner stroke lines. + withRGBA pathPointOutline Cairo.setSourceRGBA + Cairo.setLineWidth 0.7 + Cairo.newPath + Cairo.moveTo 33.964844 25.773438 + Cairo.curveTo 31.613281 23.15625 28.257813 22.132813 23.363281 22.984375 + Cairo.stroke + Cairo.newPath + Cairo.moveTo 24.085938 26.734375 + Cairo.lineTo 21.511719 24.238281 + Cairo.stroke + + Cairo.newPath + Cairo.moveTo 15.0625 6.875 + Cairo.curveTo 17.679688 9.222656 18.703125 12.582031 17.855469 17.472656 + Cairo.stroke + + Cairo.newPath + Cairo.moveTo 14.101563 16.753906 + Cairo.lineTo 16.597656 19.324219 + Cairo.stroke + + -- Main butterfly shape (stroke). + Cairo.setLineWidth 1 + Cairo.newPath + Cairo.moveTo 16.996094 23.980469 + Cairo.curveTo 16.996094 23.980469 16.222656 26.507813 15.796875 28.203125 + Cairo.curveTo 15.4375 29.644531 15.527344 31.308594 16.335938 32.453125 + Cairo.curveTo 16.8125 33.128906 17.414063 33.683594 18.234375 33.613281 + Cairo.curveTo 20.246094 33.441406 23.480469 32.308594 25.085938 31.679688 + Cairo.curveTo 25.648438 31.457031 26.0625 30.730469 25.542969 29.425781 + Cairo.curveTo 25.023438 28.117188 23.886719 26.554688 23.886719 26.554688 + Cairo.curveTo 24.746094 27.292969 25.777344 28.53125 26.8125 28.6875 + Cairo.curveTo 27.351563 28.769531 29.625 28.847656 30.128906 28.632813 + Cairo.curveTo 32.265625 27.71875 33.246094 26.621094 34.417969 25.539063 + Cairo.curveTo 35.289063 24.730469 35.078125 23.976563 34.5625 23.472656 + Cairo.curveTo 34.511719 23.421875 34.453125 23.371094 34.394531 23.324219 + Cairo.curveTo 28.414063 18.578125 20.386719 21.746094 20.386719 21.746094 + Cairo.lineTo 19.09375 20.449219 + Cairo.curveTo 19.09375 20.449219 22.257813 12.421875 17.511719 6.441406 + Cairo.curveTo 17.464844 6.382813 17.417969 6.328125 17.363281 6.273438 + Cairo.curveTo 16.859375 5.761719 16.105469 5.546875 15.296875 6.421875 + Cairo.curveTo 14.214844 7.589844 13.117188 8.574219 12.207031 10.710938 + Cairo.curveTo 11.992188 11.210938 12.066406 13.484375 12.148438 14.023438 + Cairo.curveTo 12.308594 15.058594 13.546875 16.09375 14.28125 16.949219 + Cairo.curveTo 14.28125 16.949219 12.722656 15.8125 11.410156 15.292969 + Cairo.curveTo 10.105469 14.777344 9.378906 15.1875 9.160156 15.75 + Cairo.curveTo 8.53125 17.355469 7.394531 20.589844 7.222656 22.601563 + Cairo.curveTo 7.152344 23.421875 7.707031 24.027344 8.382813 24.5 + Cairo.curveTo 9.527344 25.308594 11.191406 25.398438 12.632813 25.039063 + Cairo.curveTo 14.328125 24.613281 16.855469 23.839844 16.855469 23.839844 + Cairo.closePath + Cairo.stroke + + -- Antennae. + withRGBA pathPointOutline Cairo.setSourceRGBA + Cairo.newPath + Cairo.moveTo 21.863281 18.566406 + Cairo.curveTo 21.988281 18.363281 25.179688 13.878906 24.394531 9.574219 + Cairo.curveTo 24.394531 9.558594 24.328125 9.144531 24.050781 8.867188 + Cairo.curveTo 23.777344 8.59375 23.191406 8.59375 22.898438 8.886719 + Cairo.curveTo 22.605469 9.179688 22.585938 9.644531 22.863281 9.917969 + Cairo.curveTo 23.042969 10.097656 23.542969 10.09375 23.554688 10.40625 + Cairo.curveTo 24.234375 14.113281 21.546875 18.210938 21.519531 18.257813 + Cairo.curveTo 21.433594 18.398438 21.761719 18.738281 21.863281 18.566406 + Cairo.closePath + Cairo.fillPreserve + Cairo.stroke + + Cairo.newPath + Cairo.moveTo 22.214844 18.917969 + Cairo.curveTo 22.417969 18.792969 26.902344 15.601563 31.207031 16.386719 + Cairo.curveTo 31.222656 16.386719 31.636719 16.453125 31.914063 16.730469 + Cairo.curveTo 32.1875 17.003906 32.1875 17.589844 31.894531 17.882813 + Cairo.curveTo 31.601563 18.175781 31.136719 18.191406 30.859375 17.917969 + Cairo.curveTo 30.683594 17.738281 30.6875 17.238281 30.375 17.226563 + Cairo.curveTo 26.667969 16.546875 22.570313 19.230469 22.519531 19.261719 + Cairo.curveTo 22.382813 19.347656 22.042969 19.019531 22.214844 18.917969 + Cairo.closePath + Cairo.fillPreserve + Cairo.stroke + + -- Butterfly body & head. + withRGBA path Cairo.setSourceRGBA + Cairo.newPath + Cairo.moveTo 20.351563 22.605469 + Cairo.curveTo 18.414063 24.546875 14.851563 27.230469 14.3125 26.691406 + Cairo.curveTo 13.777344 26.152344 16.265625 22.398438 18.207031 20.460938 + Cairo.curveTo 20.144531 18.519531 20.597656 19.691406 20.894531 19.988281 + Cairo.curveTo 21.191406 20.289063 22.292969 20.667969 20.351563 22.605469 + Cairo.closePath + Cairo.fillPreserve + Cairo.stroke + + Cairo.newPath + Cairo.moveTo 22.789063 19.429688 + Cairo.curveTo 22.789063 18.722656 22.222656 18.148438 21.527344 18.148438 + Cairo.curveTo 20.832031 18.148438 20.269531 18.722656 20.269531 19.429688 + Cairo.curveTo 20.269531 20.140625 20.832031 20.714844 21.527344 20.714844 + Cairo.curveTo 22.222656 20.714844 22.789063 20.140625 22.789063 19.429688 + Cairo.closePath + Cairo.fillPreserve + Cairo.stroke + + pure True diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 31fd953..2e39796 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -45,7 +45,7 @@ import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar ) import {-# SOURCE #-} MetaBrush.UI.Menu ( Menu, ResourceType(Object) ) -import MetaBrush.UI.ToolBar +import {-# SOURCE #-} MetaBrush.UI.ToolBar ( Tool, Mode ) import MetaBrush.UI.Viewport ( Viewport(..), Ruler(..) ) @@ -76,6 +76,7 @@ data Variables , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , toolTVar :: !( STM.TVar Tool ) , modeTVar :: !( STM.TVar Mode ) + , debugTVar :: !( STM.TVar Bool ) , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) , fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) ) , showGuidesTVar :: !( STM.TVar Bool ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 8c57a7b..71658d5 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -19,8 +19,10 @@ module MetaBrush.Render.Document -- base import Control.Monad ( guard, when, unless ) +import Data.Fixed + ( mod' ) import Data.Foldable - ( for_, sequenceA_ ) + ( for_, sequenceA_, traverse_ ) import Data.Functor.Compose ( Compose(..) ) import Data.Int @@ -59,11 +61,17 @@ import qualified GI.Cairo.Render as Cairo import Control.Lens ( view ) +-- transformers +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.State.Strict + ( StateT, evalStateT, get, put ) + -- MetaBrush import qualified Math.Bezier.Cubic as Cubic ( Bezier(..) ) import Math.Bezier.Cubic.Fit - ( FitParameters ) + ( FitPoint(..), FitParameters ) import qualified Math.Bezier.Quadratic as Quadratic ( Bezier(..) ) import Math.Bezier.Stroke @@ -115,12 +123,12 @@ blankRender :: Colours -> Cairo.Render () blankRender ( Colours {..} ) = pure () renderDocument - :: Colours -> FitParameters -> Mode -> ( Int32, Int32 ) + :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 ) -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Document -> Cairo.Render () renderDocument - cols params mode ( viewportWidth, viewportHeight ) + cols params mode debug ( viewportWidth, viewportHeight ) mbMousePos mbHoldEvent mbPartialPath doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) = do @@ -177,20 +185,20 @@ renderDocument | otherwise = strokes content - for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode zoomFactor ) + for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode debug zoomFactor ) renderSelectionRect Cairo.restore pure () -renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render () -renderStroke cols@( Colours { brush } ) mbHoverContext params mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) +renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Bool -> Double -> Stroke -> Compose Renders Cairo.Render () +renderStroke cols@( Colours { brush } ) mbHoverContext params mode debug zoom ( Stroke { strokePoints = pts, strokeVisible } ) | strokeVisible = renderStrokePoints cols mode mbHoverContext zoom ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ) pts - *> Compose blank { renderStrokes = drawStroke cols ( stroke params pts ) } + *> Compose blank { renderStrokes = drawStroke cols debug zoom ( stroke params pts ) } | otherwise = pure () @@ -418,18 +426,25 @@ drawCubicBezier ( Colours { path } ) zoom Cairo.restore -drawStroke :: Colours -> Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) -> Cairo.Render () -drawStroke ( Colours { brushStroke } ) strokeData = do +drawStroke + :: Colours -> Bool -> Double + -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint ) + -> Cairo.Render () +drawStroke cols@( Colours { brushStroke } ) debug zoom strokeData = do Cairo.save withRGBA brushStroke Cairo.setSourceRGBA - Cairo.setLineWidth 3 case strokeData of - Left outline -> do + ( Left outline, fitPts ) -> do go outline - Right ( fwd, bwd ) -> do + Cairo.fill + when debug do + ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts + ( Right ( fwd, bwd ), fitPts ) -> do go fwd go bwd - Cairo.fill + Cairo.fill + when debug do + ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts Cairo.restore where @@ -459,6 +474,41 @@ drawStroke ( Colours { brushStroke } ) strokeData = do go' p3 ps go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) +drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render () +drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do + + hue <- get + put ( hue + 0.01 ) + let + r, g, b :: Double + ( r, g, b ) = hsl2rgb hue 0.9 0.4 + lift do + Cairo.save + Cairo.translate x y + Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi ) + Cairo.setSourceRGBA r g b 1 + Cairo.fill + Cairo.restore + +drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do + + hue <- get + put ( hue + 0.01 ) + let + r, g, b :: Double + ( r, g, b ) = hsl2rgb hue 0.9 0.4 + lift do + Cairo.save + Cairo.translate x y + Cairo.moveTo 0 0 + Cairo.lineTo ( 0.05 * tx ) ( 0.05 * ty ) + Cairo.setLineWidth ( 1 / zoom ) + Cairo.setSourceRGBA r g b 1 + Cairo.stroke + Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi ) + Cairo.fill + Cairo.restore + drawSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render () drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do @@ -497,3 +547,25 @@ drawCross ( Colours {..} ) zoom = do Cairo.stroke Cairo.restore + + +hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double ) +hsl2rgb h s l = case hc2rgb h c of + ( r, g, b ) -> ( r + m, g + m, b + m ) + where + c = ( 1 - abs ( 2 * l - 1 ) ) * s + m = l - c / 2 + +hc2rgb :: Double -> Double -> ( Double, Double, Double ) +hc2rgb h c + | h' <= 1 = ( c, x, 0 ) + | h' <= 2 = ( x, c, 0 ) + | h' <= 3 = ( 0, c, x ) + | h' <= 4 = ( 0, x, c ) + | h' <= 5 = ( x, 0, c ) + | otherwise = ( c, 0, x ) + where + h' = ( h * 6 ) `mod'` 6 + hTrunc = truncate h' :: Int + hMod2 = fromIntegral ( hTrunc `mod` 2 ) + ( h' - fromIntegral hTrunc ) + x = c * ( 1 - abs ( hMod2 - 1 ) ) diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 19ad7f1..927fbc1 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -41,21 +41,24 @@ createPanelBar panelBox = do strokesPanel <- GTK.boxNew GTK.OrientationVertical 0 brushesPanel <- GTK.boxNew GTK.OrientationVertical 0 transformPanel <- GTK.boxNew GTK.OrientationVertical 0 + historyPanel <- GTK.boxNew GTK.OrientationVertical 0 strokesTab <- GTK.labelNew ( Just "Strokes" ) brushesTab <- GTK.labelNew ( Just "Brushes" ) transformTab <- GTK.labelNew ( Just "Transform" ) + historyTab <- GTK.labelNew ( Just "History" ) - for_ [ strokesTab, brushesTab, transformTab ] \ tab -> do + for_ [ strokesTab, brushesTab, transformTab, historyTab ] \ tab -> do widgetAddClasses tab [ "plain", "text", "panelTab" ] - for_ [ strokesPanel, brushesPanel, transformPanel ] \ panel -> do + for_ [ strokesPanel, brushesPanel, transformPanel, historyPanel ] \ panel -> do widgetAddClass panel "panel" void $ GTK.notebookAppendPage panels1 strokesPanel ( Just strokesTab ) void $ GTK.notebookAppendPage panels1 brushesPanel ( Just brushesTab ) void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab ) + void $ GTK.notebookAppendPage panels2 historyPanel ( Just historyTab ) GTK.notebookSetTabReorderable panels1 strokesPanel True GTK.notebookSetTabDetachable panels1 strokesPanel True @@ -64,13 +67,17 @@ createPanelBar panelBox = do GTK.notebookSetTabReorderable panels2 transformPanel True GTK.notebookSetTabDetachable panels2 transformPanel True + GTK.notebookSetTabReorderable panels2 historyPanel True + GTK.notebookSetTabDetachable panels2 historyPanel True strokesContent <- GTK.labelNew ( Just "Strokes tab content..." ) brushesContent <- GTK.labelNew ( Just "Brushes tab content..." ) transformContent <- GTK.labelNew ( Just "Transform tab content..." ) + historyContent <- GTK.labelNew ( Just "History tab content..." ) GTK.boxPackStart strokesPanel strokesContent True True 0 GTK.boxPackStart brushesPanel brushesContent True True 0 GTK.boxPackStart transformPanel transformContent True True 0 + GTK.boxPackStart historyPanel historyContent True True 0 pure () diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index 124802a..9cc1dd6 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -27,7 +27,7 @@ import qualified GI.Gtk as GTK import qualified Control.Concurrent.STM as STM ( atomically ) import qualified Control.Concurrent.STM.TVar as STM - ( TVar, writeTVar ) + ( writeTVar ) -- MetaBrush import MetaBrush.Asset.Colours @@ -35,7 +35,9 @@ import MetaBrush.Asset.Colours import MetaBrush.Asset.Cursor ( drawCursorIcon ) import MetaBrush.Asset.Tools - ( drawBrush, drawMeta, drawPath, drawPen ) + ( drawBug, drawBrush, drawMeta, drawPath, drawPen ) +import MetaBrush.Context + ( Variables(..) ) import MetaBrush.Util ( widgetAddClass ) @@ -54,10 +56,11 @@ data Mode data ToolBar = ToolBar - { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton } + { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton + , debugTool :: !GTK.ToggleButton } -createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.DrawingArea -> GTK.Box -> IO ToolBar -createToolBar toolTVar modeTVar colours drawingArea toolBar = do +createToolBar :: Variables -> Colours -> GTK.DrawingArea -> GTK.Box -> IO ToolBar +createToolBar ( Variables {..} ) colours drawingArea toolBar = do widgetAddClass toolBar "toolBar" @@ -89,36 +92,53 @@ createToolBar toolTVar modeTVar colours drawingArea toolBar = do GTK.widgetQueueDraw drawingArea + toolSep2 <- GTK.boxNew GTK.OrientationVertical 0 + + debugTool <- GTK.toggleButtonNew + + _ <- GTK.onButtonClicked debugTool do + clicked <- GTK.toggleButtonGetActive debugTool + STM.atomically $ STM.writeTVar debugTVar clicked + GTK.widgetQueueDraw drawingArea + GTK.boxPackStart toolBar selectionTool True True 0 GTK.boxPackStart toolBar penTool True True 0 GTK.boxPackStart toolBar toolSep1 True True 0 GTK.boxPackStart toolBar pathTool True True 0 GTK.boxPackStart toolBar brushTool True True 0 GTK.boxPackStart toolBar metaTool True True 0 + GTK.boxPackStart toolBar toolSep2 True True 0 + GTK.boxPackStart toolBar debugTool True True 0 for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do GTK.toggleButtonSetMode tool False -- don't display radio indicator widgetAddClass tool "toolItem" - widgetAddClass toolSep1 "toolBarSeparator" + widgetAddClass debugTool "toolItem" + + for_ [ toolSep1, toolSep2 ] \ sep -> do + widgetAddClass sep "toolBarSeparator" GTK.widgetSetTooltipText selectionTool ( Just "Select" ) GTK.widgetSetTooltipText penTool ( Just "Draw" ) GTK.widgetSetTooltipText pathTool ( Just "Brush path" ) GTK.widgetSetTooltipText brushTool ( Just "Brushes" ) GTK.widgetSetTooltipText metaTool ( Just "Meta-parameters" ) + GTK.widgetSetTooltipText debugTool ( Just "Debug mode" ) selectionToolArea <- GTK.drawingAreaNew penToolArea <- GTK.drawingAreaNew pathToolArea <- GTK.drawingAreaNew brushToolArea <- GTK.drawingAreaNew metaToolArea <- GTK.drawingAreaNew + debugToolArea <- GTK.drawingAreaNew GTK.containerAdd selectionTool selectionToolArea GTK.containerAdd penTool penToolArea GTK.containerAdd pathTool pathToolArea GTK.containerAdd brushTool brushToolArea GTK.containerAdd metaTool metaToolArea + GTK.containerAdd debugTool debugToolArea void $ GTK.onWidgetDraw selectionToolArea $ Cairo.renderWithContext @@ -140,4 +160,8 @@ createToolBar toolTVar modeTVar colours drawingArea toolBar = do $ Cairo.renderWithContext ( drawMeta colours ) + void $ GTK.onWidgetDraw debugToolArea + $ Cairo.renderWithContext + ( drawBug colours ) + pure ( ToolBar {..} ) diff --git a/src/app/MetaBrush/UI/ToolBar.hs-boot b/src/app/MetaBrush/UI/ToolBar.hs-boot new file mode 100644 index 0000000..c5618cd --- /dev/null +++ b/src/app/MetaBrush/UI/ToolBar.hs-boot @@ -0,0 +1,25 @@ +module MetaBrush.UI.ToolBar + ( Tool(..), Mode(..) + , ToolBar(..) + ) + where + +-- gi-gtk +import qualified GI.Gtk as GTK + +-------------------------------------------------------------------------------- + +data Tool + = Selection + | Pen + +data Mode + = Path + | Brush + | Meta + +data ToolBar + = ToolBar + { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton + , debugTool :: !GTK.ToggleButton + } diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/lib/Math/Bezier/Cubic/Fit.hs index 3c98fc2..03a77d7 100644 --- a/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/src/lib/Math/Bezier/Cubic/Fit.hs @@ -1,10 +1,13 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Math.Bezier.Cubic.Fit - ( FitParameters(..) + ( FitParameters(..), FitPoint(..) , fitSpline, fitPiece ) where @@ -24,6 +27,8 @@ import Data.Functor ( ($>) ) import Data.Semigroup ( Arg(..), Max(..), ArgMax ) +import GHC.Generics + ( Generic ) -- acts import Data.Act @@ -33,9 +38,13 @@ import Data.Act -- containers import Data.Sequence - ( Seq ) + ( Seq(..) ) import qualified Data.Sequence as Seq - ( singleton ) + ( fromList, singleton ) + +-- deepseq +import Control.DeepSeq + ( NFData ) -- transformers import Control.Monad.Trans.State.Strict @@ -78,10 +87,23 @@ data FitParameters , t_tol :: !Double -- ^ the tolerance for the Bézier parameter (for the fitting process) , maxIters :: !Int -- ^ maximum number of iterations (for the fitting process) } + deriving stock Show + +data FitPoint + = FitPoint + { fitPoint :: Point2D Double } + | FitTangent + { fitPoint :: Point2D Double + , fitTangent :: Vector2D Double + } + deriving stock ( Show, Generic ) + deriving anyclass NFData -- | Fits a cubic Bézier spline to the given curve \( t \mapsto C(t), 0 \leqslant t \leqslant 1 \), -- assumed to be G1-continuous. -- +-- Additionally returns the points that were used to perform the fit, for debugging purposes. +-- -- Subdivides the given curve into the specified number of segments \( \texttt{nbSegments} \), -- and tries to fit the resulting points with a cubic Bézier curve using 'fitPiece'. -- @@ -93,7 +115,7 @@ data FitParameters fitSpline :: FitParameters -> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit - -> Seq ( Cubic.Bezier ( Point2D Double ) ) + -> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint ) fitSpline ( FitParameters {..} ) = go 0 where dt :: Double @@ -101,7 +123,7 @@ fitSpline ( FitParameters {..} ) = go 0 go :: Int -> ( Double -> ( Point2D Double, Vector2D Double ) ) - -> Seq ( Cubic.Bezier ( Point2D Double ) ) + -> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint ) go subdiv curve = let p, r :: Point2D Double @@ -115,10 +137,10 @@ fitSpline ( FitParameters {..} ) = go 0 ( bez, Max ( Arg t_split sq_d ) ) | subdiv >= maxSubdiv || sq_d <= dist_tol ^ ( 2 :: Int ) - -> Seq.singleton bez + -> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr ) | otherwise - -> go ( subdiv + 1 ) ( \ t -> curve ( t * t_split ) ) - <> go ( subdiv + 1 ) ( \ t -> curve ( t_split + t * ( 1 - t_split ) ) ) + -> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split ) + <> go ( subdiv + 1 ) ( \ t -> curve $ t_split + t * ( 1 - t_split ) ) -- | Fits a single cubic Bézier curve to the given data. -- diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index 28fc68e..e0c477c 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -69,7 +69,7 @@ import qualified Control.Monad.Par as Par -- MetaBrush import qualified Math.Bezier.Cubic as Cubic import Math.Bezier.Cubic.Fit - ( FitParameters, fitSpline ) + ( FitPoint, FitParameters, fitSpline ) import qualified Math.Bezier.Quadratic as Quadratic import Math.Epsilon ( epsilon ) @@ -122,18 +122,18 @@ stroke ) => FitParameters -> Seq ( StrokePoint d ) - -> Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) -stroke _ Empty = Left Empty -stroke _ ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0 + -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint ) +stroke _ Empty = ( Left Empty, Empty ) +stroke _ ( spt0 :<| Empty ) = ( Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0, Empty ) stroke params allPts@( spt0 :<| spt1 :<| spts ) | isClosed = if null ( brushShape @x spt0 ) - then Right ( Empty, Empty ) - else Right ( fwdPts, bwdPts ) + then ( Right mempty, mempty ) + else ( Right ( fwdPts, bwdPts ), fwdFits <> bwdFits ) | otherwise = if null ( brushShape @x spt0 ) - then Left Empty - else Left ( startingCap <> fwdPts <> bwdPts ) + then ( Left Empty, Empty ) + else ( Left ( startingCap <> fwdPts <> bwdPts ), fwdFits <> bwdFits ) where startOffset, endOffset :: Vector2D Double @@ -154,7 +154,8 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) _ -> False fwdPts, bwdPts :: Seq ( StrokePoint () ) - ( fwdPts, bwdPts ) = Par.runPar $ go spt0 ( spt1 :<| spts ) + fwdFits, bwdFits :: Seq FitPoint + ( ( fwdPts, fwdFits ), ( bwdPts, bwdFits ) ) = Par.runPar $ go spt0 ( spt1 :<| spts ) (<~>) :: ( Monoid a, Monoid b ) @@ -165,7 +166,11 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) -- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity). -- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction). - joinAndContinue :: Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> Par ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) + joinAndContinue + :: Vector2D Double + -> StrokePoint d + -> Seq ( StrokePoint d ) + -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) ) joinAndContinue tgt sp0 ( sp1 :<| sps ) | tgt' `parallel` tgt = go sp0 ( sp1 :<| sps ) @@ -174,9 +179,10 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) ptOffset = Point2D 0 0 --> coords sp0 = do let + brushJoin :: ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) ) brushJoin = - ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0 - , ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0 + ( ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0, Empty ) + , ( ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0, Empty ) ) next <- go sp0 ( sp1 :<| sps ) pure ( brushJoin <~> next ) @@ -190,15 +196,15 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) | isClosed = pure $ if parallel tgt_start tgt_end - then ( Empty, Empty ) - else ( startOffset • joinWithBrush ( withTangent tgt_start brush_start ) ( withTangent tgt_end brush_start ) brush_start - , startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start + then mempty + else ( ( startOffset • joinWithBrush ( withTangent tgt_start brush_start ) ( withTangent tgt_end brush_start ) brush_start, Empty ) + , ( startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start, Empty ) ) -- Open curve. | otherwise = pure - ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end - , Empty -- handled separately: see 'startingCap' below + ( ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end, Empty ) + , ( Empty, Empty ) -- handled separately: see 'startingCap' below ) -- Final cap for an open curve. Handled separately for correct stroke order. @@ -206,8 +212,8 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) startingCap = startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start - go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) - go _ Empty = pure ( Empty, Empty ) + go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) ) + go _ Empty = pure mempty -- Line. go sp0 ( sp1 :<| sps ) | PathPoint {} <- sp1 @@ -323,8 +329,8 @@ stroke params allPts@( spt0 :<| spt1 :<| spts ) fitCurve :: ( Double -> ( Point2D Double, Vector2D Double ) ) - -> Seq ( StrokePoint () ) - fitCurve = splinePoints . fitSpline params + -> ( Seq ( StrokePoint () ), Seq FitPoint ) + fitCurve = first splinePoints . fitSpline params ----------------------------------- -- Various utility functions