start implementing brush mode

MetaBrush.cabal

@@ -32,6 +32,8 @@ common common
           ^>= 0.3.1.0
       , containers
           >= 0.6.0.1 && < 0.6.4
+      , generic-data
+          >= 0.8.0.0 && < 0.8.4.0
       , groups
           ^>= 0.4.1.0
 
@@ -69,9 +71,7 @@ library
       , Math.Vector2D
 
     build-depends:
-        generic-data
+        groups-generic
-          >= 0.8.0.0 && < 0.8.4.0
-      , groups-generic
           ^>= 0.1.0.0
 
 executable MetaBrush

app/Main.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE BlockArguments      #-}
-{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NegativeLiterals    #-}
-{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 
 module Main
   ( main )
@@ -62,7 +64,8 @@ import MetaBrush.Asset.Logo
   ( drawLogo )
 import MetaBrush.Document
   ( Document(..), AABB(..), Stroke(..)
-  , PointData(..), FocusState(..)
+  , FocusState(..)
+  , PointData(..), BrushPointData(..)
   , currentDocument
   )
 import MetaBrush.Event
@@ -99,7 +102,8 @@ testDocuments = IntMap.fromList
       { displayName    = "Document 1"
       , filePath       = Nothing
       , unsavedChanges = False
-      , strokes        = [ Stroke circle "Circle" True ( unsafeUnique 0 ) ]
+      , strokes        = [ Stroke ( circle ( PointData Normal ( razor $ BrushPointData Normal ) ) ) "Circle" True ( unsafeUnique 0 )
+                         ]
       , bounds         = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
       , viewportCenter = Point2D 50 50
       , zoomFactor     = 1
@@ -115,8 +119,8 @@ testDocuments = IntMap.fromList
       }
     ]
 
-circle :: Seq ( StrokePoint PointData )
+circle :: forall a. a -> Seq ( StrokePoint a)
-circle = Seq.fromList
+circle d = Seq.fromList
   [ pp ( Point2D   0    1  )
   , cp ( Point2D   a    1  )
   , cp ( Point2D   1    a  )
@@ -134,9 +138,24 @@ circle = Seq.fromList
   where
     a :: Double
     a = 0.551915024494
-    pp, cp :: Point2D Double -> StrokePoint PointData
+    pp, cp :: Point2D Double -> StrokePoint a
-    pp p =    PathPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty )
+    pp p =    PathPoint ( fmap ( * 100 ) p ) d
-    cp p = ControlPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty )
+    cp p = ControlPoint ( fmap ( * 100 ) p ) d
+
+razor :: forall a. a -> Seq ( StrokePoint a )
+razor d = Seq.fromList
+  [ pp ( Point2D  10  0 )
+  , cp ( Point2D  10 -3 )
+  , cp ( Point2D -10 -3 )
+  , pp ( Point2D -10  0 )
+  , cp ( Point2D -10  3 )
+  , cp ( Point2D  10  3 )
+  , pp ( Point2D  10  0 )
+  ]
+  where
+    pp, cp :: Point2D Double -> StrokePoint a
+    pp p =    PathPoint p d
+    cp p = ControlPoint p d
 
 --------------------------------------------------------------------------------
 
@@ -260,11 +279,6 @@ main = do
   widgetAddClasses title [ "text", "title", "plain" ]
   GTK.boxSetCenterWidget titleBar ( Just title )
 
-  ---------------------------------------------------------
-  -- Tool bar
-
-  _ <- createToolBar toolTVar modeTVar colours toolBar
-
   ---------------------------------------------------------
   -- Main viewport
 
@@ -280,15 +294,21 @@ main = do
       mbMousePos    <- STM.readTVarIO mousePosTVar
       mbHoldEvent   <- STM.readTVarIO mouseHoldTVar
       mbPartialPath <- STM.readTVarIO partialPathTVar
+      mode          <- STM.readTVarIO modeTVar
       viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
       viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
       ( `Cairo.renderWithContext` ctx ) $
         renderDocument
