From 86a1426136379700b4b394009e6cd2bbe86d4af1 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 20 Aug 2020 03:57:26 +0200 Subject: [PATCH] start implementing brush mode --- MetaBrush.cabal | 6 +- app/Main.hs | 54 +++-- assets/theme.css | 8 +- src/app/MetaBrush/Asset/Colours.hs | 4 + src/app/MetaBrush/Document.hs | 22 +- src/app/MetaBrush/Document/Draw.hs | 6 +- src/app/MetaBrush/Document/Selection.hs | 50 ++-- src/app/MetaBrush/Render/Document.hs | 296 +++++++++++++++++------- src/app/MetaBrush/UI/Coordinates.hs | 2 +- src/app/MetaBrush/UI/ToolBar.hs | 20 +- 10 files changed, 323 insertions(+), 145 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 943f7fc..7d4f2c9 100644 --- a/MetaBrush.cabal +++ b/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 - >= 0.8.0.0 && < 0.8.4.0 - , groups-generic + groups-generic ^>= 0.1.0.0 executable MetaBrush diff --git a/app/Main.hs b/app/Main.hs index aaf3fe5..7c972ce 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# 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 = Seq.fromList +circle :: forall a. a -> Seq ( StrokePoint a) +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 p = PathPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty ) - cp p = ControlPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty ) + pp, cp :: Point2D Double -> StrokePoint a + pp p = PathPoint ( fmap ( * 100 ) p ) d + 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 diff --git a/assets/theme.css b/assets/theme.css index a689e38..58acf1c 100644 --- a/assets/theme.css +++ b/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); } diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index 4ad9020..506dba9 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/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 ] diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 85ccd54..de8b84f 100644 --- a/src/app/MetaBrush/Document.hs +++ b/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(..) - , selection + , PointData(..), BrushPointData(..) + , 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 = field' @"pointData" . field' @"pointState" +_selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState +_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 diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 271ad0d..a73dfa7 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/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 ) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index cd7ae23..52dd052 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/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" . traverse ) - ( updatePoint strokeVisible ) - stroke + ( field' @"strokePoints" ) + ( traverse ( updatePoint strokeVisible ) + >>> fmap matchEndpoints + ) + 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 - _ -> set selection Selected pt + Subtract -> set _selection Normal 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" . traverse ) - ( updatePoint strokeVisible ) - stroke + ( field' @"strokePoints" ) + ( traverse ( updatePoint strokeVisible ) + >>> fmap matchEndpoints + ) + 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 - _ -> set selection Selected pt + Subtract -> set _selection Normal 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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index ec8ff63..e70a079 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# 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(..) - , selection + , Stroke(..), FocusState(..) + , 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 - { mkRenderPoints :: a - , mkRenderPaths :: a + = Renders + { renderPath :: 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 - pure a = MkRenders a a - MkRenders f1 f2 <*> MkRenders a1 a2 = MkRenders ( f1 a1 ) ( f2 a2 ) +blank :: Renders ( Cairo.Render () ) +blank = pure ( pure () ) -{-# COMPLETE Renders #-} -pattern Renders :: Cairo.Render a -> Cairo.Render a -> Compose Renders Cairo.Render a -pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints renderPaths ) +compositeRenders :: Renders ( Cairo.Render () ) -> Cairo.Render () +compositeRenders = sequenceA_ + +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 - rdrPoints + + for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mode zoomFactor ) renderSelectionRect Cairo.restore pure () -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 - go :: StrokePoint PointData -> Seq ( StrokePoint PointData ) -> Compose Renders Cairo.Render () - go _ Empty = 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 () +renderStroke :: Colours -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render () +renderStroke cols mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) + | strokeVisible + = renderContent Path cols mode zoom pts + | otherwise + = 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 { path, controlPoint } ) zoom p1 p2 = do +drawLine :: Colours -> Mode -> Double -> StrokePoint d -> StrokePoint d -> Cairo.Render () +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 ) - withRGBA path Cairo.setSourceRGBA + Cairo.setLineWidth ( sz / zoom ) + 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 { path } ) zoom +drawQuadraticBezier :: Colours -> Mode -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render () +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 ) - withRGBA path Cairo.setSourceRGBA + Cairo.setLineWidth ( sz / zoom ) + withRGBA col Cairo.setSourceRGBA Cairo.stroke Cairo.restore -drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render () -drawCubicBezier ( Colours { path } ) zoom +drawCubicBezier :: Colours -> Mode -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render () +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 ) - withRGBA path Cairo.setSourceRGBA + Cairo.setLineWidth ( sz / zoom ) + 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 diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 0f4391a..43d5b08 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/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 } ) diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index f9acbe4..11a7908 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/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 toolTVar modeTVar colours toolBar = do +createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.DrawingArea -> GTK.Box -> IO ToolBar +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 - ( STM.atomically $ STM.writeTVar modeTVar Path ) - _ <- GTK.onButtonClicked brushTool - ( STM.atomically $ STM.writeTVar modeTVar Brush ) - _ <- GTK.onButtonClicked metaTool - ( STM.atomically $ STM.writeTVar modeTVar Meta ) + _ <- GTK.onButtonClicked pathTool do + STM.atomically $ STM.writeTVar modeTVar Path + GTK.widgetQueueDraw drawingArea + _ <- GTK.onButtonClicked brushTool do + STM.atomically $ STM.writeTVar modeTVar Brush + 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