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

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

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

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

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

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

@ -18,6 +18,10 @@ import Data.Set
import Data.Map.Strict import Data.Map.Strict
( Map ) ( Map )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
( Render )
-- gi-gtk -- gi-gtk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
@ -76,21 +80,23 @@ data UIElements
data Variables data Variables
= Variables = Variables
{ uniqueSupply :: !UniqueSupply { uniqueSupply :: !UniqueSupply
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) , recomputeStrokesTVar :: !( STM.TVar Bool )
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) , documentRenderTVar :: !( STM.TVar ( Cairo.Render () ) )
, brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) ) , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
, toolTVar :: !( STM.TVar Tool ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modeTVar :: !( STM.TVar Mode ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) )
, debugTVar :: !( STM.TVar Bool ) , toolTVar :: !( STM.TVar Tool )
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) , modeTVar :: !( STM.TVar Mode )
, fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) ) , debugTVar :: !( STM.TVar Bool )
, showGuidesTVar :: !( STM.TVar Bool ) , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
, maxHistorySizeTVar :: !( STM.TVar Int ) , fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) )
, fitParametersTVar :: !( STM.TVar FitParameters ) , 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 #-} {-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise module MetaBrush.Document.Serialise
( Serialisable(..) ( Workaround(..), Serialisable(..)
, documentToJSON, documentFromJSON , documentToJSON, documentFromJSON
, saveDocument, loadDocument , 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). -- | Serialise a document to JSON (in the form of a lazy bytestring).
documentToJSON :: Document -> Lazy.ByteString documentToJSON :: Document -> Lazy.ByteString
documentToJSON documentToJSON

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

@ -2,7 +2,7 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise module MetaBrush.Document.Serialise
( Serialisable(..) ) ( Workaround(..), Serialisable(..) )
where where
-- base -- base
@ -29,6 +29,8 @@ import Math.Vector2D
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Workaround = Workaround
class Serialisable a where class Serialisable a where
encoder :: Monad f => JSON.Encoder f a encoder :: Monad f => JSON.Encoder f a
decoder :: Monad m => JSON.Decoder m 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 import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( readTVar, readTVar, modifyTVar' ) ( readTVar, readTVar, modifyTVar', writeTVar )
-- text -- text
import Data.Text import Data.Text
@ -210,7 +210,7 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables
mbDoc = present <$> mbDocHist mbDoc = present <$> mbDocHist
mbTitleText :: Maybe ( Text, Bool ) mbTitleText :: Maybe ( Text, Bool )
mbTitleText = fmap ( displayName &&& unsavedChanges . documentContent ) mbDoc 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 mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
pure ( (,) <$> mbActiveTab <*> mbDoc ) pure ( (,) <$> mbActiveTab <*> mbDoc )
pure do pure do
@ -219,7 +219,7 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables
for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do
GTK.buttonSetLabel activeTabLabel ( displayName activeDoc ) GTK.buttonSetLabel activeTabLabel ( displayName activeDoc )
GTK.widgetQueueDraw activeTab GTK.widgetQueueDraw activeTab
GTK.widgetQueueDraw viewportDrawingArea STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea GTK.widgetQueueDraw drawingArea

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

@ -19,7 +19,7 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module MetaBrush.Render.Document module MetaBrush.Render.Document
( renderDocument, blankRender ) ( getDocumentRender, blankRender )
where where
-- base -- base
@ -60,6 +60,10 @@ import Data.Sequence
import Data.Set import Data.Set
( Set ) ( Set )
-- deepseq
import Control.DeepSeq
( NFData(..), deepseq )
-- generic-data -- generic-data
import Generic.Data import Generic.Data
( Generically1(..) ) ( Generically1(..) )
@ -165,16 +169,16 @@ toAll action = Compose ( pure action )
blankRender :: Colours -> Cairo.Render () blankRender :: Colours -> Cairo.Render ()
blankRender _ = pure () blankRender _ = pure ()
renderDocument getDocumentRender
:: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 ) :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 )
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
-> Document -> Document
-> ( Maybe Document, Cairo.Render () ) -> ( Maybe Document, Cairo.Render () )
renderDocument getDocumentRender
cols fitParams mode debug ( viewportWidth, viewportHeight ) cols fitParams mode debug ( viewportWidth, viewportHeight )
modifiers mbMousePos mbHoldEvent mbPartialPath modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } ) doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } )
= ( mbUpdatedDoc, drawingInstructions ) = strokesRenderData `deepseq` ( mbUpdatedDoc, drawingInstructions )
where where
@ -272,12 +276,12 @@ renderDocument
data StrokeRenderData where data StrokeRenderData where
StrokeRenderData StrokeRenderData
:: forall pointParams clo :: forall pointParams clo
. ( KnownSplineType clo, Show pointParams ) . ( KnownSplineType clo, Show pointParams, NFData pointParams )
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) } => { strokeDataSpline :: !( StrokeSpline clo pointParams ) }
-> StrokeRenderData -> StrokeRenderData
StrokeWithOutlineRenderData StrokeWithOutlineRenderData
:: forall pointParams clo :: forall pointParams clo
. ( KnownSplineType clo, Show pointParams ) . ( KnownSplineType clo, Show pointParams, NFData pointParams )
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) => { strokeDataSpline :: !( StrokeSpline clo pointParams )
, strokeOutlineData :: !( Either , strokeOutlineData :: !( Either
( SplinePts Closed ) ( SplinePts Closed )
@ -288,6 +292,12 @@ data StrokeRenderData where
} }
-> StrokeRenderData -> 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. -- | Compute the data necessary to render a stroke.
-- --
-- - If the stroke has an associated brush, this consists of: -- - 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 { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton
, debugTool :: !GTK.ToggleButton } , 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" widgetAddClass toolBar "toolBar"
@ -70,10 +70,10 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool ) 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 toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
@ -81,15 +81,15 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
metaTool <- 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 toolSep2 <- GTK.boxNew GTK.OrientationVertical 0
@ -98,8 +98,9 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do
_ <- GTK.onButtonClicked debugTool do _ <- GTK.onButtonClicked debugTool do
clicked <- GTK.toggleButtonGetActive debugTool 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 selectionTool True True 0
GTK.boxPackStart toolBar penTool 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(..) , Spline(..), SplinePts, Curves(..), Curve(..)
, openCurveStart, openCurveEnd , openCurveStart, openCurveEnd
, splitSplineAt, dropCurves , splitSplineAt, dropCurves
, reverseSpline
) )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
import Math.Epsilon import Math.Epsilon
@ -200,7 +199,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
= fmap ( MkVector2D ( coords endPt ) • ) = fmap ( MkVector2D ( coords endPt ) • )
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush $ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
-> ( newSpline -> ( newSpline
, Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts ) , Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, fwdFits <> bwdFits , fwdFits <> bwdFits
) )
-- Closed brush path with at least one segment. -- Closed brush path with at least one segment.
@ -607,6 +606,14 @@ withTangent
:: forall crvData ptData :: forall crvData ptData
. ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData ) . ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData )
=> Vector2D Double -> Spline Closed crvData ptData -> Offset => 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 withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spline of
Nothing -> Nothing ->
Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) } Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }