hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

split out stroke code to library

Browse source
This commit is contained in:
sheaf 2020-08-19 23:34:43 +02:00
parent e044b1b06c
commit e8c77befd6
12 changed files with 282 additions and 239 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
MetaBrush.cabal
View file

@ -30,6 +30,8 @@ common common
>= 4.13 && < 4.16
, acts
^>= 0.3.1.0
, containers
>= 0.6.0.1 && < 0.6.4
, groups
^>= 0.4.1.0
@ -59,7 +61,7 @@ library
exposed-modules:
Math.Bezier.Cubic
, Math.Bezier.Quadratic
--, Math.Bezier.Stroke
, Math.Bezier.Stroke
, Math.Bezier.Subdivision
, Math.Epsilon
, Math.Module
@ -92,9 +94,6 @@ executable MetaBrush
, MetaBrush.Asset.TickBox
, MetaBrush.Asset.Tools
, MetaBrush.Asset.WindowIcons
-- temporarily here
, MetaBrush.Bezier.Stroke
--
, MetaBrush.Document
, MetaBrush.Document.Draw
, MetaBrush.Document.Selection
@ -121,8 +120,6 @@ executable MetaBrush
build-depends:
MetaBrush
, containers
>= 0.6.0.1 && < 0.6.4
, directory
>= 1.3.4.0 && < 1.4
--, fingertree
@ -143,6 +140,8 @@ executable MetaBrush
^>= 0.0.1
, haskell-gi-base
^>= 0.24
, lens
^>= 4.19.2
, stm
^>= 2.5.0.0
, tardis

17
app/Main.hs
View file

@ -25,7 +25,7 @@ import Data.IntMap.Strict
import qualified Data.IntMap.Strict as IntMap
( fromList )
import Data.Sequence
( Seq )
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
@ -52,6 +52,8 @@ import qualified Data.Text as Text
( pack )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D
( Point2D(..) )
import MetaBrush.Asset.Colours
@ -59,9 +61,8 @@ import MetaBrush.Asset.Colours
import MetaBrush.Asset.Logo
( drawLogo )
import MetaBrush.Document
( Document(..), AABB(..)
, Stroke(..), StrokePoint(..)
, PointType(..), FocusState(..)
( Document(..), AABB(..), Stroke(..)
, PointData(..), FocusState(..)
, currentDocument
)
import MetaBrush.Event
@ -114,7 +115,7 @@ testDocuments = IntMap.fromList
}
]
circle :: Seq StrokePoint
circle :: Seq ( StrokePoint PointData )
circle = Seq.fromList
[ pp ( Point2D 0 1 )
, cp ( Point2D a 1 )
@ -133,9 +134,9 @@ circle = Seq.fromList
where
a :: Double
a = 0.551915024494
pp, cp :: Point2D Double -> StrokePoint
pp p = StrokePoint ( fmap ( * 100 ) p ) PathPoint Normal
cp p = StrokePoint ( fmap ( * 100 ) p ) ControlPoint Normal
pp, cp :: Point2D Double -> StrokePoint PointData
pp p = PathPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty )
cp p = ControlPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty )
--------------------------------------------------------------------------------

4
assets/theme.css
View file

@ -72,10 +72,10 @@
.glass {
color: rgba(156, 231, 255, 0.5);
}
.selection {
.selected {
color: rgba(161,201,236,0.5)
}
.selectionOutline {
.selectedOutline {
color: rgb(74,150,218);
}

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

@ -51,8 +51,8 @@ data ColourRecord a
, tabScrollbar :: !a
, magnifier :: !a
, glass :: !a
, selection :: !a
, selectionOutline :: !a
, selected :: !a
, selectedOutline :: !a
}
deriving stock ( Show, Functor, Foldable, Traversable )
@ -92,8 +92,8 @@ colourNames = Colours
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ]
, selection = ColourName "selection" Colour [ GTK.StateFlagsNormal ]
, selectionOutline = ColourName "selectionOutline" Colour [ GTK.StateFlagsNormal ]
, selected = ColourName "selected" Colour [ GTK.StateFlagsNormal ]
, selectedOutline = ColourName "selectedOutline" Colour [ GTK.StateFlagsNormal ]
}
type Colours = ColourRecord GDK.RGBA

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

