mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
start implementing brush mode
This commit is contained in:
sheaf
parent
e8c77befd6
commit
86a1426136
|
|
@ -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
|
||||
|
|
|
|||
54
app/Main.hs
54
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue