mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
split out stroke code to library
This commit is contained in:
parent
e044b1b06c
commit
e8c77befd6
|
@ -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
17
app/Main.hs
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
|
@ -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);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 } )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -1,14 +0,0 @@
|
||||||
module MetaBrush.Stroke where
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
{-
|
|
||||||
data StrokePoint
|
|
||||||
= StrokePoint
|
|
||||||
{ center :: Point2D Double
|
|
||||||
,
|
|
||||||
|
|
||||||
newtype Stroke =
|
|
||||||
Stroke { strokePoints :: Seq (
|
|
||||||
|
|
||||||
-}
|
|
|
@ -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
|
||||||
|
|
|
@ -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)"
|
Loading…
Reference in a new issue