always use current viewport sizes

app/Main.hs

@@ -218,7 +218,7 @@ main = do
           mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
 
   recomputeStrokesTVar <- STM.newTVarIO @Bool                                        False
-  documentRenderTVar   <- STM.newTVarIO @( Cairo.Render () )                         ( pure () )
+  documentRenderTVar   <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () )     ( const $ pure () )
   activeDocumentTVar   <- STM.newTVarIO @( Maybe Unique )                            Nothing
   openDocumentsTVar    <- STM.newTVarIO @( Map Unique DocumentHistory )              testDocuments
   brushesTVar          <- STM.newTVarIO @( HashMap Brush Unique )                    testBrushes
@@ -350,8 +350,6 @@ main = 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
@@ -359,7 +357,7 @@ main = do
           True  -> do
               mbDocNow <- fmap present <$> activeDocument variables
               case mbDocNow of
-                Nothing -> pure ( Nothing, blankRender colours )
+                Nothing -> pure ( Nothing, const $ blankRender colours )
                 Just doc -> do
                   modifiers      <- STM.readTVar modifiersTVar
                   mbMousePos     <- STM.readTVar mousePosTVar
@@ -371,17 +369,17 @@ main = do
                   fitParameters  <- STM.readTVar fitParametersTVar
                   STM.writeTVar recomputeStrokesTVar False
                   let
-                    addRulers :: ( Maybe Document, Cairo.Render () ) -> Cairo.Render ()
+                    addRulers :: ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) 
-                    addRulers ( Nothing    , newRender ) = newRender
+                    addRulers ( Nothing    , newRender ) viewportSize = newRender viewportSize
-                    addRulers ( Just newDoc, newRender ) = do
+                    addRulers ( Just newDoc, newRender ) viewportSize = do
-                      newRender
+                      newRender viewportSize
                       renderRuler
-                        colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
+                        colours viewportSize ViewportOrigin viewportSize
                         mbMousePos mbHoldAction showGuides
                         newDoc
                   pure $
                     ( fst &&& addRulers ) $ getDocumentRender
-                      colours fitParameters mode debug ( viewportWidth, viewportHeight )
+                      colours fitParameters mode debug
                       modifiers mbMousePos mbHoldAction mbPartialPath
                       doc
       STM.atomically do
@@ -394,12 +392,15 @@ main = do
 
   -- Render the document using the latest available draw data.
   void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
+    viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
+    viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
     -- 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
+        render <- STM.readTVar documentRenderTVar
+        pure ( render ( viewportWidth, viewportHeight ) )
     Cairo.renderWithContext render ctx
     pure True
 

src/app/MetaBrush/Action.hs

@@ -635,11 +635,11 @@ instance HandleAction MouseMove where
         mbPartialPath <- STM.readTVar partialPathTVar
         case tool of
           Pen
-            | any ( \ case { Control _ -> True; _ -> False } ) modifiers
+            | Just pp <- mbPartialPath
-            , Just pp <- mbPartialPath
             -> do
-              STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
               STM.writeTVar recomputeStrokesTVar True
+              when ( any ( \ case { Control _ -> True; _ -> False } ) modifiers ) do
+                STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
           _ | Just _ <- mbMouseHold
             -> STM.writeTVar recomputeStrokesTVar True
             | otherwise
@@ -901,7 +901,6 @@ instance HandleAction MouseRelease where
                                 Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
                                 Nothing  -> pure Don'tModifyDoc
                           | SelectionHold pos0 <- hold
-                          , pos0 /= pos
                           -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
                         _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
 

src/app/MetaBrush/Context.hs

@@ -9,6 +9,8 @@ module MetaBrush.Context
   where
 
 -- base
+import Data.Int
+  ( Int32 )
 import Data.Word
   ( Word32 )
 
@@ -82,7 +84,7 @@ data Variables
   = Variables
   { uniqueSupply         :: !UniqueSupply
   , recomputeStrokesTVar :: !( STM.TVar Bool                                        )
-  , documentRenderTVar   :: !( STM.TVar ( Cairo.Render () )                         )
+  , documentRenderTVar   :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () )     )
   , activeDocumentTVar   :: !( STM.TVar ( Maybe Unique )                            )
   , openDocumentsTVar    :: !( STM.TVar ( Map Unique DocumentHistory )              )
   , brushesTVar          :: !( STM.TVar ( HashMap Brush Unique )                    )

src/app/MetaBrush/Render/Document.hs

@@ -170,20 +170,20 @@ blankRender :: Colours -> Cairo.Render ()
 blankRender _ = pure ()
 
 getDocumentRender
-  :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 )
+  :: Colours -> FitParameters -> Mode -> Bool
   -> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
   -> Document 
-  -> ( Maybe Document, Cairo.Render () )
+  -> ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () )
 getDocumentRender
-  cols fitParams mode debug ( viewportWidth, viewportHeight ) 
+  cols fitParams mode debug  
   modifiers mbMousePos mbHoldEvent mbPartialPath
   doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } )
     = strokesRenderData `deepseq` ( mbUpdatedDoc, drawingInstructions )
 
     where
 
-      drawingInstructions :: Cairo.Render ()
+      drawingInstructions :: ( Int32, Int32 ) -> Cairo.Render ()
-      drawingInstructions = do
+      drawingInstructions ( viewportWidth, viewportHeight ) = do
         Cairo.save
         Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
         Cairo.scale zoomFactor zoomFactor