basic rendering, mousewheel scrolling

This commit is contained in:
sheaf 2020-08-10 16:38:27 +02:00
parent 8e051c0f14
commit 9fc7b8acb3
8 changed files with 467 additions and 95 deletions

View file

@ -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

View file

@ -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
Exists :: c a => a -> Exists c

View file

@ -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

View file

@ -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
}
-}
deriving stock Show
data Stroke
= Stroke
{ strokePoints :: ![ Point2D Double ] }
deriving stock Show

View file

@ -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

View file

@ -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 ()

View file

@ -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

View file

@ -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 )
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