compute outline data concurrently

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,6 +217,8 @@ main = do
           mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
           mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
 
+  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
@@ -343,53 +348,65 @@ main = do
   -----------------
   -- Viewport rendering
 
-  void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
+  -- Update the document render data in a separate thread.
-    -- Get the relevant document information
+  _ <- forkIO $ forever do
       viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
       viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
-    mbDocAndRender <- STM.atomically $ withActiveDocument variables \ doc -> do
+      ( !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
-      debug          <- STM.readTVar debugTVar
                   showGuides     <- STM.readTVar showGuidesTVar
+                  debug          <- STM.readTVar debugTVar
                   fitParameters  <- STM.readTVar fitParametersTVar
-
+                  STM.writeTVar recomputeStrokesTVar False
                   let
-        mbUpdatedDoc :: Maybe Document
+                    addRulers :: ( Maybe Document, Cairo.Render () ) -> Cairo.Render ()
-        renderDoc, renderAction :: Cairo.Render ()
+                    addRulers ( Nothing    , newRender ) = newRender
-        ( mbUpdatedDoc, renderDoc ) =
+                    addRulers ( Just newDoc, newRender ) = do
-          renderDocument
+                      newRender
-            colours fitParameters mode debug ( viewportWidth, viewportHeight )
-            modifiers mbMousePos mbHoldAction mbPartialPath
-            doc
-        renderAction = do
-          renderDoc
                       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
-      pure
+      STM.atomically do
-        ( mbUpdatedDoc, renderAction )
+        STM.writeTVar documentRenderTVar renderDoc
-
+        for_ mbUpdatedDoc \ newDoc -> do
-    case mbDocAndRender of
-      Just ( mbNewDoc, render ) -> do
-        Cairo.renderWithContext render ctx
-        for_ mbNewDoc \ newDoc -> STM.atomically do
           mbCurrDocUnique <- STM.readTVar activeDocumentTVar
           for_ mbCurrDocUnique \ currDocUnique -> do
             STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
-      Nothing ->
+      GTK.widgetQueueDraw viewportDrawingArea
-        Cairo.renderWithContext ( blankRender colours ) ctx
 
+  -- 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 )
+  for_ [ ( rulerCornerDrawingArea , RulerCorner )
-       , ( topRulerDrawingArea, TopRuler )
+       , ( topRulerDrawingArea    , TopRuler    )
-       , ( leftRulerDrawingArea, LeftRuler
+       , ( leftRulerDrawingArea   , LeftRuler   )
-       ) ] \ ( rulerDrawingArea, ruler ) -> do
+       ] \ ( 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

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
+    = STM.atomically do
-        tool <- STM.readTVarIO toolTVar
+        tool <- STM.readTVar toolTVar
         case tool of
           -- End ongoing drawing on pressing enter key.
           Pen -> do
-            STM.atomically $ STM.writeTVar partialPathTVar Nothing
+            STM.writeTVar partialPathTVar Nothing
-            GTK.widgetQueueDraw viewportDrawingArea
+            STM.writeTVar recomputeStrokesTVar True
           _ -> pure ()
 
 ----------------
@@ -621,6 +621,7 @@ instance HandleAction MouseMove where
       viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
       uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
         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 } )
+            -> do
-          _ -> pure ()
+              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
+      3 -> STM.atomically do
-        STM.atomically $ STM.writeTVar partialPathTVar Nothing
+        STM.writeTVar partialPathTVar Nothing
-        GTK.widgetQueueDraw viewportDrawingArea
+        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 do
-                    STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
+                    STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
-                    GTK.widgetQueueDraw viewportDrawingArea
+                    STM.writeTVar recomputeStrokesTVar True
               _ -> pure ()
 
         _ -> pure ()

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

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
 
@@ -77,6 +81,8 @@ data UIElements
 data Variables
   = Variables
   { 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 )                    )

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

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

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
 

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:

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 -> GTK.Box -> IO ToolBar
-createToolBar ( Variables {..} ) colours drawingArea toolBar = do
+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
+  _ <- GTK.onButtonClicked selectionTool $ STM.atomically do
-    ( STM.atomically $ STM.writeTVar toolTVar Selection )
+    STM.writeTVar toolTVar Selection
-  _ <- GTK.onButtonClicked penTool
+  _ <- GTK.onButtonClicked penTool $ STM.atomically do
-    ( STM.atomically $ STM.writeTVar toolTVar Pen )
+    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
+  _ <- GTK.onButtonClicked pathTool $ STM.atomically do
-    STM.atomically $ STM.writeTVar modeTVar PathMode
+    STM.writeTVar modeTVar PathMode
-    GTK.widgetQueueDraw drawingArea
+    STM.writeTVar recomputeStrokesTVar True
-  _ <- GTK.onButtonClicked brushTool do
+  _ <- GTK.onButtonClicked brushTool $ STM.atomically do
-    STM.atomically $ STM.writeTVar modeTVar BrushMode
+    STM.writeTVar modeTVar BrushMode
-    GTK.widgetQueueDraw drawingArea
+    STM.writeTVar recomputeStrokesTVar True
-  _ <- GTK.onButtonClicked metaTool do
+  _ <- GTK.onButtonClicked metaTool $ STM.atomically do
-    STM.atomically $ STM.writeTVar modeTVar MetaMode
+    STM.writeTVar modeTVar MetaMode
-    GTK.widgetQueueDraw drawingArea
+    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
+    STM.atomically do
-    GTK.widgetQueueDraw drawingArea
+      STM.writeTVar debugTVar clicked
+      STM.writeTVar recomputeStrokesTVar True
 
   GTK.boxPackStart toolBar selectionTool True True 0
   GTK.boxPackStart toolBar       penTool True True 0

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