diff --git a/app/Main.hs b/app/Main.hs index b868207..44d4404 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 4e281a7..039feb8 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 () diff --git a/src/app/MetaBrush/Brush.hs b/src/app/MetaBrush/Brush.hs index 270fac8..b3dcb18 100644 --- a/src/app/MetaBrush/Brush.hs +++ b/src/app/MetaBrush/Brush.hs @@ -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 diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 692d7f3..7381916 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -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 ) } -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 8ce5066..17865f4 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Serialise.hs-boot b/src/app/MetaBrush/Document/Serialise.hs-boot index b9c8e70..9bd7431 100644 --- a/src/app/MetaBrush/Document/Serialise.hs-boot +++ b/src/app/MetaBrush/Document/Serialise.hs-boot @@ -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 diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs index 27c3979..243420a 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/src/app/MetaBrush/Document/Update.hs @@ -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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 99109af..16d942a 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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: diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index e21b118..2e5f2fd 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -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 diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index 81a78c3..39ccd54 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -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 ) }