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

add debug mode to visualise fitting algorithm

Browse source
This commit is contained in:
sheaf 2020-09-14 06:03:45 +02:00
parent 087c29aef3
commit e3d920573d
11 changed files with 430 additions and 76 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
app/Main.hs
View file

@ -207,17 +207,18 @@ main = do
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path modeTVar <- STM.newTVarIO @Mode Path
debugTVar <- STM.newTVarIO @Bool False
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
showGuidesTVar <- STM.newTVarIO @Bool True showGuidesTVar <- STM.newTVarIO @Bool True
maxHistorySizeTVar <- STM.newTVarIO @Int 1000 maxHistorySizeTVar <- STM.newTVarIO @Int 1000
fitParametersTVar <- STM.newTVarIO @FitParameters fitParametersTVar <- STM.newTVarIO @FitParameters
( FitParameters ( FitParameters
{ maxSubdiv = 2 { maxSubdiv = 3
, nbSegments = 13 , nbSegments = 30
, dist_tol = 2e-3 , dist_tol = 5e-4
, t_tol = 5e-4 , t_tol = 1e-4
, maxIters = 500 , maxIters = 100
} }
) )
@ -243,7 +244,7 @@ main = do
GTK.setWindowResizable window True GTK.setWindowResizable window True
GTK.setWindowDecorated window False GTK.setWindowDecorated window False
GTK.setWindowTitle window "MetaBrush" GTK.setWindowTitle window "MetaBrush"
GTK.windowSetDefaultSize window 800 600 GTK.windowSetDefaultSize window 1024 768
GTK.widgetAddEvents window GTK.widgetAddEvents window
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ] [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
@ -336,11 +337,12 @@ main = do
mbHoldAction <- STM.readTVar mouseHoldTVar mbHoldAction <- STM.readTVar mouseHoldTVar
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar mode <- STM.readTVar modeTVar
debug <- STM.readTVar debugTVar
showGuides <- STM.readTVar showGuidesTVar showGuides <- STM.readTVar showGuidesTVar
fitParameters <- STM.readTVar fitParametersTVar fitParameters <- STM.readTVar fitParametersTVar
pure do pure do
renderDocument renderDocument
colours fitParameters mode ( viewportWidth, viewportHeight ) colours fitParameters mode debug ( viewportWidth, viewportHeight )
mbMousePos mbHoldAction mbPartialPath mbMousePos mbHoldAction mbPartialPath
doc doc
renderRuler renderRuler
@ -378,7 +380,7 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- Tool bar -- Tool bar
_ <- createToolBar toolTVar modeTVar colours viewportDrawingArea toolBar _ <- createToolBar variables colours viewportDrawingArea toolBar
--------------------------------------------------------- ---------------------------------------------------------
-- Info bar -- Info bar

14
assets/theme.css
View file

@ -78,6 +78,12 @@
.tabScrollbar { .tabScrollbar {
background-color: rgba(48, 45, 38, 0.66); 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 { .rulerTick {
color: black; color: black;
} }
@ -151,13 +157,6 @@ tooltip {
/* Rulers */ /* Rulers */
.ruler {
background-color: rgb(237, 226, 154);
min-width: 16px;
min-height: 16px;
background-size: 16px 16px;
}
.leftRuler { .leftRuler {
border-right: 1px solid black; border-right: 1px solid black;
min-width: 16px; min-width: 16px;
@ -435,6 +434,7 @@ tooltip {
.panel { .panel {
background-color: rgb(72,70,61); background-color: rgb(72,70,61);
min-height: 20px;
} }
/* Info bar */ /* Info bar */

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

@ -37,7 +37,7 @@ data ColourRecord a
, path, brush, brushStroke, brushCenter , path, brush, brushStroke, brushCenter
, pointHover, pointSelected , pointHover, pointSelected
, viewport, viewportScrollbar, tabScrollbar , viewport, viewportScrollbar, tabScrollbar
, guide, rulerTick, magnifier, glass , guide, rulerBg, rulerTick, magnifier, glass
, selected, selectedOutline :: !a , selected, selectedOutline :: !a
} }
deriving stock ( Show, Functor, Foldable, Traversable ) deriving stock ( Show, Functor, Foldable, Traversable )
@ -80,6 +80,7 @@ colourNames = Colours
, viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ] , viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ]
, viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
, rulerBg = ColourName "ruler" BackgroundColour [ GTK.StateFlagsNormal ]
, rulerTick = ColourName "rulerTick" Colour [ GTK.StateFlagsNormal ] , rulerTick = ColourName "rulerTick" Colour [ GTK.StateFlagsNormal ]
, guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ] , guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ]
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ] , magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]

