implement drawing with the pen tool

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

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
+      , strokes        = [ ]
-                            [ StrokePoint ( Point2D 0 0 ) PathPoint Normal ]
-                            "Stroke1"
-                            False
-                         , Stroke
-                            [ StrokePoint ( Point2D 100 0 )    PathPoint Normal
-                            , StrokePoint ( Point2D 105 0 ) ControlPoint Normal
-                            , StrokePoint ( Point2D 110 0 )    PathPoint Normal
-                            ]
-                            "Stroke2"
-                            True
-                         , Stroke
-                            [ StrokePoint ( Point2D 0 100 ) PathPoint Normal ]
-                            "Stroke3"
-                            True
-                         , Stroke
-                            [ StrokePoint ( Point2D 100 100 )    PathPoint Normal
-                            , StrokePoint ( Point2D 105 105 ) ControlPoint Normal
-                            , StrokePoint ( Point2D 110 100 )    PathPoint Normal
-                            ]
-                            "Stroke4"
-                            True
-                         ]
       , bounds         = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
       , viewportCenter = Point2D 50 50
       , zoomFactor     = 1
@@ -124,14 +101,7 @@ testDocuments = IntMap.fromList
       { displayName    = "Document 2"
       , filePath       = Nothing
       , unsavedChanges = True
-      , strokes        = [ Stroke
+      , strokes        = [ ]
-                            [ StrokePoint ( Point2D 0   0 )    PathPoint Normal
-                            , StrokePoint ( Point2D 10 10 ) ControlPoint Normal
-                            , StrokePoint ( Point2D 20 20 )    PathPoint Normal
-                            ]
-                            "Stroke1"
-                            True
-                         ]
       , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
       , 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
+      mbMousePos    <- STM.readTVarIO mousePosTVar
-      holdEvent <- STM.readTVarIO mouseHoldTVar
+      mbHoldEvent   <- STM.readTVarIO mouseHoldTVar
-      let
+      mbPartialPath <- STM.readTVarIO partialPathTVar
-        mbHoldEvent :: Maybe ( HoldEvent, Point2D Double )
-        mbHoldEvent = (,) <$> holdEvent <*> mousePos
       viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
       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
 
   ---------------------------------------------------------

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 ]
+  { strokePoints  :: !( Seq StrokePoint )
-  , strokeName    :: !Text
+  , 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

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

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" )
+        field' @"strokePoints"
-          ( fmap ( updatePoint strokeVisible ) )
+          ( traverse ( updatePoint strokeVisible ) )
           stroke
-      updatePoint :: Bool -> StrokePoint -> StrokePoint
+      updatePoint :: Bool -> StrokePoint -> State Bool StrokePoint
-      updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
+      updatePoint isVisible pt@( StrokePoint { strokePoint = p } ) = do
-        | selected  = case mode of
+        anotherPointHasAlreadyBeenSelected <- get
-          New      -> pt { pointState = switchFocusState oldFocusState }
+        if selected && not anotherPointHasAlreadyBeenSelected
-          Add      -> pt { pointState = Selected }
+        then put True $> case mode of
           Subtract -> pt { pointState = Normal   }
-        | 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,9 +145,16 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
     updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
       | selected
       = do
+          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.modifyForwards ( const $ Just ClickedOnSelected )
+                Selected -> Tardis.sendFuture ( Just ClickedOnSelected   )
-            _        -> Tardis.modifyForwards ( <> Just ClickedOnUnselected )
+                _        -> Tardis.sendFuture ( Just ClickedOnUnselected )
+              -- Select this point (whether it was previously selected or not).
               pure $ pt { pointState = Selected }
       | otherwise
       = do
@@ -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

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,19 +309,21 @@ handleMouseButtonEvent
               toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
               pos :: Point2D Double
               pos = toViewport ( Point2D x y )
+
+            STM.atomically do
+              STM.writeTVar mousePosTVar  ( Just pos )
+              pressedKeys <- STM.readTVar pressedKeysTVar
+              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.
-            STM.atomically do
+                Selection ->
-              STM.writeTVar mousePosTVar  ( Just pos )
+                  case selectionMode pressedKeys of
-              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
@@ -304,29 +337,62 @@ handleMouseButtonEvent
                     _ ->
                         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
-                newDoc :: Document
+                  case mbHoldPos of
-                newDoc = case tool of
+                    Just hold
-                  Selection
+                      | DragMoveHold  pos0 <- hold
-                    | Just ( SelectionHold pos0 ) <- mbHoldPos
                       , pos0 /= pos
-                    -> selectRectangle mode pos0 pos doc
+                      -> pure $ translateSelection ( pos0 --> pos ) doc
-                    | Just ( DragMoveHold pos0 ) <- mbHoldPos
+                      | SelectionHold pos0 <- hold
-                    -> translateSelection ( pos0 --> pos ) doc
+                      , 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
-                    -> selectAt mode pos doc
+                          = ( pos, Nothing, Nothing )
-                  Pen -> doc -- TODO
+                      ( _, 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
                 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
-handleKeyboardPressEvent pressedKeysTVar evt = do
+  :: 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
-  case keyCode of
+    STM.atomically do
-    Escape -> GTK.mainQuit
-    _      -> STM.atomically do
       pressedKeys <- STM.readTVar pressedKeysTVar
       STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
+    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

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

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
-renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
+  :: Colours -> ( Int32, Int32 )
+  -> Maybe ( Point2D Double ) -> Maybe HoldEvent -> Maybe PartialPath
+  -> Document 
+  -> Cairo.Render ()
+renderDocument
+  cols ( viewportWidth, viewportHeight ) 
+  mbMousePos mbHoldEvent mbPartialPath
   doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
   = do
 
@@ -74,17 +94,49 @@ renderDocument cols ( viewportWidth, viewportHeight ) mbHoldEvent
     Cairo.translate ( -cx ) ( -cy )
   
     let
-      translatedStrokes :: [ Stroke ]
       renderSelectionRect :: Cairo.Render ()
-      ( translatedStrokes, renderSelectionRect )
+      renderSelectionRect
-        = case mbHoldEvent of
+        | Just ( SelectionHold p0 ) <- mbHoldEvent
-            Nothing
+        , Just p1 <- mbMousePos
-              -> ( strokes doc, pure () )
+        = renderSelectionRectangle cols zoomFactor p0 p1
-            Just ( SelectionHold p0, p1 )
+        | otherwise
-              -> ( strokes doc, renderSelectionRectangle cols zoomFactor p0 p1 )
+        = pure ()
-            Just ( DragMoveHold  p0, p1 )
+
-              -> ( strokes $ translateSelection ( p0 --> p1 ) doc, pure () )
+      modifiedStrokes :: [ Stroke ]
-      Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) translatedStrokes
+      modifiedStrokes
+        | Just ( DragMoveHold p0 ) <- mbHoldEvent
+        , Just p1 <- mbMousePos
+        = strokes $ translateSelection ( p0 --> p1 ) doc
+        | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
+        , let
+            mbFinalPoint :: Maybe ( Point2D Double )
+            mbControlPoint :: Maybe ( Point2D Double )
+            ( mbFinalPoint, mbControlPoint )
+              | Just ( DrawHold holdPos ) <- mbHoldEvent
+              = ( Just holdPos, ( \ cp -> ( cp --> holdPos :: Vector2D Double ) • holdPos ) <$> mbMousePos )
+              | otherwise
+              = ( mbMousePos, Nothing )
+        , Just finalPoint <- mbFinalPoint
+        , let
+            previewPts :: Seq StrokePoint
+            previewPts
+              = Seq.fromList
+              $ catMaybes
+              [ Just ( StrokePoint p0 PathPoint Normal )
+              , do
+                  cp <- cp0
+                  guard ( cp /= p0 )
+                  pure $ StrokePoint cp ControlPoint Normal
+              , do
+                  cp <- mbControlPoint
+                  guard ( cp /= finalPoint )
+                  pure $ StrokePoint cp ControlPoint Normal
+              , Just ( StrokePoint finalPoint PathPoint Normal )
+              ]
+        = ( Stroke previewPts undefined True undefined ) : strokes doc
+        | otherwise
+        = strokes doc
+      Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) modifiedStrokes
     rdrPaths
     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 :: StrokePoint -> Seq StrokePoint -> Compose Renders Cairo.Render ()
-    go _  [] = pure ()
+    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 p3 ps
-    go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 : ps )
+    go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
 renderStroke _ _ _ = pure ()
 
 drawPoint :: Colours -> Double -> StrokePoint -> Cairo.Render ()

src/app/MetaBrush/Time.hs

@@ -60,7 +60,7 @@ 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
+    (h,r) = round ( abs secs ) `divMod` 3600
     (m,s) = r                  `divMod` 60
     fixed2 :: String -> String
     fixed2 []  = "00"

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 :: StrokePoint -> Seq StrokePoint -> ArgMin Double ( Maybe ( Point2D Double ) )
-    go p0 [] = res ( strokePoint p0 )
+    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

src/app/MetaBrush/UI/FileBar.hs

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

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

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 )

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