hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

implement drawing with the pen tool

Browse source
This commit is contained in:
sheaf 2020-08-17 00:09:16 +02:00
parent 38c4e9fa6c
commit 596821222f
14 changed files with 627 additions and 184 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
MetaBrush.cabal
View file

@ -92,6 +92,7 @@ executable MetaBrush
, MetaBrush.Asset.Tools
, MetaBrush.Asset.WindowIcons
, MetaBrush.Document
, MetaBrush.Document.Draw
, MetaBrush.Document.Selection
, MetaBrush.Event
, MetaBrush.Event.KeyCodes
@ -105,6 +106,7 @@ executable MetaBrush
, MetaBrush.UI.Panels
, MetaBrush.UI.ToolBar
, MetaBrush.UI.Viewport
, MetaBrush.Unique
, Paths_MetaBrush
autogen-modules:
@ -143,3 +145,5 @@ executable MetaBrush
^>= 0.4.1.0
, text
^>= 1.2.3.1 && < 1.2.5
, transformers
^>= 0.5.6.2

62
app/Main.hs
View file

@ -1,10 +1,6 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Main
@ -60,11 +56,12 @@ import MetaBrush.Asset.Logo
( drawLogo )
import MetaBrush.Document
( Document(..), AABB(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, currentDocument
)
import MetaBrush.Event
( HoldEvent, handleEvents )
( HoldEvent, PartialPath
, handleEvents
)
import MetaBrush.Render.Document
( renderDocument )
import MetaBrush.Render.Util
@ -81,6 +78,8 @@ import MetaBrush.UI.ToolBar
( Tool(..), Mode(..), createToolBar )
import MetaBrush.UI.Viewport
( Viewport(..), createViewport )
import MetaBrush.Unique
( newUniqueSupply )
import qualified Paths_MetaBrush as Cabal
( getDataFileName )
@ -93,29 +92,7 @@ testDocuments = IntMap.fromList
{ displayName = "Document 1"
, filePath = Nothing
, unsavedChanges = False
, strokes = [ Stroke
[ StrokePoint ( Point2D 0 0 ) PathPoint Normal ]
"Stroke1"
False
, Stroke
[ StrokePoint ( Point2D 100 0 ) PathPoint Normal
, StrokePoint ( Point2D 105 0 ) ControlPoint Normal
, StrokePoint ( Point2D 110 0 ) PathPoint Normal
]
"Stroke2"
True
, Stroke
[ StrokePoint ( Point2D 0 100 ) PathPoint Normal ]
"Stroke3"
True
, Stroke
[ StrokePoint ( Point2D 100 100 ) PathPoint Normal
, StrokePoint ( Point2D 105 105 ) ControlPoint Normal
, StrokePoint ( Point2D 110 100 ) PathPoint Normal
]
"Stroke4"
True
]
, strokes = [ ]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
, viewportCenter = Point2D 50 50
, zoomFactor = 1
@ -124,14 +101,7 @@ testDocuments = IntMap.fromList
{ displayName = "Document 2"
, filePath = Nothing
, unsavedChanges = True
, strokes = [ Stroke
[ StrokePoint ( Point2D 0 0 ) PathPoint Normal
, StrokePoint ( Point2D 10 10 ) ControlPoint Normal
, StrokePoint ( Point2D 20 20 ) PathPoint Normal
]
"Stroke1"
True
]
, strokes = [ ]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
, viewportCenter = Point2D 10 10
, zoomFactor = 0.25
@ -146,6 +116,7 @@ main = do
---------------------------------------------------------
-- Initialise state
uniqueSupply <- newUniqueSupply
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
@ -153,6 +124,7 @@ main = do
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
---------------------------------------------------------
-- Initialise GTK
@ -275,15 +247,16 @@ main = do
-- Get the relevant document information
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
for_ mbDoc \ doc -> do
mousePos <- STM.readTVarIO mousePosTVar
holdEvent <- STM.readTVarIO mouseHoldTVar
let
mbHoldEvent :: Maybe ( HoldEvent, Point2D Double )
mbHoldEvent = (,) <$> holdEvent <*> mousePos
mbMousePos <- STM.readTVarIO mousePosTVar
mbHoldEvent <- STM.readTVarIO mouseHoldTVar
mbPartialPath <- STM.readTVarIO partialPathTVar
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
( `Cairo.renderWithContext` ctx ) $
renderDocument colours ( viewportWidth, viewportHeight ) mbHoldEvent doc
renderDocument
colours ( viewportWidth, viewportHeight )
mbMousePos mbHoldEvent mbPartialPath
doc
pure True
---------------------------------------------------------
@ -313,9 +286,10 @@ main = do
-- Actions
handleEvents
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar
toolTVar modeTVar partialPathTVar
window viewportDrawingArea infoBarElements
---------------------------------------------------------

16
src/app/MetaBrush/Document.hs
View file

@ -7,7 +7,7 @@ module MetaBrush.Document
( AABB(..)
, Document(..), currentDocument
, Stroke(..), StrokePoint(..), PointType(..)
, FocusState(..), switchFocusState
, FocusState(..)
)
where
@ -16,6 +16,8 @@ import Data.IntMap.Strict
( IntMap )
import qualified Data.IntMap.Strict as IntMap
( lookup )
import Data.Sequence
( Seq )
import GHC.Generics
( Generic )
@ -32,6 +34,8 @@ import qualified Control.Concurrent.STM.TVar as STM
-- MetaBrush
import Math.Vector2D
( Point2D )
import MetaBrush.Unique
( Unique )
--------------------------------------------------------------------------------
@ -56,9 +60,10 @@ data Document
data Stroke
= Stroke
{ strokePoints :: ![ StrokePoint ]
, strokeName :: !Text
{ strokePoints :: !( Seq StrokePoint )
, strokeName :: Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
}
deriving stock ( Show, Generic )
@ -81,11 +86,6 @@ data FocusState
| Selected
deriving stock Show
switchFocusState :: FocusState -> FocusState
switchFocusState Normal = Selected
switchFocusState Hover = Hover
switchFocusState Selected = Normal
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar

142
src/app/MetaBrush/Document/Draw.hs Normal file
View file

@ -0,0 +1,142 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Draw
( DrawAnchor(..), anchorsAreComplementary
, getDrawAnchor, addToAnchor
)
where
-- base
import Data.Functor
( ($>) )
-- acts
import Data.Act
( Torsor((-->)) )
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( singleton, reverse, take, drop, length )
-- generic-lens
import Data.GenericLens.Internal
( over )
import Data.Generics.Product.Fields
( field' )
-- stm
import Control.Concurrent.STM
( STM )
-- transformers
import Control.Monad.Trans.State.Strict
( State, runState, get, put )
-- MetaBrush
import Math.Module
( squaredNorm )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Stroke(..), StrokePoint(..)
, PointType(..), FocusState(..)
)
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText )
--------------------------------------------------------------------------------
data DrawAnchor
= AnchorAtStart { anchorStrokeUnique :: Unique }
| AnchorAtEnd { anchorStrokeUnique :: Unique }
deriving stock Show
-- | Computes whether two anchors are the two ends of the same stroke.
anchorsAreComplementary :: DrawAnchor -> DrawAnchor -> Bool
anchorsAreComplementary ( AnchorAtStart uniq1 ) ( AnchorAtEnd uniq2 )
| uniq1 == uniq2
= True
anchorsAreComplementary ( AnchorAtEnd uniq1 ) ( AnchorAtStart uniq2 )
| uniq1 == uniq2
= True
anchorsAreComplementary _ _ = False
getDrawAnchor :: UniqueSupply -> Point2D Double -> Document -> STM ( Document, DrawAnchor, Point2D Double )
getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
case ( `runState` Nothing ) $ field' @"strokes" ( traverse updateStroke ) doc of
-- Anchor found: use it.
( newDoc, Just ( anchor, anchorPt ) ) -> pure ( newDoc, anchor, anchorPt )
-- No anchor found: start a new stroke (on a new stroke layer).
( newDoc, Nothing ) -> do
uniq <- freshUnique uniqueSupply
let
newDoc' :: Document
newDoc' =
over ( field' @"strokes" )
( Stroke
( Seq.singleton $ StrokePoint c PathPoint Normal )
( "Stroke " <> uniqueText uniq )
True
uniq
: )
newDoc
pure ( newDoc', AnchorAtEnd uniq, c )
where
-- Deselect all points, and try to find a valid anchor for drawing
-- (a path start/end point at mouse click point).
updateStroke :: Stroke -> State ( Maybe ( DrawAnchor, Point2D Double ) ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokePoints, strokeUnique } ) = do
mbAnchor <- get
case mbAnchor of
-- If we haven't already found an anchor,
-- and the current point is a valid candidate,
-- then select it as an anchor for the drawing operation.
Nothing
| strokeVisible
, Just anchor <- endpointAnchor strokeUnique strokePoints
-> put ( Just anchor )
$> over ( field' @"strokePoints" ) ( fmap deselectPoint ) stroke
-- Otherwise, just deselect.
_ -> pure $ over ( field' @"strokePoints" ) ( fmap deselectPoint ) stroke
-- See if we can anchor a drawing operation on a given (visible) stroke.
endpointAnchor :: Unique -> Seq StrokePoint -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor _ ( StrokePoint p0 PathPoint _ :<| ( _ :|> StrokePoint pn PathPoint _ ) )
| p0 == pn
= Nothing
endpointAnchor uniq ( StrokePoint p0 PathPoint _ :<| _ )
| inPointClickRange p0
= Just ( AnchorAtStart uniq, p0 )
endpointAnchor uniq ( _ :|> StrokePoint pn PathPoint _ )
| inPointClickRange pn
= Just ( AnchorAtEnd uniq, pn )
endpointAnchor _ _ = Nothing
deselectPoint :: StrokePoint -> StrokePoint
deselectPoint pt = pt { pointState = Normal }
inPointClickRange :: Point2D Double -> Bool
inPointClickRange p =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
addToAnchor :: DrawAnchor -> Seq StrokePoint -> Document -> Document
addToAnchor anchor newPts = over ( field' @"strokes" ) ( fmap addToStroke )
where
addToStroke :: Stroke -> Stroke
addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } )
| strokeUnique == anchorStrokeUnique anchor
= case anchor of
AnchorAtStart _ -> stroke { strokePoints = Seq.reverse newPts <> Seq.drop 1 pts }
AnchorAtEnd _ -> stroke { strokePoints = dropEnd 1 pts <> newPts }
| otherwise
= stroke
dropEnd :: Int -> Seq a -> Seq a
dropEnd i as = Seq.take ( n - i ) as
where
n :: Int
n = Seq.length as

68
src/app/MetaBrush/Document/Selection.hs
View file

@ -5,8 +5,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Selection
@ -14,10 +12,13 @@ module MetaBrush.Document.Selection
, selectAt, selectRectangle
, DragMoveSelect(..), dragMoveSelect
, translateSelection
, deleteSelected
)
where
-- base
import Data.Functor
( ($>) )
import Data.Functor.Identity
( runIdentity )
import Data.Word
@ -38,9 +39,13 @@ import Control.Monad.Trans.Tardis
( Tardis )
import qualified Control.Monad.Trans.Tardis as Tardis
( TardisT(..)
, getPast, getFuture, sendPast, modifyForwards
, getPast, getFuture, sendPast, sendFuture
)
-- transformers
import Control.Monad.Trans.State.Strict
( State, evalState, get, put )
-- MetaBrush
import Math.Module
( squaredNorm )
@ -48,7 +53,7 @@ import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Stroke(..), StrokePoint(..)
, FocusState(..), switchFocusState
, FocusState(..)
)
import MetaBrush.Event.KeyCodes
( pattern Alt_L , pattern Alt_R
@ -82,25 +87,23 @@ selectionMode = foldMap \case
_ -> New
-- | Updates the selected objects on a single click selection event.
--
-- TODO: currently selects points regardless of layers,
-- e.g. it will simultaneously select points with equal coordinates.
selectAt :: SelectionMode -> Point2D Double -> Document -> Document
selectAt mode c doc@( Document { zoomFactor } ) =
over ( field' @"strokes" ) ( fmap updateStroke ) doc
( `evalState` False ) $ field' @"strokes" ( traverse updateStroke ) doc
where
updateStroke :: Stroke -> Stroke
updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" )
( fmap ( updatePoint strokeVisible ) )
field' @"strokePoints"
( traverse ( updatePoint strokeVisible ) )
stroke
updatePoint :: Bool -> StrokePoint -> StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
| selected = case mode of
New -> pt { pointState = switchFocusState oldFocusState }
Add -> pt { pointState = Selected }
updatePoint :: Bool -> StrokePoint -> State Bool StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = p } ) = do
anotherPointHasAlreadyBeenSelected <- get
if selected && not anotherPointHasAlreadyBeenSelected
then put True $> case mode of
Subtract -> pt { pointState = Normal }
| otherwise = case mode of
_ -> pt { pointState = Selected }
else pure $ case mode of
New -> pt { pointState = Normal }
_ -> pt
where
@ -118,16 +121,6 @@ data DragMoveSelect
| ClickedOnUnselected
deriving stock Show
instance {-# OVERLAPPING #-} Semigroup ( Maybe DragMoveSelect ) where
Just ( ClickedOnSelected ) <> _ = Just ( ClickedOnSelected )
Nothing <> r = r
_ <> Just ( ClickedOnSelected ) = Just ( ClickedOnSelected )
l <> Nothing = l
_ <> _ = Just ClickedOnUnselected
instance {-# OVERLAPPING #-} Monoid ( Maybe DragMoveSelect ) where
mempty = Nothing
-- | Checks whether a mouse click can initiate a drag move event,
-- and if so returns an updated document with the selection modified from the start of the drag move.
dragMoveSelect :: Point2D Double -> Document -> Maybe Document
@ -152,10 +145,17 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
| selected
= do
case oldFocusState of
Selected -> Tardis.modifyForwards ( const $ Just ClickedOnSelected )
_ -> Tardis.modifyForwards ( <> Just ClickedOnUnselected )
pure $ pt { pointState = Selected }
mbPreviousSelect <- Tardis.getPast
case mbPreviousSelect of
-- Already clicked on a point: don't select further points.
Just _ -> pure pt
-- First click on a point: record this.
Nothing -> do
case oldFocusState of
Selected -> Tardis.sendFuture ( Just ClickedOnSelected )
_ -> Tardis.sendFuture ( Just ClickedOnUnselected )
-- Select this point (whether it was previously selected or not).
pure $ pt { pointState = Selected }
| otherwise
= do
mbDragClick <- Tardis.getFuture
@ -163,8 +163,10 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
-- needs to be lazy
newPointState :: FocusState
newPointState
-- User clicked on a selected point: preserve selection.
| Just ClickedOnSelected <- mbDragClick
= pointState pt
-- User clicked on an unselected point, or not on a point at all: discard selection.
| otherwise
= Normal
pure ( pt { pointState = newPointState } )
@ -212,3 +214,7 @@ translateSelection t = over ( field' @"strokes" ) ( fmap updateStroke )
= pt { strokePoint = t • p }
| otherwise
= pt
-- | Delete the selected points
deleteSelected :: Document -> Document
deleteSelected doc = doc -- TODO

316
src/app/MetaBrush/Event.hs
View file

@ -7,15 +7,17 @@
module MetaBrush.Event
( handleEvents
, HoldEvent(..)
, HoldEvent(..), PartialPath(..)
)
where
-- base
import Control.Monad
( unless )
( unless, guard )
import Data.Foldable
( for_ )
import Data.Maybe
( catMaybes )
import Data.Word
( Word32 )
@ -32,6 +34,10 @@ import Data.IntMap.Strict
( IntMap )
import qualified Data.IntMap.Strict as IntMap
( insert, lookup )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
-- gi-gdk
import qualified GI.Gdk as GDK
@ -51,16 +57,20 @@ import Math.Module
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..) )
( Document(..), StrokePoint(..), PointType(..), FocusState(..) )
import MetaBrush.Document.Draw
( DrawAnchor(..), getDrawAnchor, addToAnchor, anchorsAreComplementary )
import MetaBrush.Document.Selection
( SelectionMode(..), selectionMode
, selectAt, selectRectangle
, dragMoveSelect, translateSelection
, deleteSelected
)
import MetaBrush.Event.KeyCodes
( pattern Escape
( pattern Escape, pattern Return, pattern Delete
, pattern Control_L, pattern Control_R
, pattern Shift_L , pattern Shift_R
, pattern F1
)
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
@ -68,19 +78,23 @@ import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar )
import MetaBrush.UI.ToolBar
( Tool(..), Mode )
import MetaBrush.Unique
( UniqueSupply )
--------------------------------------------------------------------------------
handleEvents
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
:: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.Window -> GTK.DrawingArea -> InfoBar
-> IO ()
handleEvents
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar _modeTVar
toolTVar _modeTVar partialPathTVar
window viewportDrawingArea infoBar = do
-- Mouse events
@ -89,12 +103,12 @@ handleEvents
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
( handleMouseButtonEvent uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea )
( handleMouseButtonRelease uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea )
-- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
-- Window quit
@ -105,10 +119,22 @@ handleEvents
-- | Keep track of a mouse hold event:
--
-- - start a rectangular selection,
-- - move objects by dragging.
-- - move objects by dragging,
-- - drawing a control point.
data HoldEvent
= SelectionHold { holdStartPos :: !( Point2D Double ) }
| DragMoveHold { holdStartPos :: !( Point2D Double ) }
| DrawHold { holdStartPos :: !( Point2D Double ) }
deriving stock Show
-- | Keep track of a path that is in the middle of being drawn.
data PartialPath
= PartialPath
{ partialStartPos :: !( Point2D Double )
, partialControlPoint :: !( Maybe ( Point2D Double ) )
, partialPathAnchor :: !DrawAnchor
, firstPoint :: !Bool
}
deriving stock Show
--------------------------------------------------------------------------------
@ -249,21 +275,26 @@ handleScrollEvent
pure False
handleMouseButtonEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
:: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
handleMouseButtonEvent
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar partialPathTVar
viewportDrawingArea
mouseClickEvent
= do
button <- GDK.getEventButtonButton mouseClickEvent
case button of
-- left mouse button
-- Left mouse button.
1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
@ -278,55 +309,90 @@ handleMouseButtonEvent
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
pressedKeys <- STM.readTVar pressedKeysTVar
let
mode :: SelectionMode
mode = selectionMode pressedKeys
case mode of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just newDoc <- dragMoveSelect pos doc
-> do
let
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
-- Rectangular selection.
_ ->
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
tool <- STM.readTVar toolTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode pressedKeys of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just newDoc <- dragMoveSelect pos doc
-> do
let
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
-- Rectangular selection.
_ ->
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
-- Pen tool: start or continue a drawing operation.
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do
( newDoc, drawAnchor, anchorPt ) <- getDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar
( Just $ PartialPath
{ partialStartPos = anchorPt
, partialControlPoint = Nothing
, partialPathAnchor = drawAnchor
, firstPoint = True
}
)
let
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
-- Path already started: indicate that we are continuing a path.
Just pp ->
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
GTK.widgetQueueDraw viewportDrawingArea
-- Right mouse button: end partial path.
3 -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
pure False
handleMouseButtonRelease
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
:: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool
-> STM.TVar Tool -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea
-> GDK.EventButton
-> IO Bool
handleMouseButtonRelease
uniqueSupply
activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar
toolTVar partialPathTVar
viewportDrawingArea
mouseReleaseEvent
= do
button <- GDK.getEventButtonButton mouseReleaseEvent
case button of
-- left mouse button
-- Left mouse button.
1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
@ -342,30 +408,111 @@ handleMouseButtonRelease
pos :: Point2D Double
pos = toViewport ( Point2D x y )
STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
pressedKeys <- STM.readTVar pressedKeysTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
tool <- STM.readTVar toolTVar
newDoc <- case tool of
Selection -> do
let
mode :: SelectionMode
mode = selectionMode pressedKeys
case mbHoldPos of
Just hold
| DragMoveHold pos0 <- hold
, pos0 /= pos
-> pure $ translateSelection ( pos0 --> pos ) doc
| SelectionHold pos0 <- hold
, pos0 /= pos
-> pure $ selectRectangle mode pos0 pos doc
_ -> pure $ selectAt mode pos doc
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor.
-- If no anchor exists, then just ignore the mouse release event.
Nothing -> pure doc
-- Mouse click release possibilities:
--
-- - click was on complementary draw stroke draw anchor to close the path,
-- - release at same point as click: finish current segment,
-- - release at different point as click: finish current segment, adding a control point.
Just
( PartialPath
{ partialStartPos = p1
, partialControlPoint = mbCp2
, partialPathAnchor = anchor
, firstPoint
}
) -> do
let
pathPoint :: Point2D Double
mbControlPoint :: Maybe ( Point2D Double )
partialControlPoint :: Maybe ( Point2D Double )
( pathPoint, mbControlPoint, partialControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldPos
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
| otherwise
= ( pos, Nothing, Nothing )
( _, otherAnchor, otherAnchorPt ) <- getDrawAnchor uniqueSupply pathPoint doc
if not firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path.
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Seq StrokePoint
newSegment
= Seq.fromList
$ catMaybes
[ Just ( StrokePoint p1 PathPoint Normal )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ StrokePoint cp ControlPoint Normal
, do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure $ StrokePoint cp ControlPoint Normal
, Just ( StrokePoint otherAnchorPt PathPoint Normal )
]
pure ( addToAnchor anchor newSegment doc )
else
if firstPoint
-- Continue current partial path.
then do
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
pure doc
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Seq StrokePoint
newSegment
= Seq.fromList
$ catMaybes
[ Just ( StrokePoint p1 PathPoint Normal )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ StrokePoint cp ControlPoint Normal
, do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure $ StrokePoint cp ControlPoint Normal
, Just ( StrokePoint pathPoint PathPoint Normal )
]
pure ( addToAnchor anchor newSegment doc )
let
mode :: SelectionMode
mode = selectionMode pressedKeys
newDoc :: Document
newDoc = case tool of
Selection
| Just ( SelectionHold pos0 ) <- mbHoldPos
, pos0 /= pos
-> selectRectangle mode pos0 pos doc
| Just ( DragMoveHold pos0 ) <- mbHoldPos
-> translateSelection ( pos0 --> pos ) doc
| otherwise
-> selectAt mode pos doc
Pen -> doc -- TODO
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mousePosTVar ( Just pos )
GTK.widgetQueueDraw viewportDrawingArea
-- any other mouse button: no action (for the moment)
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
pure False
@ -373,15 +520,60 @@ handleMouseButtonRelease
--------------------------------------------------------------------------------
-- Keyboard events.
handleKeyboardPressEvent, handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
handleKeyboardPressEvent pressedKeysTVar evt = do
keyCode <- GDK.getEventKeyKeyval evt
case keyCode of
Escape -> GTK.mainQuit
_ -> STM.atomically do
handleKeyboardPressEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea
-> GDK.EventKey
-> IO Bool
handleKeyboardPressEvent
activeDocumentTVar openDocumentsTVar
pressedKeysTVar
toolTVar partialPathTVar
viewportDrawingArea
evt = do
keyCode <- GDK.getEventKeyKeyval evt
STM.atomically do
pressedKeys <- STM.readTVar pressedKeysTVar
STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
pure True
case keyCode of
Escape -> GTK.mainQuit
Return -> do
tool <- STM.atomically $ STM.readTVar toolTVar
case tool of
-- End ongoing drawing on pressing enter key.
Pen -> do
STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
Delete -> do
tool <- STM.atomically $ STM.readTVar toolTVar
case tool of
-- Delete selected points on pressing 'Delete'.
Selection -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc -> do
let
newDoc :: Document
newDoc = deleteSelected doc
newDocs :: IntMap Document
newDocs = IntMap.insert i newDoc docs
STM.atomically $ STM.writeTVar openDocumentsTVar newDocs
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure ()
F1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc -> do
writeFile "log.txt" ( show doc <> "\n\n" )
_ -> pure ()
pure True
handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
handleKeyboardReleaseEvent pressedKeysTVar evt = do
keyCode <- GDK.getEventKeyKeyval evt
STM.atomically do

24
src/app/MetaBrush/Event/KeyCodes.hs
View file

@ -49,3 +49,27 @@ pattern Alt_L :: Word32
pattern Alt_L = 0xffe9
pattern Alt_R :: Word32
pattern Alt_R = 0xffea
pattern F1 :: Word32
pattern F1 = 0xffbe
pattern F2 :: Word32
pattern F2 = 0xffbf
pattern F3 :: Word32
pattern F3 = 0xffc0
pattern F4 :: Word32
pattern F4 = 0xffc1
pattern F5 :: Word32
pattern F5 = 0xffc2
pattern F6 :: Word32
pattern F6 = 0xffc3
pattern F7 :: Word32
pattern F7 = 0xffc4
pattern F8 :: Word32
pattern F8 = 0xffc5
pattern F9 :: Word32
pattern F9 = 0xffc6
pattern F10 :: Word32
pattern F10 = 0xffc7
pattern F11 :: Word32
pattern F11 = 0xffc8
pattern F12 :: Word32
pattern F12 = 0xffc9

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

@ -10,16 +10,30 @@ module MetaBrush.Render.Document
where
-- base
import Control.Monad
( guard )
import Data.Foldable
( traverse_ )
import Data.Functor.Compose
( Compose(..) )
import Data.Int
( Int32 )
import Data.Maybe
( catMaybes )
-- acts
import Data.Act
( Torsor((-->)) )
( Act
( (•) )
, Torsor
( (-->) )
)
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
@ -30,7 +44,7 @@ import qualified Math.Bezier.Cubic as Cubic
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) )
import Math.Vector2D
( Point2D(..) )
( Point2D(..), Vector2D(..) )
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Document
@ -40,7 +54,7 @@ import MetaBrush.Document
import MetaBrush.Document.Selection
( translateSelection )
import MetaBrush.Event
( HoldEvent(..) )
( HoldEvent(..), PartialPath(..) )
import MetaBrush.Render.Util
( withRGBA )
@ -63,8 +77,14 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
--------------------------------------------------------------------------------
renderDocument :: Colours -> ( Int32, Int32 ) -> Maybe ( HoldEvent, Point2D Double ) -> Document -> Cairo.Render ()
renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
renderDocument
:: Colours -> ( Int32, Int32 )
-> Maybe ( Point2D Double ) -> Maybe HoldEvent -> Maybe PartialPath
-> Document
-> Cairo.Render ()
renderDocument
cols ( viewportWidth, viewportHeight )
mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
= do
@ -74,17 +94,49 @@ renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
Cairo.translate ( -cx ) ( -cy )
let
translatedStrokes :: [ Stroke ]
renderSelectionRect :: Cairo.Render ()
( translatedStrokes, renderSelectionRect )
= case mbHoldEvent of
Nothing
-> ( strokes doc, pure () )
Just ( SelectionHold p0, p1 )
-> ( strokes doc, renderSelectionRectangle cols zoomFactor p0 p1 )
Just ( DragMoveHold p0, p1 )
-> ( strokes $ translateSelection ( p0 --> p1 ) doc, pure () )
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) translatedStrokes
renderSelectionRect
| Just ( SelectionHold p0 ) <- mbHoldEvent
, Just p1 <- mbMousePos
= renderSelectionRectangle cols zoomFactor p0 p1
| otherwise
= pure ()
modifiedStrokes :: [ Stroke ]
modifiedStrokes
| Just ( DragMoveHold p0 ) <- mbHoldEvent
, Just p1 <- mbMousePos
= strokes $ translateSelection ( p0 --> p1 ) doc
| Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
, let
mbFinalPoint :: Maybe ( Point2D Double )
mbControlPoint :: Maybe ( Point2D Double )
( mbFinalPoint, mbControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldEvent
= ( Just holdPos, ( \ cp -> ( cp --> holdPos :: Vector2D Double ) • holdPos ) <$> mbMousePos )
| otherwise
= ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint
, let
previewPts :: Seq StrokePoint
previewPts
= Seq.fromList
$ catMaybes
[ Just ( StrokePoint p0 PathPoint Normal )
, do
cp <- cp0
guard ( cp /= p0 )
pure $ StrokePoint cp ControlPoint Normal
, do
cp <- mbControlPoint
guard ( cp /= finalPoint )
pure $ StrokePoint cp ControlPoint Normal
, Just ( StrokePoint finalPoint PathPoint Normal )
]
= ( Stroke previewPts undefined True undefined ) : strokes doc
| otherwise
= strokes doc
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) modifiedStrokes
rdrPaths
rdrPoints
renderSelectionRect
@ -94,13 +146,13 @@ renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
pure ()
renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render ()
renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } )
renderStroke cols zoom ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } )
= go pt0 pts *> Renders { renderPoints = drawPoint cols zoom pt0, renderPaths = pure () }
where
go :: StrokePoint -> [ StrokePoint ] -> Compose Renders Cairo.Render ()
go _ [] = pure ()
go :: StrokePoint -> Seq StrokePoint -> Compose Renders Cairo.Render ()
go _ Empty = pure ()
-- Line.
go p0 ( p1 : ps )
go p0 ( p1 :<| ps )
| PathPoint <- pointType p1
= Renders
{ renderPoints = drawPoint cols zoom p1
@ -108,7 +160,7 @@ renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible =
}
*> go p1 ps
-- Quadratic Bézier curve.
go p0 ( p1 : p2 : ps )
go p0 ( p1 :<| p2 :<| ps )
| ControlPoint <- pointType p1
, PathPoint <- pointType p2
= Renders
@ -117,11 +169,11 @@ renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible =
*> drawLine cols zoom p1 p2
*> drawPoint cols zoom p1
*> drawPoint cols zoom p2
, renderPaths = drawQuadraticBezier cols zoom ( fmap strokePoint $ Quadratic.Bezier { p0, p1, p2 } )
, renderPaths = drawQuadraticBezier cols zoom ( strokePoint <$> Quadratic.Bezier { p0, p1, p2 } )
}
*> go p2 ps
-- Cubic Bézier curve.
go p0 ( p1 : p2 : p3 : ps )
go p0 ( p1 :<| p2 :<| p3 :<| ps )
| ControlPoint <- pointType p1
, ControlPoint <- pointType p1
, PathPoint <- pointType p3
@ -132,10 +184,10 @@ renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible =
*> drawPoint cols zoom p1
*> drawPoint cols zoom p2
*> drawPoint cols zoom p3
, renderPaths = drawCubicBezier cols zoom ( fmap strokePoint $ Cubic.Bezier { p0, p1, p2, p3 } )
, renderPaths = drawCubicBezier cols zoom ( strokePoint <$> Cubic.Bezier { p0, p1, p2, p3 } )
}
*> go p2 ps
go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 : ps )
*> go p3 ps
go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
renderStroke _ _ _ = pure ()
drawPoint :: Colours -> Double -> StrokePoint -> Cairo.Render ()

