mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
implement drawing with the pen tool
This commit is contained in:
parent
38c4e9fa6c
commit
596821222f
|
@ -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
62
app/Main.hs
|
@ -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
|
||||
|
||||
---------------------------------------------------------
|
||||
|
|
|
@ -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
142
src/app/MetaBrush/Document/Draw.hs
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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,7 +1,6 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
|
|
@ -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
47
src/app/MetaBrush/Unique.hs
Normal 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 )
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue