diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 931c4f8..50e0e21 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 7551700..52b00f8 100644 --- a/app/Main.hs +++ b/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 --------------------------------------------------------- diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 0b32900..8f1433a 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs new file mode 100644 index 0000000..b34a99d --- /dev/null +++ b/src/app/MetaBrush/Document/Draw.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index d659ab8..3d1e12c 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index f751af7..041cc1b 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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 diff --git a/src/app/MetaBrush/Event/KeyCodes.hs b/src/app/MetaBrush/Event/KeyCodes.hs index 84fc39c..4d4e4d2 100644 --- a/src/app/MetaBrush/Event/KeyCodes.hs +++ b/src/app/MetaBrush/Event/KeyCodes.hs @@ -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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 224ab7d..029c623 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 () diff --git a/src/app/MetaBrush/Time.hs b/src/app/MetaBrush/Time.hs index 5a87e3f..0467953 100644 --- a/src/app/MetaBrush/Time.hs +++ b/src/app/MetaBrush/Time.hs @@ -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] diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index c64dbab..a764f3c 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -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 diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 19e274c..244e9cd 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 51534c3..6740c04 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -4,7 +4,6 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} module MetaBrush.UI.InfoBar ( InfoBar(..), createInfoBar, updateInfoBar diff --git a/src/app/MetaBrush/Unique.hs b/src/app/MetaBrush/Unique.hs new file mode 100644 index 0000000..c69a78c --- /dev/null +++ b/src/app/MetaBrush/Unique.hs @@ -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 ) diff --git a/src/lib/Math/RealRoots.hs b/src/lib/Math/RealRoots.hs index f638776..5205cbd 100644 --- a/src/lib/Math/RealRoots.hs +++ b/src/lib/Math/RealRoots.hs @@ -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