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

compute outline data concurrently

Browse source
This commit is contained in:
sheaf 2021-02-23 20:58:53 +01:00
parent b32499cc68
commit c1cae2b69f
10 changed files with 188 additions and 133 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

155
app/Main.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
@ -15,8 +16,10 @@ module Main
where
-- base
import Control.Arrow
( (&&&) )
import Control.Monad
( void )
( forever, void )
import Data.Foldable
( for_ )
import Data.Function
@ -26,7 +29,7 @@ import Data.Int
import System.Exit
( exitSuccess )
import GHC.Conc
( getNumProcessors, setNumCapabilities )
( forkIO, getNumProcessors, setNumCapabilities )
-- containers
import Data.Map.Strict
@ -70,9 +73,9 @@ import Control.Lens.At
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
( atomically, retry )
import qualified Control.Concurrent.STM.TVar as STM
( modifyTVar', newTVarIO, readTVar )
( modifyTVar', newTVarIO, readTVar, writeTVar )
-- superrecord
import qualified SuperRecord as Super
@ -130,7 +133,7 @@ import MetaBrush.Document.Update
import MetaBrush.Event
( handleEvents )
import MetaBrush.Render.Document
( renderDocument, blankRender )
( blankRender, getDocumentRender )
import MetaBrush.Render.Rulers
( renderRuler )
import MetaBrush.UI.FileBar
@ -214,28 +217,30 @@ main = do
mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode PathMode
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 = 6
, nbSegments = 12
, dist_tol = 5e-3
, t_tol = 1e-4
, maxIters = 100
}
)
recomputeStrokesTVar <- STM.newTVarIO @Bool False
documentRenderTVar <- STM.newTVarIO @( Cairo.Render () ) ( pure () )
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode PathMode
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 = 6
, nbSegments = 12
, dist_tol = 5e-3
, t_tol = 1e-4
, maxIters = 100
}
)
-- Put all these stateful variables in a record for conciseness.
let
@ -343,53 +348,65 @@ main = do
-----------------
-- Viewport rendering
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
-- Get the relevant document information
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
mbDocAndRender <- STM.atomically $ withActiveDocument variables \ doc -> do
modifiers <- STM.readTVar modifiersTVar
mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar
mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar
debug <- STM.readTVar debugTVar
showGuides <- STM.readTVar showGuidesTVar
fitParameters <- STM.readTVar fitParametersTVar
let
mbUpdatedDoc :: Maybe Document
renderDoc, renderAction :: Cairo.Render ()
( mbUpdatedDoc, renderDoc ) =
renderDocument
colours fitParameters mode debug ( viewportWidth, viewportHeight )
modifiers mbMousePos mbHoldAction mbPartialPath
doc
renderAction = do
renderDoc
renderRuler
colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
mbMousePos mbHoldAction showGuides
doc
pure
( mbUpdatedDoc, renderAction )
case mbDocAndRender of
Just ( mbNewDoc, render ) -> do
Cairo.renderWithContext render ctx
for_ mbNewDoc \ newDoc -> STM.atomically do
-- Update the document render data in a separate thread.
_ <- forkIO $ forever do
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
( !mbUpdatedDoc, renderDoc ) <- STM.atomically do
needsRecomputation <- STM.readTVar recomputeStrokesTVar
case needsRecomputation of
False -> STM.retry
True -> do
mbDocNow <- fmap present <$> activeDocument variables
case mbDocNow of
Nothing -> pure ( Nothing, blankRender colours )
Just doc -> do
modifiers <- STM.readTVar modifiersTVar
mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar
mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar
showGuides <- STM.readTVar showGuidesTVar
debug <- STM.readTVar debugTVar
fitParameters <- STM.readTVar fitParametersTVar
STM.writeTVar recomputeStrokesTVar False
let
addRulers :: ( Maybe Document, Cairo.Render () ) -> Cairo.Render ()
addRulers ( Nothing , newRender ) = newRender
addRulers ( Just newDoc, newRender ) = do
newRender
renderRuler
colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
mbMousePos mbHoldAction showGuides
newDoc
pure $
( fst &&& addRulers ) $ getDocumentRender
colours fitParameters mode debug ( viewportWidth, viewportHeight )
modifiers mbMousePos mbHoldAction mbPartialPath
doc
STM.atomically do
STM.writeTVar documentRenderTVar renderDoc
for_ mbUpdatedDoc \ newDoc -> do
mbCurrDocUnique <- STM.readTVar activeDocumentTVar
for_ mbCurrDocUnique \ currDocUnique -> do
STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
Nothing ->
Cairo.renderWithContext ( blankRender colours ) ctx
GTK.widgetQueueDraw viewportDrawingArea
-- Render the document using the latest available draw data.
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
-- Get the Cairo instructions for rendering the current document
mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
render <- case mbDoc of
Nothing -> pure ( blankRender colours )
Just _ -> STM.atomically do
STM.readTVar documentRenderTVar
Cairo.renderWithContext render ctx
pure True
for_ [ ( rulerCornerDrawingArea, RulerCorner )
, ( topRulerDrawingArea, TopRuler )
, ( leftRulerDrawingArea, LeftRuler
) ] \ ( rulerDrawingArea, ruler ) -> do
for_ [ ( rulerCornerDrawingArea , RulerCorner )
, ( topRulerDrawingArea , TopRuler )
, ( leftRulerDrawingArea , LeftRuler )
] \ ( rulerDrawingArea, ruler ) -> do
void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
@ -411,7 +428,7 @@ main = do
---------------------------------------------------------
-- Tool bar
_ <- createToolBar variables colours viewportDrawingArea toolBar
_ <- createToolBar variables colours toolBar
---------------------------------------------------------
-- Info bar