@ -1,13 +1,16 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document
( AABB(..)
, Document(..), currentDocument
, Stroke(..), StrokePoint(..), PointType(..)
, FocusState(..)
, Stroke(..)
, PointData(..), FocusState(..)
, selection
)
where
@ -21,6 +24,14 @@ import Data.Sequence
import GHC.Generics
( Generic )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( Lens' )
-- text
import Data.Text
( Text )
@ -32,6 +43,8 @@ import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D
( Point2D )
import MetaBrush.Unique
@ -60,32 +73,29 @@ data Document
data Stroke
= Stroke
{ strokePoints :: !( Seq StrokePoint )
{ strokePoints :: !( Seq ( StrokePoint PointData ) )
, strokeName :: Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
}
deriving stock ( Show, Generic )
data StrokePoint
= StrokePoint
{ strokePoint :: !( Point2D Double )
, pointType :: !PointType
, pointState :: FocusState -- needs to be lazy for drag selection code
data PointData
= PointData
{ pointState :: FocusState
, brush :: Seq ( StrokePoint () )
}
deriving stock ( Show, Generic )
data PointType
= PathPoint
| ControlPoint
deriving stock ( Show, Eq )
data FocusState
= Normal
| Hover
| Selected
deriving stock ( Show, Eq )
selection :: Lens' ( StrokePoint PointData ) FocusState
selection = field' @"pointData" . field' @"pointState"
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar

32
src/app/MetaBrush/Document/Draw.hs
View file

@ -25,11 +25,13 @@ import qualified Data.Sequence as Seq
( singleton, reverse, take, drop, length )
-- generic-lens
import Data.GenericLens.Internal
( over )
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( set, over, mapped )
-- stm
import Control.Concurrent.STM
( STM )
@ -39,13 +41,15 @@ import Control.Monad.Trans.State.Strict
( State, runState, get, put )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module
( squaredNorm )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Stroke(..), StrokePoint(..)
, PointType(..), FocusState(..)
( Document(..), Stroke(..), FocusState(..), PointData(..)
, selection
)
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText )
@ -80,7 +84,7 @@ getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
newDoc' =
over ( field' @"strokes" )
( Stroke
( Seq.singleton $ StrokePoint c PathPoint Normal )
( Seq.singleton $ PathPoint c ( PointData Normal Empty ) )
( "Stroke " <> uniqueText uniq )
True
uniq
@ -102,30 +106,28 @@ getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
| strokeVisible
, Just anchor <- endpointAnchor strokeUnique strokePoints
-> put ( Just anchor )
$> over ( field' @"strokePoints" ) ( fmap deselectPoint ) stroke
$> set ( field' @"strokePoints" . mapped . selection ) Normal stroke
-- Otherwise, just deselect.
_ -> pure $ over ( field' @"strokePoints" ) ( fmap deselectPoint ) 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 -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor _ ( StrokePoint p0 PathPoint _ :<| ( _ :|> StrokePoint pn PathPoint _ ) )
endpointAnchor :: Unique -> Seq ( StrokePoint PointData ) -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor _ ( PathPoint { coords = p0 } :<| ( _ :|> PathPoint { coords = pn } ) )
| p0 == pn
= Nothing
endpointAnchor uniq ( StrokePoint p0 PathPoint _ :<| _ )
endpointAnchor uniq (PathPoint { coords = p0 } :<| _ )
| inPointClickRange p0
= Just ( AnchorAtStart uniq, p0 )
endpointAnchor uniq ( _ :|> StrokePoint pn PathPoint _ )
endpointAnchor uniq ( _ :|> PathPoint { coords = pn } )
| inPointClickRange pn
= Just ( AnchorAtEnd uniq, pn )
endpointAnchor _ _ = Nothing
deselectPoint :: StrokePoint -> StrokePoint
deselectPoint pt = pt { pointState = Normal }
inPointClickRange :: Point2D Double -> Bool
inPointClickRange p =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
addToAnchor :: DrawAnchor -> Seq StrokePoint -> Document -> Document
addToAnchor anchor newPts = over ( field' @"strokes" ) ( fmap addToStroke )
addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document
addToAnchor anchor newPts = over ( field' @"strokes" . mapped ) addToStroke
where
addToStroke :: Stroke -> Stroke
addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } )

153
src/app/MetaBrush/Document/Selection.hs
View file

@ -33,11 +33,13 @@ import Data.Sequence
( Seq(..) )
-- generic-lens
import Data.GenericLens.Internal
( over )
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( view, set, over, mapped )
-- tardis
import Control.Monad.Trans.Tardis
( Tardis )
@ -51,13 +53,16 @@ import Control.Monad.Trans.State.Strict
( State, evalState, get, put )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module
( squaredNorm )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Stroke(..), StrokePoint(..)
, PointType(..), FocusState(..)
( Document(..), Stroke(..)
, PointData(..), FocusState(..)
, selection
)
import MetaBrush.Event.KeyCodes
( pattern Alt_L , pattern Alt_R
@ -98,29 +103,29 @@ selectAt mode c doc@( Document { zoomFactor } ) =
updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" ) matchEndpoints <$>
field' @"strokePoints"
( traverse ( updatePoint strokeVisible ) )
( field' @"strokePoints" . traverse )
( updatePoint strokeVisible )
stroke
updatePoint :: Bool -> StrokePoint -> State Bool StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = p } ) = do
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 -> pt { pointState = Normal }
_ -> pt { pointState = Selected }
Subtract -> set selection Normal pt
_ -> set selection Selected pt
else pure $ case mode of
New -> pt { pointState = Normal }
New -> set selection Normal pt
_ -> pt
where
selected :: Bool
selected
| not isVisible = False
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
| otherwise = squaredNorm ( c --> coords pt :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
-- Ensure consistency of selection at endpoints for closed loops.
matchEndpoints :: Seq StrokePoint -> Seq StrokePoint
matchEndpoints :: Seq ( StrokePoint PointData ) -> Seq ( StrokePoint PointData )
matchEndpoints ( p0 :<| ( ps :|> pn ) )
| strokePoint p0 == strokePoint pn
= p0 :<| ( ps :|> pn { pointState = pointState p0 } )
| coords p0 == coords pn
= p0 :<| ( ps :|> set selection ( view selection p0 ) pn )
matchEndpoints ps = ps
-- | Type of a drag move selection:
@ -150,11 +155,11 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" ) matchEndpoints <$>
field' @"strokePoints"
( traverse ( updatePoint strokeVisible ) )
( field' @"strokePoints" . traverse )
( updatePoint strokeVisible )
stroke
updatePoint :: Bool -> StrokePoint -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = p, pointState = oldFocusState } )
updatePoint :: Bool -> StrokePoint PointData -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ( StrokePoint PointData )
updatePoint isVisible pt
| selected
= do
mbPreviousSelect <- Tardis.getPast
@ -163,11 +168,11 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
Just _ -> pure pt
-- First click on a point: record this.
Nothing -> do
case oldFocusState of
case pointState ( pointData pt ) of
Selected -> Tardis.sendFuture ( Just ClickedOnSelected )
_ -> Tardis.sendFuture ( Just ClickedOnUnselected )
-- Select this point (whether it was previously selected or not).
pure $ pt { pointState = Selected }
pure $ set selection Selected pt
| otherwise
= do
mbDragClick <- Tardis.getFuture
@ -177,44 +182,46 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
newPointState
-- User clicked on a selected point: preserve selection.
| Just ClickedOnSelected <- mbDragClick
= pointState pt
= view selection pt
-- User clicked on an unselected point, or not on a point at all: discard selection.
| otherwise
= Normal
pure ( pt { pointState = newPointState } )
pure ( set selection newPointState pt )
where
selected :: Bool
selected
| not isVisible = False
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
| otherwise = squaredNorm ( c --> coords pt :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
-- Ensure consistency of selection at endpoints for closed loops.
matchEndpoints :: Seq StrokePoint -> Seq StrokePoint
matchEndpoints :: Seq ( StrokePoint PointData ) -> Seq ( StrokePoint PointData )
matchEndpoints ( p0 :<| ( ps :|> pn ) )
| strokePoint p0 == strokePoint pn
= p0 :<| ( ps :|> pn { pointState = pointState p0 } )
| coords p0 == coords pn
= p0 :<| ( ps :|> set selection ( view selection p0 ) pn )
matchEndpoints ps = ps
-- | Updates the selected objects on a rectangular selection event.
selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" ) ( fmap updateStroke )
selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" . mapped ) updateStroke
where
xMin, xMax, yMin, yMax :: Double
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
updateStroke :: Stroke -> Stroke
updateStroke stroke@( Stroke { strokeVisible } ) =
over ( field' @"strokePoints" )
( fmap ( updatePoint strokeVisible ) )
over ( field' @"strokePoints" . mapped )
( updatePoint strokeVisible )
stroke
updatePoint :: Bool -> StrokePoint -> StrokePoint
updatePoint isVisible pt@( StrokePoint { strokePoint = Point2D x y } )
updatePoint :: Bool -> StrokePoint PointData -> StrokePoint PointData
updatePoint isVisible pt
| selected = case mode of
Subtract -> pt { pointState = Normal }
_ -> pt { pointState = Selected }
Subtract -> set selection Normal pt
_ -> set selection Selected pt
| otherwise = case mode of
New -> pt { pointState = Normal }
New -> set selection Normal pt
_ -> pt
where
x, y :: Double
Point2D x y = coords pt
selected :: Bool
selected
| not isVisible = False
@ -222,48 +229,52 @@ selectRectangle mode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strok
-- | Translate all selected points by the given vector.
translateSelection :: Vector2D Double -> Document -> Document
translateSelection t = over ( field' @"strokes" ) ( fmap updateStroke )
translateSelection t = over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped ) updateStrokePoint
where
updateStroke :: Stroke -> Stroke
updateStroke = over ( field' @"strokePoints" ) ( fmap updateStrokePoint )
updateStrokePoint :: StrokePoint -> StrokePoint
updateStrokePoint pt@( StrokePoint { strokePoint = p, pointState } )
| Selected <- pointState
= pt { strokePoint = t • p }
updateStrokePoint :: StrokePoint PointData -> StrokePoint PointData
updateStrokePoint pt
| Selected <- view selection pt
= pt { coords = t • coords pt }
| otherwise
= pt
-- | Delete the selected points.
deleteSelected :: Document -> Document
deleteSelected doc
deleteSelected
= fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) )
$ field' @"strokes"
( traverse $ field' @"strokePoints" updateStroke )
doc
. ( field' @"strokes" . traverse . field' @"strokePoints" )
updateStroke
where
updateStroke :: Seq StrokePoint -> Tardis Bool Bool ( Seq StrokePoint )
updateStroke :: Seq ( StrokePoint PointData ) -> Tardis Bool Bool ( Seq ( StrokePoint PointData ) )
updateStroke Empty = pure Empty
updateStroke ( StrokePoint { pointType = PathPoint, pointState = Selected } :<| ps ) = do
Tardis.sendPast True
Tardis.sendFuture True
updateStroke ps
updateStroke ( p@( StrokePoint { pointType = PathPoint } ) :<| ps ) = do
Tardis.sendPast False
Tardis.sendFuture False
( p :<| ) <$> updateStroke ps
updateStroke ( p@( StrokePoint { pointType = ControlPoint, pointState } ) :<| ps ) = do
prevPathPointDeleted <- Tardis.getPast
nextPathPointDeleted <- Tardis.getFuture
rest <- updateStroke ps
let
-- Control point must be deleted:
-- - if it is selected,
-- - if the previous path point was deleted,
-- - if the next path point is going to be deleted.
--
-- Need to be lazy in "nextPathPointDeleted" to avoid looping.
res :: Seq StrokePoint
res = if pointState == Selected || prevPathPointDeleted || nextPathPointDeleted
then rest
else p :<| rest
pure res
updateStroke ( p :<| ps ) = case p of
PathPoint {}
| Selected <- selectionState
-> do
Tardis.sendPast True
Tardis.sendFuture True
updateStroke ps
| otherwise
-> do
Tardis.sendPast False
Tardis.sendFuture False
( p :<| ) <$> updateStroke ps
_ -> do
prevPathPointDeleted <- Tardis.getPast
nextPathPointDeleted <- Tardis.getFuture
rest <- updateStroke ps
let
-- Control point must be deleted:
-- - if it is selected,
-- - if the previous path point was deleted,
-- - if the next path point is going to be deleted.
--
-- Need to be lazy in "nextPathPointDeleted" to avoid looping.
res :: Seq ( StrokePoint PointData )
res = if selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted
then rest
else p :<| rest
pure res
where
selectionState :: FocusState
selectionState = view selection p

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

@ -52,12 +52,14 @@ import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar, readTVarIO, writeTVar, swapTVar )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module
( (*^) )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), StrokePoint(..), PointType(..), FocusState(..) )
( Document(..), FocusState(..), PointData(..) )
import MetaBrush.Document.Draw
( DrawAnchor(..), getDrawAnchor, addToAnchor, anchorsAreComplementary )
import MetaBrush.Document.Selection
@ -477,20 +479,20 @@ handleMouseButtonRelease
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Seq StrokePoint
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( StrokePoint p1 PathPoint Normal )
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ StrokePoint cp ControlPoint Normal
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure $ StrokePoint cp ControlPoint Normal
, Just ( StrokePoint otherAnchorPt PathPoint Normal )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
]
pure ( addToAnchor anchor newSegment doc )
else
@ -503,20 +505,20 @@ handleMouseButtonRelease
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Seq StrokePoint
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( StrokePoint p1 PathPoint Normal )
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ StrokePoint cp ControlPoint Normal
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure $ StrokePoint cp ControlPoint Normal
, Just ( StrokePoint pathPoint PathPoint Normal )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
]
pure ( addToAnchor anchor newSegment doc )

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

@ -38,18 +38,25 @@ import qualified Data.Sequence as Seq
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
-- lens
import Control.Lens
( view )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) )
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Document
( Document(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, Stroke(..), PointData(..), FocusState(..)
, selection
)
import MetaBrush.Document.Selection
( translateSelection )
@ -118,20 +125,20 @@ renderDocument
= ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint
, let
previewPts :: Seq StrokePoint
previewPts :: Seq ( StrokePoint PointData )
previewPts
= Seq.fromList
$ catMaybes
[ Just ( StrokePoint p0 PathPoint Normal )
[ Just ( PathPoint p0 ( PointData Normal Empty ) )
, do
cp <- cp0
guard ( cp /= p0 )
pure $ StrokePoint cp ControlPoint Normal
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= finalPoint )
pure $ StrokePoint cp ControlPoint Normal
, Just ( StrokePoint finalPoint PathPoint Normal )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint finalPoint ( PointData Normal Empty ) )
]
= ( Stroke previewPts undefined True undefined ) : strokes doc
| otherwise
@ -149,11 +156,12 @@ 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 -> Seq StrokePoint -> Compose Renders Cairo.Render ()
go _ Empty = pure ()
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 <- pointType p1
| PathPoint {} <- p1
= Renders
{ renderPoints = drawPoint cols zoom p1
, renderPaths = drawLine cols zoom p0 p1
@ -161,22 +169,22 @@ renderStroke cols zoom ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = Tr
*> go p1 ps
-- Quadratic Bézier curve.
go p0 ( p1 :<| p2 :<| ps )
| ControlPoint <- pointType p1
, PathPoint <- pointType p2
| 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 ( strokePoint <$> Quadratic.Bezier { p0, p1, 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 <- pointType p1
, ControlPoint <- pointType p2
, PathPoint <- pointType p3
| ControlPoint {} <- p1
, ControlPoint {} <- p2
, PathPoint {} <- p3
= Renders
{ renderPoints
= drawLine cols zoom p0 p1
@ -184,19 +192,20 @@ renderStroke cols zoom ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = Tr
*> drawPoint cols zoom p1
*> drawPoint cols zoom p2
*> drawPoint cols zoom p3
, renderPaths = drawCubicBezier cols zoom ( strokePoint <$> Cubic.Bezier { p0, p1, p2, 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 ()
drawPoint :: Colours -> Double -> StrokePoint -> Cairo.Render ()
drawPoint ( Colours { .. } ) zoom
( StrokePoint { strokePoint = Point2D x y, pointType = PathPoint, pointState } )
drawPoint :: Colours -> Double -> StrokePoint PointData -> 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
Cairo.save
Cairo.translate x y
@ -211,12 +220,12 @@ drawPoint ( Colours { .. } ) zoom
Cairo.closePath
Cairo.setLineWidth 1.0
case pointState of
case selectionState of
Normal -> withRGBA pathPointOutline Cairo.setSourceRGBA
_ -> withRGBA pathPoint Cairo.setSourceRGBA
Cairo.strokePreserve
case pointState of
case selectionState of
Normal -> withRGBA pathPoint Cairo.setSourceRGBA
Hover -> withRGBA pointHover Cairo.setSourceRGBA
Selected -> withRGBA pointSelected Cairo.setSourceRGBA
@ -224,9 +233,11 @@ drawPoint ( Colours { .. } ) zoom
Cairo.restore
drawPoint ( Colours { .. } ) zoom
( StrokePoint { strokePoint = Point2D x y, pointType = ControlPoint, pointState } )
drawPoint ( Colours { .. } ) zoom pt@( ControlPoint { coords = Point2D x y } )
= do
let
selectionState :: FocusState
selectionState = view selection pt
Cairo.save
Cairo.translate x y
@ -235,12 +246,12 @@ drawPoint ( Colours { .. } ) zoom
Cairo.arc 0 0 1 0 ( 2 * pi )
Cairo.setLineWidth 1.0
case pointState of
case selectionState of
Normal -> withRGBA controlPointOutline Cairo.setSourceRGBA
_ -> withRGBA controlPoint Cairo.setSourceRGBA
Cairo.strokePreserve
case pointState of
case selectionState of
Normal -> withRGBA controlPoint Cairo.setSourceRGBA
Hover -> withRGBA pointHover Cairo.setSourceRGBA
Selected -> withRGBA pointSelected Cairo.setSourceRGBA
@ -251,18 +262,19 @@ drawPoint ( Colours { .. } ) zoom
Cairo.restore
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
drawLine :: Colours -> Double -> StrokePoint PointData -> StrokePoint PointData -> Cairo.Render ()
drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
let
x1, y1, x2, y2 :: Double
Point2D x1 y1 = coords p1
Point2D x2 y2 = coords p2
Cairo.save
Cairo.moveTo x1 y1
Cairo.lineTo x2 y2
case ( ty1, ty2 ) of
( PathPoint, PathPoint ) -> do
case ( p1, p2 ) of
( PathPoint {}, PathPoint {} ) -> do
Cairo.setLineWidth ( 6 / zoom )
withRGBA path Cairo.setSourceRGBA
_ -> do
@ -331,10 +343,10 @@ renderSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1
Cairo.closePath
Cairo.setLineWidth ( 1 / zoom )
withRGBA selection Cairo.setSourceRGBA
withRGBA selected Cairo.setSourceRGBA
Cairo.fillPreserve
withRGBA selectionOutline Cairo.setSourceRGBA
withRGBA selectedOutline Cairo.setSourceRGBA
Cairo.stroke
Cairo.restore

14
src/app/MetaBrush/Stroke.hs
View file

@ -1,14 +0,0 @@
module MetaBrush.Stroke where
--------------------------------------------------------------------------------
{-
data StrokePoint
= StrokePoint
{ center :: Point2D Double
,
newtype Stroke =
Stroke { strokePoints :: Seq (
-}

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

@ -26,12 +26,14 @@ import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint )
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module
( (*^), squaredNorm, closestPointToLine )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Stroke(..), StrokePoint(..), PointType(..) )
( Stroke(..), PointData(..) )
--------------------------------------------------------------------------------
@ -47,27 +49,25 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) =
where
res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
go :: StrokePoint -> Seq StrokePoint -> ArgMin Double ( Maybe ( Point2D Double ) )
go p0 Empty = res ( strokePoint p0 )
go :: StrokePoint PointData -> Seq ( StrokePoint PointData ) -> ArgMin Double ( Maybe ( Point2D Double ) )
go ( ControlPoint {} ) _ = error "closedPoint: path starts with a control point"
go p0 Empty = res ( coords p0 )
-- Line.
go p0 ( p1 :<| ps )
| PathPoint <- pointType p1
= res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) )
<> go p1 ps
go ( PathPoint { coords = p0 } )
( sp1@( PathPoint { coords = p1 } ) :<| ps )
= res ( closestPointToLine @( Vector2D Double ) c p0 p1 )
<> go sp1 ps
-- Quadratic Bézier curve.
go p0 ( p1 :<| p2 :<| ps )
| ControlPoint <- pointType p1
, PathPoint <- pointType p2
go ( PathPoint { coords = p0 } )
( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps )
= fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( strokePoint <$> Quadratic.Bezier { .. } ) c )
<> go p2 ps
( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier { .. } ) c )
<> go sp2 ps
-- Cubic Bézier curve.
go p0 ( p1 :<| p2 :<| p3 :<| ps )
| ControlPoint <- pointType p1
, ControlPoint <- pointType p2
, PathPoint <- pointType p3
go ( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps )
= fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( strokePoint <$> Cubic.Bezier { .. } ) c )
<> go p3 ps
( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier { .. } ) c )
<> go sp3 ps
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps )
closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing

106
src/app/MetaBrush/Bezier/Stroke.hs → src/lib/Math/Bezier/Stroke.hs
View file

@ -1,11 +1,15 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-- TODO: refactor and move this module to the library component.
module MetaBrush.Bezier.Stroke
( Offset(..), withTangent
module Math.Bezier.Stroke
( StrokePoint(..)
, Offset(..)
, withTangent
, between, parallel
)
where
@ -15,6 +19,8 @@ import Control.Monad
( guard )
import Data.Maybe
( mapMaybe )
import GHC.Generics
( Generic )
-- acts
import Data.Act
@ -37,11 +43,20 @@ import Math.RealRoots
( realRoots )
import Math.Vector2D
( Point2D(..), Vector2D(..), cross )
import MetaBrush.Document
( StrokePoint(..), PointType(..) )
--------------------------------------------------------------------------------
data StrokePoint d
= PathPoint
{ coords :: !( Point2D Double )
, pointData :: d
}
| ControlPoint
{ coords :: !( Point2D Double )
, pointData :: d
}
deriving stock ( Show, Generic )
data Offset
= Offset
{ offsetIndex :: !Int
@ -51,46 +66,51 @@ data Offset
}
deriving stock Show
withTangent :: Vector2D Double -> Seq StrokePoint -> Offset
withTangent :: forall d. Vector2D Double -> Seq ( StrokePoint d ) -> Offset
withTangent tgt ( spt0 :<| spt1 :<| spts ) =
let
tgt0 :: Vector2D Double
tgt0 = strokePoint spt0 --> strokePoint spt1
tgt0 = coords spt0 --> coords spt1
in
if parallel tgt tgt0
then Offset 0 ( Just 0 ) ( strokePoint spt0 )
then Offset 0 ( Just 0 ) ( coords spt0 )
else go 0 tgt0 spt0 spt1 spts
where
go :: Int -> Vector2D Double -> StrokePoint -> StrokePoint -> Seq StrokePoint -> Offset
go :: Int -> Vector2D Double -> StrokePoint d -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset
go _ _ ( ControlPoint { } ) _ _ = error "withTangent: path starts with a control point"
-- Line.
go i tgt0 p0 p1 ps
| PathPoint <- pointType p1
= if parallel tgt tgt0
then Offset i Nothing ( lerp @( Vector2D Double ) 0.5 ( strokePoint p0 ) ( strokePoint p1 ) )
else continue ( i + 1 ) tgt0 p1 ps
go i tgt0
( PathPoint { coords = p0 } )
( sp1@( PathPoint { coords = p1 } ) )
ps
| parallel tgt tgt0
= Offset i Nothing ( lerp @( Vector2D Double ) 0.5 p0 p1 )
| otherwise
= continue ( i + 1 ) tgt0 sp1 ps
-- Quadratic Bézier curve.
go i tgt0 p0 p1 ( p2 :<| ps )
| ControlPoint <- pointType p1
, PathPoint <- pointType p2
, let
tgt1 :: Vector2D Double
tgt1 = strokePoint p1 --> strokePoint p2
= case between tgt tgt0 tgt1 of
Just t -> Offset i ( Just t ) ( Quadratic.bezier @( Vector2D Double ) ( strokePoint <$> Quadratic.Bezier { .. } ) t )
Nothing -> continue ( i + 2 ) tgt1 p2 ps
go i tgt0
( PathPoint { coords = p0 } )
( ControlPoint { coords = p1 } )
( sp2@( PathPoint { coords = p2 } ) :<| ps ) =
let
tgt1 :: Vector2D Double
tgt1 = p1 --> p2
in case between tgt tgt0 tgt1 of
Just t -> Offset i ( Just t ) ( Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t )
Nothing -> continue ( i + 2 ) tgt1 sp2 ps
-- Cubic Bézier curve.
go i tgt0 p0 p1 ( p2 :<| p3 :<| ps )
| ControlPoint <- pointType p1
, ControlPoint <- pointType p2
, PathPoint <- pointType p3
, let
tgt1, tgt2 :: Vector2D Double
tgt1 = strokePoint p1 --> strokePoint p2
tgt2 = strokePoint p2 --> strokePoint p3
bez :: Cubic.Bezier ( Point2D Double )
bez = strokePoint <$> Cubic.Bezier { .. }
= case between tgt tgt0 tgt2 of
go i tgt0
( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } )
( PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) =
let
tgt1, tgt2 :: Vector2D Double
tgt1 = p1 --> p2
tgt2 = p2 --> p3
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier { .. }
in case between tgt tgt0 tgt2 of
Just s
| let
c01, c12, c23 :: Double
@ -110,19 +130,19 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
| otherwise
-> Offset i ( Just s ) ( Cubic.bezier @( Vector2D Double ) bez s )
-- Go to next piece of the curve.
_ -> continue ( i + 3 ) tgt2 p3 ps
_ -> continue ( i + 3 ) tgt2 sp3 ps
go _ _ _ _ _
= error "withTangent: unrecognised path type (more than two consecutive control points)"
-- Handles corners in the Bézier curve.
continue :: Int -> Vector2D Double -> StrokePoint -> Seq StrokePoint -> Offset
continue _ _ _ Empty = Offset 0 ( Just 0 ) ( strokePoint spt0 )
continue :: Int -> Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset
continue _ _ _ Empty = Offset 0 ( Just 0 ) ( coords spt0 )
continue i ptgt p0 ( p1 :<| ps ) =
let
tgt0 :: Vector2D Double
tgt0 = strokePoint p0 --> strokePoint p1
tgt0 = coords p0 --> coords p1
in case between tgt ptgt tgt0 of
Just _ -> Offset i ( Just 0 ) ( strokePoint p0 )
Just _ -> Offset i ( Just 0 ) ( coords p0 )
Nothing -> go i tgt0 p0 p1 ps
withTangent _ _ = error $ "withTangent: invalid path (fewer than 2 points)"