basic rendering, mousewheel scrolling

MetaBrush.cabal

@@ -28,6 +28,8 @@ common common
     build-depends:
         base
           >= 4.13 && < 4.16
+      , acts
+          ^>= 0.3.1.0
 
     default-language:
         Haskell2010
@@ -61,9 +63,7 @@ library
       , Math.Vector2D
 
     build-depends:
-        acts
+        generic-data
-          ^>= 0.3.1.0
-      , generic-data
           >= 0.8.0.0 && < 0.8.4.0
       , groups
           ^>= 0.4.1.0
@@ -92,8 +92,8 @@ executable MetaBrush
       , MetaBrush.Asset.WindowIcons
       , MetaBrush.Document
       , MetaBrush.Event
+      , MetaBrush.Render.Document
       , MetaBrush.Render.Util
-      , MetaBrush.Stroke
       , MetaBrush.UI.Menu
       , Paths_MetaBrush
 
@@ -105,8 +105,12 @@ executable MetaBrush
 
     build-depends:
         MetaBrush
+      , containers
+          >= 0.6.0.1 && < 0.6.4
       , directory
           >= 1.3.4.0 && < 1.4
+    --, fingertree
+    --    >= 0.1.4.2 && < 0.2
       , generic-lens
           >= 1.2.0.1 && < 2.0
       , gi-gdk
@@ -123,5 +127,7 @@ executable MetaBrush
           ^>= 0.0.1
       , haskell-gi-base
           ^>= 0.24
+      , stm
+          ^>= 2.5.0.0
       , text
           ^>= 1.2.3.1 && < 1.2.5

app/Main.hs

@@ -2,8 +2,10 @@
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE NegativeLiterals  #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms   #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeApplications  #-}
 
@@ -13,14 +15,28 @@ module Main
 
 -- base
 import Control.Monad
-  ( void )
+  ( void, unless )
 import Data.Foldable
   ( for_ )
 import Data.Int
   ( Int32 )
+import Data.Word
+  ( Word32 )
 import System.Exit
   ( exitSuccess )
 
+-- acts
+import Data.Act
+  ( Act
+    ( (•) )
+  )
+
+-- containers
+import Data.IntMap.Strict
+  ( IntMap )
+import qualified Data.IntMap.Strict as IntMap
+  ( fromList, lookup, insert, traverseWithKey )
+
 -- directory
 import qualified System.Directory as Directory
   ( canonicalizePath )
@@ -38,11 +54,21 @@ import qualified GI.Gdk as GDK
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- stm
+import qualified Control.Concurrent.STM      as STM
+  ( atomically )
+import qualified Control.Concurrent.STM.TVar as STM
+  ( newTVarIO, writeTVar, readTVarIO )
+
 -- text
 import qualified Data.Text as Text
   ( pack )
 
 -- MetaBrush
+import Math.Module
+  ( (*^) )
+import Math.Vector2D
+  ( Point2D(..), Vector2D(..) )
 import MetaBrush.Asset.Colours
   ( getColours )
 import MetaBrush.Asset.Cursor
@@ -55,8 +81,18 @@ import MetaBrush.Asset.Tools
   ( drawBrush, drawMeta, drawPath, drawPen )
 import MetaBrush.Asset.WindowIcons
   ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
+import MetaBrush.Document
+  ( Document(..)
+  , AABB(..)
+  , Stroke(..)
+  )
 import MetaBrush.Event
-  ( handleKeyboardPressEvent, handleKeyboardReleaseEvent )
+  ( handleKeyboardPressEvent, handleKeyboardReleaseEvent
+  , pattern Control_L, pattern Control_R
+  , pattern Shift_L, pattern Shift_R
+  )
+import MetaBrush.Render.Document
+  ( renderDocument )
 import MetaBrush.Render.Util
   ( widgetAddClass, widgetAddClasses )
 import MetaBrush.UI.Menu