4
src/app/MetaBrush/Time.hs
View file

@ -60,8 +60,8 @@ pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute
| secs <= (-1) = "-"
| otherwise = ""
h, r, m, s :: Int64
(h,r) = ( round $ abs secs ) `divMod` 3600
(m,s) = r `divMod` 60
(h,r) = round ( abs secs ) `divMod` 3600
(m,s) = r `divMod` 60
fixed2 :: String -> String
fixed2 [] = "00"
fixed2 [x] = ['0', x]

22
src/app/MetaBrush/UI/Coordinates.hs
View file

@ -17,6 +17,10 @@ import Data.Act
( (-->) )
)
-- containers
import Data.Sequence
( Seq(..) )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint )
@ -39,31 +43,31 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
-- | Find the closest point in a set of strokes.
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
closestPoint c ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } ) = go pt0 pts
closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) = go pt0 pts
where
res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
go :: StrokePoint -> [ StrokePoint ] -> ArgMin Double ( Maybe ( Point2D Double ) )
go p0 [] = res ( strokePoint p0 )
go :: StrokePoint -> Seq StrokePoint -> ArgMin Double ( Maybe ( Point2D Double ) )
go p0 Empty = res ( strokePoint p0 )
-- Line.
go p0 ( p1 : ps )
go p0 ( p1 :<| ps )
| PathPoint <- pointType p1
= res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) )
<> go p1 ps
-- Quadratic Bézier curve.
go p0 ( p1 : p2 : ps )
go p0 ( p1 :<| p2 :<| ps )
| ControlPoint <- pointType p1
, PathPoint <- pointType p2
= fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Quadratic.Bezier { .. } ) c )
( Quadratic.closestPoint @( Vector2D Double ) ( strokePoint <$> Quadratic.Bezier { .. } ) c )
<> go p2 ps
-- Cubic Bézier curve.
go p0 ( p1 : p2 : p3 : ps )
go p0 ( p1 :<| p2 :<| p3 :<| ps )
| ControlPoint <- pointType p1
, ControlPoint <- pointType p1
, PathPoint <- pointType p3
= fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Cubic.Bezier { .. } ) c )
( Cubic.closestPoint @( Vector2D Double ) ( strokePoint <$> Cubic.Bezier { .. } ) c )
<> go p3 ps
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 : ps )
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps )
closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing

