hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 23:03:38 +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.Tools
, MetaBrush.Asset.WindowIcons , MetaBrush.Asset.WindowIcons
, MetaBrush.Document , MetaBrush.Document
, MetaBrush.Document.Draw
, MetaBrush.Document.Selection , MetaBrush.Document.Selection
, MetaBrush.Event , MetaBrush.Event
, MetaBrush.Event.KeyCodes , MetaBrush.Event.KeyCodes
@ -105,6 +106,7 @@ executable MetaBrush
, MetaBrush.UI.Panels , MetaBrush.UI.Panels
, MetaBrush.UI.ToolBar , MetaBrush.UI.ToolBar
, MetaBrush.UI.Viewport , MetaBrush.UI.Viewport
, MetaBrush.Unique
, Paths_MetaBrush , Paths_MetaBrush
autogen-modules: autogen-modules:
@ -143,3 +145,5 @@ executable MetaBrush
^>= 0.4.1.0 ^>= 0.4.1.0
, text , text
^>= 1.2.3.1 && < 1.2.5 ^>= 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 BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Main module Main
@ -60,11 +56,12 @@ import MetaBrush.Asset.Logo
( drawLogo ) ( drawLogo )
import MetaBrush.Document import MetaBrush.Document
( Document(..), AABB(..) ( Document(..), AABB(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, currentDocument , currentDocument
) )
import MetaBrush.Event import MetaBrush.Event
( HoldEvent, handleEvents ) ( HoldEvent, PartialPath
, handleEvents
)
import MetaBrush.Render.Document import MetaBrush.Render.Document
( renderDocument ) ( renderDocument )
import MetaBrush.Render.Util import MetaBrush.Render.Util
@ -81,6 +78,8 @@ import MetaBrush.UI.ToolBar
( Tool(..), Mode(..), createToolBar ) ( Tool(..), Mode(..), createToolBar )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), createViewport ) ( Viewport(..), createViewport )
import MetaBrush.Unique
( newUniqueSupply )
import qualified Paths_MetaBrush as Cabal import qualified Paths_MetaBrush as Cabal
( getDataFileName ) ( getDataFileName )
@ -93,29 +92,7 @@ testDocuments = IntMap.fromList
{ displayName = "Document 1" { displayName = "Document 1"
, filePath = Nothing , filePath = Nothing
, unsavedChanges = False , unsavedChanges = False
, strokes = [ Stroke , strokes = [ ]
[ 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
]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
, viewportCenter = Point2D 50 50 , viewportCenter = Point2D 50 50
, zoomFactor = 1 , zoomFactor = 1
@ -124,14 +101,7 @@ testDocuments = IntMap.fromList
{ displayName = "Document 2" { displayName = "Document 2"
, filePath = Nothing , filePath = Nothing
, unsavedChanges = True , unsavedChanges = True
, strokes = [ Stroke , strokes = [ ]
[ StrokePoint ( Point2D 0 0 ) PathPoint Normal
, StrokePoint ( Point2D 10 10 ) ControlPoint Normal
, StrokePoint ( Point2D 20 20 ) PathPoint Normal
]
"Stroke1"
True
]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) , bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
, viewportCenter = Point2D 10 10 , viewportCenter = Point2D 10 10
, zoomFactor = 0.25 , zoomFactor = 0.25
@ -146,6 +116,7 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- Initialise state -- Initialise state
uniqueSupply <- newUniqueSupply
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
@ -153,6 +124,7 @@ main = do
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] [] pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
toolTVar <- STM.newTVarIO @Tool Selection toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path modeTVar <- STM.newTVarIO @Mode Path
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
--------------------------------------------------------- ---------------------------------------------------------
-- Initialise GTK -- Initialise GTK
@ -275,15 +247,16 @@ main = do
-- Get the relevant document information -- Get the relevant document information
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
for_ mbDoc \ doc -> do for_ mbDoc \ doc -> do
mousePos <- STM.readTVarIO mousePosTVar mbMousePos <- STM.readTVarIO mousePosTVar
holdEvent <- STM.readTVarIO mouseHoldTVar mbHoldEvent <- STM.readTVarIO mouseHoldTVar
let mbPartialPath <- STM.readTVarIO partialPathTVar
mbHoldEvent :: Maybe ( HoldEvent, Point2D Double )
mbHoldEvent = (,) <$> holdEvent <*> mousePos
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
( `Cairo.renderWithContext` ctx ) $ ( `Cairo.renderWithContext` ctx ) $
renderDocument colours ( viewportWidth, viewportHeight ) mbHoldEvent doc renderDocument
colours ( viewportWidth, viewportHeight )
mbMousePos mbHoldEvent mbPartialPath
doc
pure True pure True
--------------------------------------------------------- ---------------------------------------------------------
@ -313,9 +286,10 @@ main = do
-- Actions -- Actions
handleEvents handleEvents
uniqueSupply
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar toolTVar modeTVar partialPathTVar
window viewportDrawingArea infoBarElements window viewportDrawingArea infoBarElements
--------------------------------------------------------- ---------------------------------------------------------

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

@ -7,7 +7,7 @@ module MetaBrush.Document
( AABB(..) ( AABB(..)
, Document(..), currentDocument , Document(..), currentDocument
, Stroke(..), StrokePoint(..), PointType(..) , Stroke(..), StrokePoint(..), PointType(..)
, FocusState(..), switchFocusState , FocusState(..)
) )
where where
@ -16,6 +16,8 @@ import Data.IntMap.Strict
( IntMap ) ( IntMap )
import qualified Data.IntMap.Strict as IntMap import qualified Data.IntMap.Strict as IntMap
( lookup ) ( lookup )
import Data.Sequence
( Seq )
import GHC.Generics import GHC.Generics
( Generic ) ( Generic )
@ -32,6 +34,8 @@ import qualified Control.Concurrent.STM.TVar as STM
-- MetaBrush -- MetaBrush
import Math.Vector2D import Math.Vector2D
( Point2D ) ( Point2D )
import MetaBrush.Unique
( Unique )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -56,9 +60,10 @@ data Document
data Stroke data Stroke
= Stroke = Stroke
{ strokePoints :: ![ StrokePoint ] { strokePoints :: !( Seq StrokePoint )
, strokeName :: !Text , strokeName :: Text
, strokeVisible :: !Bool , strokeVisible :: !Bool
, strokeUnique :: Unique
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
@ -81,11 +86,6 @@ data FocusState
| Selected | Selected
deriving stock Show 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 :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar 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 LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Selection module MetaBrush.Document.Selection
@ -14,10 +12,13 @@ module MetaBrush.Document.Selection
, selectAt, selectRectangle , selectAt, selectRectangle
, DragMoveSelect(..), dragMoveSelect , DragMoveSelect(..), dragMoveSelect
, translateSelection , translateSelection
, deleteSelected
) )
where where
-- base -- base
import Data.Functor
( ($>) )
import Data.Functor.Identity import Data.Functor.Identity
( runIdentity ) ( runIdentity )
import Data.Word import Data.Word
@ -38,9 +39,13 @@ import Control.Monad.Trans.Tardis
( Tardis ) ( Tardis )
import qualified Control.Monad.Trans.Tardis as Tardis import qualified Control.Monad.Trans.Tardis as Tardis
( TardisT(..) ( TardisT(..)
, getPast, getFuture, sendPast, modifyForwards , getPast, getFuture, sendPast, sendFuture
) )
-- transformers
import Control.Monad.Trans.State.Strict
( State, evalState, get, put )
-- MetaBrush -- MetaBrush
import Math.Module import Math.Module
( squaredNorm ) ( squaredNorm )
@ -48,7 +53,7 @@ import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), Stroke(..), StrokePoint(..) ( Document(..), Stroke(..), StrokePoint(..)
, FocusState(..), switchFocusState , FocusState(..)
) )
import MetaBrush.Event.KeyCodes import MetaBrush.Event.KeyCodes
( pattern Alt_L , pattern Alt_R ( pattern Alt_L , pattern Alt_R
@ -82,25 +87,23 @@ selectionMode = foldMap \case
_ -> New _ -> New
-- | Updates the selected objects on a single click selection event. -- | 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 :: SelectionMode -> Point2D Double -> Document -> Document
selectAt mode c doc@( Document { zoomFactor } ) = selectAt mode c doc@( Document { zoomFactor } ) =
over ( field' @"strokes" ) ( fmap updateStroke ) doc ( `evalState` False ) $ field' @"strokes" ( traverse updateStroke ) doc
where where
updateStroke :: Stroke -> Stroke updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } ) = updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" ) field' @"strokePoints"
( fmap ( updatePoint strokeVisible ) ) ( traverse ( updatePoint strokeVisible ) )
stroke stroke
updatePoint :: Bool -> StrokePoint -> StrokePoint updatePoint :: Bool -> StrokePoint -> State Bool StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } ) updatePoint isVisible pt@( StrokePoint { strokePoint = p } ) = do
| selected = case mode of anotherPointHasAlreadyBeenSelected <- get
New -> pt { pointState = switchFocusState oldFocusState } if selected && not anotherPointHasAlreadyBeenSelected
Add -> pt { pointState = Selected } then put True $> case mode of
Subtract -> pt { pointState = Normal } Subtract -> pt { pointState = Normal }
| otherwise = case mode of _ -> pt { pointState = Selected }
else pure $ case mode of
New -> pt { pointState = Normal } New -> pt { pointState = Normal }
_ -> pt _ -> pt
where where
@ -118,16 +121,6 @@ data DragMoveSelect
| ClickedOnUnselected | ClickedOnUnselected
deriving stock Show 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, -- | 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. -- and if so returns an updated document with the selection modified from the start of the drag move.
dragMoveSelect :: Point2D Double -> Document -> Maybe Document dragMoveSelect :: Point2D Double -> Document -> Maybe Document
@ -152,10 +145,17 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } ) updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
| selected | selected
= do = do
case oldFocusState of mbPreviousSelect <- Tardis.getPast
Selected -> Tardis.modifyForwards ( const $ Just ClickedOnSelected ) case mbPreviousSelect of
_ -> Tardis.modifyForwards ( <> Just ClickedOnUnselected ) -- Already clicked on a point: don't select further points.
pure $ pt { pointState = Selected } 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 | otherwise
= do = do
mbDragClick <- Tardis.getFuture mbDragClick <- Tardis.getFuture
@ -163,8 +163,10 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
-- needs to be lazy -- needs to be lazy
newPointState :: FocusState newPointState :: FocusState
newPointState newPointState
-- User clicked on a selected point: preserve selection.
| Just ClickedOnSelected <- mbDragClick | Just ClickedOnSelected <- mbDragClick
= pointState pt = pointState pt
-- User clicked on an unselected point, or not on a point at all: discard selection.
| otherwise | otherwise
= Normal = Normal
pure ( pt { pointState = newPointState } ) pure ( pt { pointState = newPointState } )
@ -212,3 +214,7 @@ translateSelection t = over ( field' @"strokes" ) ( fmap updateStroke )
= pt { strokePoint = t • p } = pt { strokePoint = t • p }
| otherwise | otherwise
= pt = pt
-- | Delete the selected points
deleteSelected :: Document -> Document
deleteSelected doc = doc -- TODO

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

@ -7,15 +7,17 @@
module MetaBrush.Event module MetaBrush.Event
( handleEvents ( handleEvents
, HoldEvent(..) , HoldEvent(..), PartialPath(..)
) )
where where
-- base -- base
import Control.Monad import Control.Monad
( unless ) ( unless, guard )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import Data.Maybe
( catMaybes )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
@ -32,6 +34,10 @@ import Data.IntMap.Strict
( IntMap ) ( IntMap )
import qualified Data.IntMap.Strict as IntMap import qualified Data.IntMap.Strict as IntMap
( insert, lookup ) ( insert, lookup )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
-- gi-gdk -- gi-gdk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
@ -51,16 +57,20 @@ import Math.Module
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..) ) ( Document(..), StrokePoint(..), PointType(..), FocusState(..) )
import MetaBrush.Document.Draw
( DrawAnchor(..), getDrawAnchor, addToAnchor, anchorsAreComplementary )
import MetaBrush.Document.Selection import MetaBrush.Document.Selection
( SelectionMode(..), selectionMode ( SelectionMode(..), selectionMode
, selectAt, selectRectangle , selectAt, selectRectangle
, dragMoveSelect, translateSelection , dragMoveSelect, translateSelection
, deleteSelected
) )
import MetaBrush.Event.KeyCodes import MetaBrush.Event.KeyCodes
( pattern Escape ( pattern Escape, pattern Return, pattern Delete
, pattern Control_L, pattern Control_R , pattern Control_L, pattern Control_R
, pattern Shift_L , pattern Shift_R , pattern Shift_L , pattern Shift_R
, pattern F1
) )
import MetaBrush.UI.Coordinates import MetaBrush.UI.Coordinates
( toViewportCoordinates ) ( toViewportCoordinates )
@ -68,19 +78,23 @@ import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar ) ( InfoBar, InfoData(..), updateInfoBar )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Tool(..), Mode ) ( Tool(..), Mode )
import MetaBrush.Unique
( UniqueSupply )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
handleEvents 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 ( 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 -> GTK.Window -> GTK.DrawingArea -> InfoBar
-> IO () -> IO ()
handleEvents handleEvents
uniqueSupply
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar _modeTVar toolTVar _modeTVar partialPathTVar
window viewportDrawingArea infoBar = do window viewportDrawingArea infoBar = do
-- Mouse events -- Mouse events
@ -89,12 +103,12 @@ handleEvents
_ <- GTK.onWidgetScrollEvent viewportDrawingArea _ <- GTK.onWidgetScrollEvent viewportDrawingArea
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar ) ( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea _ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea ) ( handleMouseButtonEvent uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar viewportDrawingArea ) ( handleMouseButtonRelease uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea )
-- Keyboard events -- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar ) _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar toolTVar partialPathTVar viewportDrawingArea )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
-- Window quit -- Window quit
@ -105,10 +119,22 @@ handleEvents
-- | Keep track of a mouse hold event: -- | Keep track of a mouse hold event:
-- --
-- - start a rectangular selection, -- - start a rectangular selection,
-- - move objects by dragging. -- - move objects by dragging,
-- - drawing a control point.
data HoldEvent data HoldEvent
= SelectionHold { holdStartPos :: !( Point2D Double ) } = SelectionHold { holdStartPos :: !( Point2D Double ) }
| DragMoveHold { 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 deriving stock Show
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -249,21 +275,26 @@ handleScrollEvent
pure False pure False
handleMouseButtonEvent 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 ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
-> GDK.EventButton -> GDK.EventButton
-> IO Bool -> IO Bool
handleMouseButtonEvent handleMouseButtonEvent
uniqueSupply
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar partialPathTVar
viewportDrawingArea viewportDrawingArea
mouseClickEvent mouseClickEvent
= do = do
button <- GDK.getEventButtonButton mouseClickEvent button <- GDK.getEventButtonButton mouseClickEvent
case button of case button of
-- left mouse button
-- Left mouse button.
1 -> do 1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
@ -278,55 +309,90 @@ handleMouseButtonEvent
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double pos :: Point2D Double
pos = toViewport ( Point2D x y ) 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.atomically do
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
pressedKeys <- STM.readTVar pressedKeysTVar pressedKeys <- STM.readTVar pressedKeysTVar
let tool <- STM.readTVar toolTVar
mode :: SelectionMode case tool of
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 )
-- 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 ()
pure False pure False
handleMouseButtonRelease 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 ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Tool -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
-> GDK.EventButton -> GDK.EventButton
-> IO Bool -> IO Bool
handleMouseButtonRelease handleMouseButtonRelease
uniqueSupply
activeDocumentTVar openDocumentsTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar toolTVar partialPathTVar
viewportDrawingArea viewportDrawingArea
mouseReleaseEvent mouseReleaseEvent
= do = do
button <- GDK.getEventButtonButton mouseReleaseEvent button <- GDK.getEventButtonButton mouseReleaseEvent
case button of case button of
-- left mouse button
-- Left mouse button.
1 -> do 1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
@ -342,30 +408,111 @@ handleMouseButtonRelease
pos :: Point2D Double pos :: Point2D Double
pos = toViewport ( Point2D x y ) pos = toViewport ( Point2D x y )
STM.atomically do STM.atomically do
STM.writeTVar mousePosTVar ( Just pos )
pressedKeys <- STM.readTVar pressedKeysTVar pressedKeys <- STM.readTVar pressedKeysTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
tool <- STM.readTVar toolTVar 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 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 Document
newDocs = IntMap.insert i newDoc docs newDocs = IntMap.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mousePosTVar ( Just pos )
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
-- any other mouse button: no action (for the moment) -- Other mouse buttons: ignored (for the moment at least).
_ -> pure () _ -> pure ()
pure False pure False
@ -373,15 +520,60 @@ handleMouseButtonRelease
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Keyboard events. -- Keyboard events.
handleKeyboardPressEvent, handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool handleKeyboardPressEvent
handleKeyboardPressEvent pressedKeysTVar evt = do :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
keyCode <- GDK.getEventKeyKeyval evt -> STM.TVar [ Word32 ]
case keyCode of -> STM.TVar Tool -> STM.TVar ( Maybe PartialPath )
Escape -> GTK.mainQuit -> GTK.DrawingArea
_ -> STM.atomically do -> GDK.EventKey
-> IO Bool
handleKeyboardPressEvent
activeDocumentTVar openDocumentsTVar
pressedKeysTVar
toolTVar partialPathTVar
viewportDrawingArea
evt = do
keyCode <- GDK.getEventKeyKeyval evt
STM.atomically do
pressedKeys <- STM.readTVar pressedKeysTVar pressedKeys <- STM.readTVar pressedKeysTVar
STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys ) 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 handleKeyboardReleaseEvent pressedKeysTVar evt = do
keyCode <- GDK.getEventKeyKeyval evt keyCode <- GDK.getEventKeyKeyval evt
STM.atomically do 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_L = 0xffe9
pattern Alt_R :: Word32 pattern Alt_R :: Word32
pattern Alt_R = 0xffea 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 where
-- base -- base
import Control.Monad
( guard )
import Data.Foldable import Data.Foldable
( traverse_ ) ( traverse_ )
import Data.Functor.Compose import Data.Functor.Compose
( Compose(..) ) ( Compose(..) )
import Data.Int import Data.Int
( Int32 ) ( Int32 )
import Data.Maybe
( catMaybes )
-- acts -- acts
import Data.Act import Data.Act
( Torsor((-->)) ) ( Act
( (•) )
, Torsor
( (-->) )
)
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
-- gi-cairo-render -- gi-cairo-render
import qualified GI.Cairo.Render as Cairo 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 import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) ) ( Bezier(..) )
import Math.Vector2D import Math.Vector2D
( Point2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) ) ( Colours, ColourRecord(..) )
import MetaBrush.Document import MetaBrush.Document
@ -40,7 +54,7 @@ import MetaBrush.Document
import MetaBrush.Document.Selection import MetaBrush.Document.Selection
( translateSelection ) ( translateSelection )
import MetaBrush.Event import MetaBrush.Event
( HoldEvent(..) ) ( HoldEvent(..), PartialPath(..) )
import MetaBrush.Render.Util import MetaBrush.Render.Util
( withRGBA ) ( withRGBA )
@ -63,8 +77,14 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
renderDocument :: Colours -> ( Int32, Int32 ) -> Maybe ( HoldEvent, Point2D Double ) -> Document -> Cairo.Render () renderDocument
renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent :: 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 } ) doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
= do = do
@ -74,17 +94,49 @@ renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
Cairo.translate ( -cx ) ( -cy ) Cairo.translate ( -cx ) ( -cy )
let let
translatedStrokes :: [ Stroke ]
renderSelectionRect :: Cairo.Render () renderSelectionRect :: Cairo.Render ()
( translatedStrokes, renderSelectionRect ) renderSelectionRect
= case mbHoldEvent of | Just ( SelectionHold p0 ) <- mbHoldEvent
Nothing , Just p1 <- mbMousePos
-> ( strokes doc, pure () ) = renderSelectionRectangle cols zoomFactor p0 p1
Just ( SelectionHold p0, p1 ) | otherwise
-> ( strokes doc, renderSelectionRectangle cols zoomFactor p0 p1 ) = pure ()
Just ( DragMoveHold p0, p1 )
-> ( strokes $ translateSelection ( p0 --> p1 ) doc, pure () ) modifiedStrokes :: [ Stroke ]
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) translatedStrokes 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 rdrPaths
rdrPoints rdrPoints
renderSelectionRect renderSelectionRect
@ -94,13 +146,13 @@ renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
pure () pure ()
renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render () 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 () } = go pt0 pts *> Renders { renderPoints = drawPoint cols zoom pt0, renderPaths = pure () }
where where
go :: StrokePoint -> [ StrokePoint ] -> Compose Renders Cairo.Render () go :: StrokePoint -> Seq StrokePoint -> Compose Renders Cairo.Render ()
go _ [] = pure () go _ Empty = pure ()
-- Line. -- Line.
go p0 ( p1 : ps ) go p0 ( p1 :<| ps )
| PathPoint <- pointType p1 | PathPoint <- pointType p1
= Renders = Renders
{ renderPoints = drawPoint cols zoom p1 { renderPoints = drawPoint cols zoom p1
@ -108,7 +160,7 @@ renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible =
} }
*> go p1 ps *> go p1 ps
-- Quadratic Bézier curve. -- Quadratic Bézier curve.
go p0 ( p1 : p2 : ps ) go p0 ( p1 :<| p2 :<| ps )
| ControlPoint <- pointType p1 | ControlPoint <- pointType p1
, PathPoint <- pointType p2 , PathPoint <- pointType p2
= Renders = Renders
@ -117,11 +169,11 @@ renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible =
*> drawLine cols zoom p1 p2 *> drawLine cols zoom p1 p2
*> drawPoint cols zoom p1 *> drawPoint cols zoom p1
*> drawPoint cols zoom p2 *> 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 *> go p2 ps
-- Cubic Bézier curve. -- Cubic Bézier curve.
go p0 ( p1 : p2 : p3 : ps ) go p0 ( p1 :<| p2 :<| p3 :<| ps )
| ControlPoint <- pointType p1 | ControlPoint <- pointType p1
, ControlPoint <- pointType p1 , ControlPoint <- pointType p1
, PathPoint <- pointType p3 , PathPoint <- pointType p3
@ -132,10 +184,10 @@ renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible =
*> drawPoint cols zoom p1 *> drawPoint cols zoom p1
*> drawPoint cols zoom p2 *> drawPoint cols zoom p2
*> drawPoint cols zoom p3 *> 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 p3 ps
go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 : ps ) go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
renderStroke _ _ _ = pure () renderStroke _ _ _ = pure ()
drawPoint :: Colours -> Double -> StrokePoint -> Cairo.Render () 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) = "-" | secs <= (-1) = "-"
| otherwise = "" | otherwise = ""
h, r, m, s :: Int64 h, r, m, s :: Int64
(h,r) = ( round $ abs secs ) `divMod` 3600 (h,r) = round ( abs secs ) `divMod` 3600
(m,s) = r `divMod` 60 (m,s) = r `divMod` 60
fixed2 :: String -> String fixed2 :: String -> String
fixed2 [] = "00" fixed2 [] = "00"
fixed2 [x] = ['0', x] 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 -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint ) ( Bezier(..), closestPoint )
@ -39,31 +43,31 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
-- | Find the closest point in a set of strokes. -- | Find the closest point in a set of strokes.
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) ) 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 where
res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) ) res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p ) res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
go :: StrokePoint -> [ StrokePoint ] -> ArgMin Double ( Maybe ( Point2D Double ) ) go :: StrokePoint -> Seq StrokePoint -> ArgMin Double ( Maybe ( Point2D Double ) )
go p0 [] = res ( strokePoint p0 ) go p0 Empty = res ( strokePoint p0 )
-- Line. -- Line.
go p0 ( p1 : ps ) go p0 ( p1 :<| ps )
| PathPoint <- pointType p1 | PathPoint <- pointType p1
= res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) ) = res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) )
<> go p1 ps <> go p1 ps
-- Quadratic Bézier curve. -- Quadratic Bézier curve.
go p0 ( p1 : p2 : ps ) go p0 ( p1 :<| p2 :<| ps )
| ControlPoint <- pointType p1 | ControlPoint <- pointType p1
, PathPoint <- pointType p2 , PathPoint <- pointType p2
= fmap ( fmap ( Just . snd ) ) = fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Quadratic.Bezier { .. } ) c ) ( Quadratic.closestPoint @( Vector2D Double ) ( strokePoint <$> Quadratic.Bezier { .. } ) c )
<> go p2 ps <> go p2 ps
-- Cubic Bézier curve. -- Cubic Bézier curve.
go p0 ( p1 : p2 : p3 : ps ) go p0 ( p1 :<| p2 :<| p3 :<| ps )
| ControlPoint <- pointType p1 | ControlPoint <- pointType p1
, ControlPoint <- pointType p1 , ControlPoint <- pointType p1
, PathPoint <- pointType p3 , PathPoint <- pointType p3
= fmap ( fmap ( Just . snd ) ) = 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 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 closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing

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

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

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

@ -4,7 +4,6 @@
{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.InfoBar module MetaBrush.UI.InfoBar
( InfoBar(..), createInfoBar, updateInfoBar ( 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 ] -- ^ polynomial
-> Complex a -- ^ initial point -> Complex a -- ^ initial point
-> Complex a -> Complex a
laguerre eps maxIters p x0 = go maxIters x0 laguerre eps maxIters p = go maxIters
where where
p', p'' :: [ Complex a ] p', p'' :: [ Complex a ]
p' = derivative p p' = derivative p