@@ -66,9 +102,41 @@ import qualified Paths_MetaBrush as Cabal
 
 --------------------------------------------------------------------------------
 
+testDocuments :: IntMap Document
+testDocuments = IntMap.fromList
+  $ zip [0..]
+    [ Document
+      { displayName    = "Document 1"
+      , filePath       = Nothing
+      , unsavedChanges = False
+      , strokes        = [ Stroke [ Point2D 10 10, Point2D 30 30, Point2D 40 70 ] ]
+      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 100 100 )
+      , viewportCenter = Point2D 50 50
+      , zoomFactor     = 1
+      }
+    , Document
+      { displayName    = "Document 2"
+      , filePath       = Nothing
+      , unsavedChanges = True
+      , strokes        = [ Stroke [ Point2D 0 0, Point2D 10 10, Point2D 20 20 ] ]
+      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
+      , viewportCenter = Point2D 10 10
+      , zoomFactor     = 0.25
+      }
+    ]
+
+--------------------------------------------------------------------------------
+
 main :: IO ()
 main = do
 
+  ---------------------------------------------------------
+  -- Initialise state
+
+  activeDocumentTVar <- STM.newTVarIO @( Maybe Int       ) Nothing
+  openDocumentsTVar  <- STM.newTVarIO @( IntMap Document ) testDocuments
+  pressedKeysTVar    <- STM.newTVarIO @[ Word32 ]          []
+
   ---------------------------------------------------------
   -- Initialise GTK
 
@@ -84,7 +152,7 @@ main = do
   windowWidgetPath <- GTK.widgetGetPath window
   widgetAddClass window "window"
   GTK.setWindowResizable window True
-  GTK.setWindowDecorated window True
+  GTK.setWindowDecorated window False
   GTK.setWindowTitle window "MetaBrush"
   GTK.windowSetDefaultSize window 800 600
 
@@ -219,7 +287,6 @@ main = do
     $ Cairo.renderWithContext
       ( drawClose colours )
 
-
   for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do
     widgetAddClass button "windowIcon"
 
@@ -293,61 +360,7 @@ main = do
     $ Cairo.renderWithContext
       ( drawMeta colours )
 
-  ---------------------------------------------------------
+---------------------------------------------------------
-  -- File bar
-
-  widgetAddClass fileBar "fileBar"
-
-  fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
-  GTK.containerAdd fileBar fileTabs
-  widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
-
-  fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
-
-  for_ [ 1 .. 12 ] \ i -> do
-    -- File tab elements.
-    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( "New Document (" <> Text.pack ( show i ) <> ")" )
-    GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
-    closeFileButton <- GTK.buttonNewWithLabel "x"
-
-    -- Create box for file tab elements.
-    tab <- GTK.boxNew GTK.OrientationHorizontal 0
-    widgetAddClasses tab [ "fileBarTab" ]
-    GTK.boxPackStart fileTabs tab               False False 0
-    GTK.boxPackStart tab      pgButton          True  True  0
-    GTK.boxPackStart tab      closeFileButton   False False 0
-
-    widgetAddClasses pgButton        [ "fileBarTabButton" ]
-    widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
-
-    -- Make both file tab elements activate styling on the whole tab
-    -- (e.g. hovering over the close file button should highlight the whole tab).
-    void $ GTK.onButtonClicked pgButton do
-      isActive <- GTK.toggleButtonGetActive pgButton
-      flags  <- GTK.widgetGetStateFlags tab
-      if isActive
-      then GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
-      else GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
-
-{-
-    void $ GTK.onButtonClicked closeFileButton do
-      closeFileDialog ...
--}
-
-    for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
-      void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
-        flags <- GTK.widgetGetStateFlags tab
-        GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
-        pure False
-      void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
-        flags <- GTK.widgetGetStateFlags tab
-        GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
-        pure False
-
-  GTK.scrolledWindowSetPolicy           fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
-  GTK.scrolledWindowSetOverlayScrolling fileBar True
-
-  ---------------------------------------------------------
   -- Main viewport
 
   widgetAddClass viewportGrid "viewport"