-          colours ( viewportWidth, viewportHeight )
+          colours mode ( viewportWidth, viewportHeight )
           mbMousePos mbHoldEvent mbPartialPath
           doc
     pure True
 
+  ---------------------------------------------------------
+  -- Tool bar
+
+  _ <- createToolBar toolTVar modeTVar colours viewportDrawingArea toolBar
+
   ---------------------------------------------------------
   -- Info bar
 

assets/theme.css

@@ -42,9 +42,15 @@
 .path {
   color: rgb(184,80,80);
 }
-.brushStroke {
+.brush {
   color: rgb(235,118,219);
 }
+.brushStroke {
+  color: rgba(235,118,219,0.66);
+}
+.brushCenter {
+  color: rgb(0,0,0);
+}
 .pointHover {
   color: rgb(225,225,225);
 }

src/app/MetaBrush/Asset/Colours.hs

@@ -43,7 +43,9 @@ data ColourRecord a
   , controlPoint        :: !a
   , controlPointOutline :: !a
   , path                :: !a
+  , brush               :: !a
   , brushStroke         :: !a
+  , brushCenter         :: !a
   , pointHover          :: !a
   , pointSelected       :: !a
   , viewport            :: !a
@@ -84,7 +86,9 @@ colourNames = Colours
   , controlPoint        = ColourName "controlPoint"                Colour [ GTK.StateFlagsNormal ]
   , controlPointOutline = ColourName "controlPointStroke"          Colour [ GTK.StateFlagsNormal ]
   , path                = ColourName "path"                        Colour [ GTK.StateFlagsNormal ]
+  , brush               = ColourName "brush"                       Colour [ GTK.StateFlagsNormal ]
   , brushStroke         = ColourName "brushStroke"                 Colour [ GTK.StateFlagsNormal ]
+  , brushCenter         = ColourName "brushCenter"                 Colour [ GTK.StateFlagsNormal ]
   , pointHover          = ColourName "pointHover"                  Colour [ GTK.StateFlagsNormal ]
   , pointSelected       = ColourName "pointSelected"               Colour [ GTK.StateFlagsNormal ]
   , viewport            = ColourName "viewport"          BackgroundColour [ GTK.StateFlagsNormal ]

src/app/MetaBrush/Document.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeApplications      #-}
 
@@ -9,8 +10,9 @@ module MetaBrush.Document
   ( AABB(..)
   , Document(..), currentDocument
   , Stroke(..)
-  , PointData(..), FocusState(..)
+  , PointData(..), BrushPointData(..)
-  , selection
+  , FocusState(..)
+  , _selection, _brush
   )
   where
 
@@ -27,6 +29,8 @@ import GHC.Generics
 -- generic-lens
 import Data.Generics.Product.Fields
   ( field' )
+import Data.Generics.Product.Typed
+  ( HasType(typed) )
 
 -- lens
 import Control.Lens
@@ -83,18 +87,26 @@ data Stroke
 data PointData
   = PointData
   { pointState :: FocusState
-  , brush      :: Seq ( StrokePoint () )
+  , brushShape :: Seq ( StrokePoint BrushPointData )
   }
   deriving stock ( Show, Generic )
 
+data BrushPointData
+  = BrushPointData
+  { brushPointState :: FocusState }
+  deriving stock ( Show, Generic )
+
 data FocusState
   = Normal
   | Hover
   | Selected
   deriving stock ( Show, Eq )
 
-selection :: Lens' ( StrokePoint PointData ) FocusState
+_selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState
-selection = field' @"pointData" . field' @"pointState"
+_selection = field' @"pointData" . typed @FocusState
+
+_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
+_brush = field' @"pointData" . field' @"brushShape"
 
 currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
 currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do

src/app/MetaBrush/Document/Draw.hs

@@ -49,7 +49,7 @@ import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
   ( Document(..), Stroke(..), FocusState(..), PointData(..)
-  , selection
+  , _selection
   )
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique, uniqueText )
@@ -106,9 +106,9 @@ getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
           | strokeVisible
           , Just anchor <- endpointAnchor strokeUnique strokePoints
           -> put ( Just anchor )
-                  $> set ( field' @"strokePoints" . mapped . selection ) Normal stroke
+                  $> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
         -- Otherwise, just deselect.
-        _ -> pure $  set ( field' @"strokePoints"  . mapped . selection ) Normal stroke
+        _ -> pure $  set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
     
     -- See if we can anchor a drawing operation on a given (visible) stroke.
     endpointAnchor :: Unique -> Seq ( StrokePoint PointData ) -> Maybe ( DrawAnchor, Point2D Double )

src/app/MetaBrush/Document/Selection.hs

@@ -17,6 +17,8 @@ module MetaBrush.Document.Selection
   where
 
 -- base
+import Control.Category
+  ( (>>>) )
 import Data.Functor
   ( ($>) )
 import Data.Functor.Identity
@@ -62,7 +64,7 @@ import Math.Vector2D
 import MetaBrush.Document
   ( Document(..), Stroke(..)
   , PointData(..), FocusState(..)
-  , selection
+  , _selection
   )
 import MetaBrush.Event.KeyCodes
   ( pattern Alt_L  , pattern Alt_R
@@ -102,19 +104,20 @@ selectAt mode c doc@( Document { zoomFactor } ) =
     where
       updateStroke :: Stroke -> State Bool Stroke
       updateStroke stroke@( Stroke { strokeVisible } ) =
-        over ( field' @"strokePoints" ) matchEndpoints <$>
+        ( field' @"strokePoints" )
-          ( field' @"strokePoints" . traverse )
+          ( traverse ( updatePoint strokeVisible )
-            ( updatePoint strokeVisible )
+          >>> fmap matchEndpoints 
-            stroke
+          )
+          stroke
       updatePoint :: Bool -> StrokePoint PointData -> State Bool ( StrokePoint PointData )
       updatePoint isVisible pt = do
         anotherPointHasAlreadyBeenSelected <- get
         if selected && not anotherPointHasAlreadyBeenSelected
         then put True $> case mode of
-          Subtract -> set selection Normal   pt
+          Subtract -> set _selection Normal   pt
-          _        -> set selection Selected pt
+          _        -> set _selection Selected pt
         else pure $ case mode of
-          New      -> set selection Normal   pt
+          New      -> set _selection Normal   pt
           _        -> pt
         where
           selected :: Bool
@@ -125,7 +128,7 @@ selectAt mode c doc@( Document { zoomFactor } ) =
       matchEndpoints :: Seq ( StrokePoint PointData ) -> Seq ( StrokePoint PointData )
       matchEndpoints ( p0 :<| ( ps :|> pn ) )
         | coords p0 == coords pn
-        = p0 :<| ( ps :|> set selection ( view selection p0 ) pn )
+        = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
       matchEndpoints ps = ps
 
 -- | Type of a drag move selection:
@@ -154,10 +157,11 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
   where
     updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke
     updateStroke stroke@( Stroke { strokeVisible } ) =
-      over ( field' @"strokePoints" ) matchEndpoints <$>
+      ( field' @"strokePoints" )
-        ( field' @"strokePoints" . traverse )
+        ( traverse ( updatePoint strokeVisible )
-          ( updatePoint strokeVisible )
+        >>> fmap matchEndpoints 
-          stroke
+        )
+        stroke
     updatePoint :: Bool -> StrokePoint PointData -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ( StrokePoint PointData )
     updatePoint isVisible pt
       | selected
@@ -172,7 +176,7 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
                 Selected -> Tardis.sendFuture ( Just ClickedOnSelected   )
                 _        -> Tardis.sendFuture ( Just ClickedOnUnselected )
               -- Select this point (whether it was previously selected or not).
-              pure $ set selection Selected pt
+              pure $ set _selection Selected pt
       | otherwise
       = do
         mbDragClick <- Tardis.getFuture
@@ -180,13 +184,13 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
           -- needs to be lazy
           newPointState :: FocusState
           newPointState
-            -- User clicked on a selected point: preserve selection.
+            -- User clicked on a selected point: preserve _selection.
             | Just ClickedOnSelected <- mbDragClick
-            = view selection pt
+            = view _selection pt
             -- User clicked on an unselected point, or not on a point at all: discard selection.
             | otherwise
             = Normal
-        pure ( set selection newPointState pt )
+        pure ( set _selection newPointState pt )
       where
         selected :: Bool
         selected
@@ -196,7 +200,7 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
     matchEndpoints :: Seq ( StrokePoint PointData ) -> Seq ( StrokePoint PointData )
     matchEndpoints ( p0 :<| ( ps :|> pn ) )
       | coords p0 == coords pn
-      = p0 :<| ( ps :|> set selection ( view selection p0 ) pn )
+      = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
     matchEndpoints ps = ps
 
 -- | Updates the selected objects on a rectangular selection event.
@@ -214,10 +218,10 @@ selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strok
       updatePoint :: Bool -> StrokePoint PointData -> StrokePoint PointData
       updatePoint isVisible pt
         | selected  = case mode of
-          Subtract -> set selection Normal   pt
+          Subtract -> set _selection Normal   pt
-          _        -> set selection Selected pt
+          _        -> set _selection Selected pt
         | otherwise = case mode of
-          New      -> set selection Normal   pt
+          New      -> set _selection Normal   pt
           _        -> pt
         where
           x, y :: Double
@@ -233,7 +237,7 @@ translateSelection t = over ( field' @"strokes" . mapped . field' @"strokePoints
   where
     updateStrokePoint :: StrokePoint PointData -> StrokePoint PointData
     updateStrokePoint pt
-      | Selected <- view selection pt
+      | Selected <- view _selection pt
       = pt { coords = t • coords pt }
       | otherwise
       = pt
@@ -277,4 +281,4 @@ deleteSelected
         pure res
       where
         selectionState :: FocusState
-        selectionState = view selection p
+        selectionState = view _selection p

src/app/MetaBrush/Render/Document.hs

@@ -1,9 +1,13 @@
-{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE BlockArguments      #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveTraversable   #-}
-{-# LANGUAGE NamedFieldPuns     #-}
+{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE NegativeLiterals   #-}
+{-# LANGUAGE DerivingVia         #-}
-{-# LANGUAGE PatternSynonyms    #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE NegativeLiterals    #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module MetaBrush.Render.Document
   ( renderDocument )
@@ -13,13 +17,15 @@ module MetaBrush.Render.Document
 import Control.Monad
   ( guard )
 import Data.Foldable
-  ( traverse_ )
+  ( for_, sequenceA_ )
 import Data.Functor.Compose
   ( Compose(..) )
 import Data.Int
   ( Int32 )
 import Data.Maybe
   ( catMaybes )
+import GHC.Generics
+  ( Generic, Generic1 )
 
 -- acts
 import Data.Act
@@ -35,9 +41,20 @@ import Data.Sequence
 import qualified Data.Sequence as Seq
   ( fromList )
 
+-- generic-data
+import Generic.Data
+  ( Generically1(..) )
+
+-- generic-lens
+import Data.Generics.Product.Typed
+  ( HasType )
+
 -- gi-cairo-render
 import qualified GI.Cairo.Render as Cairo
 
+-- gi-gdk
+import qualified GI.Gdk as GDK
+
 -- lens
 import Control.Lens
   ( view )
@@ -55,8 +72,9 @@ import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Document
   ( Document(..)
-  , Stroke(..), PointData(..), FocusState(..)
+  , Stroke(..), FocusState(..)
-  , selection
+  , PointData(..), BrushPointData(..)
+  , _selection
   )
 import MetaBrush.Document.Selection
   ( translateSelection )
@@ -64,33 +82,50 @@ import MetaBrush.Event
   ( HoldEvent(..), PartialPath(..) )
 import MetaBrush.Render.Util
   ( withRGBA )
+import MetaBrush.UI.ToolBar
+  ( Mode(..) )
 
 --------------------------------------------------------------------------------
 
 data Renders a
-  = MkRenders
+  = Renders
-  { mkRenderPoints :: a
+  { renderPath    :: a
-  , mkRenderPaths  :: a
+  , renderStrokes :: a
+  , renderBrushes :: a
+  , renderCPts    :: a
+  , renderCLines  :: a
+  , renderPPts    :: a
   }
-  deriving stock ( Show, Functor )
+  deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
+  deriving Applicative
+    via Generically1 Renders
 
-instance Applicative Renders where
+blank :: Renders ( Cairo.Render () )
-  pure a = MkRenders a a
+blank = pure ( pure () )
-  MkRenders f1 f2 <*> MkRenders a1 a2 = MkRenders ( f1 a1 ) ( f2 a2 )
 
-{-# COMPLETE Renders #-}
+compositeRenders :: Renders ( Cairo.Render () ) -> Cairo.Render ()
-pattern Renders :: Cairo.Render a -> Cairo.Render a -> Compose Renders Cairo.Render a
+compositeRenders = sequenceA_
-pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints renderPaths )
+
+toAll :: Cairo.Render () -> Compose Renders Cairo.Render ()
+toAll action = Compose ( pure action )
+
+whenPath :: Applicative m => Mode -> m () -> m ()
+whenPath Path = id
+whenPath _    = const ( pure () )
+
+whenBrush :: Applicative m => Mode -> m () -> m ()
+whenBrush Brush = id
+whenBrush _     = const ( pure () )
 
 --------------------------------------------------------------------------------
 
 renderDocument
-  :: Colours -> ( Int32, Int32 )
+  :: Colours -> Mode -> ( Int32, Int32 )
   -> Maybe ( Point2D Double ) -> Maybe HoldEvent -> Maybe PartialPath
   -> Document 
   -> Cairo.Render ()
 renderDocument
-  cols ( viewportWidth, viewportHeight ) 
+  cols mode ( viewportWidth, viewportHeight ) 
   mbMousePos mbHoldEvent mbPartialPath
   doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } )
   = do
@@ -143,69 +178,120 @@ renderDocument
         = ( Stroke previewPts undefined True undefined ) : strokes doc
         | otherwise
         = strokes doc
-      Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) modifiedStrokes
+    
-    rdrPaths
+    for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mode zoomFactor )
-    rdrPoints
     renderSelectionRect
 
     Cairo.restore
   
     pure ()
 
-renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render ()
+renderStroke :: Colours -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
-renderStroke cols zoom ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } )
+renderStroke cols mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
-  = go pt0 pts *> Renders { renderPoints = drawPoint cols zoom pt0, renderPaths = pure () }
+  | strokeVisible
-  where
+  = renderContent Path cols mode zoom pts
-    go :: StrokePoint PointData -> Seq ( StrokePoint PointData ) -> Compose Renders Cairo.Render ()
+  | otherwise
-    go _ Empty = pure ()
+  = pure ()
-    go ( ControlPoint {} ) _ = error "closestPoint: path starts with a control point"
-    -- Line.
-    go p0 ( p1 :<| ps )
-      | PathPoint {} <- p1
-      = Renders
-          { renderPoints = drawPoint cols zoom p1
-          , renderPaths  = drawLine  cols zoom p0 p1
-          }
-        *> go p1 ps
-    -- Quadratic Bézier curve.
-    go p0 ( p1 :<| p2 :<| ps )
-      | ControlPoint {} <- p1
-      , PathPoint    {} <- p2
-      = Renders
-          { renderPoints
-            =  drawLine  cols zoom p0 p1
-            *> drawLine  cols zoom p1 p2
-            *> drawPoint cols zoom p1
-            *> drawPoint cols zoom p2
-          , renderPaths = drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } )
-          }
-      *> go p2 ps
-    -- Cubic Bézier curve.
-    go p0 ( p1 :<| p2 :<| p3 :<| ps )
-      | ControlPoint {} <- p1
-      , ControlPoint {} <- p2
-      , PathPoint    {} <- p3
-      = Renders
-          { renderPoints
-            =  drawLine  cols zoom p0 p1
-            *> drawLine  cols zoom p2 p3
-            *> drawPoint cols zoom p1
-            *> drawPoint cols zoom p2
-            *> drawPoint cols zoom p3
-          , renderPaths = drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } )
-          }
-      *> go p3 ps
-    go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
-renderStroke _ _ _ = pure ()
 
-drawPoint :: Colours -> Double -> StrokePoint PointData -> Cairo.Render ()
+class RenderableContent d where
+  renderContent :: Mode -> Colours -> Mode -> Double -> d -> Compose Renders Cairo.Render ()
+
+instance RenderableContent ( StrokePoint PointData ) where
+  renderContent _ cols _ zoom pt =
+    let
+      x, y :: Double
+      Point2D x y = coords pt
+      brushPts :: Seq ( StrokePoint BrushPointData )
+      brushPts = brushShape ( pointData pt )
+    in
+      toAll do
+        Cairo.save
+        Cairo.translate x y
+      *> renderContent Brush cols Path zoom brushPts
+      *> Compose blank { renderPPts = drawCross cols zoom }
+      *> toAll Cairo.restore
+
+instance RenderableContent ( StrokePoint BrushPointData ) where
+  renderContent _ _ _ _ _ = pure ()
+
+instance ( Show d, RenderableContent ( StrokePoint d ), HasType FocusState d ) => RenderableContent ( Seq ( StrokePoint d ) ) where
+  renderContent _  _    _    _    Empty = pure ()
+  renderContent tp cols mode zoom ( pt0 :<| pts ) =
+    Compose blank
+      { renderPPts = whenPath mode $ drawPoint cols zoom pt0 }
+    *> whenBrush mode ( renderContent Brush cols mode zoom pt0 )
+    *> go pt0 pts
+    where
+      go :: StrokePoint d -> Seq ( StrokePoint d ) -> Compose Renders Cairo.Render ()
+      go _ Empty = pure ()
+      go ( ControlPoint {} ) _ = error "renderContent: path starts with a control point"
+      -- Line.
+      go p0 ( p1 :<| ps )
+        | PathPoint {} <- p1
+        = Compose blank
+            { renderPPts
+              = whenPath mode $ drawPoint cols zoom p1
+            , renderPath
+              = drawLine cols tp zoom p0 p1
+             }
+        *> ( whenBrush mode $ renderContent Brush cols mode zoom p1 )
+        *> go p1 ps
+      -- Quadratic Bézier curve.
+      go p0 ( p1 :<| p2 :<| ps )
+        | ControlPoint {} <- p1
+        , PathPoint    {} <- p2
+        = Compose blank
+            { renderCLines
+              = whenPath mode do
+                drawLine cols tp zoom p0 p1
+                drawLine cols tp zoom p1 p2
+            , renderCPts
+              = whenPath mode $ drawPoint cols zoom p1
+            , renderPPts
+              = whenPath mode $ drawPoint cols zoom p2
+            , renderPath
+              = drawQuadraticBezier cols tp zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } )
+            }
+        *> whenBrush mode 
+          (  renderContent Brush cols mode zoom p1
+          *> renderContent Brush cols mode zoom p2
+          )
+        *> go p2 ps
+      -- Cubic Bézier curve.
+      go p0 ( p1 :<| p2 :<| p3 :<| ps )
+        | ControlPoint {} <- p1
+        , ControlPoint {} <- p2
+        , PathPoint    {} <- p3
+        = Compose blank
+            { renderCLines
+              = whenPath mode do
+                drawLine cols tp zoom p0 p1
+                drawLine cols tp zoom p2 p3
+            , renderCPts
+              = whenPath mode do
+                drawPoint cols zoom p1
+                drawPoint cols zoom p2
+            , renderPPts
+              = whenPath mode $ drawPoint cols zoom p3
+            , renderPath
+              = drawCubicBezier cols tp zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } )
+            }
+        *> whenBrush mode
+          (  renderContent Brush cols mode zoom p1
+          *> renderContent Brush cols mode zoom p2
+          *> renderContent Brush cols mode zoom p3
+          )
+        *> go p3 ps
+      go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
+
+drawPoint :: HasType FocusState d => Colours -> Double -> StrokePoint d -> Cairo.Render ()
 drawPoint ( Colours { .. } ) zoom pt@( PathPoint { coords = Point2D x y } )
   = do
   let
     hsqrt3 :: Double
     hsqrt3 = sqrt 0.75
     selectionState :: FocusState
-    selectionState = view selection pt
+    selectionState = view _selection pt
 
   Cairo.save
   Cairo.translate x y
@@ -237,7 +323,7 @@ drawPoint ( Colours { .. } ) zoom pt@( ControlPoint { coords = Point2D x y } )
   = do
   let
     selectionState :: FocusState
-    selectionState = view selection pt
+    selectionState = view _selection pt
 
   Cairo.save
   Cairo.translate x y
@@ -262,12 +348,19 @@ drawPoint ( Colours { .. } ) zoom pt@( ControlPoint { coords = Point2D x y } )
 
   Cairo.restore
 
-drawLine :: Colours -> Double -> StrokePoint PointData -> StrokePoint PointData -> Cairo.Render ()
+drawLine :: Colours -> Mode -> Double -> StrokePoint d -> StrokePoint d -> Cairo.Render ()
-drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
+drawLine ( Colours { path, brush, controlPoint } ) mode zoom p1 p2 = do
   let
     x1, y1, x2, y2 :: Double
     Point2D x1 y1 = coords p1
     Point2D x2 y2 = coords p2
+    col :: GDK.RGBA
+    sz :: Double
+    ( col, sz )
+      | Brush <- mode
+      = ( brush, 3 )
+      | otherwise
+      = ( path, 6 )
 
   Cairo.save
   Cairo.moveTo x1 y1
@@ -275,8 +368,8 @@ drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
 
   case ( p1, p2 ) of
     ( PathPoint {}, PathPoint {} ) -> do
-      Cairo.setLineWidth ( 6 / zoom )
+      Cairo.setLineWidth ( sz / zoom )
-      withRGBA path Cairo.setSourceRGBA
+      withRGBA col Cairo.setSourceRGBA
     _ -> do
       Cairo.setLineWidth ( 3 / zoom )
       withRGBA controlPoint Cairo.setSourceRGBA
@@ -284,8 +377,8 @@ drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
 
   Cairo.restore
 
-drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
+drawQuadraticBezier :: Colours -> Mode -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
-drawQuadraticBezier ( Colours { path } ) zoom
+drawQuadraticBezier ( Colours { path, brush } ) mode zoom
   ( Quadratic.Bezier
     { p0 = Point2D x0 y0
     , p1 = Point2D x1 y1
@@ -293,6 +386,14 @@ drawQuadraticBezier ( Colours { path } ) zoom
     }
   )
   = do
+  let
+    col :: GDK.RGBA
+    sz :: Double
+    ( col, sz )
+      | Brush <- mode
+      = ( brush, 3 )
+      | otherwise
+      = ( path, 6 )
 
   Cairo.save
 
@@ -302,14 +403,14 @@ drawQuadraticBezier ( Colours { path } ) zoom
     ( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
     x2 y2
 
-  Cairo.setLineWidth ( 6 / zoom )
+  Cairo.setLineWidth ( sz / zoom )
-  withRGBA path Cairo.setSourceRGBA
+  withRGBA col Cairo.setSourceRGBA
   Cairo.stroke
 
   Cairo.restore
 
-drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
+drawCubicBezier :: Colours -> Mode -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
-drawCubicBezier ( Colours { path } ) zoom
+drawCubicBezier ( Colours { path, brush } ) mode zoom
   ( Cubic.Bezier
     { p0 = Point2D x0 y0
     , p1 = Point2D x1 y1
@@ -318,14 +419,22 @@ drawCubicBezier ( Colours { path } ) zoom
     }
   )
   = do
+  let 
+    col :: GDK.RGBA
+    sz :: Double
+    ( col, sz )
+      | Brush <- mode
+      = ( brush, 3 )
+      | otherwise
+      = ( path, 6 )
 
   Cairo.save
 
   Cairo.moveTo x0 y0
   Cairo.curveTo x1 y1 x2 y2 x3 y3
 
-  Cairo.setLineWidth ( 6 / zoom )
+  Cairo.setLineWidth ( sz / zoom )
-  withRGBA path Cairo.setSourceRGBA
+  withRGBA col Cairo.setSourceRGBA
   Cairo.stroke
 
   Cairo.restore
@@ -350,3 +459,22 @@ renderSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1
   Cairo.stroke
 
   Cairo.restore
+
+drawCross :: Colours -> Double -> Cairo.Render ()
+drawCross ( Colours { .. } ) zoom = do
+  Cairo.save
+
+  Cairo.setLineWidth 2
+  withRGBA brushCenter Cairo.setSourceRGBA
+
+  Cairo.scale ( 1 / zoom ) ( 1 / zoom )
+
+  Cairo.moveTo -3 -3
+  Cairo.lineTo  3  3
+  Cairo.stroke
+
+  Cairo.moveTo -3  3
+  Cairo.lineTo  3 -3
+  Cairo.stroke
+
+  Cairo.restore

src/app/MetaBrush/UI/Coordinates.hs

@@ -50,7 +50,7 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) =
     res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
     res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
     go :: StrokePoint PointData -> Seq ( StrokePoint PointData ) -> ArgMin Double ( Maybe ( Point2D Double ) )
-    go ( ControlPoint {} ) _ = error "closedPoint: path starts with a control point"
+    go ( ControlPoint {} ) _ = error "closestPoint: path starts with a control point"
     go p0 Empty = res ( coords p0 )
     -- Line.
     go ( PathPoint { coords = p0 } )

src/app/MetaBrush/UI/ToolBar.hs

@@ -61,8 +61,8 @@ data ToolBar
   , metaTool      :: !GTK.RadioButton
   }
 
-createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.Box -> IO ToolBar
+createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.DrawingArea -> GTK.Box -> IO ToolBar
-createToolBar toolTVar modeTVar colours toolBar = do
+createToolBar toolTVar modeTVar colours drawingArea toolBar = do
   
   widgetAddClass toolBar "toolBar"
 
@@ -83,12 +83,16 @@ createToolBar toolTVar modeTVar colours toolBar = do
   brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
   metaTool  <- GTK.radioButtonNewFromWidget ( Just pathTool )
 
-  _ <- GTK.onButtonClicked pathTool
+  _ <- GTK.onButtonClicked pathTool do
-    ( STM.atomically $ STM.writeTVar modeTVar Path )
+    STM.atomically $ STM.writeTVar modeTVar Path
-  _ <- GTK.onButtonClicked brushTool
+    GTK.widgetQueueDraw drawingArea
-    ( STM.atomically $ STM.writeTVar modeTVar Brush )
+  _ <- GTK.onButtonClicked brushTool do
-  _ <- GTK.onButtonClicked metaTool
+    STM.atomically $ STM.writeTVar modeTVar Brush
-    ( STM.atomically $ STM.writeTVar modeTVar Meta )
+    GTK.widgetQueueDraw drawingArea
+  _ <- GTK.onButtonClicked metaTool do
+    STM.atomically $ STM.writeTVar modeTVar Meta
+    GTK.widgetQueueDraw drawingArea
+
 
   GTK.boxPackStart toolBar selectionTool True True 0
   GTK.boxPackStart toolBar       penTool True True 0