208
src/app/MetaBrush/Asset/Tools.hs
View file

@ -2,7 +2,7 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module MetaBrush.Asset.Tools module MetaBrush.Asset.Tools
( drawBrush, drawMeta, drawPath, drawPen ) ( drawBrush, drawBug, drawMeta, drawPath, drawPen )
where where
-- gi-cairo-render -- gi-cairo-render
@ -31,7 +31,7 @@ drawBrush ( Colours { base, splash } ) = do
Cairo.setLineWidth 1 Cairo.setLineWidth 1
withRGBA base Cairo.setSourceRGBA withRGBA base Cairo.setSourceRGBA
Cairo.strokePreserve Cairo.stroke
-- Brush body -- Brush body
@ -48,7 +48,7 @@ drawBrush ( Colours { base, splash } ) = do
Cairo.closePath Cairo.closePath
withRGBA splash Cairo.setSourceRGBA withRGBA splash Cairo.setSourceRGBA
Cairo.fillPreserve Cairo.fill
-- Brush tip -- Brush tip
Cairo.newPath Cairo.newPath
@ -63,7 +63,7 @@ drawBrush ( Colours { base, splash } ) = do
Cairo.closePath Cairo.closePath
withRGBA base Cairo.setSourceRGBA withRGBA base Cairo.setSourceRGBA
Cairo.fillPreserve Cairo.fill
pure True pure True
@ -94,7 +94,7 @@ drawMeta ( Colours { splash } ) = do
Cairo.closePath Cairo.closePath
withRGBA splash Cairo.setSourceRGBA withRGBA splash Cairo.setSourceRGBA
Cairo.fillPreserve Cairo.fill
pure True 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.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.curveTo 21.179688 22.230469 24.476563 16.863281 24.476563 16.863281
Cairo.closePath Cairo.closePath
Cairo.fillPreserve Cairo.fill
withRGBA splash Cairo.setSourceRGBA withRGBA splash Cairo.setSourceRGBA
Cairo.newPath Cairo.newPath
@ -219,6 +219,200 @@ drawPen ( Colours { base, splash } ) = do
Cairo.lineTo 26.640625 13.464844 Cairo.lineTo 26.640625 13.464844
Cairo.lineTo 28.875 9.597656 Cairo.lineTo 28.875 9.597656
Cairo.closePath Cairo.closePath
Cairo.fillPreserve Cairo.fill
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 pure True

3
src/app/MetaBrush/Context.hs
View file

@ -45,7 +45,7 @@ import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar ) ( InfoBar )
import {-# SOURCE #-} MetaBrush.UI.Menu import {-# SOURCE #-} MetaBrush.UI.Menu
( Menu, ResourceType(Object) ) ( Menu, ResourceType(Object) )
import MetaBrush.UI.ToolBar import {-# SOURCE #-} MetaBrush.UI.ToolBar
( Tool, Mode ) ( Tool, Mode )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) ) ( Viewport(..), Ruler(..) )
@ -76,6 +76,7 @@ data Variables
, modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) )
, toolTVar :: !( STM.TVar Tool ) , toolTVar :: !( STM.TVar Tool )
, modeTVar :: !( STM.TVar Mode ) , modeTVar :: !( STM.TVar Mode )
, debugTVar :: !( STM.TVar Bool )
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
, fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) ) , fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) )
, showGuidesTVar :: !( STM.TVar Bool ) , showGuidesTVar :: !( STM.TVar Bool )

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