@@ -362,6 +375,9 @@ main = do
   GTK.gridAttach viewportGrid rvTopRuler      1 0 1 1
   GTK.gridAttach viewportGrid viewportOverlay 1 1 1 1
 
+  ----------
+  -- Rulers
+
   rulerCorner <- GTK.boxNew GTK.OrientationVertical   0
   leftRuler   <- GTK.boxNew GTK.OrientationVertical   0
   topRuler    <- GTK.boxNew GTK.OrientationHorizontal 0
@@ -403,8 +419,12 @@ main = do
   viewportArea <- GTK.drawingAreaNew
   GTK.setContainerChild viewportOverlay viewportArea
 
+  -----------------
+  -- Viewport scrolling
+
   viewportScrollbarGrid <- GTK.gridNew
   GTK.overlayAddOverlay viewportOverlay viewportScrollbarGrid
+  GTK.overlaySetOverlayPassThrough viewportOverlay viewportScrollbarGrid True
 
   viewportHScrollbar <- GTK.scrollbarNew GTK.OrientationHorizontal ( Nothing @GTK.Adjustment )
   viewportVScrollbar <- GTK.scrollbarNew GTK.OrientationVertical   ( Nothing @GTK.Adjustment )
@@ -417,6 +437,129 @@ main = do
   widgetAddClass viewportHScrollbar "viewportScrollbar"
   widgetAddClass viewportVScrollbar "viewportScrollbar"
 