1
src/app/MetaBrush/UI/FileBar.hs
View file

@ -1,7 +1,6 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

1
src/app/MetaBrush/UI/InfoBar.hs
View file

@ -4,7 +4,6 @@
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.InfoBar
( InfoBar(..), createInfoBar, updateInfoBar

47
src/app/MetaBrush/Unique.hs Normal file
View file

@ -0,0 +1,47 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Unique
( Unique
, freshUnique, uniqueText
, UniqueSupply, newUniqueSupply
)
where
-- base
import Data.Word
( Word64 )
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, newTVarIO, readTVar, writeTVar )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( pack )
--------------------------------------------------------------------------------
newtype Unique = Unique { unique :: Word64 }
deriving stock Show
deriving newtype ( Eq, Ord )
uniqueText :: Unique -> Text
uniqueText ( Unique i ) = "%" <> Text.pack ( show i )
newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique }
freshUnique :: UniqueSupply -> STM Unique
freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do
uniq@( Unique i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
pure uniq
newUniqueSupply :: IO UniqueSupply
newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 )

2
src/lib/Math/RealRoots.hs
View file

@ -63,7 +63,7 @@ laguerre
-> [ Complex a ] -- ^ polynomial
-> Complex a -- ^ initial point
-> Complex a
laguerre eps maxIters p x0 = go maxIters x0
laguerre eps maxIters p = go maxIters
where
p', p'' :: [ Complex a ]
p' = derivative p