diff --git a/MetaBrush.cabal b/MetaBrush.cabal index d302330..cc194cc 100644 --- a/MetaBrush.cabal +++ b/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 - ^>= 0.3.1.0 - , generic-data + 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 diff --git a/app/Main.hs b/app/Main.hs index b6fb628..29ad652 100644 --- a/app/Main.hs +++ b/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,9 +713,9 @@ main = do then GTK.windowUnmaximize window else GTK.windowMaximize window - _ <- GTK.onWidgetKeyPressEvent window handleKeyboardPressEvent - _ <- GTK.onWidgetKeyReleaseEvent window handleKeyboardReleaseEvent - _ <- GTK.onWidgetDestroy window GTK.mainQuit + _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar ) + _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) + _ <- GTK.onWidgetDestroy window GTK.mainQuit --------------------------------------------------------- -- GTK main loop @@ -580,6 +725,8 @@ main = do exitSuccess +--------------------------------------------------------- +-- Utils. data Exists c where - Exists :: c a => a -> Exists c \ No newline at end of file + Exists :: c a => a -> Exists c diff --git a/cabal.project b/cabal.project index be0cafa..6132e2d 100644 --- a/cabal.project +++ b/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 diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index e6ca575..85c990e 100644 --- a/src/app/MetaBrush/Document.hs +++ b/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 :: !(Set Stroke) + , strokes :: ![ Stroke ] + , bounds :: !AABB + , viewportCenter :: !( Point2D Double ) + , zoomFactor :: !Double } --} \ No newline at end of file + deriving stock Show + +data Stroke + = Stroke + { strokePoints :: ![ Point2D Double ] } + deriving stock Show diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 4da5e5b..4a61d37 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -1,8 +1,11 @@ -module MetaBrush.Event - ( handleKeyboardPressEvent - , handleKeyboardReleaseEvent - ) - where +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +module MetaBrush.Event 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 evt = do +handleKeyboardPressEvent, handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool +handleKeyboardPressEvent pressedKeysTVar evt = do keyCode <- GDK.getEventKeyKeyval evt case keyCode of - -- escape - 0xff1b -> GTK.mainQuit - _ -> pure () + Escape -> GTK.mainQuit + _ -> STM.atomically do + 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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs new file mode 100644 index 0000000..c17f00e --- /dev/null +++ b/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 () diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index e74d871..7b2d3f8 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/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 diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index ba651cc..8a4cbe5 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/lib/Math/Bezier/Quadratic.hs @@ -14,6 +14,7 @@ module Math.Bezier.Quadratic ( Bezier(..) , bezier, bezier' + , subdivide ) where @@ -46,14 +47,19 @@ 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 ) -- | 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 ) \ No newline at end of file +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