41
src/app/MetaBrush/Action.hs
View file

@ -554,7 +554,7 @@ data ToggleGuides = ToggleGuides
deriving stock Show
instance HandleAction ToggleGuides where
handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { showGuidesTVar } ) _ = do
handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do
guidesWereShown <- STM.atomically do
guidesWereShown <- STM.readTVar showGuidesTVar
STM.writeTVar showGuidesTVar ( not guidesWereShown )
@ -565,7 +565,7 @@ instance HandleAction ToggleGuides where
| guidesWereShown = "Show guides"
| otherwise = "Hide guides"
GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText
GTK.widgetQueueDraw viewportDrawingArea
STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
@ -578,16 +578,16 @@ data Confirm = Confirm
instance HandleAction Confirm where
handleAction
( UIElements { viewport = Viewport {..} } )
_
( Variables {..} )
_
= do
tool <- STM.readTVarIO toolTVar
= STM.atomically do
tool <- STM.readTVar toolTVar
case tool of
-- End ongoing drawing on pressing enter key.
Pen -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
STM.writeTVar partialPathTVar Nothing
STM.writeTVar recomputeStrokesTVar True
_ -> pure ()
----------------
@ -620,7 +620,8 @@ instance HandleAction MouseMove where
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
modifiers <- STM.readTVar modifiersTVar
modifiers <- STM.readTVar modifiersTVar
mbMouseHold <- STM.readTVar mouseHoldTVar
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
@ -636,11 +637,15 @@ instance HandleAction MouseMove where
Pen
| any ( \ case { Control _ -> True; _ -> False } ) modifiers
, Just pp <- mbPartialPath
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ -> pure ()
-> do
STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
STM.writeTVar recomputeStrokesTVar True
_ | Just _ <- mbMouseHold
-> STM.writeTVar recomputeStrokesTVar True
| otherwise
-> pure ()
pure do
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
GTK.widgetQueueDraw viewportDrawingArea
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
sequenceA_ uiUpdateAction
@ -785,9 +790,9 @@ instance HandleAction MouseClick where
pure Don'tModifyDoc
-- Right mouse button: end partial path.
3 -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
3 -> STM.atomically do
STM.writeTVar partialPathTVar Nothing
STM.writeTVar recomputeStrokesTVar True
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
@ -1059,7 +1064,7 @@ data KeyboardPress = KeyboardPress Word32
instance HandleAction KeyboardPress where
handleAction
uiElts@( UIElements { viewport = Viewport {..} } )
uiElts
vars@( Variables {..} )
( KeyboardPress keyCode ) = do
@ -1088,9 +1093,9 @@ instance HandleAction KeyboardPress where
Pen
| Just mp <- mbMousePos
, Just pp <- mbPartialPath
-> do
STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
GTK.widgetQueueDraw viewportDrawingArea
-> STM.atomically do
STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
STM.writeTVar recomputeStrokesTVar True
_ -> pure ()
_ -> pure ()

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