+  void $ GTK.onWidgetScrollEvent viewportArea \ scrollEvent -> do
+
+    dx <- GDK.getEventScrollDeltaX scrollEvent
+    dy <- GDK.getEventScrollDeltaY scrollEvent
+    --GDK.getEventScrollDirection scrollEvent
+    --GDK.getEventScrollType scrollEvent
+    --GDK.getEventScrollX scrollEvent
+    --GDK.getEventScrollY scrollEvent
+
+    unless ( dx == 0 && dy == 0 ) do
+      mbActiveDoc <- STM.readTVarIO activeDocumentTVar
+      for_ mbActiveDoc \ i -> do
+        docs <- STM.readTVarIO openDocumentsTVar
+        for_ ( IntMap.lookup i docs ) \ ( doc@(Document { viewportCenter, zoomFactor } ) ) -> do
+          pressedKeys <- STM.readTVarIO pressedKeysTVar
+          let
+            newDoc :: Document
+            newDoc
+              -- Zooming using 'Control'.
+              | any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
+              = let
+                  newZoomFactor :: Double
+                  newZoomFactor
+                    | dy > 0
+                    = max 0.0078125 ( zoomFactor / 2 )
+                    | otherwise
+                    = zoomFactor * 2
+                in doc { zoomFactor = newZoomFactor }
+              -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
+              | dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys
+              = let
+                  newCenter :: Point2D Double
+                  newCenter = ( ( 25 / zoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • viewportCenter
+                in doc { viewportCenter = newCenter }
+              -- Vertical scrolling.
+              | otherwise
+              = let
+                  newCenter :: Point2D Double
+                  newCenter = ( ( 25 / zoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • viewportCenter
+                in doc { viewportCenter = newCenter }
+            docs' :: IntMap Document
+            docs' = IntMap.insert i newDoc docs
+          STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
+          GTK.widgetQueueDraw viewportArea
+    pure True
+
+  -----------------
+  -- Rendering
+
+  void $ GTK.onWidgetDraw viewportArea \ctx -> do
+    -- Get the relevant document information
+    mbActiveDoc <- STM.readTVarIO activeDocumentTVar
+    for_ mbActiveDoc \ i -> do
+      docs <- STM.readTVarIO openDocumentsTVar
+      for_ ( IntMap.lookup i docs ) \ doc -> do
+        ( `Cairo.renderWithContext` ctx ) $ do
+          viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportArea
+          viewportHeight <- GTK.widgetGetAllocatedHeight viewportArea
+          renderDocument colours ( viewportWidth, viewportHeight ) doc
+    pure True
+
+  ---------------------------------------------------------
+  -- File bar
+
+  widgetAddClass fileBar "fileBar"
+
+  fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
+  GTK.containerAdd fileBar fileTabs
+  widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
+
+  fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
+
+  -- TODO: currently using static list of documents.
+  -- Need to dynamically update this widget as the user opens/closes documents.
+  fileButtons <- ( `IntMap.traverseWithKey` testDocuments ) \ i ( Document { displayName, unsavedChanges } ) -> do
+    -- File tab elements.
+    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) displayName
+    GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
+    closeFileButton <- GTK.buttonNewWithLabel "x"
+
+    -- Create box for file tab elements.
+    tab <- GTK.boxNew GTK.OrientationHorizontal 0
+    widgetAddClasses tab [ "fileBarTab" ]
+    GTK.boxPackStart fileTabs tab               False False 0
+    GTK.boxPackStart tab      pgButton          True  True  0
+    GTK.boxPackStart tab      closeFileButton   False False 0
+
+    widgetAddClasses pgButton        [ "fileBarTabButton" ]
+    widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
+
+    -- Make both file tab elements activate styling on the whole tab
+    -- (e.g. hovering over the close file button should highlight the whole tab).
+    void $ GTK.onButtonClicked pgButton do
+      isActive <- GTK.toggleButtonGetActive pgButton
+      flags  <- GTK.widgetGetStateFlags tab
+      if isActive
+      then do
+        GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
+        STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) )
+        GTK.widgetQueueDraw viewportArea
+      else 
+        GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
+
+{-
+    void $ GTK.onButtonClicked closeFileButton do
+      closeFileDialog ...
+-}
+
+    for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
+      void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
+        flags <- GTK.widgetGetStateFlags tab
+        GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
+        pure False
+      void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
+        flags <- GTK.widgetGetStateFlags tab
+        GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
+        pure False
+
+    pure pgButton
+
+  GTK.scrolledWindowSetPolicy           fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
+  GTK.scrolledWindowSetOverlayScrolling fileBar True
+
   ---------------------------------------------------------
   -- Panels
 
@@ -469,7 +612,6 @@ main = do
   GTK.boxPackStart   brushesPanel   brushesContent True True 0
   GTK.boxPackStart transformPanel transformContent True True 0
 
-
   ---------------------------------------------------------
   -- Info bar
 
@@ -554,7 +696,10 @@ main = do
   ---------------------------------------------------------
   -- Actions
 
-  GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask]
+  GTK.widgetAddEvents window
+    [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
+  GTK.widgetAddEvents viewportArea
+    [ GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask ]
 
   _ <- GTK.onButtonClicked         closeButton    GTK.mainQuit
   _ <- GTK.onButtonClicked         minimiseButton ( GTK.windowIconify window )
@@ -568,8 +713,8 @@ main = do
       then GTK.windowUnmaximize   window
       else GTK.windowMaximize     window
 
-  _ <- GTK.onWidgetKeyPressEvent   window      handleKeyboardPressEvent  
+  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   pressedKeysTVar )
-  _ <- GTK.onWidgetKeyReleaseEvent window      handleKeyboardReleaseEvent
+  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
   _ <- GTK.onWidgetDestroy         window GTK.mainQuit
 
   ---------------------------------------------------------
@@ -580,6 +725,8 @@ main = do
 
   exitSuccess
 
+---------------------------------------------------------
+-- Utils.
 
 data Exists c where
   Exists :: c a => a -> Exists c

cabal.project

@@ -2,7 +2,6 @@ packages: .
 
 constraints:
     acts -finitary
-  , haskell-gi >= 0.24
 
 -- fixes gi-cairo-render to work with haskell-gi >= 0.24
 source-repository-package

src/app/MetaBrush/Document.hs

