mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 09:24:08 +00:00
compute outline data concurrently
This commit is contained in:
sheaf
parent
b32499cc68
commit
c1cae2b69f
155
app/Main.hs
155
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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ) }
|
||||
|
|
|
|||
Loading…
Reference in a new issue