split out stroke code to library

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

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

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 )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

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);
} }

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

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

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 } )

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,48 +229,52 @@ 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
Tardis.sendPast True PathPoint {}
Tardis.sendFuture True | Selected <- selectionState
updateStroke ps -> do
updateStroke ( p@( StrokePoint { pointType = PathPoint } ) :<| ps ) = do Tardis.sendPast True
Tardis.sendPast False Tardis.sendFuture True
Tardis.sendFuture False updateStroke ps
( p :<| ) <$> updateStroke ps | otherwise
updateStroke ( p@( StrokePoint { pointType = ControlPoint, pointState } ) :<| ps ) = do -> do
prevPathPointDeleted <- Tardis.getPast Tardis.sendPast False
nextPathPointDeleted <- Tardis.getFuture Tardis.sendFuture False
rest <- updateStroke ps ( p :<| ) <$> updateStroke ps
let _ -> do
-- Control point must be deleted: prevPathPointDeleted <- Tardis.getPast
-- - if it is selected, nextPathPointDeleted <- Tardis.getFuture
-- - if the previous path point was deleted, rest <- updateStroke ps
-- - if the next path point is going to be deleted. let
-- -- Control point must be deleted:
-- Need to be lazy in "nextPathPointDeleted" to avoid looping. -- - if it is selected,
res :: Seq StrokePoint -- - if the previous path point was deleted,
res = if pointState == Selected || prevPathPointDeleted || nextPathPointDeleted -- - if the next path point is going to be deleted.
then rest --
else p :<| rest -- Need to be lazy in "nextPathPointDeleted" to avoid looping.
pure res res :: Seq ( StrokePoint PointData )
res = if selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted
then rest
else p :<| rest
pure res
where
selectionState :: FocusState
selectionState = view selection p

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 )

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

View file

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

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

View file

@ -1,11 +1,15 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 ) =
tgt1 :: Vector2D Double let
tgt1 = strokePoint p1 --> strokePoint p2 tgt1 :: Vector2D Double
= case between tgt tgt0 tgt1 of tgt1 = p1 --> p2
Just t -> Offset i ( Just t ) ( Quadratic.bezier @( Vector2D Double ) ( strokePoint <$> Quadratic.Bezier { .. } ) t ) in case between tgt tgt0 tgt1 of
Nothing -> continue ( i + 2 ) tgt1 p2 ps Just t -> Offset i ( Just t ) ( Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t )
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)"