@ -19,8 +19,10 @@ module MetaBrush.Render.Document
-- base -- base
import Control.Monad import Control.Monad
( guard, when, unless ) ( guard, when, unless )
import Data.Fixed
( mod' )
import Data.Foldable import Data.Foldable
( for_, sequenceA_ ) ( for_, sequenceA_, traverse_ )
import Data.Functor.Compose import Data.Functor.Compose
( Compose(..) ) ( Compose(..) )
import Data.Int import Data.Int
@ -59,11 +61,17 @@ import qualified GI.Cairo.Render as Cairo
import Control.Lens import Control.Lens
( view ) ( view )
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.State.Strict
( StateT, evalStateT, get, put )
-- MetaBrush -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) ) ( Bezier(..) )
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitParameters ) ( FitPoint(..), FitParameters )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) ) ( Bezier(..) )
import Math.Bezier.Stroke import Math.Bezier.Stroke
@ -115,12 +123,12 @@ blankRender :: Colours -> Cairo.Render ()
blankRender ( Colours {..} ) = pure () blankRender ( Colours {..} ) = pure ()
renderDocument renderDocument
:: Colours -> FitParameters -> Mode -> ( Int32, Int32 ) :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 )
-> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
-> Document -> Document
-> Cairo.Render () -> Cairo.Render ()
renderDocument renderDocument
cols params mode ( viewportWidth, viewportHeight ) cols params mode debug ( viewportWidth, viewportHeight )
mbMousePos mbHoldEvent mbPartialPath mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
= do = do
@ -177,20 +185,20 @@ renderDocument
| otherwise | otherwise
= strokes content = strokes content
for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode zoomFactor ) for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode debug zoomFactor )
renderSelectionRect renderSelectionRect
Cairo.restore Cairo.restore
pure () pure ()
renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render () renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Bool -> Double -> Stroke -> Compose Renders Cairo.Render ()
renderStroke cols@( Colours { brush } ) mbHoverContext params mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) renderStroke cols@( Colours { brush } ) mbHoverContext params mode debug zoom ( Stroke { strokePoints = pts, strokeVisible } )
| strokeVisible | strokeVisible
= renderStrokePoints cols mode mbHoverContext zoom = renderStrokePoints cols mode mbHoverContext zoom
( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ) ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) )
pts pts
*> Compose blank { renderStrokes = drawStroke cols ( stroke params pts ) } *> Compose blank { renderStrokes = drawStroke cols debug zoom ( stroke params pts ) }
| otherwise | otherwise
= pure () = pure ()
@ -418,18 +426,25 @@ drawCubicBezier ( Colours { path } ) zoom
Cairo.restore Cairo.restore
drawStroke :: Colours -> Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) -> Cairo.Render () drawStroke
drawStroke ( Colours { brushStroke } ) strokeData = do :: Colours -> Bool -> Double
-> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint )
-> Cairo.Render ()
drawStroke cols@( Colours { brushStroke } ) debug zoom strokeData = do
Cairo.save Cairo.save
withRGBA brushStroke Cairo.setSourceRGBA withRGBA brushStroke Cairo.setSourceRGBA
Cairo.setLineWidth 3
case strokeData of case strokeData of
Left outline -> do ( Left outline, fitPts ) -> do
go outline 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 fwd
go bwd go bwd
Cairo.fill Cairo.fill
when debug do
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
Cairo.restore Cairo.restore
where where
@ -459,6 +474,41 @@ drawStroke ( Colours { brushStroke } ) strokeData = do
go' p3 ps go' p3 ps
go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| 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 -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
@ -497,3 +547,25 @@ drawCross ( Colours {..} ) zoom = do
Cairo.stroke Cairo.stroke
Cairo.restore 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 ) )

11
src/app/MetaBrush/UI/Panels.hs
View file

