hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 23:03:38 +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 >= 4.13 && < 4.16
, acts , acts
^>= 0.3.1.0 ^>= 0.3.1.0
, containers
>= 0.6.0.1 && < 0.6.4
, groups , groups
^>= 0.4.1.0 ^>= 0.4.1.0
@ -59,7 +61,7 @@ library
exposed-modules: exposed-modules:
Math.Bezier.Cubic Math.Bezier.Cubic
, Math.Bezier.Quadratic , Math.Bezier.Quadratic
--, Math.Bezier.Stroke , Math.Bezier.Stroke
, Math.Bezier.Subdivision , Math.Bezier.Subdivision
, Math.Epsilon , Math.Epsilon
, Math.Module , Math.Module
@ -92,9 +94,6 @@ executable MetaBrush
, MetaBrush.Asset.TickBox , MetaBrush.Asset.TickBox
, MetaBrush.Asset.Tools , MetaBrush.Asset.Tools
, MetaBrush.Asset.WindowIcons , MetaBrush.Asset.WindowIcons
-- temporarily here
, MetaBrush.Bezier.Stroke
--
, MetaBrush.Document , MetaBrush.Document
, MetaBrush.Document.Draw , MetaBrush.Document.Draw
, MetaBrush.Document.Selection , MetaBrush.Document.Selection
@ -121,8 +120,6 @@ executable MetaBrush
build-depends: build-depends:
MetaBrush MetaBrush
, containers
>= 0.6.0.1 && < 0.6.4
, directory , directory
>= 1.3.4.0 && < 1.4 >= 1.3.4.0 && < 1.4
--, fingertree --, fingertree
@ -143,6 +140,8 @@ executable MetaBrush
^>= 0.0.1 ^>= 0.0.1
, haskell-gi-base , haskell-gi-base
^>= 0.24 ^>= 0.24
, lens
^>= 4.19.2
, stm , stm
^>= 2.5.0.0 ^>= 2.5.0.0
, tardis , tardis

17
app/Main.hs
View file

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

4
assets/theme.css
View file

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

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

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

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

@ -1,13 +1,16 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document module MetaBrush.Document
( AABB(..) ( AABB(..)
, Document(..), currentDocument , Document(..), currentDocument
, Stroke(..), StrokePoint(..), PointType(..) , Stroke(..)
, FocusState(..) , PointData(..), FocusState(..)
, selection
) )
where where
@ -21,6 +24,14 @@ import Data.Sequence
import GHC.Generics import GHC.Generics
( Generic ) ( Generic )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( Lens' )
-- text -- text
import Data.Text import Data.Text
( Text ) ( Text )
@ -32,6 +43,8 @@ import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar ) ( TVar, readTVar )
-- MetaBrush -- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D import Math.Vector2D
( Point2D ) ( Point2D )
import MetaBrush.Unique import MetaBrush.Unique
@ -60,32 +73,29 @@ data Document
data Stroke data Stroke
= Stroke = Stroke
{ strokePoints :: !( Seq StrokePoint ) { strokePoints :: !( Seq ( StrokePoint PointData ) )
, strokeName :: Text , strokeName :: Text
, strokeVisible :: !Bool , strokeVisible :: !Bool
, strokeUnique :: Unique , strokeUnique :: Unique
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
data StrokePoint data PointData
= StrokePoint = PointData
{ strokePoint :: !( Point2D Double ) { pointState :: FocusState
, pointType :: !PointType , brush :: Seq ( StrokePoint () )
, pointState :: FocusState -- needs to be lazy for drag selection code
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
data PointType
= PathPoint
| ControlPoint
deriving stock ( Show, Eq )
data FocusState data FocusState
= Normal = Normal
| Hover | Hover
| Selected | Selected
deriving stock ( Show, Eq ) 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 :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar 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 ) ( singleton, reverse, take, drop, length )
-- generic-lens -- generic-lens
import Data.GenericLens.Internal
( over )
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
( field' ) ( field' )
-- lens
import Control.Lens
( set, over, mapped )
-- stm -- stm
import Control.Concurrent.STM import Control.Concurrent.STM
( STM ) ( STM )
@ -39,13 +41,15 @@ import Control.Monad.Trans.State.Strict
( State, runState, get, put ) ( State, runState, get, put )
-- MetaBrush -- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module import Math.Module
( squaredNorm ) ( squaredNorm )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), Stroke(..), StrokePoint(..) ( Document(..), Stroke(..), FocusState(..), PointData(..)
, PointType(..), FocusState(..) , selection
) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText ) ( Unique, UniqueSupply, freshUnique, uniqueText )
@ -80,7 +84,7 @@ getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
newDoc' = newDoc' =
over ( field' @"strokes" ) over ( field' @"strokes" )
( Stroke ( Stroke
( Seq.singleton $ StrokePoint c PathPoint Normal ) ( Seq.singleton $ PathPoint c ( PointData Normal Empty ) )
( "Stroke " <> uniqueText uniq ) ( "Stroke " <> uniqueText uniq )
True True
uniq uniq
@ -102,30 +106,28 @@ getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
| strokeVisible | strokeVisible
, Just anchor <- endpointAnchor strokeUnique strokePoints , Just anchor <- endpointAnchor strokeUnique strokePoints
-> put ( Just anchor ) -> put ( Just anchor )
$> over ( field' @"strokePoints" ) ( fmap deselectPoint ) stroke $> set ( field' @"strokePoints" . mapped . selection ) Normal stroke
-- Otherwise, just deselect. -- 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. -- See if we can anchor a drawing operation on a given (visible) stroke.
endpointAnchor :: Unique -> Seq StrokePoint -> Maybe ( DrawAnchor, Point2D Double ) endpointAnchor :: Unique -> Seq ( StrokePoint PointData ) -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor _ ( StrokePoint p0 PathPoint _ :<| ( _ :|> StrokePoint pn PathPoint _ ) ) endpointAnchor _ ( PathPoint { coords = p0 } :<| ( _ :|> PathPoint { coords = pn } ) )
| p0 == pn | p0 == pn
= Nothing = Nothing
endpointAnchor uniq ( StrokePoint p0 PathPoint _ :<| _ ) endpointAnchor uniq (PathPoint { coords = p0 } :<| _ )
| inPointClickRange p0 | inPointClickRange p0
= Just ( AnchorAtStart uniq, p0 ) = Just ( AnchorAtStart uniq, p0 )
endpointAnchor uniq ( _ :|> StrokePoint pn PathPoint _ ) endpointAnchor uniq ( _ :|> PathPoint { coords = pn } )
| inPointClickRange pn | inPointClickRange pn
= Just ( AnchorAtEnd uniq, pn ) = Just ( AnchorAtEnd uniq, pn )
endpointAnchor _ _ = Nothing endpointAnchor _ _ = Nothing
deselectPoint :: StrokePoint -> StrokePoint
deselectPoint pt = pt { pointState = Normal }
inPointClickRange :: Point2D Double -> Bool inPointClickRange :: Point2D Double -> Bool
inPointClickRange p = inPointClickRange p =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
addToAnchor :: DrawAnchor -> Seq StrokePoint -> Document -> Document addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document
addToAnchor anchor newPts = over ( field' @"strokes" ) ( fmap addToStroke ) addToAnchor anchor newPts = over ( field' @"strokes" . mapped ) addToStroke
where where
addToStroke :: Stroke -> Stroke addToStroke :: Stroke -> Stroke
addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } ) addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } )

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

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

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

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

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

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