diff --git a/app/Main.hs b/app/Main.hs index 44d4404..1591ed8 100644 --- a/app/Main.hs +++ b/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 ( Nothing , newRender ) = newRender - addRulers ( Just newDoc, newRender ) = do - newRender + addRulers :: ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) + addRulers ( Nothing , newRender ) viewportSize = newRender viewportSize + addRulers ( Just newDoc, newRender ) viewportSize = do + 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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 039feb8..0d254c0 100644 --- a/src/app/MetaBrush/Action.hs +++ b/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 ) diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 7381916..91a93ab 100644 --- a/src/app/MetaBrush/Context.hs +++ b/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 ) ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 16d942a..b635cbc 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/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 = do + drawingInstructions :: ( Int32, Int32 ) -> Cairo.Render () + drawingInstructions ( viewportWidth, viewportHeight ) = do Cairo.save Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight ) Cairo.scale zoomFactor zoomFactor