@ -41,21 +41,24 @@ createPanelBar panelBox = do
strokesPanel <- GTK.boxNew GTK.OrientationVertical 0 strokesPanel <- GTK.boxNew GTK.OrientationVertical 0
brushesPanel <- GTK.boxNew GTK.OrientationVertical 0 brushesPanel <- GTK.boxNew GTK.OrientationVertical 0
transformPanel <- GTK.boxNew GTK.OrientationVertical 0 transformPanel <- GTK.boxNew GTK.OrientationVertical 0
historyPanel <- GTK.boxNew GTK.OrientationVertical 0
strokesTab <- GTK.labelNew ( Just "Strokes" ) strokesTab <- GTK.labelNew ( Just "Strokes" )
brushesTab <- GTK.labelNew ( Just "Brushes" ) brushesTab <- GTK.labelNew ( Just "Brushes" )
transformTab <- GTK.labelNew ( Just "Transform" ) 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" ] widgetAddClasses tab [ "plain", "text", "panelTab" ]
for_ [ strokesPanel, brushesPanel, transformPanel ] \ panel -> do for_ [ strokesPanel, brushesPanel, transformPanel, historyPanel ] \ panel -> do
widgetAddClass panel "panel" widgetAddClass panel "panel"
void $ GTK.notebookAppendPage panels1 strokesPanel ( Just strokesTab ) void $ GTK.notebookAppendPage panels1 strokesPanel ( Just strokesTab )
void $ GTK.notebookAppendPage panels1 brushesPanel ( Just brushesTab ) void $ GTK.notebookAppendPage panels1 brushesPanel ( Just brushesTab )
void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab ) void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab )
void $ GTK.notebookAppendPage panels2 historyPanel ( Just historyTab )
GTK.notebookSetTabReorderable panels1 strokesPanel True GTK.notebookSetTabReorderable panels1 strokesPanel True
GTK.notebookSetTabDetachable panels1 strokesPanel True GTK.notebookSetTabDetachable panels1 strokesPanel True
@ -64,13 +67,17 @@ createPanelBar panelBox = do
GTK.notebookSetTabReorderable panels2 transformPanel True GTK.notebookSetTabReorderable panels2 transformPanel True
GTK.notebookSetTabDetachable 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..." ) strokesContent <- GTK.labelNew ( Just "Strokes tab content..." )
brushesContent <- GTK.labelNew ( Just "Brushes tab content..." ) brushesContent <- GTK.labelNew ( Just "Brushes tab content..." )
transformContent <- GTK.labelNew ( Just "Transform 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 strokesPanel strokesContent True True 0
GTK.boxPackStart brushesPanel brushesContent True True 0 GTK.boxPackStart brushesPanel brushesContent True True 0
GTK.boxPackStart transformPanel transformContent True True 0 GTK.boxPackStart transformPanel transformContent True True 0
GTK.boxPackStart historyPanel historyContent True True 0
pure () pure ()

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

@ -27,7 +27,7 @@ import qualified GI.Gtk as GTK
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( TVar, writeTVar ) ( writeTVar )
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
@ -35,7 +35,9 @@ import MetaBrush.Asset.Colours
import MetaBrush.Asset.Cursor import MetaBrush.Asset.Cursor
( drawCursorIcon ) ( drawCursorIcon )
import MetaBrush.Asset.Tools import MetaBrush.Asset.Tools
( drawBrush, drawMeta, drawPath, drawPen ) ( drawBug, drawBrush, drawMeta, drawPath, drawPen )
import MetaBrush.Context
( Variables(..) )
import MetaBrush.Util import MetaBrush.Util
( widgetAddClass ) ( widgetAddClass )
@ -54,10 +56,11 @@ data Mode
data ToolBar data ToolBar
= 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 :: Variables -> Colours -> GTK.DrawingArea -> GTK.Box -> IO ToolBar
createToolBar toolTVar modeTVar colours drawingArea toolBar = do createToolBar ( Variables {..} ) colours drawingArea toolBar = do
widgetAddClass toolBar "toolBar" widgetAddClass toolBar "toolBar"
@ -89,36 +92,53 @@ createToolBar toolTVar modeTVar colours drawingArea toolBar = do
GTK.widgetQueueDraw drawingArea 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 selectionTool True True 0
GTK.boxPackStart toolBar penTool True True 0 GTK.boxPackStart toolBar penTool True True 0
GTK.boxPackStart toolBar toolSep1 True True 0 GTK.boxPackStart toolBar toolSep1 True True 0
GTK.boxPackStart toolBar pathTool True True 0 GTK.boxPackStart toolBar pathTool True True 0
GTK.boxPackStart toolBar brushTool True True 0 GTK.boxPackStart toolBar brushTool True True 0
GTK.boxPackStart toolBar metaTool 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 for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do
GTK.toggleButtonSetMode tool False -- don't display radio indicator GTK.toggleButtonSetMode tool False -- don't display radio indicator
widgetAddClass tool "toolItem" widgetAddClass tool "toolItem"
widgetAddClass toolSep1 "toolBarSeparator" widgetAddClass debugTool "toolItem"
for_ [ toolSep1, toolSep2 ] \ sep -> do
widgetAddClass sep "toolBarSeparator"
GTK.widgetSetTooltipText selectionTool ( Just "Select" ) GTK.widgetSetTooltipText selectionTool ( Just "Select" )
GTK.widgetSetTooltipText penTool ( Just "Draw" ) GTK.widgetSetTooltipText penTool ( Just "Draw" )
GTK.widgetSetTooltipText pathTool ( Just "Brush path" ) GTK.widgetSetTooltipText pathTool ( Just "Brush path" )
GTK.widgetSetTooltipText brushTool ( Just "Brushes" ) GTK.widgetSetTooltipText brushTool ( Just "Brushes" )
GTK.widgetSetTooltipText metaTool ( Just "Meta-parameters" ) GTK.widgetSetTooltipText metaTool ( Just "Meta-parameters" )
GTK.widgetSetTooltipText debugTool ( Just "Debug mode" )
selectionToolArea <- GTK.drawingAreaNew selectionToolArea <- GTK.drawingAreaNew
penToolArea <- GTK.drawingAreaNew penToolArea <- GTK.drawingAreaNew
pathToolArea <- GTK.drawingAreaNew pathToolArea <- GTK.drawingAreaNew
brushToolArea <- GTK.drawingAreaNew brushToolArea <- GTK.drawingAreaNew
metaToolArea <- GTK.drawingAreaNew metaToolArea <- GTK.drawingAreaNew
debugToolArea <- GTK.drawingAreaNew
GTK.containerAdd selectionTool selectionToolArea GTK.containerAdd selectionTool selectionToolArea
GTK.containerAdd penTool penToolArea GTK.containerAdd penTool penToolArea
GTK.containerAdd pathTool pathToolArea GTK.containerAdd pathTool pathToolArea
GTK.containerAdd brushTool brushToolArea GTK.containerAdd brushTool brushToolArea
GTK.containerAdd metaTool metaToolArea GTK.containerAdd metaTool metaToolArea
GTK.containerAdd debugTool debugToolArea
void $ GTK.onWidgetDraw selectionToolArea void $ GTK.onWidgetDraw selectionToolArea
$ Cairo.renderWithContext $ Cairo.renderWithContext
@ -140,4 +160,8 @@ createToolBar toolTVar modeTVar colours drawingArea toolBar = do
$ Cairo.renderWithContext $ Cairo.renderWithContext
( drawMeta colours ) ( drawMeta colours )
void $ GTK.onWidgetDraw debugToolArea
$ Cairo.renderWithContext
( drawBug colours )
pure ( ToolBar {..} ) pure ( ToolBar {..} )

25
src/app/MetaBrush/UI/ToolBar.hs-boot Normal file
View file

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

38
src/lib/Math/Bezier/Cubic/Fit.hs
View file

@ -1,10 +1,13 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Math.Bezier.Cubic.Fit module Math.Bezier.Cubic.Fit
( FitParameters(..) ( FitParameters(..), FitPoint(..)
, fitSpline, fitPiece , fitSpline, fitPiece
) )
where where
@ -24,6 +27,8 @@ import Data.Functor
( ($>) ) ( ($>) )
import Data.Semigroup import Data.Semigroup
( Arg(..), Max(..), ArgMax ) ( Arg(..), Max(..), ArgMax )
import GHC.Generics
( Generic )
-- acts -- acts
import Data.Act import Data.Act
@ -33,9 +38,13 @@ import Data.Act
-- containers -- containers
import Data.Sequence import Data.Sequence
( Seq ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( singleton ) ( fromList, singleton )
-- deepseq
import Control.DeepSeq
( NFData )
-- transformers -- transformers
import Control.Monad.Trans.State.Strict 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) , t_tol :: !Double -- ^ the tolerance for the Bézier parameter (for the fitting process)
, maxIters :: !Int -- ^ maximum number of iterations (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 \), -- | Fits a cubic Bézier spline to the given curve \( t \mapsto C(t), 0 \leqslant t \leqslant 1 \),
-- assumed to be G1-continuous. -- 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} \), -- 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'. -- and tries to fit the resulting points with a cubic Bézier curve using 'fitPiece'.
-- --
@ -93,7 +115,7 @@ data FitParameters
fitSpline fitSpline
:: FitParameters :: FitParameters
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit -> ( 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 fitSpline ( FitParameters {..} ) = go 0
where where
dt :: Double dt :: Double
@ -101,7 +123,7 @@ fitSpline ( FitParameters {..} ) = go 0
go go
:: Int :: Int
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -> ( Double -> ( Point2D Double, Vector2D Double ) )
-> Seq ( Cubic.Bezier ( Point2D Double ) ) -> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint )
go subdiv curve = go subdiv curve =
let let
p, r :: Point2D Double p, r :: Point2D Double
@ -115,10 +137,10 @@ fitSpline ( FitParameters {..} ) = go 0
( bez, Max ( Arg t_split sq_d ) ) ( bez, Max ( Arg t_split sq_d ) )
| subdiv >= maxSubdiv | subdiv >= maxSubdiv
|| sq_d <= dist_tol ^ ( 2 :: Int ) || sq_d <= dist_tol ^ ( 2 :: Int )
-> Seq.singleton bez -> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
| otherwise | otherwise
-> go ( subdiv + 1 ) ( \ t -> curve ( t * t_split ) ) -> 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_split + t * ( 1 - t_split ) )
-- | Fits a single cubic Bézier curve to the given data. -- | Fits a single cubic Bézier curve to the given data.
-- --