@@ -1,14 +1,38 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module MetaBrush.Document where
 
+-- text
+import Data.Text
+  ( Text )
+
+-- MetaBrush
+import Math.Vector2D
+  ( Point2D )
+
 --------------------------------------------------------------------------------
 
-{-
+data AABB
+  = AABB
+  { topLeft  :: !( Point2D Double )
+  , botRight :: !( Point2D Double )
+  }
+  deriving stock Show
+
 data Document
   = Document
     { displayName    :: !Text
-    , filePath       :: !(Maybe FilePath)
+    , filePath       :: !( Maybe FilePath )
     , unsavedChanges :: !Bool
-    , viewport       :: !AABB
+    , strokes        :: ![ Stroke ]
-    , strokes        :: !(Set Stroke)
+    , bounds         :: !AABB
+    , viewportCenter :: !( Point2D Double )
+    , zoomFactor     :: !Double
     }
--}
+  deriving stock Show
+
+data Stroke
+  = Stroke
+  { strokePoints :: ![ Point2D Double ] }
+  deriving stock Show

src/app/MetaBrush/Event.hs

@@ -1,8 +1,11 @@
-module MetaBrush.Event
+{-# LANGUAGE BlockArguments  #-}
-  ( handleKeyboardPressEvent
+{-# LANGUAGE PatternSynonyms #-}
-  , handleKeyboardReleaseEvent
+
-  )
+module MetaBrush.Event where
-  where
+
+-- base
+import Data.Word
+  ( Word32 )
 
 -- gi-gdk
 import qualified GI.Gdk as GDK
@@ -10,14 +13,67 @@ import qualified GI.Gdk as GDK
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- stm
+import qualified Control.Concurrent.STM      as STM
+  ( atomically )
+import qualified Control.Concurrent.STM.TVar as STM
+  ( TVar, readTVar, writeTVar )
+
 --------------------------------------------------------------------------------
 
-handleKeyboardPressEvent, handleKeyboardReleaseEvent :: GDK.EventKey -> IO Bool
+handleKeyboardPressEvent, handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
-handleKeyboardPressEvent evt = do
+handleKeyboardPressEvent pressedKeysTVar evt = do
   keyCode <- GDK.getEventKeyKeyval evt
   case keyCode of
-    -- escape
+    Escape -> GTK.mainQuit
-    0xff1b -> GTK.mainQuit
+    _      -> STM.atomically do
-    _      -> pure ()
+      pressedKeys <- STM.readTVar pressedKeysTVar
+      STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
   pure True
-handleKeyboardReleaseEvent _ = pure True
+handleKeyboardReleaseEvent pressedKeysTVar evt = do
+  keyCode <- GDK.getEventKeyKeyval evt
+  STM.atomically do
+    pressedKeys <- STM.readTVar pressedKeysTVar
+    STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys )
+  pure True
+
+pattern Escape    :: Word32
+pattern Escape    = 0xff1b
+pattern Delete    :: Word32
+pattern Delete    = 0xffff
+pattern BackSpace :: Word32
+pattern BackSpace = 0xff08
+pattern Tab       :: Word32
+pattern Tab       = 0xff09
+pattern Return    :: Word32
+pattern Return    = 0xff0d
+pattern Pause     :: Word32
+pattern Pause     = 0xff13
+pattern Left      :: Word32
+pattern Left      = 0xff51
+pattern Up        :: Word32
+pattern Up        = 0xff52
+pattern Right     :: Word32
+pattern Right     = 0xff53
+pattern Down      :: Word32
+pattern Down      = 0xff54
+pattern PageUp    :: Word32
+pattern PageUp    = 0xff55
+pattern Next      :: Word32
+pattern Next      = 0xff56
+pattern PageDown  :: Word32
+pattern PageDown  = 0xff56
+pattern End       :: Word32
+pattern End       = 0xff57
+pattern Shift_L   :: Word32
+pattern Shift_L   = 0xffe1
+pattern Shift_R   :: Word32
+pattern Shift_R   = 0xffe2
+pattern Control_L :: Word32
+pattern Control_L = 0xffe3
+pattern Control_R :: Word32
+pattern Control_R = 0xffe4
+pattern Alt_L     :: Word32
+pattern Alt_L     = 0xffe9
+pattern Alt_R     :: Word32
+pattern Alt_R     = 0xffea

src/app/MetaBrush/Render/Document.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE NamedFieldPuns   #-}
+{-# LANGUAGE NegativeLiterals #-}
+{-# LANGUAGE RecordWildCards  #-}
+
+module MetaBrush.Render.Document
+  ( renderDocument )
+  where
+
+-- base
+import Control.Monad
+  ( when )
+import Data.Int
+  ( Int32 )
+
+-- gi-cairo-render
+import qualified GI.Cairo.Render as Cairo
+
+-- MetaBrush
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(..) )
+import Math.Vector2D
+  ( Point2D(..) )
+import MetaBrush.Asset.Colours
+  ( Colours, ColourRecord(..) )
+import MetaBrush.Document
+  ( Document(..), Stroke(..) )
+import MetaBrush.Render.Util
+  ( withRGBA )
+
+--------------------------------------------------------------------------------
+
+renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render ()
+renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do
+
+  Cairo.save
+  Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
+  Cairo.scale zoomFactor zoomFactor
+  Cairo.translate ( -cx ) ( -cy )
+
+  let
+    ( renderPoints, renderPath ) = renderStrokes cols zoomFactor strokes
+  renderPath
+  renderPoints
+
+  Cairo.restore
+
+  pure ()
+
+renderStrokes :: Colours -> Double -> [ Stroke ] -> ( Cairo.Render (), Cairo.Render () )
+renderStrokes _    _    []         = ( pure (), pure () )
+renderStrokes cols zoom ( s : ss ) = ( points1 *> points2, path1 *> path2 )
+  where
+    ( points1, path1 ) = renderStroke  cols zoom s
+    ( points2, path2 ) = renderStrokes cols zoom ss
+
+renderStroke :: Colours -> Double -> Stroke -> ( Cairo.Render (), Cairo.Render () )
+renderStroke cols zoom ( Stroke strokePts ) = go True strokePts
+  where
+    go :: Bool -> [ Point2D Double ] -> ( Cairo.Render (), Cairo.Render () )
+    go drawFirstPoint pts = case pts of
+      []  -> ( pure (), pure () )
+      [p0] -> ( when drawFirstPoint ( drawPoint cols zoom p0 ), pure () )
+      [_,_] -> error "'renderStroke': unexpected pair of points"
+      ( p0 : p1 : p2 : ps ) ->
+        let
+          drawPoints, drawNextPoints, drawPath, drawNextPath :: Cairo.Render ()
+          ( drawNextPoints, drawNextPath ) = go False ( p2 : ps )
+          drawPoints = do
+            when drawFirstPoint ( drawPoint cols zoom p0 )
+            drawControl cols zoom p1
+            drawPoint cols zoom p2
+            drawNextPoints
+          drawPath = do
+            drawQuadraticBezier cols zoom ( Quadratic.Bezier p0 p1 p2 )
+            drawNextPath
+        in ( drawPoints, drawPath )
+          
+
+drawPoint, drawControl :: Colours -> Double -> Point2D Double -> Cairo.Render ()
+drawPoint ( Colours { pathPoint, pathPointOutline } ) zoom ( Point2D x y ) = do
+
+  let
+    hsqrt3 :: Double
+    hsqrt3 = sqrt 0.75
+
+  Cairo.save
+  Cairo.translate x y
+  Cairo.scale ( 4 / zoom ) ( 4 / zoom )
+
+  Cairo.moveTo  1          0
+  Cairo.lineTo  0.5   hsqrt3
+  Cairo.lineTo -0.5   hsqrt3
+  Cairo.lineTo -1          0
+  Cairo.lineTo -0.5 (-hsqrt3)
+  Cairo.lineTo  0.5 (-hsqrt3)
+  Cairo.closePath
+
+  Cairo.setLineWidth 1
+  withRGBA pathPointOutline Cairo.setSourceRGBA
+  Cairo.strokePreserve
+
+  withRGBA pathPoint Cairo.setSourceRGBA
+  Cairo.fill
+
+  Cairo.restore
+
+drawControl ( Colours { controlPoint, controlPointOutline } ) zoom ( Point2D x y ) = do
+
+  Cairo.save
+  Cairo.translate x y
+  Cairo.scale ( 4 / zoom ) ( 4 / zoom )
+
+  Cairo.arc 0 0 1 0 ( 2 * pi )
+
+  Cairo.setLineWidth 1
+  withRGBA controlPointOutline Cairo.setSourceRGBA
+  Cairo.strokePreserve
+
+  withRGBA controlPoint Cairo.setSourceRGBA
+  Cairo.fill
+
+  Cairo.restore
+
+drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
+drawQuadraticBezier _ _ _ = pure ()

src/lib/Math/Bezier/Cubic.hs

@@ -14,6 +14,7 @@
 module Math.Bezier.Cubic
   ( Bezier(..)
   , bezier, bezier'
+  , subdivide
   )
   where
 
@@ -49,10 +50,6 @@ data Bezier p
     }
   deriving stock ( Show, Generic, Functor, Foldable, Traversable )
 
-instance Module r p => Module r ( Bezier p ) where
-  ( Bezier p0 p1 p2 p3 ) ^+^ ( Bezier q0 q1 q2 q3 ) = Bezier ( p0 ^+^ q0 ) ( p1 ^+^ q1 ) ( p2 ^+^ q2 ) ( p3 ^+^ q3 )
-  r *^ bz = fmap ( r *^ ) bz
-
 -- | Cubic Bézier curve.
 bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
 bezier ( Bezier { .. } ) t =
@@ -67,3 +64,15 @@ bezier' ( Bezier { .. } ) t
   $ lerp @v t
       ( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) )
       ( lerp @v t ( p1 --> p2 ) ( p2 --> p3 ) )