@ -80,7 +80,7 @@ import Math.Module
import Math.Vector2D
( Point2D )
import {-# SOURCE #-} MetaBrush.Document.Serialise
( Serialisable )
( Serialisable, Workaround(..) )
import MetaBrush.MetaParameter.AST
( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes
, Adapted, BrushFunction
@ -93,6 +93,10 @@ import MetaBrush.Unique
--------------------------------------------------------------------------------
whatever :: Int
whatever = case Workaround of
Workaround -> 0
data Brush where
BrushData
:: forall brushFields

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

@ -18,6 +18,10 @@ import Data.Set
import Data.Map.Strict
( Map )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
( Render )
-- gi-gtk
import qualified GI.Gdk as GDK
@ -76,21 +80,23 @@ data UIElements
data Variables
= Variables
{ uniqueSupply :: !UniqueSupply
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
, brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, 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 )
, maxHistorySizeTVar :: !( STM.TVar Int )
, fitParametersTVar :: !( STM.TVar FitParameters )
{ uniqueSupply :: !UniqueSupply
, recomputeStrokesTVar :: !( STM.TVar Bool )
, documentRenderTVar :: !( STM.TVar ( Cairo.Render () ) )
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
, brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, 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 )
, maxHistorySizeTVar :: !( STM.TVar Int )
, fitParametersTVar :: !( STM.TVar FitParameters )
}
--------------------------------------------------------------------------------

5
src/app/MetaBrush/Document/Serialise.hs
View file

@ -14,7 +14,7 @@
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise
( Serialisable(..)
( Workaround(..), Serialisable(..)
, documentToJSON, documentFromJSON
, saveDocument, loadDocument
)
@ -200,6 +200,9 @@ import MetaBrush.Unique
--------------------------------------------------------------------------------
-- | Dummy data-type that helps workaround a GHC bug with hs-boot files.
data Workaround = Workaround
-- | Serialise a document to JSON (in the form of a lazy bytestring).
documentToJSON :: Document -> Lazy.ByteString
documentToJSON

4
src/app/MetaBrush/Document/Serialise.hs-boot
View file

@ -2,7 +2,7 @@
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise
( Serialisable(..) )
( Workaround(..), Serialisable(..) )
where
-- base
@ -29,6 +29,8 @@ import Math.Vector2D
--------------------------------------------------------------------------------
data Workaround = Workaround
class Serialisable a where
encoder :: Monad f => JSON.Encoder f a
decoder :: Monad m => JSON.Decoder m a

6
src/app/MetaBrush/Document/Update.hs
View file

@ -53,7 +53,7 @@ import Control.Concurrent.STM
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( readTVar, readTVar, modifyTVar' )
( readTVar, readTVar, modifyTVar', writeTVar )
-- text
import Data.Text
@ -210,7 +210,7 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables
mbDoc = present <$> mbDocHist
mbTitleText :: Maybe ( Text, Bool )
mbTitleText = fmap ( displayName &&& unsavedChanges . documentContent ) mbDoc
mbActiveTabDoc <- fmap join $ for mbDoc \doc -> do
mbActiveTabDoc <- fmap join $ for mbDoc \ doc -> do
mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
pure ( (,) <$> mbActiveTab <*> mbDoc )
pure do
@ -219,7 +219,7 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables
for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do
GTK.buttonSetLabel activeTabLabel ( displayName activeDoc )
GTK.widgetQueueDraw activeTab
GTK.widgetQueueDraw viewportDrawingArea
STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea

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

@ -19,7 +19,7 @@
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Render.Document
( renderDocument, blankRender )
( getDocumentRender, blankRender )
where
-- base
@ -60,6 +60,10 @@ import Data.Sequence
import Data.Set
( Set )
-- deepseq
import Control.DeepSeq
( NFData(..), deepseq )
-- generic-data
import Generic.Data
( Generically1(..) )
@ -165,16 +169,16 @@ toAll action = Compose ( pure action )
blankRender :: Colours -> Cairo.Render ()
blankRender _ = pure ()
renderDocument
getDocumentRender
:: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 )
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
-> Document
-> ( Maybe Document, Cairo.Render () )
renderDocument
getDocumentRender
cols fitParams mode debug ( viewportWidth, viewportHeight )
modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } )
= ( mbUpdatedDoc, drawingInstructions )
= strokesRenderData `deepseq` ( mbUpdatedDoc, drawingInstructions )
where
@ -272,12 +276,12 @@ renderDocument
data StrokeRenderData where
StrokeRenderData
:: forall pointParams clo
. ( KnownSplineType clo, Show pointParams )
. ( KnownSplineType clo, Show pointParams, NFData pointParams )
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) }
-> StrokeRenderData
StrokeWithOutlineRenderData
:: forall pointParams clo
. ( KnownSplineType clo, Show pointParams )
. ( KnownSplineType clo, Show pointParams, NFData pointParams )
=> { strokeDataSpline :: !( StrokeSpline clo pointParams )
, strokeOutlineData :: !( Either
( SplinePts Closed )
@ -288,6 +292,12 @@ data StrokeRenderData where
}
-> StrokeRenderData
instance NFData StrokeRenderData where
rnf ( StrokeRenderData spline ) =
rnf spline
rnf ( StrokeWithOutlineRenderData { strokeDataSpline, strokeOutlineData } ) =
strokeDataSpline `deepseq` strokeOutlineData `deepseq` ()
-- | Compute the data necessary to render a stroke.
--
-- - If the stroke has an associated brush, this consists of:

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

@ -59,8 +59,8 @@ data ToolBar
{ selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton
, debugTool :: !GTK.ToggleButton }
createToolBar :: Variables -> Colours -> GTK.DrawingArea -> GTK.Box -> IO ToolBar
createToolBar ( Variables {..} ) colours drawingArea toolBar = do
createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar
createToolBar ( Variables {..} ) colours toolBar = do
widgetAddClass toolBar "toolBar"
@ -70,10 +70,10 @@ createToolBar ( Variables {..} ) colours drawingArea 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 )
_ <- GTK.onButtonClicked selectionTool $ STM.atomically do
STM.writeTVar toolTVar Selection
_ <- GTK.onButtonClicked penTool $ STM.atomically do
STM.writeTVar toolTVar Pen
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
@ -81,15 +81,15 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
_ <- GTK.onButtonClicked pathTool do
STM.atomically $ STM.writeTVar modeTVar PathMode
GTK.widgetQueueDraw drawingArea
_ <- GTK.onButtonClicked brushTool do
STM.atomically $ STM.writeTVar modeTVar BrushMode
GTK.widgetQueueDraw drawingArea
_ <- GTK.onButtonClicked metaTool do
STM.atomically $ STM.writeTVar modeTVar MetaMode
GTK.widgetQueueDraw drawingArea
_ <- GTK.onButtonClicked pathTool $ STM.atomically do
STM.writeTVar modeTVar PathMode
STM.writeTVar recomputeStrokesTVar True
_ <- GTK.onButtonClicked brushTool $ STM.atomically do
STM.writeTVar modeTVar BrushMode
STM.writeTVar recomputeStrokesTVar True
_ <- GTK.onButtonClicked metaTool $ STM.atomically do
STM.writeTVar modeTVar MetaMode
STM.writeTVar recomputeStrokesTVar True
toolSep2 <- GTK.boxNew GTK.OrientationVertical 0
@ -98,8 +98,9 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do
_ <- GTK.onButtonClicked debugTool do
clicked <- GTK.toggleButtonGetActive debugTool
STM.atomically $ STM.writeTVar debugTVar clicked
GTK.widgetQueueDraw drawingArea
STM.atomically do
STM.writeTVar debugTVar clicked
STM.writeTVar recomputeStrokesTVar True
GTK.boxPackStart toolBar selectionTool True True 0
GTK.boxPackStart toolBar penTool True True 0

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

@ -96,7 +96,6 @@ import Math.Bezier.Spline
, Spline(..), SplinePts, Curves(..), Curve(..)
, openCurveStart, openCurveEnd
, splitSplineAt, dropCurves
, reverseSpline
)
import qualified Math.Bezier.Quadratic as Quadratic
import Math.Epsilon
@ -200,7 +199,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
= fmap ( MkVector2D ( coords endPt ) • )
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
-> ( newSpline
, Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, fwdFits <> bwdFits
)
-- Closed brush path with at least one segment.
@ -607,6 +606,14 @@ withTangent
:: forall crvData ptData
. ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData )
=> Vector2D Double -> Spline Closed crvData ptData -> Offset
withTangent ( Vector2D tx ty ) ( Spline { splineStart } )
-- handle bad tangent vectors
| isNaN tx
|| isNaN ty
|| isInfinite tx
|| isInfinite ty
|| ( abs tx < epsilon && abs ty < epsilon )
= Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }
withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spline of
Nothing ->
Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }