hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

highlight points for hover/selection

Browse source
This commit is contained in:
sheaf 2020-08-13 19:05:19 +02:00
parent ae0ac23910
commit 8d50c92ca9
10 changed files with 268 additions and 101 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -8,3 +8,4 @@ refs/
*.txt
*.md
*.html
hie.yaml

40
app/Main.hs
View file

@ -56,9 +56,8 @@ import MetaBrush.Asset.Colours
import MetaBrush.Asset.Logo
( drawLogo )
import MetaBrush.Document
( Document(..)
, AABB(..)
, Stroke(..)
( Document(..), AABB(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
)
import MetaBrush.Event
( handleEvents )
@ -88,10 +87,28 @@ testDocuments = IntMap.fromList
{ displayName = "Document 1"
, filePath = Nothing
, unsavedChanges = False
, strokes = [ Stroke [ Point2D 0 0 ]
, Stroke [ Point2D 100 0, Point2D 105 0, Point2D 110 0 ]
, Stroke [ Point2D 0 100 ]
, Stroke [ Point2D 100 100, Point2D 105 105, Point2D 110 100 ]
, strokes = [ Stroke
[ StrokePoint ( Point2D 0 0 ) PathPoint Normal ]
"Stroke1"
False
, Stroke
[ StrokePoint ( Point2D 100 0 ) PathPoint Hover
, StrokePoint ( Point2D 105 0 ) ControlPoint Normal
, StrokePoint ( Point2D 110 0 ) PathPoint Selected
]
"Stroke2"
True
, Stroke
[ StrokePoint ( Point2D 0 100 ) PathPoint Normal ]
"Stroke3"
True
, Stroke
[ StrokePoint ( Point2D 100 100 ) PathPoint Normal
, StrokePoint ( Point2D 105 105 ) ControlPoint Selected
, StrokePoint ( Point2D 110 100 ) PathPoint Normal
]
"Stroke4"
True
]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
, viewportCenter = Point2D 50 50
@ -101,7 +118,14 @@ testDocuments = IntMap.fromList
{ displayName = "Document 2"
, filePath = Nothing
, unsavedChanges = True
, strokes = [ Stroke [ Point2D 0 0, Point2D 10 10, Point2D 20 20 ] ]
, strokes = [ Stroke
[ StrokePoint ( Point2D 0 0 ) PathPoint Normal
, StrokePoint ( Point2D 10 10 ) ControlPoint Normal
, StrokePoint ( Point2D 20 20 ) PathPoint Normal
]
"Stroke1"
True
]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
, viewportCenter = Point2D 10 10
, zoomFactor = 0.25

6
assets/theme.css
View file

@ -45,6 +45,12 @@
.brushStroke {
color: rgb(235,118,219);
}
.pointHover {
color: rgb(225,225,225);
}
.pointSelected {
color: rgb(252,237,120);
}
.viewport {
background-color: rgb(236, 223, 210);
-GtkWidget-window-dragging: false;

4
src/app/MetaBrush/Asset/Colours.hs
View file

@ -44,6 +44,8 @@ data ColourRecord a
, controlPointOutline :: !a
, path :: !a
, brushStroke :: !a
, pointHover :: !a
, pointSelected :: !a
, viewport :: !a
, viewportScrollbar :: !a
, tabScrollbar :: !a
@ -81,6 +83,8 @@ colourNames = Colours
, controlPointOutline = ColourName "controlPointStroke" Colour [ GTK.StateFlagsNormal ]
, path = ColourName "path" Colour [ GTK.StateFlagsNormal ]
, brushStroke = ColourName "brushStroke" Colour [ GTK.StateFlagsNormal ]
, pointHover = ColourName "pointHover" Colour [ GTK.StateFlagsNormal ]
, pointSelected = ColourName "pointSelected" Colour [ GTK.StateFlagsNormal ]
, viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ]
, viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]

23
src/app/MetaBrush/Document.hs
View file

@ -47,9 +47,30 @@ data Document
data Stroke
= Stroke
{ strokePoints :: ![ Point2D Double ] }
{ strokePoints :: ![ StrokePoint ]
, strokeName :: !Text
, strokeVisible :: !Bool
}
deriving stock Show
data StrokePoint
= StrokePoint
{ strokePoint :: !( Point2D Double )
, pointType :: !PointType
, pointState :: !FocusState
}
deriving stock Show
data PointType
= PathPoint
| ControlPoint
deriving stock Show
data FocusState
= Normal
| Hover
| Selected
deriving stock Show
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do

17
src/app/MetaBrush/Event.hs
View file

@ -11,6 +11,9 @@ import Control.Monad
( unless )
import Data.Foldable
( for_ )
-- base
import Data.Semigroup
( Arg(..), Min(..) )
import Data.Word
( Word32 )
@ -48,7 +51,7 @@ import Math.Vector2D
import MetaBrush.Document
( Document(..), currentDocument )
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
( closestPoint, toViewportCoordinates )
import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar )
@ -78,8 +81,10 @@ handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewpor
handleMotionEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> GTK.DrawingArea -> InfoBar -> GDK.EventMotion -> IO Bool
handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar eventMotion = do
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
for_ mbDoc \ ( Document { .. } ) -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc@( Document { .. } ) -> do
----------------------------------------------------------
-- Update mouse position in info bar on mouse move event.
@ -91,17 +96,19 @@ handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoB
let
toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double
pos = toViewport ( Point2D x y )
infoData :: InfoData
infoData =
InfoData
{ zoom = zoomFactor
, mousePos = toViewport ( Point2D x y )
, mousePos = pos
, topLeftPos = toViewport ( Point2D 0 0 )
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
}
updateInfoBar infoBar infoData
pure False
pure True
handleScrollEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.DrawingArea -> InfoBar -> GDK.EventScroll -> IO Bool
handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar scrollEvent = do

177
src/app/MetaBrush/Render/Document.hs
View file

@ -1,5 +1,8 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
module MetaBrush.Render.Document
@ -7,8 +10,10 @@ module MetaBrush.Render.Document
where
-- base
import Control.Monad
( when )
import Data.Foldable
( traverse_ )
import Data.Functor.Compose
( Compose(..) )
import Data.Int
( Int32 )
@ -16,6 +21,8 @@ import Data.Int
import qualified GI.Cairo.Render as Cairo
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) )
import Math.Vector2D
@ -23,12 +30,31 @@ import Math.Vector2D
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Document
( Document(..), Stroke(..) )
( Document(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
)
import MetaBrush.Render.Util
( withRGBA )
--------------------------------------------------------------------------------
data Renders a
= MkRenders
{ mkRenderPoints :: a
, mkRenderPaths :: a
}
deriving stock ( Show, Functor )
instance Applicative Renders where
pure a = MkRenders a a
MkRenders f1 f2 <*> MkRenders a1 a2 = MkRenders ( f1 a1 ) ( f2 a2 )
{-# COMPLETE Renders #-}
pattern Renders :: Cairo.Render a -> Cairo.Render a -> Compose Renders Cairo.Render a
pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints renderPaths )
--------------------------------------------------------------------------------
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render ()
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do
@ -38,49 +64,63 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente
Cairo.translate ( -cx ) ( -cy )
let
( renderPoints, renderPath ) = renderStrokes cols zoomFactor strokes
renderPath
Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes
renderPaths
renderPoints
Cairo.restore
pure ()
renderStrokes :: Colours -> Double -> [ Stroke ] -> ( Cairo.Render (), Cairo.Render () )
renderStrokes _ _ [] = ( pure (), pure () )
renderStrokes cols zoom ( s : ss ) = ( points1 *> points2, path1 *> path2 )
renderStroke :: Colours -> Double -> Stroke -> Compose Renders Cairo.Render ()
renderStroke cols zoom ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } )
= go pt0 pts *> Renders { renderPoints = drawPoint cols zoom pt0, renderPaths = pure () }
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
drawControl cols zoom p1
drawLine cols zoom p0 p1
drawLine cols zoom p1 p2
when drawFirstPoint ( drawPoint cols zoom p0 )
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
go :: StrokePoint -> [ StrokePoint ] -> Compose Renders Cairo.Render ()
go _ [] = pure ()
-- Line.
go p0 ( p1 : ps )
| PathPoint <- pointType 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 <- pointType p1
, PathPoint <- pointType 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 ( fmap strokePoint $ Quadratic.Bezier { p0, p1, p2 } )
}
*> go p2 ps
-- Cubic Bézier curve.
go p0 ( p1 : p2 : p3 : ps )
| ControlPoint <- pointType p1
, ControlPoint <- pointType p1
, PathPoint <- pointType 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 ( fmap strokePoint $ Cubic.Bezier { p0, p1, p2, p3 } )
}
*> go p2 ps
go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 : ps )
renderStroke _ _ _ = pure ()
drawPoint :: Colours -> Double -> StrokePoint -> Cairo.Render ()
drawPoint ( Colours { .. } ) zoom
( StrokePoint { strokePoint = Point2D x y, pointType = PathPoint, pointState } )
= do
let
hsqrt3 :: Double
hsqrt3 = sqrt 0.75
@ -97,16 +137,23 @@ drawPoint ( Colours { pathPoint, pathPointOutline } ) zoom ( Point2D x y ) = do
Cairo.lineTo 0.5 (-hsqrt3)
Cairo.closePath
Cairo.setLineWidth 0.8
withRGBA pathPointOutline Cairo.setSourceRGBA
Cairo.setLineWidth 1.0
case pointState of
Normal -> withRGBA pathPointOutline Cairo.setSourceRGBA
_ -> withRGBA pathPoint Cairo.setSourceRGBA
Cairo.strokePreserve
withRGBA pathPoint Cairo.setSourceRGBA
case pointState of
Normal -> withRGBA pathPoint Cairo.setSourceRGBA
Hover -> withRGBA pointHover Cairo.setSourceRGBA
Selected -> withRGBA pointSelected Cairo.setSourceRGBA
Cairo.fill
Cairo.restore
drawControl ( Colours { controlPoint, controlPointOutline } ) zoom ( Point2D x y ) = do
drawPoint ( Colours { .. } ) zoom
( StrokePoint { strokePoint = Point2D x y, pointType = ControlPoint, pointState } )
= do
Cairo.save
Cairo.translate x y
@ -114,22 +161,38 @@ drawControl ( Colours { controlPoint, controlPointOutline } ) zoom ( Point2D x y
Cairo.arc 0 0 1 0 ( 2 * pi )
Cairo.setLineWidth 0.8
withRGBA controlPointOutline Cairo.setSourceRGBA
Cairo.setLineWidth 1.0
case pointState of
Normal -> withRGBA controlPointOutline Cairo.setSourceRGBA
_ -> withRGBA controlPoint Cairo.setSourceRGBA
Cairo.strokePreserve
case pointState of
Normal -> withRGBA controlPoint Cairo.setSourceRGBA
Hover -> withRGBA pointHover Cairo.setSourceRGBA
Selected -> withRGBA pointSelected Cairo.setSourceRGBA
Cairo.fill
withRGBA controlPoint Cairo.setSourceRGBA
Cairo.fill
Cairo.restore
drawLine :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
drawLine ( Colours { controlPoint } ) zoom ( Point2D x1 y1 ) ( Point2D x2 y2 ) = do
drawLine :: Colours -> Double -> StrokePoint -> StrokePoint -> Cairo.Render ()
drawLine ( Colours { path, controlPoint } ) zoom
( StrokePoint { strokePoint = Point2D x1 y1, pointType = ty1 } )
( StrokePoint { strokePoint = Point2D x2 y2, pointType = ty2 } )
= do
Cairo.save
Cairo.moveTo x1 y1
Cairo.lineTo x2 y2
case ( ty1, ty2 ) of
( PathPoint, PathPoint ) -> do
Cairo.setLineWidth ( 6 / zoom )
withRGBA path Cairo.setSourceRGBA
_ -> do
Cairo.setLineWidth ( 3 / zoom )
withRGBA controlPoint Cairo.setSourceRGBA
Cairo.stroke
@ -159,3 +222,25 @@ drawQuadraticBezier ( Colours { path } ) zoom
Cairo.stroke
Cairo.restore
drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
drawCubicBezier ( Colours { path } ) zoom
( Cubic.Bezier
{ p0 = Point2D x0 y0
, p1 = Point2D x1 y1
, p2 = Point2D x2 y2
, p3 = Point2D x3 y3
}
)
= do
Cairo.save
Cairo.moveTo x0 y0
Cairo.curveTo x1 y1 x2 y2 x3 y3
Cairo.setLineWidth ( 6 / zoom )
withRGBA path Cairo.setSourceRGBA
Cairo.stroke
Cairo.restore

30
src/app/MetaBrush/UI/Coordinates.hs
View file

@ -1,7 +1,14 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.Coordinates
( toViewportCoordinates )
( toViewportCoordinates, closestPoint )
where
-- base
import Data.Semigroup
( ArgMin, Arg(..), Min(..) )
-- acts
import Data.Act
( Act
@ -11,14 +18,33 @@ import Data.Act
)
-- MetaBrush
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint )
import Math.Module
( (*^) )
( (*^), squaredNorm )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Stroke(..) )
--------------------------------------------------------------------------------
-- | Convert a position relative to the drawing area into viewport coordinates.
toViewportCoordinates :: Double -> ( Double, Double ) -> Point2D Double -> Point2D Double -> Point2D Double
toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( Point2D x y )
= ( recip zoomFactor *^ ( Point2D ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> Point2D x y :: Vector2D Double ) )
• viewportCenter
-- | Find the closest point in a set of strokes.
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Point2D Double )
closestPoint = undefined
{-
closestPoint c ( Stroke pts ) = go pts
where
go :: [ Point2D Double ] -> ArgMin Double ( Point2D Double )
go [] = error "'closestPoint': empty stroke"
go [p] = Min ( Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) p )
go (p0:p1:p2:ps)
= fmap ( fmap snd ) ( Quadratic.closestPoint @(Vector2D Double) ( Quadratic.Bezier { .. } ) c )
<> go (p2:ps)
-}

9
src/app/MetaBrush/UI/Panels.hs
View file

@ -11,19 +11,10 @@ import Control.Monad
import Data.Foldable
( for_ )
-- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo
( renderWithContext )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
-- gi-gtk
import qualified GI.Gtk as GTK
-- MetaBrush
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Render.Util
( widgetAddClass, widgetAddClasses )

10
src/lib/Math/Bezier/Quadratic.hs
View file

@ -20,6 +20,8 @@ module Math.Bezier.Quadratic
-- base
import Data.List.NonEmpty
( NonEmpty(..) )
import Data.Semigroup
( ArgMin, Min(..), Arg(..) )
import GHC.Generics
( Generic )
@ -69,7 +71,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
pt = lerp @v t q1 r1
-- | Finds the closest point to a given point on a quadratic Bézier curve.
closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ( r, p )
closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p )
closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
where
roots :: [ r ]
@ -83,17 +85,17 @@ closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
a0, a1, a2, a3 :: r
a0 = v ^.^ v'
a1 = v ^.^ v'' + 2 * squaredNorm v'
a2 = 3 * ( v' ^.^ v'' )
a2 = 3 * v' ^.^ v''
a3 = squaredNorm v''
pickClosest :: NonEmpty r -> ( r, p )
pickClosest :: NonEmpty r -> ArgMin r ( r, p )
pickClosest ( s :| ss ) = go s q nm0 ss
where
q :: p
q = bezier @v pts s
nm0 :: r
nm0 = squaredNorm ( c --> q :: v )
go t p _ [] = ( t, p )
go t p nm [] = Min ( Arg nm ( t, p ) )
go t p nm ( t' : ts )
| nm' < nm = go t' p' nm' ts
| otherwise = go t p nm ts