+
+-- | Subdivide a cubic Bézier curve into two parts.
+subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
+subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
+  where
+    pt, s, q1, q2, r1, r2 :: p
+    q1 = lerp @v t p0 p1
+    s  = lerp @v t p1 p2
+    r2 = lerp @v t p2 p3
+    q2 = lerp @v t q1 s
+    r1 = lerp @v t s  r2
+    pt = lerp @v t q2 r1

src/lib/Math/Bezier/Quadratic.hs

@@ -14,6 +14,7 @@
 module Math.Bezier.Quadratic
   ( Bezier(..)
   , bezier, bezier'
+  , subdivide
   )
   where
 
@@ -46,10 +47,6 @@ data Bezier p
     }
   deriving stock ( Show, Generic, Functor, Foldable, Traversable )
 
-instance Module r p => Module r ( Bezier p ) where
-  ( Bezier p0 p1 p2 ) ^+^ ( Bezier q0 q1 q2 ) = Bezier ( p0 ^+^ q0 ) ( p1 ^+^ q1 ) ( p2 ^+^ q2 )
-  r *^ bz = fmap ( r *^ ) bz
-
 -- | Quadratic Bézier curve.
 bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
 bezier ( Bezier { .. } ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
@@ -57,3 +54,12 @@ bezier ( Bezier { .. } ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
 -- | Derivative of quadratic Bézier curve.
 bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
 bezier' ( Bezier { .. } ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
+
+-- | Subdivide a quadratic Bézier curve into two parts.
+subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
+subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
+  where
+    pt, q1, r1 :: p
+    q1 = lerp @v t p0 p1
+    r1 = lerp @v t p1 p2
+    pt = lerp @v t q1 r1