48
src/lib/Math/Bezier/Stroke.hs
View file

@ -69,7 +69,7 @@ import qualified Control.Monad.Par as Par
-- MetaBrush -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitParameters, fitSpline ) ( FitPoint, FitParameters, fitSpline )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
import Math.Epsilon import Math.Epsilon
( epsilon ) ( epsilon )
@ -122,18 +122,18 @@ stroke
) )
=> FitParameters => FitParameters
-> Seq ( StrokePoint d ) -> Seq ( StrokePoint d )
-> Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint )
stroke _ Empty = Left Empty stroke _ Empty = ( Left Empty, Empty )
stroke _ ( spt0 :<| Empty ) = Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0 stroke _ ( spt0 :<| Empty ) = ( Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0, Empty )
stroke params allPts@( spt0 :<| spt1 :<| spts ) stroke params allPts@( spt0 :<| spt1 :<| spts )
| isClosed | isClosed
= if null ( brushShape @x spt0 ) = if null ( brushShape @x spt0 )
then Right ( Empty, Empty ) then ( Right mempty, mempty )
else Right ( fwdPts, bwdPts ) else ( Right ( fwdPts, bwdPts ), fwdFits <> bwdFits )
| otherwise | otherwise
= if null ( brushShape @x spt0 ) = if null ( brushShape @x spt0 )
then Left Empty then ( Left Empty, Empty )
else Left ( startingCap <> fwdPts <> bwdPts ) else ( Left ( startingCap <> fwdPts <> bwdPts ), fwdFits <> bwdFits )
where where
startOffset, endOffset :: Vector2D Double startOffset, endOffset :: Vector2D Double
@ -154,7 +154,8 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
_ -> False _ -> False
fwdPts, bwdPts :: Seq ( StrokePoint () ) 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 ) :: ( 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). -- 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). -- 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 ) joinAndContinue tgt sp0 ( sp1 :<| sps )
| tgt' `parallel` tgt | tgt' `parallel` tgt
= go sp0 ( sp1 :<| sps ) = go sp0 ( sp1 :<| sps )
@ -174,9 +179,10 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
ptOffset = Point2D 0 0 --> coords sp0 ptOffset = Point2D 0 0 --> coords sp0
= do = do
let let
brushJoin :: ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
brushJoin = brushJoin =
( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0 ( ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0, Empty )
, ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0 , ( ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0, Empty )
) )
next <- go sp0 ( sp1 :<| sps ) next <- go sp0 ( sp1 :<| sps )
pure ( brushJoin <~> next ) pure ( brushJoin <~> next )
@ -190,15 +196,15 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
| isClosed | isClosed
= pure $ = pure $
if parallel tgt_start tgt_end if parallel tgt_start tgt_end
then ( Empty, Empty ) then mempty
else ( startOffset • joinWithBrush ( withTangent tgt_start brush_start ) ( withTangent tgt_end brush_start ) brush_start 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 , ( startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start, Empty )
) )
-- Open curve. -- Open curve.
| otherwise | otherwise
= pure = pure
( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end ( ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end, Empty )
, Empty -- handled separately: see 'startingCap' below , ( Empty, Empty ) -- handled separately: see 'startingCap' below
) )
-- Final cap for an open curve. Handled separately for correct stroke order. -- Final cap for an open curve. Handled separately for correct stroke order.
@ -206,8 +212,8 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
startingCap startingCap
= startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start = 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 :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
go _ Empty = pure ( Empty, Empty ) go _ Empty = pure mempty
-- Line. -- Line.
go sp0 ( sp1 :<| sps ) go sp0 ( sp1 :<| sps )
| PathPoint {} <- sp1 | PathPoint {} <- sp1
@ -323,8 +329,8 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
fitCurve fitCurve
:: ( Double -> ( Point2D Double, Vector2D Double ) ) :: ( Double -> ( Point2D Double, Vector2D Double ) )
-> Seq ( StrokePoint () ) -> ( Seq ( StrokePoint () ), Seq FitPoint )
fitCurve = splinePoints . fitSpline params fitCurve = first splinePoints . fitSpline params
----------------------------------- -----------------------------------
-- Various utility functions -- Various utility functions