mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 06:43:37 +00:00
Refactors in preparation for stroke hierarchy
This commit is contained in:
parent
8b3705b8d1
commit
0eb0724dde
|
@ -183,17 +183,22 @@ library metabrushes
|
|||
Haskell2010
|
||||
|
||||
exposed-modules:
|
||||
MetaBrush.Assert
|
||||
MetaBrush.Action
|
||||
, MetaBrush.Assert
|
||||
, MetaBrush.Asset.Brushes
|
||||
, MetaBrush.Brush
|
||||
, MetaBrush.Brush.Widget
|
||||
, MetaBrush.Document
|
||||
, MetaBrush.Document.Draw
|
||||
, MetaBrush.Document.Diff
|
||||
, MetaBrush.Document.History
|
||||
, MetaBrush.Document.Serialise
|
||||
, MetaBrush.Document.SubdivideStroke
|
||||
, MetaBrush.Draw
|
||||
, MetaBrush.Guide
|
||||
, MetaBrush.Hover
|
||||
, MetaBrush.Layer
|
||||
, MetaBrush.Records
|
||||
, MetaBrush.Serialisable
|
||||
, MetaBrush.Stroke
|
||||
, MetaBrush.Unique
|
||||
, MetaBrush.Util
|
||||
|
||||
|
@ -219,8 +224,10 @@ executable MetaBrush
|
|||
Haskell2010
|
||||
|
||||
other-modules:
|
||||
MetaBrush.Action
|
||||
, MetaBrush.Application
|
||||
MetaBrush.Application
|
||||
, MetaBrush.Application.Action
|
||||
, MetaBrush.Application.Context
|
||||
, MetaBrush.Application.UpdateDocument
|
||||
, MetaBrush.Asset.CloseTabButton
|
||||
, MetaBrush.Asset.Colours
|
||||
, MetaBrush.Asset.Cursor
|
||||
|
@ -229,13 +236,11 @@ executable MetaBrush
|
|||
, MetaBrush.Asset.TickBox
|
||||
, MetaBrush.Asset.Tools
|
||||
, MetaBrush.Asset.WindowIcons
|
||||
, MetaBrush.Context
|
||||
, MetaBrush.Document.Selection
|
||||
, MetaBrush.Document.Update
|
||||
, MetaBrush.Event
|
||||
, MetaBrush.GTK.Util
|
||||
, MetaBrush.Render.Document
|
||||
, MetaBrush.Render.Rulers
|
||||
, MetaBrush.Time
|
||||
, MetaBrush.UI.Coordinates
|
||||
, MetaBrush.UI.FileBar
|
||||
, MetaBrush.UI.InfoBar
|
||||
|
@ -243,7 +248,6 @@ executable MetaBrush
|
|||
, MetaBrush.UI.Panels
|
||||
, MetaBrush.UI.ToolBar
|
||||
, MetaBrush.UI.Viewport
|
||||
, MetaBrush.Time
|
||||
|
||||
ghc-options:
|
||||
-threaded
|
||||
|
|
|
@ -56,6 +56,8 @@ main = withCP65001 do
|
|||
when (isNothing mbGdkScale) $
|
||||
setEnv "GDK_SCALE" "2"
|
||||
|
||||
setEnv "GSK_RENDERER" "cairo"
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Run GTK application
|
||||
|
||||
|
|
|
@ -14,7 +14,7 @@ extra-source-files:
|
|||
|
||||
flag use-simd
|
||||
description: Use SIMD instructions to implement interval arithmetic.
|
||||
default: True
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag use-fma
|
||||
|
|
|
@ -20,6 +20,8 @@ import Data.Foldable
|
|||
( toList )
|
||||
import Data.List
|
||||
( intersperse )
|
||||
import Data.List.NonEmpty
|
||||
( unzip )
|
||||
import Data.Proxy
|
||||
( Proxy(..) )
|
||||
import Data.Typeable
|
||||
|
@ -54,7 +56,7 @@ import Math.Differentiable
|
|||
import Math.Interval
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..)
|
||||
, Vec(..), (!), unzip
|
||||
, Vec(..), (!)
|
||||
, Fin(..), RepDim, Representable(..), RepresentableQ(..)
|
||||
)
|
||||
import Math.Module
|
||||
|
|
|
@ -62,8 +62,18 @@ import Math.Linear
|
|||
|
||||
data PointType
|
||||
= PathPoint
|
||||
| ControlPoint
|
||||
deriving stock Show
|
||||
| ControlPoint ControlPoint
|
||||
deriving stock ( Eq, Ord, Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
data ControlPoint
|
||||
= Bez2Cp
|
||||
| Bez3Cp1
|
||||
| Bez3Cp2
|
||||
deriving stock ( Eq, Ord, Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data SplineType = Open | Closed
|
||||
|
||||
|
@ -224,27 +234,27 @@ bimapCurve
|
|||
:: Functor ( NextPoint clo )
|
||||
=> ( crvData -> crvData' ) -> ( PointType -> ptData -> ptData' )
|
||||
-> Curve clo crvData ptData -> Curve clo crvData' ptData'
|
||||
bimapCurve f g ( LineTo p1 d ) = LineTo ( g PathPoint <$> p1 ) ( f d )
|
||||
bimapCurve f g ( Bezier2To p1 p2 d ) = Bezier2To ( g ControlPoint p1 ) ( g PathPoint <$> p2 ) ( f d )
|
||||
bimapCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To ( g ControlPoint p1 ) ( g ControlPoint p2 ) ( g PathPoint <$> p3 ) ( f d )
|
||||
bimapCurve f g ( LineTo p1 d ) = LineTo ( g PathPoint <$> p1 ) ( f d )
|
||||
bimapCurve f g ( Bezier2To p1 p2 d ) = Bezier2To ( g ( ControlPoint Bez2Cp ) p1 ) ( g PathPoint <$> p2 ) ( f d )
|
||||
bimapCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To ( g ( ControlPoint Bez3Cp1 ) p1 ) ( g ( ControlPoint Bez3Cp2 ) p2 ) ( g PathPoint <$> p3 ) ( f d )
|
||||
|
||||
bifoldMapCurve
|
||||
:: forall m clo crvData ptData
|
||||
. ( Monoid m, Foldable ( NextPoint clo ) )
|
||||
=> ( crvData -> m ) -> ( PointType -> ptData -> m )
|
||||
-> Curve clo crvData ptData -> m
|
||||
bifoldMapCurve f g ( LineTo p1 d ) = ( foldMap ( g PathPoint ) p1 ) <> f d
|
||||
bifoldMapCurve f g ( Bezier2To p1 p2 d ) = g ControlPoint p1 <> ( foldMap ( g PathPoint ) p2 ) <> f d
|
||||
bifoldMapCurve f g ( Bezier3To p1 p2 p3 d ) = g ControlPoint p1 <> g ControlPoint p2 <> ( foldMap ( g PathPoint ) p3 ) <> f d
|
||||
bifoldMapCurve f g ( LineTo p1 d ) = ( foldMap ( g PathPoint ) p1 ) <> f d
|
||||
bifoldMapCurve f g ( Bezier2To p1 p2 d ) = g ( ControlPoint Bez2Cp ) p1 <> ( foldMap ( g PathPoint ) p2 ) <> f d
|
||||
bifoldMapCurve f g ( Bezier3To p1 p2 p3 d ) = g ( ControlPoint Bez3Cp1 ) p1 <> g ( ControlPoint Bez3Cp2 ) p2 <> ( foldMap ( g PathPoint ) p3 ) <> f d
|
||||
|
||||
bitraverseCurve
|
||||
:: forall f clo crvData crvData' ptData ptData'
|
||||
. ( Applicative f, Traversable ( NextPoint clo ) )
|
||||
=> ( crvData -> f crvData' ) -> ( PointType -> ptData -> f ptData' )
|
||||
-> Curve clo crvData ptData -> f ( Curve clo crvData' ptData' )
|
||||
bitraverseCurve f g ( LineTo p1 d ) = LineTo <$> traverse ( g PathPoint ) p1 <*> f d
|
||||
bitraverseCurve f g ( Bezier2To p1 p2 d ) = Bezier2To <$> g ControlPoint p1 <*> traverse ( g PathPoint ) p2 <*> f d
|
||||
bitraverseCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To <$> g ControlPoint p1 <*> g ControlPoint p2 <*> traverse ( g PathPoint ) p3 <*> f d
|
||||
bitraverseCurve f g ( LineTo p1 d ) = LineTo <$> traverse ( g PathPoint ) p1 <*> f d
|
||||
bitraverseCurve f g ( Bezier2To p1 p2 d ) = Bezier2To <$> g ( ControlPoint Bez2Cp ) p1 <*> traverse ( g PathPoint ) p2 <*> f d
|
||||
bitraverseCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To <$> g ( ControlPoint Bez3Cp1 ) p1 <*> g ( ControlPoint Bez3Cp2 ) p2 <*> traverse ( g PathPoint ) p3 <*> f d
|
||||
|
||||
dropCurves :: Int -> Spline Open crvData ptData -> Maybe ( Spline Open crvData ptData )
|
||||
dropCurves i spline@( Spline { splineCurves = OpenCurves curves } )
|
||||
|
@ -321,15 +331,18 @@ dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 BackToStart dat
|
|||
-- as the result type depends on whether a starting point has been found yet or not.
|
||||
data CurrentStart ( hasStart :: Bool ) ptData where
|
||||
NoStartFound :: CurrentStart False ptData
|
||||
CurrentStart :: !ptData -> CurrentStart True ptData
|
||||
CurrentStart ::
|
||||
{ wasOriginalStart :: Bool
|
||||
, startPoint :: !ptData
|
||||
} -> CurrentStart True ptData
|
||||
|
||||
deriving stock instance Show ptData => Show ( CurrentStart hasStart ptData )
|
||||
deriving stock instance Functor ( CurrentStart hasStart )
|
||||
deriving stock instance Foldable ( CurrentStart hasStart )
|
||||
deriving stock instance Traversable ( CurrentStart hasStart )
|
||||
instance NFData ptData => NFData ( CurrentStart hasStart ptData ) where
|
||||
rnf NoStartFound = ()
|
||||
rnf ( CurrentStart ptData ) = rnf ptData
|
||||
rnf NoStartFound = ()
|
||||
rnf ( CurrentStart orig ptData ) = rnf orig `seq` rnf ptData
|
||||
|
||||
-- | The result of a wither operation on a spline.
|
||||
--
|
||||
|
@ -468,13 +481,13 @@ instance KnownSplineType Open where
|
|||
-> f ( Maybe ( Spline Open crvData' ptData' ) )
|
||||
biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) = do
|
||||
mbStart' <- fp splineStart
|
||||
( curves', mbStart'' ) <- ( `runStateT` ( fmap First mbStart' ) ) $ go mbStart' curves
|
||||
( curves', mbStart'' ) <- ( `runStateT` ( fmap First mbStart' ) ) $ go ( (, True ) <$> mbStart' ) curves
|
||||
case mbStart'' of
|
||||
Nothing -> pure Nothing
|
||||
Just ( First start' ) ->
|
||||
pure ( Just $ Spline { splineStart = start', splineCurves = OpenCurves curves' } )
|
||||
where
|
||||
go :: Maybe ptData' -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
|
||||
go :: Maybe ( ptData', Bool ) -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
|
||||
go _ Empty = pure Empty
|
||||
go Nothing ( crv :<| crvs ) = do
|
||||
mbCrv' <- lift $ fc NoStartFound crv
|
||||
|
@ -483,14 +496,14 @@ instance KnownSplineType Open where
|
|||
UseStartPoint ptData'' mbCrv'' -> do
|
||||
modify' ( <> Just ( First ptData'' ) )
|
||||
case mbCrv'' of
|
||||
Nothing -> go ( Just ptData'' ) crvs
|
||||
Just crv'' -> ( crv'' :<| ) <$> go ( Just ptData'' ) crvs
|
||||
go ( Just ptData' ) ( crv :<| crvs ) = do
|
||||
mbCrv' <- lift $ fc ( CurrentStart ptData' ) crv
|
||||
Nothing -> go ( Just ( ptData'', False ) ) crvs
|
||||
Just crv'' -> ( crv'' :<| ) <$> go ( Just ( ptData'', False ) ) crvs
|
||||
go ( Just ( ptData', orig ) ) ( crv :<| crvs ) = do
|
||||
mbCrv' <- lift $ fc ( CurrentStart orig ptData' ) crv
|
||||
case mbCrv' of
|
||||
Dismiss -> go ( Just ptData' ) crvs
|
||||
Dismiss -> go ( Just ( ptData', False ) ) crvs
|
||||
UseCurve crv'' ->
|
||||
( crv'' :<| ) <$> go ( Just $ openCurveEnd crv'' ) crvs
|
||||
( crv'' :<| ) <$> go ( Just ( openCurveEnd crv'', True ) ) crvs
|
||||
|
||||
instance KnownSplineType Closed where
|
||||
|
||||
|
@ -527,36 +540,9 @@ instance KnownSplineType Closed where
|
|||
go _ _ Empty = pure Empty
|
||||
go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs
|
||||
|
||||
biwitherSpline _ fp ( Spline { splineStart, splineCurves = NoCurves } ) = fmap ( \ p -> Spline p NoCurves ) <$> fp splineStart
|
||||
biwitherSpline fc fp ( Spline { splineStart, splineCurves = ClosedCurves prevCurves lastCurve } ) = do
|
||||
mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } )
|
||||
case mbSpline' of
|
||||
Nothing -> do
|
||||
mbCrv' <- fc NoStartFound lastCurve
|
||||
case mbCrv' of
|
||||
Dismiss -> pure Nothing
|
||||
UseStartPoint ptData'' mbCrv'' ->
|
||||
case mbCrv'' of
|
||||
Nothing -> pure $ Just ( Spline { splineStart = ptData'', splineCurves = NoCurves } )
|
||||
Just crv'' -> pure $ Just ( Spline { splineStart = ptData'', splineCurves = ClosedCurves Empty crv'' } )
|
||||
Just ( Spline { splineStart = start', splineCurves = OpenCurves prevCurves' } ) ->
|
||||
case prevCurves' of
|
||||
Empty -> do
|
||||
mbLastCurve' <- fc ( CurrentStart start' ) lastCurve
|
||||
case mbLastCurve' of
|
||||
Dismiss ->
|
||||
pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } )
|
||||
UseCurve lastCurve' ->
|
||||
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } )
|
||||
( prevPrevCurves' :|> prevLastCurve' ) -> do
|
||||
let
|
||||
prevPt' = openCurveEnd prevLastCurve'
|
||||
mbLastCurve' <- fc ( CurrentStart prevPt' ) lastCurve
|
||||
case mbLastCurve' of
|
||||
Dismiss ->
|
||||
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } )
|
||||
UseCurve lastCurve' ->
|
||||
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } )
|
||||
biwitherSpline fc fp closedSpline = do
|
||||
spline' <- biwitherSpline fc fp ( adjustSplineType @Open closedSpline )
|
||||
return $ adjustSplineType @Closed <$> spline'
|
||||
|
||||
showSplinePoints :: forall clo ptData crvData
|
||||
. (KnownSplineType clo, Show ptData)
|
||||
|
|
|
@ -72,7 +72,7 @@ import Math.Linear
|
|||
import MetaBrush.DSL.Interpolation
|
||||
( Interpolatable(Diff) )
|
||||
import MetaBrush.Document
|
||||
( PointData(..), FocusState(Normal) )
|
||||
( PointData(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
12
hie.yaml
12
hie.yaml
|
@ -1,12 +0,0 @@
|
|||
cradle:
|
||||
cabal:
|
||||
- path: "./brush-strokes/src"
|
||||
component: "lib:brush-strokes"
|
||||
- path: "./src/metabrushes"
|
||||
component: "lib:metabrushes"
|
||||
- path: "./src/convert"
|
||||
component: "exe:convert-metafont"
|
||||
- path: "./src/app"
|
||||
component: "exe:MetaBrush"
|
||||
- path: "./app"
|
||||
component: "exe:MetaBrush"
|
|
@ -24,13 +24,10 @@ import GHC.Conc
|
|||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( empty )
|
||||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
( empty )
|
||||
|
||||
-- directory
|
||||
import qualified System.Directory as Directory
|
||||
|
@ -87,27 +84,24 @@ import Math.Linear
|
|||
( ℝ(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
import MetaBrush.Application.Action
|
||||
( ActionOrigin(..) )
|
||||
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
|
||||
import MetaBrush.Asset.Colours
|
||||
( getColours )
|
||||
import MetaBrush.Asset.Logo
|
||||
( drawLogo )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..)
|
||||
, HoldAction(..), PartialPath(..)
|
||||
)
|
||||
import MetaBrush.Application.UpdateDocument
|
||||
( activeDocument, withActiveDocument )
|
||||
import MetaBrush.Document
|
||||
( emptyDocument
|
||||
, Stroke(..), StrokeHierarchy(..), FocusState(..)
|
||||
, PointData(..)
|
||||
)
|
||||
( Document(..), emptyDocument )
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), newHistory )
|
||||
import MetaBrush.Document.Update
|
||||
( activeDocument, withActiveDocument )
|
||||
import MetaBrush.Event
|
||||
( handleEvents )
|
||||
import MetaBrush.GTK.Util
|
||||
|
@ -117,6 +111,7 @@ import MetaBrush.Render.Document
|
|||
( blankRender, getDocumentRender )
|
||||
import MetaBrush.Render.Rulers
|
||||
( renderRuler )
|
||||
import MetaBrush.Stroke
|
||||
import MetaBrush.UI.FileBar
|
||||
( FileBar(..), FileBarTab, createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
|
@ -125,6 +120,8 @@ import MetaBrush.UI.Menu
|
|||
( createMenuBar, createMenuActions )
|
||||
import MetaBrush.UI.Panels
|
||||
( createPanelBar )
|
||||
--import MetaBrush.UI.StrokeTreeView
|
||||
-- ( newStrokeView )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..), createToolBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
|
@ -133,10 +130,7 @@ import MetaBrush.UI.Viewport
|
|||
, createViewport
|
||||
)
|
||||
import MetaBrush.Unique
|
||||
( newUniqueSupply
|
||||
, Unique, freshUnique
|
||||
, uniqueMapFromList
|
||||
)
|
||||
( Unique, freshUnique, newUniqueSupply )
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
|
@ -156,43 +150,51 @@ runApplication application = do
|
|||
strokeUnique <- runReaderT freshUnique uniqueSupply
|
||||
|
||||
let
|
||||
|
||||
testDocuments :: Map Unique DocumentHistory
|
||||
testDocuments = newHistory <$> uniqueMapFromList
|
||||
[ emptyDocument "Test" docUnique
|
||||
& ( field' @"documentContent" . field' @"strokes" ) .~
|
||||
( Seq.fromList
|
||||
[ StrokeLeaf $ Stroke
|
||||
{ strokeName = "Stroke 1"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = strokeUnique
|
||||
, strokeBrush = Just Asset.Brushes.ellipse --tearDrop
|
||||
, strokeSpline =
|
||||
-- Spline
|
||||
-- { splineStart = mkPoint ( ℝ2 -20 -20 ) 5
|
||||
-- , splineCurves = OpenCurves $ Seq.fromList
|
||||
-- [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 20 20 ) 5 ), curveData = invalidateCache undefined }
|
||||
-- ]
|
||||
-- }
|
||||
Spline
|
||||
{ splineStart = mkPoint ( ℝ2 0 0 ) 10 25 0
|
||||
, splineCurves = OpenCurves $ Seq.fromList
|
||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 100 0 ) 15 40 0 ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 10 ) 8 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
|
||||
]
|
||||
}
|
||||
testStroke =
|
||||
Stroke
|
||||
{ strokeBrush = Just Asset.Brushes.ellipse --tearDrop
|
||||
, strokeSpline =
|
||||
-- Spline
|
||||
-- { splineStart = mkPoint ( ℝ2 -20 -20 ) 5
|
||||
-- , splineCurves = OpenCurves $ Seq.fromList
|
||||
-- [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 20 20 ) 5 ), curveData = invalidateCache undefined }
|
||||
-- ]
|
||||
-- }
|
||||
Spline
|
||||
{ splineStart = mkPoint ( ℝ2 0 0 ) 10 25 0
|
||||
, splineCurves = OpenCurves $ Seq.fromList
|
||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 100 0 ) 15 40 0 ), curveData = CurveData 0 $ invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 10 ) 8 5 ( pi / 4 ) ), curveData = CurveData 1 $ invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = CurveData 2 $ invalidateCache undefined }
|
||||
]
|
||||
}
|
||||
]
|
||||
)
|
||||
]
|
||||
}
|
||||
where
|
||||
mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
|
||||
mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi )
|
||||
--mkPoint :: ℝ 2 -> Double -> PointData ( Record Asset.Brushes.CircleBrushFields )
|
||||
--mkPoint pt r = PointData pt Normal ( MkR $ ℝ1 r )
|
||||
--mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.TearDropBrushFields )
|
||||
--mkPoint pt w h phi = PointData pt Normal ( MkR $ ℝ3 w h phi )
|
||||
mkPoint pt a b phi = PointData pt ( MkR $ ℝ3 a b phi )
|
||||
|
||||
testLayers :: Layers
|
||||
testLayers =
|
||||
[ StrokeLayer
|
||||
{ layerUnique = strokeUnique
|
||||
, layerName = "Stroke 1"
|
||||
, layerVisible = True
|
||||
, layerLocked = False
|
||||
, layerStroke = testStroke
|
||||
}
|
||||
]
|
||||
|
||||
( layerMeta, testStrokes ) = layersStrokeHierarchy testLayers
|
||||
|
||||
testDoc :: Document
|
||||
testDoc
|
||||
= emptyDocument "Test"
|
||||
& ( field' @"documentContent" . field' @"strokeHierarchy" ) .~ testStrokes
|
||||
& ( field' @"documentMetadata" . field' @"layerMetadata" ) .~ layerMeta
|
||||
|
||||
testDocuments :: Map Unique DocumentHistory
|
||||
testDocuments = newHistory <$> Map.fromList
|
||||
[ ( docUnique, testDoc ) ]
|
||||
|
||||
recomputeStrokesTVar <- STM.newTVarIO @Bool False
|
||||
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
|
||||
|
@ -223,6 +225,10 @@ runApplication application = do
|
|||
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
|
||||
Just defaultRootIsolationOptions
|
||||
|
||||
--testDocsStrokeListModels <-
|
||||
-- for testDocuments ( newStrokeView . strokes . documentContent . present )
|
||||
strokeListModelsTVar <- STM.newTVarIO @( Map Unique GTK.SelectionModel ) Map.empty --testDocsStrokeListModels
|
||||
|
||||
-- Put all these stateful variables in a record for conciseness.
|
||||
let
|
||||
variables :: Variables
|
||||
|
@ -335,7 +341,7 @@ runApplication application = do
|
|||
case needsRecomputation of
|
||||
False -> STM.retry
|
||||
True -> do
|
||||
mbDocNow <- fmap present <$> activeDocument variables
|
||||
mbDocNow <- fmap ( present . snd ) <$> activeDocument variables
|
||||
case mbDocNow of
|
||||
Nothing -> pure ( pure . const $ blankRender colours )
|
||||
Just doc -> do
|
||||
|
@ -385,7 +391,7 @@ runApplication application = do
|
|||
viewportWidth <- GTK.widgetGetWidth viewportDrawingArea
|
||||
viewportHeight <- GTK.widgetGetHeight viewportDrawingArea
|
||||
-- Get the Cairo instructions for rendering the current document
|
||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
|
||||
mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument variables )
|
||||
render <- case mbDoc of
|
||||
Nothing -> pure ( blankRender colours )
|
||||
Just _ -> STM.atomically do
|
||||
|
@ -404,7 +410,7 @@ runApplication application = do
|
|||
viewportHeight <- GTK.widgetGetHeight viewportDrawingArea
|
||||
width <- GTK.widgetGetWidth rulerDrawingArea
|
||||
height <- GTK.widgetGetHeight rulerDrawingArea
|
||||
mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
|
||||
mbRender <- STM.atomically $ withActiveDocument variables \ _ doc -> do
|
||||
mbMousePos <- STM.readTVar mousePosTVar
|
||||
mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
showGuides <- STM.readTVar showGuidesTVar
|
||||
|
@ -422,6 +428,11 @@ runApplication application = do
|
|||
|
||||
_ <- createToolBar variables colours toolBar
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels bar
|
||||
|
||||
panelsBar <- createPanelBar panelBox
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Info bar
|
||||
|
||||
|
@ -439,6 +450,7 @@ runApplication application = do
|
|||
colours variables
|
||||
application window windowKeys titleBar titleLabel viewport infoBar
|
||||
menuBar menuActions
|
||||
panelsBar
|
||||
|
||||
let
|
||||
uiElements :: UIElements
|
||||
|
@ -453,11 +465,6 @@ runApplication application = do
|
|||
GTK.boxAppend mainView viewportGrid
|
||||
GTK.boxAppend mainView infoBarArea
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels
|
||||
|
||||
createPanelBar panelBox
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Actions
|
||||
|
||||
|
@ -466,8 +473,9 @@ runApplication application = do
|
|||
---------------------------------------------------------
|
||||
-- Finishing up
|
||||
|
||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
|
||||
updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
|
||||
mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument variables )
|
||||
updateInfoBar viewportDrawingArea infoBar variables ( fmap documentMetadata mbDoc )
|
||||
-- need to update the info bar after widgets have been realized
|
||||
|
||||
widgetShow window
|
||||
|
||||
|
|
|
@ -1,14 +1,13 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module MetaBrush.Action where
|
||||
module MetaBrush.Application.Action where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( second )
|
||||
import Control.Monad
|
||||
( guard, when, unless, void )
|
||||
import Control.Monad.ST
|
||||
( RealWorld )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.List
|
||||
|
@ -34,9 +33,7 @@ import Data.Act
|
|||
|
||||
-- containers
|
||||
import qualified Data.Map as Map
|
||||
( insert, lookup )
|
||||
import qualified Data.Set as Set
|
||||
( delete, insert )
|
||||
|
||||
-- directory
|
||||
import System.Directory
|
||||
|
@ -85,66 +82,62 @@ import qualified Control.Concurrent.STM as STM
|
|||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
|
||||
|
||||
-- transformers
|
||||
import qualified Control.Monad.Trans.Reader as Reader
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( intercalate, pack )
|
||||
( pack )
|
||||
|
||||
-- brush-strokes
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplineType(Open)
|
||||
, catMaybesSpline
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..), invalidateCache )
|
||||
( invalidateCache )
|
||||
import Math.Module
|
||||
( Module((*^)), quadrance )
|
||||
( Module((*^)) )
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Asset.WindowIcons
|
||||
( drawClose )
|
||||
import qualified MetaBrush.Brush.Widget as Brush
|
||||
( describeWidgetAction )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Action
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..), modifierKey
|
||||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..), PointData(..), FocusState(..)
|
||||
, Guide(..), selectedGuide, addGuide
|
||||
( Document(..), DocumentContent(..), DocumentMetadata(..)
|
||||
, Zoom(..)
|
||||
, Guide(..)
|
||||
, StrokePoints(..)
|
||||
)
|
||||
import MetaBrush.Document.Draw
|
||||
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
|
||||
import MetaBrush.Application.UpdateDocument
|
||||
( activeDocument
|
||||
, DocumentUpdate(..)
|
||||
, PureDocModification(..), DocModification(..)
|
||||
, ActiveDocChange (..)
|
||||
, modifyingCurrentDocument
|
||||
, updateUIAction, updateHistoryState
|
||||
)
|
||||
import MetaBrush.Asset.WindowIcons
|
||||
( drawClose )
|
||||
import MetaBrush.Document.Diff
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), newHistory
|
||||
, back, fwd
|
||||
)
|
||||
import MetaBrush.Document.Selection
|
||||
( SelectionMode(..), selectionMode
|
||||
, selectAt, selectRectangle
|
||||
, DragMoveSelect(..), dragMoveSelect
|
||||
, UpdateInfo(..)
|
||||
, deleteSelected
|
||||
, dragUpdate, pressingControl
|
||||
, BrushWidgetActionState(..)
|
||||
, applyBrushWidgetAction
|
||||
)
|
||||
import MetaBrush.Document.Serialise
|
||||
( saveDocument, loadDocument )
|
||||
import MetaBrush.Document.SubdivideStroke
|
||||
( subdivide )
|
||||
import MetaBrush.Document.Update
|
||||
( activeDocument
|
||||
, DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
|
||||
, modifyingCurrentDocument
|
||||
, updateUIAction, updateHistoryState
|
||||
)
|
||||
import MetaBrush.Draw
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetShow )
|
||||
import MetaBrush.Hover
|
||||
( inPointClickRange )
|
||||
import MetaBrush.Guide
|
||||
import MetaBrush.Layer
|
||||
import MetaBrush.Stroke
|
||||
import MetaBrush.UI.Coordinates
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.InfoBar
|
||||
|
@ -154,9 +147,9 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
|
|||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), Ruler(..) )
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
( Unique, freshUnique )
|
||||
import MetaBrush.GTK.Util
|
||||
( (>=?=>), (>>?=)
|
||||
, widgetAddClass, widgetAddClasses
|
||||
|
@ -233,9 +226,10 @@ instance HandleAction OpenFile where
|
|||
case mbDoc of
|
||||
Left errMessage -> openFileWarningDialog window filePath errMessage
|
||||
Right doc -> do
|
||||
newDocUnique <- Reader.runReaderT freshUnique uniqueSupply
|
||||
let newDocHist = newHistory doc
|
||||
newFileTab uiElts vars (Just newDocHist) tabLoc
|
||||
updateHistoryState uiElts (Just newDocHist)
|
||||
newFileTab uiElts vars ( Just ( newDocUnique, newDocHist ) ) tabLoc
|
||||
updateHistoryState uiElts ( Just newDocHist )
|
||||
Nothing -> return ()
|
||||
|
||||
openFileWarningDialog
|
||||
|
@ -303,10 +297,11 @@ instance HandleAction OpenFolder where
|
|||
case mbDoc of
|
||||
Left errMessage -> openFileWarningDialog window filePath errMessage
|
||||
Right doc -> do
|
||||
newDocUnique <- Reader.runReaderT freshUnique uniqueSupply
|
||||
let
|
||||
newDocHist :: DocumentHistory
|
||||
newDocHist = newHistory doc
|
||||
newFileTab uiElts vars ( Just newDocHist ) tabLoc
|
||||
newFileTab uiElts vars ( Just ( newDocUnique, newDocHist ) ) tabLoc
|
||||
updateHistoryState uiElts ( Just newDocHist )
|
||||
|
||||
---------------------------
|
||||
|
@ -335,14 +330,14 @@ data SaveFormat
|
|||
|
||||
save :: UIElements -> Variables -> Bool -> IO ()
|
||||
save uiElts vars keepOpen = do
|
||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
||||
mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument vars )
|
||||
for_ mbDoc \case
|
||||
doc@( Document { mbFilePath, documentContent } )
|
||||
| Nothing <- mbFilePath
|
||||
doc@( Document { documentMetadata = Metadata { documentFilePath }, documentContent } )
|
||||
| Nothing <- documentFilePath
|
||||
-> saveAs uiElts vars keepOpen
|
||||
| False <- unsavedChanges documentContent
|
||||
-> pure ()
|
||||
| Just filePath <- mbFilePath
|
||||
| Just filePath <- documentFilePath
|
||||
-> modifyingCurrentDocument uiElts vars \ _ -> do
|
||||
let
|
||||
modif :: DocumentUpdate
|
||||
|
@ -361,7 +356,7 @@ saveAs uiElts vars keepOpen =
|
|||
export :: UIElements -> Variables -> IO ()
|
||||
export uiElts vars@( Variables { .. } ) = do
|
||||
mbRender <- STM.atomically $ do
|
||||
mbDoc <- fmap present <$> activeDocument vars
|
||||
mbDoc <- fmap ( present . snd ) <$> activeDocument vars
|
||||
case mbDoc of
|
||||
Nothing -> return Nothing
|
||||
Just _ -> Just <$> STM.readTVar documentRenderTVar
|
||||
|
@ -435,29 +430,29 @@ instance HandleAction Close where
|
|||
vars@( Variables {..} )
|
||||
close = do
|
||||
mbDoc <- case close of
|
||||
CloseActive -> fmap ( ( , True ) . present ) <$> STM.atomically ( activeDocument vars )
|
||||
CloseActive -> fmap ( second ( ( , True ) . present ) ) <$> STM.atomically ( activeDocument vars )
|
||||
CloseThis unique -> do
|
||||
mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
||||
mbCurrentDoc <- fmap ( second present ) <$> STM.atomically ( activeDocument vars )
|
||||
mbDoc <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
|
||||
for mbDoc \ doc ->
|
||||
pure ( doc, maybe False ( ( == unique ) . documentUnique ) mbCurrentDoc )
|
||||
pure ( unique, ( doc, maybe False ( ( == unique ) . fst ) mbCurrentDoc ) )
|
||||
case mbDoc of
|
||||
Nothing -> pure () -- could show a warning message
|
||||
Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
|
||||
Just ( closeDocUnique, ( Document { documentMetadata = Metadata { documentName }, documentContent }, isActiveDoc ) )
|
||||
| unsavedChanges documentContent
|
||||
-> do
|
||||
dialogWindow <- GTK.windowNew
|
||||
GTK.setWindowDecorated dialogWindow False
|
||||
GTK.windowSetTransientFor dialogWindow (Just window)
|
||||
GTK.windowSetTransientFor dialogWindow ( Just window )
|
||||
|
||||
contentBox <- GTK.boxNew GTK.OrientationVertical 30
|
||||
GTK.widgetSetMarginStart contentBox 20
|
||||
GTK.widgetSetMarginEnd contentBox 20
|
||||
GTK.widgetSetMarginTop contentBox 20
|
||||
GTK.widgetSetMarginBottom contentBox 20
|
||||
GTK.windowSetChild dialogWindow (Just contentBox)
|
||||
GTK.windowSetChild dialogWindow ( Just contentBox )
|
||||
|
||||
label <- GTK.labelNew $ Just $ "\n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?"
|
||||
label <- GTK.labelNew $ Just $ "\n\"" <> documentName <> "\" contains unsaved changes.\nClose anyway?"
|
||||
GTK.boxAppend contentBox label
|
||||
|
||||
buttonBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
|
@ -479,7 +474,7 @@ instance HandleAction Close where
|
|||
widgetAddClass button "dialogButton"
|
||||
|
||||
void $ GTK.onButtonClicked closeButton $ do
|
||||
closeDocument isActiveDoc documentUnique
|
||||
closeDocument isActiveDoc closeDocUnique
|
||||
GTK.windowDestroy dialogWindow
|
||||
void $ GTK.onButtonClicked saveCloseButton $ do
|
||||
save uiElts vars False
|
||||
|
@ -490,7 +485,7 @@ instance HandleAction Close where
|
|||
GTK.widgetSetVisible dialogWindow True
|
||||
|
||||
| otherwise
|
||||
-> closeDocument isActiveDoc documentUnique
|
||||
-> closeDocument isActiveDoc closeDocUnique
|
||||
|
||||
where
|
||||
closeDocument :: Bool -> Unique -> IO ()
|
||||
|
@ -499,7 +494,8 @@ instance HandleAction Close where
|
|||
when isActiveDoc do
|
||||
uiUpdateAction <- STM.atomically do
|
||||
STM.writeTVar activeDocumentTVar Nothing
|
||||
uiUpdateAction <- updateUIAction uiElts vars
|
||||
let change = ActiveDocChange { mbOldDocUnique = Just unique }
|
||||
uiUpdateAction <- updateUIAction change uiElts vars
|
||||
pure do
|
||||
uiUpdateAction
|
||||
updateHistoryState uiElts Nothing
|
||||
|
@ -535,7 +531,8 @@ instance HandleAction SwitchFromTo where
|
|||
uiUpdateAction <- STM.atomically do
|
||||
STM.writeTVar activeDocumentTVar ( Just newActiveDocUnique )
|
||||
mbHist <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar
|
||||
uiUpdateAction <- updateUIAction uiElts vars
|
||||
let change = ActiveDocChange { mbOldDocUnique = mbPrevActiveDocUnique }
|
||||
uiUpdateAction <- updateUIAction change uiElts vars
|
||||
pure do
|
||||
uiUpdateAction
|
||||
for_ mbPrevActiveDocUnique \ prevActiveDocUnique -> do
|
||||
|
@ -593,7 +590,7 @@ updateHistory f uiElts vars@( Variables {..} ) = do
|
|||
newDocHistory :: DocumentHistory
|
||||
newDocHistory = f docHistory
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDocHistory )
|
||||
uiUpdateAction <- updateUIAction uiElts vars
|
||||
uiUpdateAction <- updateUIAction NoActiveDocChange uiElts vars
|
||||
pure do
|
||||
updateHistoryState uiElts ( Just newDocHistory )
|
||||
uiUpdateAction
|
||||
|
@ -662,31 +659,21 @@ instance HandleAction Delete where
|
|||
-- Delete selected points on pressing 'Delete' in path mode.
|
||||
Selection
|
||||
| PathMode <- mode
|
||||
-> modifyingCurrentDocument uiElts vars \ doc -> do
|
||||
let
|
||||
newDocument :: Document
|
||||
updateInfo :: UpdateInfo
|
||||
( newDocument, updateInfo ) = deleteSelected doc
|
||||
case updateInfo of
|
||||
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
|
||||
| null strokesAffected
|
||||
-> pure Don'tModifyDoc
|
||||
| let
|
||||
ppDel, cpDel, changeText :: Text
|
||||
ppDel
|
||||
| pathPointsAffected == 0
|
||||
= ""
|
||||
| otherwise
|
||||
= Text.pack ( show pathPointsAffected ) <> " path points"
|
||||
cpDel
|
||||
| controlPointsAffected == 0
|
||||
= ""
|
||||
| otherwise
|
||||
= Text.pack ( show controlPointsAffected ) <> " control points"
|
||||
changeText =
|
||||
"Delete " <> Text.intercalate " and" [ ppDel, cpDel ]
|
||||
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
|
||||
-> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} )
|
||||
-> modifyingCurrentDocument uiElts vars \ doc ->
|
||||
case deleteSelected doc of
|
||||
Nothing ->
|
||||
pure Don'tModifyDoc
|
||||
Just ( doc', affectedPoints, delStrokes ) -> do
|
||||
-- TODO: this would also be a hierarchy diff...
|
||||
-- but for now we will just have emtpy strokes in the
|
||||
-- layers view.
|
||||
let diff = HistoryDiff $ ContentDiff $
|
||||
DeletePoints
|
||||
{ deletedPoints = affectedPoints
|
||||
, deletedStrokes = delStrokes
|
||||
}
|
||||
pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
|
||||
-- TODO: handle deletion of layers by checking the current focus.
|
||||
_ -> pure ()
|
||||
|
||||
-------------------
|
||||
|
@ -816,11 +803,12 @@ instance HandleAction MouseMove where
|
|||
= do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document {..} ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { documentMetadata } ) -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
let
|
||||
Metadata { documentZoom = zoom, viewportCenter } = documentMetadata
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: ℝ 2
|
||||
pos = toViewport ( ℝ2 x y )
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
|
@ -841,22 +829,34 @@ instance HandleAction MouseMove where
|
|||
| BrushMode <- mode
|
||||
-> do mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
case mbHoldAction of
|
||||
Just ( BrushWidgetAction { brushWidgetAction } ) ->
|
||||
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction ) doc of
|
||||
Just ( BrushWidgetAction { brushWidgetAction = brushAction } ) ->
|
||||
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushAction ) doc of
|
||||
Nothing ->
|
||||
pure Don'tModifyDoc
|
||||
Just ( widgetAction, newDocument ) -> do
|
||||
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange {..} )
|
||||
Just ( newDocument, _ ) -> do
|
||||
-- This is just for preview, so TrivialDiff.
|
||||
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos brushAction )
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
|
||||
_ -> pure Don'tModifyDoc
|
||||
| otherwise
|
||||
-> pure Don'tModifyDoc
|
||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
||||
for_ mbDoc \doc ->
|
||||
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
||||
mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument vars )
|
||||
for_ mbDoc \ doc ->
|
||||
updateInfoBar viewportDrawingArea infoBar vars ( Just $ documentMetadata doc )
|
||||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||||
GTK.widgetQueueDraw drawingArea
|
||||
|
||||
selectionMode :: Foldable f => f Modifier -> SelectionMode
|
||||
selectionMode = foldMap \case
|
||||
Alt _ -> Subtract
|
||||
Shift _ -> Add
|
||||
_ -> New
|
||||
|
||||
pressingControl :: Foldable f => f Modifier -> Bool
|
||||
pressingControl = any \case
|
||||
Control {} -> True
|
||||
_ -> False
|
||||
|
||||
-----------------
|
||||
-- Mouse click --
|
||||
-----------------
|
||||
|
@ -891,10 +891,12 @@ instance HandleAction MouseClick where
|
|||
1 -> do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ doc -> do
|
||||
let
|
||||
meta@( Metadata { documentZoom = zoom, viewportCenter } )
|
||||
= documentMetadata doc
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: ℝ 2
|
||||
pos = toViewport mouseClickCoords
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
|
@ -919,14 +921,21 @@ instance HandleAction MouseClick where
|
|||
case selectionMode modifiers of
|
||||
-- Drag move: not holding shift or alt, click has selected something.
|
||||
New
|
||||
| Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
|
||||
| Just dragMove <- dragMoveSelect pos doc
|
||||
-> do
|
||||
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
|
||||
case dragMove of
|
||||
ClickedOnSelected ->
|
||||
pure Don'tModifyDoc
|
||||
ClickedOnUnselected ->
|
||||
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
|
||||
ClickedOnPoint { dragPoint = (u, i), dragPointWasSelected } ->
|
||||
if dragPointWasSelected
|
||||
-- Clicked on a selected point: preserve selection.
|
||||
then pure Don'tModifyDoc
|
||||
else do
|
||||
-- Clicked on an unselected point: only select that point.
|
||||
let newDoc = set ( field' @"documentMetadata" . field' @"selectedPoints" )
|
||||
( StrokePoints $ Map.singleton u ( Set.singleton i ) )
|
||||
doc
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDoc TrivialDiff )
|
||||
-- Clicked on curve: preserve old selection.
|
||||
ClickedOnCurve {} ->
|
||||
pure Don'tModifyDoc
|
||||
-- Rectangular selection.
|
||||
|
@ -940,24 +949,29 @@ instance HandleAction MouseClick where
|
|||
case mbPartialPath of
|
||||
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
|
||||
Nothing -> do
|
||||
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
|
||||
( newDocument, drawAnchor ) <-
|
||||
getOrCreateDrawAnchor uniqueSupply pos doc
|
||||
STM.writeTVar partialPathTVar
|
||||
( Just $ PartialPath
|
||||
{ partialStartPos = anchorPt
|
||||
{ partialPathAnchor = drawAnchor
|
||||
, partialControlPoint = Nothing
|
||||
, partialPathAnchor = drawAnchor
|
||||
, firstPoint = True
|
||||
}
|
||||
)
|
||||
case mbExistingAnchorName of
|
||||
Nothing ->
|
||||
let
|
||||
changeText :: Text
|
||||
changeText = "Begin new stroke"
|
||||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
Just _ ->
|
||||
pure Don'tModifyDoc
|
||||
if anchorIsNew drawAnchor
|
||||
then do
|
||||
let
|
||||
diff :: Diff
|
||||
diff = HistoryDiff $ HierarchyDiff
|
||||
$ NewLayer
|
||||
{ newUnique = anchorStroke drawAnchor
|
||||
, newPosition = WithinParent Root 0
|
||||
-- TODO: add the stroke above the selected layer
|
||||
-- or something of the sort.
|
||||
}
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
else
|
||||
pure Don'tModifyDoc
|
||||
-- Path already started: indicate that we are continuing a path.
|
||||
Just pp -> do
|
||||
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
||||
|
@ -970,11 +984,15 @@ instance HandleAction MouseClick where
|
|||
-> Just brushWidgetAction
|
||||
_ -> Nothing
|
||||
case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
|
||||
Just ( actionState@( BrushWidgetActionState { brushWidgetAction = act } ), newDocument ) -> do
|
||||
Just ( newDocument, actionState@( BrushWidgetActionState { brushWidgetAction = act } ) ) -> do
|
||||
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
|
||||
let changeText :: Text
|
||||
changeText = "Update brush parameters (" <> Brush.describeWidgetAction act <> ")"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
let diff = HistoryDiff $ ContentDiff
|
||||
$ UpdateBrushParameters
|
||||
{ updateBrushStroke = brushWidgetStrokeUnique actionState
|
||||
, updateBrushPoint = brushWidgetPointIndex actionState
|
||||
, updateBrushAction = act
|
||||
}
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
_ ->
|
||||
pure Don'tModifyDoc
|
||||
|
||||
|
@ -992,11 +1010,11 @@ instance HandleAction MouseClick where
|
|||
case subdivide pos doc of
|
||||
Nothing ->
|
||||
pure Don'tModifyDoc
|
||||
Just ( newDocument, loc ) -> do
|
||||
Just ( newDocument, subdiv ) -> do
|
||||
let
|
||||
changeText :: Text
|
||||
changeText = "Subdivide " <> loc
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
diff = HistoryDiff $ ContentDiff
|
||||
$ SubdivideStroke subdiv
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
|
||||
-- Ignore double click event otherwise.
|
||||
_ -> pure Don'tModifyDoc
|
||||
|
@ -1005,12 +1023,12 @@ instance HandleAction MouseClick where
|
|||
showGuides <- STM.readTVar showGuidesTVar
|
||||
when showGuides do
|
||||
let
|
||||
mbGuide :: Maybe Guide
|
||||
mbGuide = selectedGuide pos doc
|
||||
mbGuide :: Maybe ( Unique, Guide )
|
||||
mbGuide = selectedGuide pos zoom ( documentGuides meta )
|
||||
guideAction :: GuideAction
|
||||
guideAction
|
||||
| Just guide <- mbGuide
|
||||
= MoveGuide ( guideUnique guide )
|
||||
| Just ( guideUnique, _guide ) <- mbGuide
|
||||
= MoveGuide guideUnique
|
||||
| otherwise
|
||||
= CreateGuide ruler
|
||||
STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
|
||||
|
@ -1043,10 +1061,11 @@ instance HandleAction MouseRelease where
|
|||
1 -> do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { documentMetadata } ) -> do
|
||||
let
|
||||
Metadata { documentZoom = zoom, viewportCenter } = documentMetadata
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: ℝ 2
|
||||
pos = toViewport ( ℝ2 x y )
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
|
@ -1060,12 +1079,9 @@ instance HandleAction MouseRelease where
|
|||
| createGuide
|
||||
-> do
|
||||
newDocument <- addGuide uniqueSupply ruler pos doc
|
||||
let
|
||||
changeText :: Text
|
||||
changeText = "Create guide"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
|
||||
| otherwise
|
||||
-> pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange doc )
|
||||
-> pure ( UpdateDoc $ UpdateDocumentTo doc TrivialDiff )
|
||||
-- ^^ force an UI update when releasing a guide inside a ruler area
|
||||
where
|
||||
createGuide :: Bool
|
||||
|
@ -1080,22 +1096,18 @@ instance HandleAction MouseRelease where
|
|||
newDocument :: Document
|
||||
newDocument =
|
||||
over
|
||||
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
|
||||
( field' @"documentMetadata" . field' @"documentGuides" . ix guideUnique . field' @"guidePoint" )
|
||||
( ( holdStartPos --> pos :: T ( ℝ 2 ) ) • )
|
||||
doc
|
||||
changeText :: Text
|
||||
changeText = "Move guide"
|
||||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
in pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
|
||||
| otherwise
|
||||
-> let
|
||||
newDocument :: Document
|
||||
newDocument =
|
||||
set ( field' @"documentContent" . field' @"guides" . at guideUnique )
|
||||
set ( field' @"documentMetadata" . field' @"documentGuides" . at guideUnique )
|
||||
Nothing
|
||||
doc
|
||||
changeText :: Text
|
||||
changeText = "Delete guide"
|
||||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
in pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
|
||||
where
|
||||
l, t :: Double
|
||||
ℝ2 l t = toViewport ( ℝ2 0 0 )
|
||||
|
@ -1119,17 +1131,27 @@ instance HandleAction MouseRelease where
|
|||
Just hold
|
||||
| PathMode <- mode
|
||||
, DragMoveHold { holdStartPos = pos0, dragAction } <- hold
|
||||
, quadrance @( T ( ℝ 2 ) ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
|
||||
, not $ inPointClickRange zoom pos0 pos
|
||||
-> let
|
||||
alternateMode :: Bool
|
||||
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
||||
in case dragUpdate pos0 pos dragAction alternateMode doc of
|
||||
Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
|
||||
Just ( doc', affectedPts ) ->
|
||||
let diff = HistoryDiff $ ContentDiff
|
||||
$ DragMove
|
||||
{ dragMoveSelection = dragAction
|
||||
, dragVector = pos0 --> pos
|
||||
, draggedPoints = affectedPts
|
||||
}
|
||||
in pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
|
||||
Nothing -> pure Don'tModifyDoc
|
||||
| SelectionHold pos0 <- hold
|
||||
, quadrance @( T ( ℝ 2 ) ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
|
||||
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
|
||||
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
|
||||
, not $ inPointClickRange zoom pos0 pos
|
||||
, let mbDoc' = fst <$> selectRectangle selMode pos0 pos doc
|
||||
-> pure ( UpdateDoc $ UpdateDocumentTo ( fromMaybe doc mbDoc' ) TrivialDiff )
|
||||
_ ->
|
||||
let mbDoc' = fst <$> selectAt selMode pos doc
|
||||
in pure ( UpdateDoc $ UpdateDocumentTo ( fromMaybe doc mbDoc' ) TrivialDiff )
|
||||
|
||||
Pen -> case mode of
|
||||
PathMode -> do
|
||||
|
@ -1145,13 +1167,14 @@ instance HandleAction MouseRelease where
|
|||
-- - release at different point as click: finish current segment, adding a control point.
|
||||
Just
|
||||
( PartialPath
|
||||
{ partialStartPos = p1
|
||||
{ partialPathAnchor = anchor
|
||||
, partialControlPoint = mbCp2
|
||||
, partialPathAnchor = anchor
|
||||
, firstPoint
|
||||
}
|
||||
) -> do
|
||||
let
|
||||
p1 :: ℝ 2
|
||||
p1 = anchorPos anchor
|
||||
pathPoint :: ℝ 2
|
||||
mbControlPoint :: Maybe ( ℝ 2 )
|
||||
partialControlPoint :: Maybe ( ℝ 2 )
|
||||
|
@ -1160,60 +1183,72 @@ instance HandleAction MouseRelease where
|
|||
= ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos )
|
||||
| otherwise
|
||||
= ( pos, Nothing, Nothing )
|
||||
( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
|
||||
i0
|
||||
| anchorIsAtEnd anchor
|
||||
= case anchorIndex anchor of
|
||||
FirstPoint -> 0
|
||||
PointIndex { pointCurve = i } -> i + 1
|
||||
| otherwise
|
||||
= case anchorIndex anchor of
|
||||
FirstPoint -> -1
|
||||
PointIndex { pointCurve = i } -> i - 1
|
||||
( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
|
||||
if not firstPoint && anchorsAreComplementary anchor otherAnchor
|
||||
-- Close path.
|
||||
then do
|
||||
STM.writeTVar partialPathTVar Nothing
|
||||
let
|
||||
newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
|
||||
newSegment = catMaybesSpline ( invalidateCache undefined )
|
||||
( PointData p1 Normal () )
|
||||
newSegment :: Spline Open CurveData ( PointData () )
|
||||
newSegment = catMaybesSpline ( CurveData i0 ( invalidateCache undefined ) )
|
||||
( PointData p1 () )
|
||||
( do
|
||||
cp <- mbCp2
|
||||
guard ( cp /= p1 )
|
||||
pure ( PointData cp Normal () )
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( do
|
||||
cp <- mbControlPoint
|
||||
guard ( cp /= otherAnchorPt )
|
||||
pure ( PointData cp Normal () )
|
||||
guard ( cp /= anchorPos otherAnchor )
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( PointData otherAnchorPt Normal () )
|
||||
( PointData ( anchorPos otherAnchor) () )
|
||||
newDocument :: Document
|
||||
newDocument = addToAnchor anchor newSegment doc
|
||||
changeText :: Text
|
||||
changeText = "Close stroke"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
diff = HistoryDiff $ ContentDiff
|
||||
$ CloseStroke { closedStroke = anchorStroke anchor }
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
else
|
||||
if firstPoint
|
||||
-- Continue current partial path.
|
||||
then do
|
||||
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
|
||||
STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False )
|
||||
pure Don'tModifyDoc
|
||||
-- Finish current partial path.
|
||||
else do
|
||||
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
|
||||
STM.writeTVar partialPathTVar ( Just $ PartialPath ( anchor { anchorPos = pathPoint } ) partialControlPoint False )
|
||||
let
|
||||
newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
|
||||
newSegment = catMaybesSpline ( invalidateCache undefined )
|
||||
( PointData p1 Normal () )
|
||||
newSegment :: Spline Open CurveData ( PointData () )
|
||||
newSegment = catMaybesSpline ( CurveData i0 ( invalidateCache undefined ) )
|
||||
( PointData p1 () )
|
||||
( do
|
||||
cp <- mbCp2
|
||||
guard ( cp /= p1 )
|
||||
pure ( PointData cp Normal () )
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( do
|
||||
cp <- mbControlPoint
|
||||
guard ( cp /= pathPoint )
|
||||
pure ( PointData cp Normal () )
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( PointData pathPoint Normal () )
|
||||
( PointData pathPoint () )
|
||||
newDocument :: Document
|
||||
newDocument = addToAnchor anchor newSegment doc
|
||||
changeText :: Text
|
||||
changeText = "Continue stroke"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
diff = HistoryDiff $ ContentDiff
|
||||
$ ContinueStroke
|
||||
{ continuedStroke = anchorStroke anchor
|
||||
, newSegment = bimapSpline ( \ _ crv -> bimapCurve ( \ _ -> () ) ( \ _ _ -> () ) crv ) ( \ _ -> () ) newSegment
|
||||
}
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
BrushMode -> do
|
||||
STM.writeTVar mouseHoldTVar Nothing
|
||||
pure Don'tModifyDoc
|
||||
|
@ -1255,7 +1290,8 @@ instance HandleAction Scroll where
|
|||
--viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
|
||||
|
||||
unless ( dx == 0 && dy == 0 ) do
|
||||
modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { documentMetadata = oldMetadata }) -> do
|
||||
let Metadata { viewportCenter = oldCenter, documentZoom = Zoom { zoomFactor = oldZoomFactor } } = oldMetadata
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
let
|
||||
mousePos :: ℝ 2
|
||||
|
@ -1276,22 +1312,31 @@ instance HandleAction Scroll where
|
|||
newCenter
|
||||
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: T ( ℝ 2 ) )
|
||||
• oldCenter
|
||||
in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos )
|
||||
newMetadata =
|
||||
oldMetadata
|
||||
{ documentZoom = Zoom newZoomFactor
|
||||
, viewportCenter = newCenter }
|
||||
|
||||
in ( doc { documentMetadata = newMetadata }, mousePos )
|
||||
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
|
||||
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
|
||||
= let
|
||||
newCenter :: ℝ 2
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dy 0 ) • oldCenter
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos )
|
||||
in ( set ( field' @"documentMetadata" . field' @"viewportCenter" ) newCenter doc
|
||||
, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos
|
||||
)
|
||||
-- Vertical scrolling.
|
||||
| otherwise
|
||||
= let
|
||||
newCenter :: ℝ 2
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dx dy ) • oldCenter
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos )
|
||||
in ( set ( field' @"documentMetadata" . field' @"viewportCenter" ) newCenter doc
|
||||
, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos
|
||||
)
|
||||
for_ mbMousePos \ _ ->
|
||||
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||||
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDoc TrivialDiff )
|
||||
|
||||
--------------------
|
||||
-- Keyboard press --
|
|
@ -1,4 +1,4 @@
|
|||
module MetaBrush.Action where
|
||||
module MetaBrush.Application.Action where
|
||||
|
||||
-- base
|
||||
import Data.Word
|
||||
|
@ -18,7 +18,7 @@ import Data.Text
|
|||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
import {-# SOURCE #-} MetaBrush.Application.Context
|
||||
( UIElements, Variables )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( TabLocation(..) )
|
|
@ -1,4 +1,4 @@
|
|||
module MetaBrush.Context
|
||||
module MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, LR(..), Modifier(..), modifierKey
|
||||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||||
|
@ -38,27 +38,35 @@ import qualified Control.Concurrent.STM.TVar as STM
|
|||
import Data.HashMap.Strict
|
||||
( HashMap )
|
||||
|
||||
-- MetaBrush
|
||||
-- brush-strokes
|
||||
import Math.Bezier.Cubic.Fit
|
||||
( FitParameters )
|
||||
import Math.Bezier.Stroke
|
||||
( RootSolvingAlgorithm )
|
||||
import Math.Linear
|
||||
( ℝ(..) )
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
import Math.Root.Isolation
|
||||
( RootIsolationOptions )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
( BrushWidgetActionState )
|
||||
import {-# SOURCE #-} MetaBrush.Application.Action
|
||||
( ActionName )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Document.Draw
|
||||
import MetaBrush.Document.Diff
|
||||
( DragMoveSelect )
|
||||
import MetaBrush.Draw
|
||||
( DrawAnchor )
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..) )
|
||||
import MetaBrush.Document.Selection
|
||||
( DragMoveSelect, BrushWidgetActionState )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( FileBar, FileBarTab )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import MetaBrush.UI.Panels
|
||||
( PanelsBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.ToolBar
|
||||
( Tool, Mode )
|
||||
import MetaBrush.UI.Viewport
|
||||
|
@ -66,6 +74,7 @@ import MetaBrush.UI.Viewport
|
|||
import MetaBrush.Unique
|
||||
( UniqueSupply, Unique )
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data UIElements
|
||||
|
@ -80,28 +89,31 @@ data UIElements
|
|||
, infoBar :: !InfoBar
|
||||
, menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
|
||||
, menuActions :: !( HashMap ActionName GIO.SimpleAction )
|
||||
, panelsBar :: !PanelsBar
|
||||
, colours :: !Colours
|
||||
}
|
||||
|
||||
data Variables
|
||||
= Variables
|
||||
{ uniqueSupply :: !UniqueSupply
|
||||
, recomputeStrokesTVar :: !( STM.TVar Bool )
|
||||
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
|
||||
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
|
||||
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
|
||||
, mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) )
|
||||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||||
, toolTVar :: !( STM.TVar Tool )
|
||||
, modeTVar :: !( STM.TVar Mode )
|
||||
, debugTVar :: !( STM.TVar Bool )
|
||||
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
|
||||
, fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) )
|
||||
, showGuidesTVar :: !( STM.TVar Bool )
|
||||
, maxHistorySizeTVar :: !( STM.TVar Int )
|
||||
, fitParametersTVar :: !( STM.TVar FitParameters )
|
||||
, rootsAlgoTVar :: !( STM.TVar RootSolvingAlgorithm )
|
||||
{ uniqueSupply :: !UniqueSupply
|
||||
, recomputeStrokesTVar :: !( STM.TVar Bool )
|
||||
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
|
||||
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
|
||||
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
|
||||
, strokeListModelsTVar :: !( STM.TVar ( Map Unique GTK.SelectionModel ) )
|
||||
, mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) )
|
||||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||||
, toolTVar :: !( STM.TVar Tool )
|
||||
, modeTVar :: !( STM.TVar Mode )
|
||||
, debugTVar :: !( STM.TVar Bool )
|
||||
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
|
||||
, fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) )
|
||||
, showGuidesTVar :: !( STM.TVar Bool )
|
||||
, maxHistorySizeTVar :: !( STM.TVar Int )
|
||||
, fitParametersTVar :: !( STM.TVar FitParameters )
|
||||
, rootsAlgoTVar :: !( STM.TVar RootSolvingAlgorithm )
|
||||
, cuspFindingOptionsTVar :: !( STM.TVar ( Maybe ( RootIsolationOptions 2 3 ) ) )
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -159,9 +171,8 @@ data HoldAction
|
|||
-- | Keep track of a path that is in the middle of being drawn.
|
||||
data PartialPath
|
||||
= PartialPath
|
||||
{ partialStartPos :: !( ℝ 2 )
|
||||
{ partialPathAnchor :: !DrawAnchor
|
||||
, partialControlPoint :: !( Maybe ( ℝ 2 ) )
|
||||
, partialPathAnchor :: !DrawAnchor
|
||||
, firstPoint :: !Bool
|
||||
}
|
||||
deriving stock Show
|
|
@ -1,4 +1,4 @@
|
|||
module MetaBrush.Context
|
||||
module MetaBrush.Application.Context
|
||||
( UIElements, Variables
|
||||
, Modifier(..), LR(..) )
|
||||
where
|
|
@ -1,18 +1,10 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module MetaBrush.Document.Update
|
||||
( activeDocument, withActiveDocument
|
||||
, DocChange(..), DocumentUpdate(..)
|
||||
, PureDocModification(..), DocModification(..)
|
||||
, modifyingCurrentDocument
|
||||
, updateUIAction
|
||||
, updateHistoryState
|
||||
)
|
||||
where
|
||||
module MetaBrush.Application.UpdateDocument where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( (&&&) )
|
||||
( (&&&), second )
|
||||
import Control.Monad
|
||||
( join )
|
||||
import Data.Coerce
|
||||
|
@ -67,48 +59,51 @@ import qualified Data.HashMap.Lazy as HashMap
|
|||
( lookup )
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
import {-# SOURCE #-} MetaBrush.Application.Action
|
||||
( ActionName(..) )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..) )
|
||||
( Document(..), DocumentContent(..), DocumentMetadata(..)
|
||||
)
|
||||
import MetaBrush.Document.Diff
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), atStart, atEnd
|
||||
, newFutureStep, affirmPresent
|
||||
)
|
||||
import MetaBrush.GTK.Util
|
||||
( (>>?=) )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( FileBarTab(..), removeFileTab )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( updateInfoBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.GTK.Util
|
||||
( (>>?=) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Read the currently active document from the stateful variables.
|
||||
activeDocument :: Variables -> STM ( Maybe DocumentHistory )
|
||||
activeDocument :: Variables -> STM ( Maybe ( Unique, DocumentHistory ) )
|
||||
activeDocument ( Variables { activeDocumentTVar, openDocumentsTVar } )
|
||||
= STM.readTVar activeDocumentTVar
|
||||
>>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar )
|
||||
>>?= ( \ unique -> fmap ( unique , ) . Map.lookup unique <$> STM.readTVar openDocumentsTVar )
|
||||
|
||||
-- | Do something with the currently active document.
|
||||
--
|
||||
-- Does nothing if no document is currently active.
|
||||
withActiveDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a )
|
||||
withActiveDocument vars f = traverse f =<< ( fmap present <$> activeDocument vars )
|
||||
|
||||
|
||||
data DocChange
|
||||
= TrivialChange { newDocument :: !Document }
|
||||
| HistoryChange { newDocument :: !Document, changeText :: !Text }
|
||||
withActiveDocument :: Variables -> ( Unique -> Document -> STM a ) -> STM ( Maybe a )
|
||||
withActiveDocument vars f = traverse ( uncurry f ) =<< ( fmap ( second present ) <$> activeDocument vars )
|
||||
|
||||
-- TODO: not sure why we need this datatype.
|
||||
data DocumentUpdate
|
||||
= CloseDocument
|
||||
| SaveDocument !( Maybe FilePath )
|
||||
| UpdateDocumentTo !DocChange
|
||||
| UpdateDocumentTo
|
||||
{ newDocument :: !Document
|
||||
, documentDiff :: !Diff
|
||||
}
|
||||
|
||||
data PureDocModification
|
||||
= Don'tModifyDoc
|
||||
|
@ -154,69 +149,83 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables
|
|||
Ap uiUpdateAction <- lift . getAp $ flip ( foldMapOf docFold ) modif $ Ap . \case
|
||||
CloseDocument -> do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.delete unique )
|
||||
coerce ( updateUIAction uiElts vars )
|
||||
let change = ActiveDocChange { mbOldDocUnique = Just unique }
|
||||
coerce ( updateUIAction change uiElts vars )
|
||||
SaveDocument Nothing -> do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique )
|
||||
coerce ( updateUIAction uiElts vars )
|
||||
coerce ( updateUIAction NoActiveDocChange uiElts vars )
|
||||
SaveDocument ( Just newFilePath ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust
|
||||
( affirmPresent
|
||||
. set ( field' @"present" . field' @"mbFilePath" )
|
||||
. set ( field' @"present" . field' @"documentMetadata" . field' @"documentFilePath" )
|
||||
( Just newFilePath )
|
||||
)
|
||||
unique
|
||||
)
|
||||
coerce ( updateUIAction uiElts vars )
|
||||
UpdateDocumentTo ( TrivialChange { newDocument } ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust ( set ( field' @"present" ) newDocument ) unique )
|
||||
coerce ( updateUIAction uiElts vars )
|
||||
UpdateDocumentTo ( HistoryChange { newDocument, changeText } ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust
|
||||
( newFutureStep maxHistSize
|
||||
. set ( field' @"documentContent" . field' @"unsavedChanges" ) True
|
||||
. set ( field' @"documentContent" . field' @"latestChange" ) changeText
|
||||
$ newDocument
|
||||
)
|
||||
unique
|
||||
)
|
||||
uiUpdateAction <- updateUIAction uiElts vars
|
||||
pure $ Ap do
|
||||
uiUpdateAction
|
||||
for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
|
||||
for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
|
||||
coerce ( updateUIAction NoActiveDocChange uiElts vars )
|
||||
UpdateDocumentTo { newDocument, documentDiff = diff } ->
|
||||
case diff of
|
||||
TrivialDiff -> do
|
||||
-- Non-content change.
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust ( set ( field' @"present" ) newDocument ) unique )
|
||||
coerce ( updateUIAction NoActiveDocChange uiElts vars )
|
||||
HistoryDiff histDiff -> do
|
||||
-- Content change.
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust
|
||||
( newFutureStep maxHistSize
|
||||
. set ( field' @"documentContent" . field' @"unsavedChanges" ) True
|
||||
$ newDocument
|
||||
)
|
||||
unique
|
||||
)
|
||||
uiUpdateAction <- updateUIAction NoActiveDocChange uiElts vars
|
||||
pure $ Ap do
|
||||
uiUpdateAction
|
||||
for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
|
||||
for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
|
||||
pure
|
||||
do
|
||||
forOf_ docFold modif \ mbNewDoc -> do
|
||||
case mbNewDoc of
|
||||
CloseDocument -> removeFileTab uiElts vars ( documentUnique oldDoc )
|
||||
CloseDocument -> removeFileTab uiElts vars unique
|
||||
_ -> pure ()
|
||||
uiUpdateAction
|
||||
sequenceAOf_ actionFold modif
|
||||
sequenceA_ mbAction
|
||||
|
||||
-- | A change in which document is currently active.
|
||||
data ActiveDocChange
|
||||
-- | Continue with the same document (or lack of document).
|
||||
= NoActiveDocChange
|
||||
-- | Change between documents, or open/close a document.
|
||||
| ActiveDocChange
|
||||
{ mbOldDocUnique :: Maybe Unique
|
||||
}
|
||||
|
||||
updateUIAction :: UIElements -> Variables -> STM ( IO () )
|
||||
updateUIAction uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
|
||||
updateUIAction :: ActiveDocChange -> UIElements -> Variables -> STM ( IO () )
|
||||
updateUIAction _docChange uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
|
||||
mbDocHist <- activeDocument vars
|
||||
let
|
||||
mbDoc :: Maybe Document
|
||||
mbDoc = present <$> mbDocHist
|
||||
mbDoc :: Maybe ( Unique, Document )
|
||||
mbDoc = second present <$> mbDocHist
|
||||
mbTitleText :: Maybe ( Text, Bool )
|
||||
mbTitleText = fmap ( displayName &&& unsavedChanges . documentContent ) mbDoc
|
||||
mbActiveTabDoc <- fmap join $ for mbDoc \ doc -> do
|
||||
mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
|
||||
mbTitleText = fmap ( ( documentName . documentMetadata &&& unsavedChanges . documentContent ) . snd ) mbDoc
|
||||
mbActiveTabDoc <- fmap join $ for mbDoc \ ( docUnique, _doc ) -> do
|
||||
mbActiveTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||
pure ( (,) <$> mbActiveTab <*> mbDoc )
|
||||
--strokeModels <- STM.readTVar strokeListModelsTVar
|
||||
pure do
|
||||
updateTitle window titleLabel mbTitleText
|
||||
updateInfoBar viewportDrawingArea infoBar vars mbDoc
|
||||
for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, activeDoc ) -> do
|
||||
GTK.buttonSetLabel fileBarTabButton ( displayName activeDoc )
|
||||
updateInfoBar viewportDrawingArea infoBar vars ( fmap ( documentMetadata . snd ) mbDoc )
|
||||
--switchStrokeView (strokesListView $ panelsBar) strokeModels (fst <$> mbDoc)
|
||||
for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, ( _, activeDoc ) ) -> do
|
||||
GTK.buttonSetLabel fileBarTabButton ( documentName $ documentMetadata activeDoc )
|
||||
GTK.widgetQueueDraw fileBarTab
|
||||
GTK.widgetQueueDraw fileBarTabCloseArea
|
||||
updateHistoryState uiElts mbDocHist
|
||||
updateHistoryState uiElts ( fmap snd mbDocHist )
|
||||
STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
|
||||
|
||||
updateTitle :: GTK.IsWindow window => window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
|
|
@ -1,27 +1,27 @@
|
|||
module MetaBrush.Document.Update
|
||||
( DocChange(..), DocumentUpdate(..)
|
||||
module MetaBrush.Application.UpdateDocument
|
||||
( DocumentUpdate(..)
|
||||
, PureDocModification(..), DocModification(..)
|
||||
, ActiveDocChange(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Document
|
||||
( Document(..) )
|
||||
import MetaBrush.Document.Diff
|
||||
( Diff )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data DocChange
|
||||
= TrivialChange { newDocument :: !Document }
|
||||
| HistoryChange { newDocument :: !Document, changeText :: !Text }
|
||||
|
||||
data DocumentUpdate
|
||||
= CloseDocument
|
||||
| SaveDocument !( Maybe FilePath )
|
||||
| UpdateDocumentTo !DocChange
|
||||
| UpdateDocumentTo
|
||||
{ newDocument :: !Document
|
||||
, documentDiff :: !Diff
|
||||
}
|
||||
|
||||
data PureDocModification
|
||||
= Don'tModifyDoc
|
||||
|
@ -34,3 +34,9 @@ data DocModification
|
|||
{ modifDocument :: !DocumentUpdate
|
||||
, postModifAction :: IO ()
|
||||
}
|
||||
|
||||
data ActiveDocChange
|
||||
= NoActiveDocChange
|
||||
| ActiveDocChange
|
||||
{ mbOldDocUnique :: Maybe Unique
|
||||
}
|
File diff suppressed because it is too large
Load diff
|
@ -25,17 +25,19 @@ import qualified GI.Gtk as GTK
|
|||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( readTVarIO )
|
||||
|
||||
-- MetaBrush
|
||||
-- brush-strokes
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Action
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Application.Action
|
||||
( HandleAction(..)
|
||||
, ActionOrigin(..)
|
||||
, MouseMove(..), MouseClick(..), MouseClickType(..), MouseRelease(..)
|
||||
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
|
||||
, quitEverything
|
||||
)
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), ViewportEventControllers(..), Ruler(..) )
|
||||
|
|
|
@ -21,6 +21,8 @@ import Data.Functor.Compose
|
|||
( Compose(..) )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import Data.Maybe
|
||||
( fromMaybe )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1, Generically1(..) )
|
||||
|
||||
|
@ -33,10 +35,12 @@ import Data.Act
|
|||
)
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
|
@ -45,17 +49,14 @@ import Control.DeepSeq
|
|||
-- gi-cairo-render
|
||||
import qualified GI.Cairo.Render as Cairo
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Class
|
||||
( lift )
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( StateT, evalStateT, get, put )
|
||||
import Control.Monad.Trans.Writer.CPS as Writer
|
||||
|
||||
-- MetaBrush
|
||||
-- brush-strokes
|
||||
import Calligraphy.Brushes
|
||||
( Brush(..) )
|
||||
import Math.Algebra.Dual
|
||||
|
@ -67,14 +68,8 @@ import Math.Bezier.Cubic.Fit
|
|||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..) )
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplinePts, PointType(..)
|
||||
, SplineType(..), SplineTypeI, KnownSplineType(bifoldSpline)
|
||||
, Curve(..)
|
||||
, fromNextPoint
|
||||
, catMaybesSpline
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( Cusp(..), CachedStroke(..), invalidateCache
|
||||
( Cusp(..), invalidateCache
|
||||
, computeStrokeOutline
|
||||
, RootSolvingAlgorithm
|
||||
)
|
||||
|
@ -86,42 +81,32 @@ import Math.Module
|
|||
( Module((*^)), normalise )
|
||||
import Math.Root.Isolation
|
||||
( RootIsolationOptions )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
( dragUpdate )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours, ColourRecord(..) )
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush(..), WithParams(..) )
|
||||
import qualified MetaBrush.Brush.Widget as Brush
|
||||
( Widget(..), WidgetElements(..), widgetElements )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( Modifier(..)
|
||||
, HoldAction(..), PartialPath(..)
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..)
|
||||
, mkAABB
|
||||
, Stroke(..), visibleStrokes
|
||||
, StrokeSpline
|
||||
, FocusState(..)
|
||||
, HoverContext(..), Hoverable(..)
|
||||
, PointData(..)
|
||||
, _selection
|
||||
, coords
|
||||
)
|
||||
import MetaBrush.Document.Draw
|
||||
( withAnchorBrushData )
|
||||
import MetaBrush.Document.Selection
|
||||
( dragUpdate )
|
||||
import MetaBrush.Document.Serialise
|
||||
( ) -- 'Serialisable' instances
|
||||
import MetaBrush.Document.Update
|
||||
( DocChange(..) )
|
||||
import MetaBrush.Draw
|
||||
import MetaBrush.Hover
|
||||
( mkAABB, HoverContext(..), Hoverable(..) )
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Stroke
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Mode(..) )
|
||||
import MetaBrush.Unique
|
||||
( unsafeUnique )
|
||||
import MetaBrush.Util
|
||||
( traverseMaybe )
|
||||
( Unique )
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
|
@ -168,12 +153,19 @@ getDocumentRender
|
|||
rootAlgo mbCuspOptions fitParams
|
||||
mode debug
|
||||
modifiers mbMousePos mbHoldEvent mbPartialPath
|
||||
doc@( Document { viewportCenter = ℝ2 cx cy, zoomFactor, documentContent = content } )
|
||||
doc@( Document
|
||||
{ documentMetadata =
|
||||
Metadata
|
||||
{ viewportCenter = ℝ2 cx cy
|
||||
, documentZoom = zoom@( Zoom { zoomFactor } )
|
||||
, selectedPoints = selPts
|
||||
}
|
||||
} )
|
||||
= do
|
||||
|
||||
let
|
||||
-- Get any modifications from in-flight user actions (e.g. in the middle of dragging something).
|
||||
modifiedStrokes :: Seq Stroke
|
||||
modifiedStrokes :: [ ( Maybe Unique, Stroke ) ]
|
||||
modifiedStrokes = case mode of
|
||||
PathMode
|
||||
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
|
||||
|
@ -182,13 +174,14 @@ getDocumentRender
|
|||
, let
|
||||
alternateMode :: Bool
|
||||
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
||||
afterDrag :: Maybe DocChange
|
||||
afterDrag :: Maybe ( Document, StrokePoints )
|
||||
afterDrag = dragUpdate p0 p1 dragAction alternateMode doc
|
||||
-> case afterDrag of
|
||||
Just docUpdate -> foldMap visibleStrokes . strokes . documentContent $ newDocument docUpdate
|
||||
_ -> foldMap visibleStrokes . strokes $ content
|
||||
| Just ( PartialPath p0 cp0 anchor firstPoint ) <- mbPartialPath
|
||||
Just ( docUpdate, _ ) -> getVisibleStrokes docUpdate
|
||||
Nothing -> getVisibleStrokes doc
|
||||
| Just ( PartialPath anchor cp0 firstPoint ) <- mbPartialPath
|
||||
, let
|
||||
p0 = anchorPos anchor
|
||||
mbFinalPoint :: Maybe ( ℝ 2 )
|
||||
mbControlPoint :: Maybe ( ℝ 2 )
|
||||
( mbFinalPoint, mbControlPoint )
|
||||
|
@ -203,34 +196,34 @@ getDocumentRender
|
|||
previewStroke :: Stroke
|
||||
previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Record pointFields ) ->
|
||||
let
|
||||
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Record pointFields ) )
|
||||
previewSpline = catMaybesSpline ( invalidateCache undefined )
|
||||
( PointData p0 Normal pointData )
|
||||
previewSpline :: Spline Open CurveData ( PointData ( Record pointFields ) )
|
||||
previewSpline = catMaybesSpline ( CurveData 987654321 ( invalidateCache undefined ) )
|
||||
( PointData p0 pointData )
|
||||
( do
|
||||
cp <- cp0
|
||||
guard ( cp /= p0 )
|
||||
pure ( PointData cp Normal pointData )
|
||||
pure ( PointData cp pointData )
|
||||
)
|
||||
( do
|
||||
cp <- mbControlPoint
|
||||
guard ( cp /= finalPoint )
|
||||
pure ( PointData cp Normal pointData )
|
||||
pure ( PointData cp pointData )
|
||||
)
|
||||
( PointData finalPoint Normal pointData )
|
||||
( PointData finalPoint pointData )
|
||||
in
|
||||
Stroke
|
||||
{ strokeSpline = previewSpline
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 987654321
|
||||
, strokeName = "Preview stroke (temporary)"
|
||||
, strokeBrush = mbBrush
|
||||
{ strokeSpline = previewSpline
|
||||
, strokeBrush = mbBrush
|
||||
}
|
||||
-> previewStroke :<| foldMap visibleStrokes ( strokes content )
|
||||
_ -> foldMap visibleStrokes ( strokes content )
|
||||
-> ( Nothing, previewStroke ) : getVisibleStrokes doc
|
||||
_ -> getVisibleStrokes doc
|
||||
|
||||
strokesRenderData <-
|
||||
traverseMaybe
|
||||
( sequenceA . strokeRenderData rootAlgo mbCuspOptions fitParams )
|
||||
traverse
|
||||
( \ ( mbUnique, stroke ) ->
|
||||
( mbUnique, ) <$>
|
||||
strokeRenderData rootAlgo mbCuspOptions fitParams stroke
|
||||
)
|
||||
modifiedStrokes
|
||||
|
||||
let
|
||||
|
@ -248,14 +241,28 @@ getDocumentRender
|
|||
Cairo.save
|
||||
Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
|
||||
Cairo.scale zoomFactor zoomFactor
|
||||
Cairo.translate ( -cx ) ( -cy )
|
||||
Cairo.translate -cx -cy
|
||||
for_ strokesRenderData
|
||||
( compositeRenders . getCompose . renderStroke cols mbHoverContext mode RenderingPath debug zoomFactor )
|
||||
( compositeRenders . getCompose . renderStroke cols selPts mbHoverContext mode RenderingPath debug zoom )
|
||||
renderSelectionRect
|
||||
Cairo.restore
|
||||
|
||||
strokesRenderData `deepseq` pure drawingInstructions
|
||||
|
||||
getVisibleStrokes :: Document -> [ ( Maybe Unique, Stroke ) ]
|
||||
getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
|
||||
let res =
|
||||
Writer.execWriter $
|
||||
forStrokeHierarchy
|
||||
( layerMetadata documentMetadata )
|
||||
( strokeHierarchy documentContent )
|
||||
( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
|
||||
when strokeVisible $
|
||||
Writer.tell [ ( Just uniq, stroke ) ]
|
||||
return PreserveStroke
|
||||
)
|
||||
in if null res then error ( show $ strokeHierarchy documentContent ) else res
|
||||
|
||||
-- | Utility type to gather information needed to render a stroke.
|
||||
-- - No outline: just the underlying spline.
|
||||
-- - Outline: keep track of the function which returns brush shape.
|
||||
|
@ -299,15 +306,13 @@ strokeRenderData
|
|||
-> Maybe ( RootIsolationOptions 2 3 )
|
||||
-> FitParameters
|
||||
-> Stroke
|
||||
-> Maybe ( ST RealWorld StrokeRenderData )
|
||||
-> ST RealWorld StrokeRenderData
|
||||
strokeRenderData rootAlgo mbCuspOptions fitParams
|
||||
( Stroke
|
||||
{ strokeSpline = spline :: StrokeSpline clo ( Record pointFields )
|
||||
, strokeBrush = ( strokeBrush :: Maybe ( NamedBrush brushFields ) )
|
||||
, ..
|
||||
}
|
||||
) | strokeVisible
|
||||
= Just $ case strokeBrush of
|
||||
) = case strokeBrush of
|
||||
Just ( NamedBrush { brushFunction = fn, brushWidget = widget } )
|
||||
| WithParams
|
||||
{ defaultParams = brush_defaults
|
||||
|
@ -350,109 +355,117 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
|
|||
( widget, \ params -> embedUsedParams $ toUsedParams params )
|
||||
}
|
||||
_ -> pure $
|
||||
StrokeRenderData
|
||||
{ strokeDataSpline = spline }
|
||||
| otherwise
|
||||
= Nothing
|
||||
StrokeRenderData
|
||||
{ strokeDataSpline = spline }
|
||||
|
||||
renderStroke
|
||||
:: Colours -> Maybe HoverContext -> Mode -> RenderMode -> Bool -> Double
|
||||
-> StrokeRenderData
|
||||
:: Colours
|
||||
-> StrokePoints -> Maybe HoverContext
|
||||
-> Mode
|
||||
-> RenderMode -> Bool -> Zoom
|
||||
-> ( Maybe Unique, StrokeRenderData )
|
||||
-> Compose Renders Cairo.Render ()
|
||||
renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
|
||||
StrokeRenderData { strokeDataSpline } ->
|
||||
renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
|
||||
StrokeWithOutlineRenderData
|
||||
{ strokeDataSpline
|
||||
, strokeOutlineData = ( strokeOutlineData, fitPts, cusps )
|
||||
, strokeBrushFunction
|
||||
, strokeWidgetData = ( widget, widgetParams )
|
||||
} ->
|
||||
renderStrokeSpline cols mode rdrMode mbHoverContext zoom
|
||||
( when ( mode == BrushMode )
|
||||
. ( \ pt ->
|
||||
renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom )
|
||||
strokeBrushFunction ( Brush.widgetElements widget ( widgetParams $ brushParams pt ) )
|
||||
pt
|
||||
renderStroke cols@( Colours { brush } ) selPts mbHoverContext mode rdrMode debug zoom ( mbUnique, strokeData ) =
|
||||
case strokeData of
|
||||
StrokeRenderData { strokeDataSpline } ->
|
||||
renderStrokeSpline cols mode rdrMode strokeSelPts mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
|
||||
StrokeWithOutlineRenderData
|
||||
{ strokeDataSpline
|
||||
, strokeOutlineData = ( strokeOutlineData, fitPts, cusps )
|
||||
, strokeBrushFunction
|
||||
, strokeWidgetData = ( widget, widgetParams )
|
||||
} ->
|
||||
renderStrokeSpline cols mode rdrMode strokeSelPts mbHoverContext zoom
|
||||
( when ( mode == BrushMode )
|
||||
. ( \ pt ->
|
||||
renderBrushShape ( cols { path = brush } ) mbHoverContext ( Zoom $ 2 * zoomFactor zoom )
|
||||
strokeBrushFunction ( Brush.widgetElements widget ( widgetParams $ brushParams pt ) )
|
||||
pt
|
||||
)
|
||||
)
|
||||
)
|
||||
strokeDataSpline
|
||||
*> Compose blank
|
||||
{ renderStrokes = drawOutline cols debug zoom strokeOutlineData
|
||||
, renderDebug =
|
||||
when debug $ drawDebugInfo cols zoom ( fitPts, cusps )
|
||||
}
|
||||
strokeDataSpline
|
||||
*> Compose blank
|
||||
{ renderStrokes = drawOutline cols debug zoom strokeOutlineData
|
||||
, renderDebug =
|
||||
when debug $ drawDebugInfo cols zoom ( fitPts, cusps )
|
||||
}
|
||||
where
|
||||
strokeSelPts =
|
||||
case mbUnique of
|
||||
Nothing -> Set.empty
|
||||
Just u -> fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
|
||||
|
||||
-- | Render a sequence of stroke points.
|
||||
--
|
||||
-- Accepts a sub-function for additional rendering of each stroke point
|
||||
-- (e.g. overlay a brush shape over each stroke point).
|
||||
renderStrokeSpline
|
||||
:: forall clo crvData pointData
|
||||
:: forall clo pointData
|
||||
. ( Show pointData, KnownSplineType clo )
|
||||
=> Colours -> Mode -> RenderMode -> Maybe HoverContext -> Double
|
||||
=> Colours -> Mode -> RenderMode
|
||||
-> Set PointIndex -> Maybe HoverContext -> Zoom
|
||||
-> ( PointData pointData -> Compose Renders Cairo.Render () )
|
||||
-> Spline clo crvData ( PointData pointData )
|
||||
-> Spline clo CurveData ( PointData pointData )
|
||||
-> Compose Renders Cairo.Render ()
|
||||
renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline =
|
||||
bifoldSpline ( renderSplineCurve ( splineStart spline ) ) renderSplinePoint spline
|
||||
renderStrokeSpline cols mode rdrMode selPts mbHover zoom renderSubcontent spline =
|
||||
bifoldSpline ( renderSplineCurve ( splineStart spline ) ) ( renderSplinePoint FirstPoint ) spline
|
||||
|
||||
where
|
||||
renderSplinePoint :: PointData pointData -> Compose Renders Cairo.Render ()
|
||||
renderSplinePoint sp0
|
||||
renderSplinePoint :: PointIndex -> PointData pointData -> Compose Renders Cairo.Render ()
|
||||
renderSplinePoint i sp0
|
||||
= Compose blank
|
||||
{ renderPPts =
|
||||
when ( rdrMode == RenderingPath ) do
|
||||
drawPoint cols mbHover zoom PathPoint sp0
|
||||
drawPoint cols selPts mbHover zoom i sp0
|
||||
}
|
||||
*> renderSubcontent sp0
|
||||
renderSplineCurve
|
||||
:: forall clo'
|
||||
. SplineTypeI clo'
|
||||
=> PointData pointData -> PointData pointData -> Curve clo' crvData ( PointData pointData ) -> Compose Renders Cairo.Render ()
|
||||
renderSplineCurve start p0 ( LineTo np1 _ )
|
||||
=> PointData pointData -> PointData pointData -> Curve clo' CurveData ( PointData pointData ) -> Compose Renders Cairo.Render ()
|
||||
renderSplineCurve start p0 ( LineTo np1 ( CurveData { curveIndex } ) )
|
||||
= Compose blank
|
||||
{ renderPPts = when ( rdrMode == RenderingPath ) do
|
||||
for_ np1 \ p1 ->
|
||||
drawPoint cols mbHover zoom PathPoint p1
|
||||
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex PathPoint ) p1
|
||||
, renderPath =
|
||||
unless ( mode == MetaMode ) $
|
||||
drawLine cols zoom PathPoint p0 ( fromNextPoint start np1 )
|
||||
}
|
||||
*> for_ np1 \ p1 -> renderSubcontent p1
|
||||
renderSplineCurve start p0 ( Bezier2To p1 np2 _ )
|
||||
renderSplineCurve start p0 ( Bezier2To p1 np2 ( CurveData { curveIndex } ) )
|
||||
= Compose blank
|
||||
{ renderCLines
|
||||
= when ( rdrMode == RenderingPath ) do
|
||||
drawLine cols zoom ControlPoint p0 p1
|
||||
drawLine cols zoom ControlPoint p1 ( fromNextPoint start np2 )
|
||||
drawLine cols zoom ( ControlPoint Bez2Cp ) p0 p1
|
||||
drawLine cols zoom ( ControlPoint Bez2Cp ) p1 ( fromNextPoint start np2 )
|
||||
, renderCPts
|
||||
= when ( rdrMode == RenderingPath ) do
|
||||
drawPoint cols mbHover zoom ControlPoint p1
|
||||
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez2Cp ) p1
|
||||
, renderPPts
|
||||
= when ( rdrMode == RenderingPath ) do
|
||||
for_ np2 \ p2 ->
|
||||
drawPoint cols mbHover zoom PathPoint p2
|
||||
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex PathPoint ) p2
|
||||
, renderPath
|
||||
= unless ( mode == MetaMode ) do
|
||||
drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 = fromNextPoint start np2 } )
|
||||
}
|
||||
*> renderSubcontent p1
|
||||
*> for_ np2 \ p2 -> renderSubcontent p2
|
||||
renderSplineCurve start p0 ( Bezier3To p1 p2 np3 _ )
|
||||
renderSplineCurve start p0 ( Bezier3To p1 p2 np3 ( CurveData { curveIndex } ) )
|
||||
= Compose blank
|
||||
{ renderCLines
|
||||
= when ( rdrMode == RenderingPath ) do
|
||||
drawLine cols zoom ControlPoint p0 p1
|
||||
drawLine cols zoom ControlPoint p2 ( fromNextPoint start np3 )
|
||||
drawLine cols zoom ( ControlPoint Bez3Cp1 ) p0 p1
|
||||
drawLine cols zoom ( ControlPoint Bez3Cp2 ) p2 ( fromNextPoint start np3 )
|
||||
, renderCPts
|
||||
= when ( rdrMode == RenderingPath ) do
|
||||
drawPoint cols mbHover zoom ControlPoint p1
|
||||
drawPoint cols mbHover zoom ControlPoint p2
|
||||
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp1 ) p1
|
||||
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp2 ) p2
|
||||
, renderPPts
|
||||
= when ( rdrMode == RenderingPath ) do
|
||||
for_ np3 \ p3 ->
|
||||
drawPoint cols mbHover zoom PathPoint p3
|
||||
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ PathPoint ) p3
|
||||
, renderPath
|
||||
= unless ( mode == MetaMode ) do
|
||||
drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } )
|
||||
|
@ -462,7 +475,7 @@ renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline =
|
|||
*> for_ np3 \ p3 -> renderSubcontent p3
|
||||
|
||||
renderBrushShape
|
||||
:: Colours -> Maybe HoverContext -> Double
|
||||
:: Colours -> Maybe HoverContext -> Zoom
|
||||
-> ( pointParams -> SplinePts Closed )
|
||||
-> Brush.WidgetElements
|
||||
-> PointData pointParams
|
||||
|
@ -479,25 +492,36 @@ renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt =
|
|||
toAll do
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
*> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () )
|
||||
( fmap ( \ p -> PointData p Normal () ) brushPts )
|
||||
*> renderStrokeSpline cols BrushMode RenderingBrush Set.empty mbHoverContext' zoom ( const $ pure () )
|
||||
( noCurveData brushPts )
|
||||
*> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts
|
||||
*> toAll Cairo.restore
|
||||
where
|
||||
noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed CurveData ( PointData () )
|
||||
noCurveData =
|
||||
bimapSpline
|
||||
( \ _ -> bimapCurve ( \ _ -> CurveData 987654321 ( invalidateCache undefined ) ) ( \ _ p -> PointData p () ) )
|
||||
( \ p -> PointData p () )
|
||||
|
||||
drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
|
||||
drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
|
||||
drawPoint :: Colours -> Set PointIndex -> Maybe HoverContext -> Zoom -> PointIndex -> PointData brushData -> Cairo.Render ()
|
||||
drawPoint ( Colours {..} ) selPts mbHover zoom@( Zoom { zoomFactor } ) i pt
|
||||
| i == FirstPoint || pointType i == PathPoint
|
||||
= do
|
||||
let
|
||||
x, y :: Double
|
||||
ℝ2 x y = coords pt
|
||||
hsqrt3 :: Double
|
||||
hsqrt3 = sqrt 0.75
|
||||
selectionState :: FocusState
|
||||
selectionState = view _selection pt <> hovered mbHover zoom ( ℝ2 x y )
|
||||
isSelected = i `Set.member` selPts
|
||||
hover
|
||||
| Just hov <- mbHover
|
||||
= hovered hov zoom ( ℝ2 x y )
|
||||
| otherwise
|
||||
= False
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.scale ( 3 / zoom ) ( 3 / zoom )
|
||||
Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor )
|
||||
|
||||
Cairo.moveTo 1 0
|
||||
Cairo.lineTo 0.5 hsqrt3
|
||||
|
@ -508,43 +532,50 @@ drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
|
|||
Cairo.closePath
|
||||
|
||||
Cairo.setLineWidth 1.0
|
||||
case selectionState of
|
||||
Selected -> withRGBA pathPoint Cairo.setSourceRGBA
|
||||
_ -> withRGBA pathPointOutline Cairo.setSourceRGBA
|
||||
if isSelected
|
||||
then withRGBA pathPoint Cairo.setSourceRGBA
|
||||
else withRGBA pathPointOutline Cairo.setSourceRGBA
|
||||
Cairo.strokePreserve
|
||||
|
||||
case selectionState of
|
||||
Normal -> withRGBA pathPoint Cairo.setSourceRGBA
|
||||
Hover -> withRGBA pointHover Cairo.setSourceRGBA
|
||||
Selected -> withRGBA pointSelected Cairo.setSourceRGBA
|
||||
if | isSelected
|
||||
-> withRGBA pointSelected Cairo.setSourceRGBA
|
||||
| hover
|
||||
-> withRGBA pointHover Cairo.setSourceRGBA
|
||||
| otherwise
|
||||
-> withRGBA pathPoint Cairo.setSourceRGBA
|
||||
Cairo.fill
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
|
||||
| otherwise
|
||||
= do
|
||||
let
|
||||
x, y :: Double
|
||||
ℝ2 x y = coords pt
|
||||
selectionState :: FocusState
|
||||
selectionState = view _selection pt <> hovered mbHover zoom ( ℝ2 x y )
|
||||
isSelected = i `Set.member` selPts
|
||||
hover
|
||||
| Just hov <- mbHover
|
||||
= hovered hov zoom ( ℝ2 x y )
|
||||
| otherwise
|
||||
= False
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.scale ( 3 / zoom ) ( 3 / zoom )
|
||||
Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor )
|
||||
|
||||
Cairo.arc 0 0 1 0 ( 2 * pi )
|
||||
|
||||
Cairo.setLineWidth 1.0
|
||||
case selectionState of
|
||||
Selected -> withRGBA controlPoint Cairo.setSourceRGBA
|
||||
_ -> withRGBA controlPointOutline Cairo.setSourceRGBA
|
||||
if isSelected
|
||||
then withRGBA controlPoint Cairo.setSourceRGBA
|
||||
else withRGBA controlPointOutline Cairo.setSourceRGBA
|
||||
Cairo.strokePreserve
|
||||
|
||||
case selectionState of
|
||||
Normal -> withRGBA controlPoint Cairo.setSourceRGBA
|
||||
Hover -> withRGBA pointHover Cairo.setSourceRGBA
|
||||
Selected -> withRGBA pointSelected Cairo.setSourceRGBA
|
||||
if | isSelected
|
||||
-> withRGBA pointSelected Cairo.setSourceRGBA
|
||||
| hover
|
||||
-> withRGBA pointHover Cairo.setSourceRGBA
|
||||
| otherwise
|
||||
-> withRGBA controlPoint Cairo.setSourceRGBA
|
||||
Cairo.fill
|
||||
|
||||
withRGBA controlPoint Cairo.setSourceRGBA
|
||||
|
@ -552,8 +583,8 @@ drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
|
|||
|
||||
Cairo.restore
|
||||
|
||||
drawLine :: Colours -> Double -> PointType -> PointData b -> PointData b -> Cairo.Render ()
|
||||
drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
|
||||
drawLine :: Colours -> Zoom -> PointType -> PointData b -> PointData b -> Cairo.Render ()
|
||||
drawLine ( Colours { path, controlPointLine } ) ( Zoom zoom ) pointType p1 p2 = do
|
||||
let
|
||||
x1, y1, x2, y2 :: Double
|
||||
ℝ2 x1 y1 = coords p1
|
||||
|
@ -567,20 +598,20 @@ drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
|
|||
PathPoint -> do
|
||||
Cairo.setLineWidth ( 5 / zoom )
|
||||
withRGBA path Cairo.setSourceRGBA
|
||||
ControlPoint -> do
|
||||
ControlPoint {} -> do
|
||||
Cairo.setLineWidth ( 3 / zoom )
|
||||
withRGBA controlPointLine Cairo.setSourceRGBA
|
||||
Cairo.stroke
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( ℝ 2 ) -> Cairo.Render ()
|
||||
drawQuadraticBezier :: Colours -> Zoom -> Quadratic.Bezier ( ℝ 2 ) -> Cairo.Render ()
|
||||
drawQuadraticBezier cols zoom bez =
|
||||
drawCubicBezier cols zoom
|
||||
( Cubic.fromQuadratic @( T ( ℝ 2 ) ) bez )
|
||||
|
||||
drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( ℝ 2 ) -> Cairo.Render ()
|
||||
drawCubicBezier ( Colours { path } ) zoom
|
||||
drawCubicBezier :: Colours -> Zoom -> Cubic.Bezier ( ℝ 2 ) -> Cairo.Render ()
|
||||
drawCubicBezier ( Colours { path } ) ( Zoom { zoomFactor } )
|
||||
( Cubic.Bezier
|
||||
{ p0 = ℝ2 x0 y0
|
||||
, p1 = ℝ2 x1 y1
|
||||
|
@ -595,17 +626,17 @@ drawCubicBezier ( Colours { path } ) zoom
|
|||
Cairo.moveTo x0 y0
|
||||
Cairo.curveTo x1 y1 x2 y2 x3 y3
|
||||
|
||||
Cairo.setLineWidth ( 6 / zoom )
|
||||
Cairo.setLineWidth ( 6 / zoomFactor )
|
||||
withRGBA path Cairo.setSourceRGBA
|
||||
Cairo.stroke
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawOutline
|
||||
:: Colours -> Bool -> Double
|
||||
:: Colours -> Bool -> Zoom
|
||||
-> Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
||||
-> Cairo.Render ()
|
||||
drawOutline ( Colours {..} ) debug zoom strokeData = do
|
||||
drawOutline ( Colours {..} ) debug ( Zoom { zoomFactor } ) strokeData = do
|
||||
Cairo.save
|
||||
withRGBA brushStroke Cairo.setSourceRGBA
|
||||
case strokeData of
|
||||
|
@ -616,7 +647,7 @@ drawOutline ( Colours {..} ) debug zoom strokeData = do
|
|||
True -> do
|
||||
Cairo.fillPreserve
|
||||
Cairo.setSourceRGBA 0 0 0 0.75
|
||||
Cairo.setLineWidth ( 2 / zoom )
|
||||
Cairo.setLineWidth ( 2 / zoomFactor )
|
||||
Cairo.stroke
|
||||
Right ( fwd, bwd ) -> do
|
||||
makeOutline fwd
|
||||
|
@ -626,7 +657,7 @@ drawOutline ( Colours {..} ) debug zoom strokeData = do
|
|||
True -> do
|
||||
Cairo.fillPreserve
|
||||
Cairo.setSourceRGBA 0 0 0 0.75
|
||||
Cairo.setLineWidth ( 2 / zoom )
|
||||
Cairo.setLineWidth ( 2 / zoomFactor )
|
||||
Cairo.stroke
|
||||
Cairo.restore
|
||||
where
|
||||
|
@ -651,16 +682,16 @@ drawOutline ( Colours {..} ) debug zoom strokeData = do
|
|||
let ℝ2 x3 y3 = fromNextPoint start mp3
|
||||
in Cairo.curveTo x1 y1 x2 y2 x3 y3
|
||||
|
||||
drawDebugInfo :: Colours -> Double
|
||||
drawDebugInfo :: Colours -> Zoom
|
||||
-> ( Seq FitPoint, [ Cusp ] )
|
||||
-> Cairo.Render ()
|
||||
drawDebugInfo cols zoom ( fitPts, cusps ) = do
|
||||
Cairo.setLineWidth ( 2 / zoom )
|
||||
drawDebugInfo cols zoom@( Zoom { zoomFactor } ) ( fitPts, cusps ) = do
|
||||
Cairo.setLineWidth ( 2 / zoomFactor )
|
||||
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
|
||||
for_ cusps ( drawCusp cols zoom )
|
||||
|
||||
drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
|
||||
drawFitPoint _ zoom ( FitPoint { fitPoint = ℝ2 x y } ) = do
|
||||
drawFitPoint :: Colours -> Zoom -> FitPoint -> StateT Double Cairo.Render ()
|
||||
drawFitPoint _ ( Zoom { zoomFactor } ) ( FitPoint { fitPoint = ℝ2 x y } ) = do
|
||||
|
||||
hue <- get
|
||||
put ( hue + 0.01 )
|
||||
|
@ -670,12 +701,12 @@ drawFitPoint _ zoom ( FitPoint { fitPoint = ℝ2 x y } ) = do
|
|||
lift do
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
|
||||
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
|
||||
Cairo.setSourceRGBA r g b 0.8
|
||||
Cairo.fill
|
||||
Cairo.restore
|
||||
|
||||
drawFitPoint _ zoom ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do
|
||||
drawFitPoint _ ( Zoom { zoomFactor } ) ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do
|
||||
|
||||
hue <- get
|
||||
put ( hue + 0.01 )
|
||||
|
@ -687,36 +718,36 @@ drawFitPoint _ zoom ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty }
|
|||
Cairo.translate x y
|
||||
Cairo.moveTo 0 0
|
||||
Cairo.lineTo ( 0.05 * tx ) ( 0.05 * ty )
|
||||
Cairo.setLineWidth ( 4 / zoom )
|
||||
Cairo.setLineWidth ( 4 / zoomFactor )
|
||||
Cairo.setSourceRGBA r g b 1.0
|
||||
Cairo.stroke
|
||||
Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi )
|
||||
Cairo.arc 0 0 ( 2 / zoomFactor ) 0 ( 2 * pi )
|
||||
Cairo.fill
|
||||
Cairo.restore
|
||||
|
||||
drawCusp :: Colours -> Double -> Cusp -> Cairo.Render ()
|
||||
drawCusp _ zoom
|
||||
drawCusp :: Colours -> Zoom -> Cusp -> Cairo.Render ()
|
||||
drawCusp _ ( Zoom { zoomFactor } )
|
||||
( Cusp { cuspPathCoords = D21 { _D21_v = ℝ2 px py
|
||||
, _D21_dx = tgt }
|
||||
, cuspStrokeCoords = ℝ2 cx cy } ) = do
|
||||
|
||||
-- Draw a line perpendicular to the underlying path at the cusp.
|
||||
let
|
||||
!( V2 tx ty ) = ( 6 / zoom ) *^ normalise tgt
|
||||
!( V2 tx ty ) = ( 6 / zoomFactor ) *^ normalise tgt
|
||||
Cairo.save
|
||||
Cairo.translate px py
|
||||
Cairo.moveTo -ty tx
|
||||
Cairo.lineTo ty -tx
|
||||
--withRGBA path Cairo.setSourceRGBA
|
||||
Cairo.setSourceRGBA 0 0 0 0.75
|
||||
Cairo.setLineWidth ( 2 / zoom )
|
||||
Cairo.setLineWidth ( 2 / zoomFactor )
|
||||
Cairo.stroke
|
||||
Cairo.restore
|
||||
|
||||
-- Draw a circle around the outline cusp point.
|
||||
Cairo.save
|
||||
Cairo.translate cx cy
|
||||
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
|
||||
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
|
||||
Cairo.setSourceRGBA 0 0 0 0.75
|
||||
Cairo.stroke
|
||||
Cairo.restore
|
||||
|
@ -762,45 +793,45 @@ drawCross ( Colours {..} ) zoom = do
|
|||
Cairo.restore
|
||||
-}
|
||||
|
||||
renderBrushWidgetElements :: Colours -> Double -> Maybe HoverContext -> Brush.WidgetElements -> Compose Renders Cairo.Render ()
|
||||
renderBrushWidgetElements ( Colours { .. } ) zoom mbHover ( Brush.WidgetElements { Brush.widgetPoints = pts, Brush.widgetLines = lns } ) =
|
||||
renderBrushWidgetElements :: Colours -> Zoom -> Maybe HoverContext -> Brush.WidgetElements -> Compose Renders Cairo.Render ()
|
||||
renderBrushWidgetElements ( Colours { .. } ) zoom@( Zoom { zoomFactor } ) mbHover ( Brush.WidgetElements { Brush.widgetPoints = pts, Brush.widgetLines = lns } ) =
|
||||
Compose blank
|
||||
{ renderBrushWidgets = do
|
||||
for_ lns $ \ seg@( Segment ( T p0@( ℝ2 x1 y1 ) ) ( T p1@( ℝ2 x2 y2 ) ) ) -> do
|
||||
let lineFocus
|
||||
let lineHover
|
||||
-- Don't do rectangle hover highlighting; doesn't make sense here.
|
||||
| Just ( MouseHover {} ) <- mbHover
|
||||
| Just ( mouseHover@( MouseHover {} ) ) <- mbHover
|
||||
-- Only focus the line if we aren't focusing a point,
|
||||
-- as line focus corresponds to horizontal/vertical scaling
|
||||
-- as opposed to 2D scaling.
|
||||
, Normal <- hovered mbHover zoom p0
|
||||
, Normal <- hovered mbHover zoom p1
|
||||
= hovered mbHover zoom ( fmap unT seg )
|
||||
, not $ hovered mouseHover zoom p0
|
||||
, not $ hovered mouseHover zoom p1
|
||||
= hovered mouseHover zoom ( fmap unT seg )
|
||||
| otherwise
|
||||
= Normal
|
||||
= False
|
||||
Cairo.save
|
||||
Cairo.moveTo x1 y1
|
||||
Cairo.lineTo x2 y2
|
||||
Cairo.setLineWidth ( 2 / zoom )
|
||||
case lineFocus of
|
||||
Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
|
||||
_ -> withRGBA brushWidget Cairo.setSourceRGBA
|
||||
Cairo.setLineWidth ( 2 / zoomFactor )
|
||||
if lineHover
|
||||
then withRGBA brushWidgetHover Cairo.setSourceRGBA
|
||||
else withRGBA brushWidget Cairo.setSourceRGBA
|
||||
Cairo.stroke
|
||||
Cairo.restore
|
||||
for_ pts $ \ ( T p@( ℝ2 x y ) ) -> do
|
||||
let ptFocus
|
||||
let ptHover
|
||||
-- Don't do rectangle hover highlighting; doesn't make sense here.
|
||||
| Just ( MouseHover {} ) <- mbHover
|
||||
= hovered mbHover zoom p
|
||||
| Just ( mouseHover@( MouseHover {} ) ) <- mbHover
|
||||
= hovered mouseHover zoom p
|
||||
| otherwise
|
||||
= Normal
|
||||
= False
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
|
||||
Cairo.setLineWidth ( 2 / zoom )
|
||||
case ptFocus of
|
||||
Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
|
||||
_ -> withRGBA brushWidget Cairo.setSourceRGBA
|
||||
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
|
||||
Cairo.setLineWidth ( 2 / zoomFactor )
|
||||
if ptHover
|
||||
then withRGBA brushWidgetHover Cairo.setSourceRGBA
|
||||
else withRGBA brushWidget Cairo.setSourceRGBA
|
||||
Cairo.fill
|
||||
Cairo.restore
|
||||
}
|
||||
|
|
|
@ -29,8 +29,9 @@ import Data.Act
|
|||
)
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map as Map
|
||||
( adjust )
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
|
@ -41,28 +42,25 @@ import qualified GI.Cairo.Render as Cairo
|
|||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( set, over )
|
||||
( over )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Action
|
||||
import MetaBrush.Application.Action
|
||||
( ActionOrigin(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours, ColourRecord(..) )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( HoldAction(..), GuideAction(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..)
|
||||
, FocusState(..), Hoverable(..), HoverContext(..)
|
||||
, Guide(..)
|
||||
)
|
||||
import MetaBrush.Hover
|
||||
import MetaBrush.UI.Coordinates
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
( unsafeUnique )
|
||||
( Unique )
|
||||
import MetaBrush.GTK.Util
|
||||
( withRGBA )
|
||||
|
||||
|
@ -76,10 +74,20 @@ renderRuler
|
|||
renderRuler
|
||||
cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height )
|
||||
mbMousePos mbHoldEvent showGuides
|
||||
( Document { viewportCenter = center@( ℝ2 cx cy ), zoomFactor, documentContent = Content { guides } } ) = do
|
||||
( Document
|
||||
{ documentMetadata =
|
||||
Metadata
|
||||
{ viewportCenter = center@( ℝ2 cx cy )
|
||||
, documentZoom = zoom@( Zoom { zoomFactor } )
|
||||
, documentGuides = guides0
|
||||
}
|
||||
} ) = do
|
||||
|
||||
let
|
||||
modifiedGuides :: [ Guide ]
|
||||
guides1 :: Map Unique ( Guide, Bool )
|
||||
guides1 = fmap ( , False ) guides0
|
||||
|
||||
modifiedGuides :: [ ( Guide, Bool ) ]
|
||||
modifiedGuides
|
||||
| Just ( GuideAction { holdStartPos = mousePos0, guideAction = act } ) <- mbHoldEvent
|
||||
, Just mousePos <- mbMousePos
|
||||
|
@ -91,26 +99,26 @@ renderRuler
|
|||
translate = ( ( mousePos0 --> mousePos :: T ( ℝ 2 ) ) • )
|
||||
in toList
|
||||
$ Map.adjust
|
||||
( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected )
|
||||
guideUnique
|
||||
guides
|
||||
( \ ( g, _ ) -> ( over ( field' @"guidePoint" ) translate g, True ) )
|
||||
guideUnique
|
||||
guides1
|
||||
CreateGuide ruler
|
||||
-> let
|
||||
addNewGuides :: [ Guide ] -> [ Guide ]
|
||||
addNewGuides :: [ ( Guide, Bool ) ] -> [ ( Guide, Bool ) ]
|
||||
addNewGuides gs = case ruler of
|
||||
RulerCorner
|
||||
-> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 }
|
||||
: Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 }
|
||||
-> ( Guide { guidePoint = mousePos, guideNormal = V2 0 1 }, True )
|
||||
: ( Guide { guidePoint = mousePos, guideNormal = V2 1 0 }, True )
|
||||
: gs
|
||||
LeftRuler
|
||||
-> Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 }
|
||||
-> ( Guide { guidePoint = mousePos, guideNormal = V2 1 0 }, True )
|
||||
: gs
|
||||
TopRuler
|
||||
-> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 }
|
||||
-> ( Guide { guidePoint = mousePos, guideNormal = V2 0 1 }, True )
|
||||
: gs
|
||||
in addNewGuides ( toList guides )
|
||||
in addNewGuides ( toList guides1 )
|
||||
| otherwise
|
||||
= toList guides
|
||||
= toList guides1
|
||||
|
||||
mbHoverContext :: Maybe HoverContext
|
||||
mbHoverContext
|
||||
|
@ -129,7 +137,7 @@ renderRuler
|
|||
-- Render tick marks.
|
||||
renderTicks
|
||||
-- Render guides.
|
||||
when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) )
|
||||
when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoom ) )
|
||||
-- Render mouse cursor indicator.
|
||||
for_ mbMousePos \ ( ℝ2 mx my ) ->
|
||||
case actionOrigin of
|
||||
|
@ -179,7 +187,7 @@ renderRuler
|
|||
TopRuler -> do
|
||||
Cairo.translate 0 dy
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center
|
||||
toViewport = toViewportCoordinates zoom ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center
|
||||
|
||||
setTickRenderContext :: Cairo.Render ()
|
||||
setTickRenderContext = do
|
||||
|
@ -280,19 +288,24 @@ data Tick
|
|||
}
|
||||
deriving stock Show
|
||||
|
||||
renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render ()
|
||||
renderGuide ( Colours {..} ) mbHoverContext zoom
|
||||
gd@( Guide { guidePoint = ℝ2 x y, guideNormal = V2 nx ny, guideFocus } )
|
||||
renderGuide :: Colours -> Maybe HoverContext -> Zoom -> ( Guide, Bool ) -> Cairo.Render ()
|
||||
renderGuide ( Colours {..} ) mbHover zoom@( Zoom { zoomFactor } )
|
||||
( gd@( Guide { guidePoint = ℝ2 x y, guideNormal = V2 nx ny } ), guideSelected )
|
||||
= do
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.scale ( 1 / zoom ) ( 1 / zoom )
|
||||
Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor )
|
||||
|
||||
Cairo.setLineWidth 1
|
||||
case guideFocus <> hovered mbHoverContext zoom gd of
|
||||
Normal -> withRGBA guide Cairo.setSourceRGBA
|
||||
_ -> withRGBA pointHover Cairo.setSourceRGBA
|
||||
let isHovered
|
||||
| Just hov <- mbHover
|
||||
= hovered hov zoom gd
|
||||
| otherwise
|
||||
= False
|
||||
if guideSelected || isHovered
|
||||
then withRGBA pointHover Cairo.setSourceRGBA
|
||||
else withRGBA guide Cairo.setSourceRGBA
|
||||
|
||||
Cairo.moveTo ( 1e5 * ny ) ( -1e5 * nx )
|
||||
Cairo.lineTo ( -1e5 * ny ) ( 1e5 * nx )
|
||||
|
|
|
@ -18,7 +18,7 @@ import Data.Act
|
|||
( (-->) )
|
||||
)
|
||||
|
||||
-- MetaBrush
|
||||
-- brush-strokes
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier(..), closestPoint )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
|
@ -31,22 +31,24 @@ import Math.Module
|
|||
( (*^), squaredNorm, closestPointOnSegment )
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..), Segment(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Document
|
||||
( Stroke(..), PointData(..)
|
||||
, coords
|
||||
)
|
||||
( Zoom(..) )
|
||||
import MetaBrush.Stroke
|
||||
( Stroke(..), PointData, coords )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Convert a position relative to the drawing area into viewport coordinates.
|
||||
toViewportCoordinates :: Double -> ( Double, Double ) -> ℝ 2 -> ℝ 2 -> ℝ 2
|
||||
toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( ℝ2 x y )
|
||||
toViewportCoordinates :: Zoom -> ( Double, Double ) -> ℝ 2 -> ℝ 2 -> ℝ 2
|
||||
toViewportCoordinates ( Zoom { zoomFactor } ) ( viewportWidth, viewportHeight ) viewportCenter ( ℝ2 x y )
|
||||
= ( recip zoomFactor *^ ( ℝ2 ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> ℝ2 x y :: T ( ℝ 2 ) ) )
|
||||
• viewportCenter
|
||||
|
||||
-- | Find the closest point in a set of strokes.
|
||||
-- | Find the closest point on a stroke.
|
||||
closestPoint :: ℝ 2 -> Stroke -> ArgMin Double ( Maybe ( ℝ 2 ) )
|
||||
closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
|
||||
closestPoint c ( Stroke { strokeSpline } ) =
|
||||
coerce $
|
||||
bifoldSpline @_ @Identity
|
||||
( closestPointToCurve ( splineStart strokeSpline ) )
|
||||
|
@ -71,7 +73,6 @@ closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
|
|||
closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $
|
||||
fmap ( fmap ( Just . snd ) )
|
||||
( Cubic.closestPoint @( T ( ℝ 2 ) ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
|
||||
closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( ℝ 2 ) ) )
|
||||
|
||||
-- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( ℝ 2 ) )`
|
||||
newtype BoundedDouble = BoundedDouble Double
|
||||
|
|
|
@ -11,13 +11,12 @@ module MetaBrush.UI.FileBar
|
|||
import Control.Monad
|
||||
( join, void )
|
||||
import Data.Foldable
|
||||
( for_, sequenceA_ )
|
||||
( sequenceA_ )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
( lookup, insert, delete )
|
||||
|
||||
-- gi-cairo-connector
|
||||
import qualified GI.Cairo.Render.Connector as Cairo
|
||||
|
@ -44,24 +43,23 @@ import Data.HashMap.Lazy
|
|||
( HashMap )
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
import {-# SOURCE #-} MetaBrush.Application.Action
|
||||
( ActionName, SwitchFromTo(..), Close(..), handleAction )
|
||||
import MetaBrush.Asset.CloseTabButton
|
||||
( drawCloseTabButton )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..)
|
||||
, emptyDocument
|
||||
)
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), newHistory )
|
||||
import MetaBrush.Document.Update
|
||||
( updateUIAction )
|
||||
import MetaBrush.Application.UpdateDocument
|
||||
( updateUIAction, ActiveDocChange (..) )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import MetaBrush.UI.Panels
|
||||
( PanelsBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
|
@ -93,7 +91,7 @@ data TabLocation
|
|||
newFileTab
|
||||
:: UIElements
|
||||
-> Variables
|
||||
-> Maybe DocumentHistory
|
||||
-> Maybe ( Unique, DocumentHistory )
|
||||
-> TabLocation
|
||||
-> IO ()
|
||||
newFileTab
|
||||
|
@ -103,21 +101,18 @@ newFileTab
|
|||
newTabLoc
|
||||
= do
|
||||
|
||||
newDocHist <- case mbDocHist of
|
||||
-- Use the provided document (e.g. document read from a file).
|
||||
Just docHist -> do pure docHist
|
||||
-- Create a new empty document.
|
||||
Nothing -> do
|
||||
newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
|
||||
pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
|
||||
|
||||
let
|
||||
thisTabDocUnique :: Unique
|
||||
thisTabDocUnique = documentUnique ( present newDocHist )
|
||||
( thisTabDocUnique, thisTabDocHist ) <-
|
||||
case mbDocHist of
|
||||
-- Use the provided document (e.g. document read from a file).
|
||||
Just docHist -> pure docHist
|
||||
-- Create a new empty document.
|
||||
Nothing -> do
|
||||
newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
|
||||
pure ( newDocUniq, newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) )
|
||||
|
||||
-- TODO: make the file tab an EditableLabel
|
||||
-- File tab elements.
|
||||
pgButton <- GTK.toggleButtonNewWithLabel ( displayName $ present newDocHist )
|
||||
pgButton <- GTK.toggleButtonNewWithLabel ( documentName $ documentMetadata $ present thisTabDocHist )
|
||||
GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton )
|
||||
closeFileButton <- GTK.buttonNew
|
||||
closeFileArea <- GTK.drawingAreaNew
|
||||
|
@ -163,10 +158,12 @@ newFileTab
|
|||
}
|
||||
-- Update the state: switch to this new document.
|
||||
uiUpdateAction <- STM.atomically do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique newDocHist )
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab )
|
||||
STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
|
||||
updateUIAction uiElts vars
|
||||
mbOldDoc <- STM.readTVar activeDocumentTVar
|
||||
STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
|
||||
let change = ActiveDocChange { mbOldDocUnique = mbOldDoc }
|
||||
updateUIAction change uiElts vars
|
||||
uiUpdateAction
|
||||
|
||||
void $ GTK.afterToggleButtonToggled pgButton do
|
||||
|
@ -214,11 +211,12 @@ createFileBar
|
|||
-> GTK.Application -> GTK.ApplicationWindow -> GTK.EventControllerKey
|
||||
-> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar
|
||||
-> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction
|
||||
-> PanelsBar
|
||||
-> IO FileBar
|
||||
createFileBar
|
||||
colours
|
||||
vars@( Variables { openDocumentsTVar } )
|
||||
application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions
|
||||
application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions panelsBar
|
||||
= do
|
||||
|
||||
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
|
||||
|
@ -251,10 +249,10 @@ createFileBar
|
|||
uiElements = UIElements {..}
|
||||
|
||||
documents <- STM.readTVarIO openDocumentsTVar
|
||||
for_ documents \ doc ->
|
||||
( `Map.foldMapWithKey` documents ) \ docUnique doc ->
|
||||
newFileTab
|
||||
uiElements vars
|
||||
( Just doc )
|
||||
( Just ( docUnique, doc ) )
|
||||
LastTab
|
||||
|
||||
void $ GTK.onButtonClicked newFileButton do
|
||||
|
@ -279,5 +277,5 @@ removeFileTab
|
|||
STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique )
|
||||
pure ( GTK.boxRemove fileTabsBox tab )
|
||||
|
||||
|
||||
sequenceA_ cleanupAction
|
||||
|
|
|
@ -8,7 +8,7 @@ module MetaBrush.UI.FileBar
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
import {-# SOURCE #-} MetaBrush.Application.Context
|
||||
( Variables, UIElements )
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory )
|
||||
|
@ -37,5 +37,5 @@ data TabLocation
|
|||
|
||||
instance Show TabLocation
|
||||
|
||||
newFileTab :: UIElements -> Variables -> Maybe DocumentHistory -> TabLocation -> IO ()
|
||||
newFileTab :: UIElements -> Variables -> Maybe ( Unique, DocumentHistory ) -> TabLocation -> IO ()
|
||||
removeFileTab :: UIElements -> Variables -> Unique -> IO ()
|
||||
|
|
|
@ -43,10 +43,10 @@ import MetaBrush.Asset.Cursor
|
|||
( drawCursorIcon )
|
||||
import MetaBrush.Asset.InfoBar
|
||||
( drawMagnifier, drawTopLeftCornerRect )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( Variables(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..) )
|
||||
( DocumentMetadata(..), Zoom(..) )
|
||||
import MetaBrush.UI.Coordinates
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.GTK.Util
|
||||
|
@ -151,7 +151,7 @@ createInfoBar colours = do
|
|||
|
||||
pure ( InfoBar {..} )
|
||||
|
||||
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
|
||||
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe DocumentMetadata -> IO ()
|
||||
updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar } ) mbDoc
|
||||
= do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetWidth viewportDrawingArea
|
||||
|
@ -162,10 +162,10 @@ updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar }
|
|||
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
|
||||
GTK.labelSetText topLeftPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
|
||||
GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
|
||||
Just ( Document { zoomFactor, viewportCenter } ) -> do
|
||||
Just ( Metadata { documentZoom = zoom@( Zoom { zoomFactor } ), viewportCenter } ) -> do
|
||||
let
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
|
||||
ℝ2 l t = toViewport ( ℝ2 0 0 )
|
||||
ℝ2 r b = toViewport ( ℝ2 viewportWidth viewportHeight )
|
||||
mbMousePos <- STM.readTVarIO mousePosTVar
|
||||
|
|
|
@ -6,10 +6,10 @@ module MetaBrush.UI.InfoBar
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
import {-# SOURCE #-} MetaBrush.Application.Context
|
||||
( Variables )
|
||||
import MetaBrush.Document
|
||||
( Document )
|
||||
( DocumentMetadata )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -21,4 +21,4 @@ data InfoBar
|
|||
}
|
||||
|
||||
updateInfoBar
|
||||
:: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
|
||||
:: GTK.DrawingArea -> InfoBar -> Variables -> Maybe DocumentMetadata -> IO ()
|
||||
|
|
|
@ -39,9 +39,9 @@ import qualified Data.HashSet as HashSet
|
|||
( fromList, toMap )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
import MetaBrush.Application.Action
|
||||
hiding ( save, saveAs )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
|
|
|
@ -1,7 +1,9 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module MetaBrush.UI.Panels
|
||||
( createPanelBar )
|
||||
( PanelsBar(..)
|
||||
, createPanelBar
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
|
@ -16,11 +18,21 @@ import qualified GI.Gtk as GTK
|
|||
-- MetaBrush
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
--import MetaBrush.UI.StrokeTreeView
|
||||
-- ( newStrokesView )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data PanelsBar
|
||||
= PanelsBar
|
||||
{ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox
|
||||
:: GTK.Box
|
||||
, strokesListView
|
||||
:: GTK.ListView
|
||||
}
|
||||
|
||||
-- | Creates the right hand side panel UI.
|
||||
createPanelBar :: GTK.Box -> IO ()
|
||||
createPanelBar :: GTK.Box -> IO PanelsBar
|
||||
createPanelBar panelBox = do
|
||||
|
||||
widgetAddClass panelBox "panels"
|
||||
|
@ -38,10 +50,10 @@ createPanelBar panelBox = do
|
|||
GTK.panedSetStartChild pane1 ( Just panels1 )
|
||||
GTK.panedSetEndChild pane1 ( Just panels2 )
|
||||
|
||||
strokesPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||||
brushesPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||||
transformPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||||
historyPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||||
strokesPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
brushesPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
transformPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
historyPanelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
strokesTab <- GTK.labelNew ( Just "Strokes" )
|
||||
brushesTab <- GTK.labelNew ( Just "Brushes" )
|
||||
|
@ -51,33 +63,35 @@ createPanelBar panelBox = do
|
|||
for_ [ strokesTab, brushesTab, transformTab, historyTab ] \ tab -> do
|
||||
widgetAddClasses tab [ "plain", "text", "panelTab" ]
|
||||
|
||||
for_ [ strokesPanel, brushesPanel, transformPanel, historyPanel ] \ panel -> do
|
||||
for_ [ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do
|
||||
widgetAddClass panel "panel"
|
||||
|
||||
void $ GTK.notebookAppendPage panels1 strokesPanel ( Just strokesTab )
|
||||
void $ GTK.notebookAppendPage panels1 brushesPanel ( Just brushesTab )
|
||||
void $ GTK.notebookAppendPage panels1 strokesPanelBox ( Just strokesTab )
|
||||
void $ GTK.notebookAppendPage panels1 brushesPanelBox ( Just brushesTab )
|
||||
|
||||
void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab )
|
||||
void $ GTK.notebookAppendPage panels2 historyPanel ( Just historyTab )
|
||||
void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab )
|
||||
void $ GTK.notebookAppendPage panels2 historyPanelBox ( Just historyTab )
|
||||
|
||||
GTK.notebookSetTabReorderable panels1 strokesPanel True
|
||||
GTK.notebookSetTabDetachable panels1 strokesPanel True
|
||||
GTK.notebookSetTabReorderable panels1 brushesPanel True
|
||||
GTK.notebookSetTabDetachable panels1 brushesPanel True
|
||||
GTK.notebookSetTabReorderable panels1 strokesPanelBox True
|
||||
GTK.notebookSetTabDetachable panels1 strokesPanelBox True
|
||||
GTK.notebookSetTabReorderable panels1 brushesPanelBox True
|
||||
GTK.notebookSetTabDetachable panels1 brushesPanelBox True
|
||||
|
||||
GTK.notebookSetTabReorderable panels2 transformPanel True
|
||||
GTK.notebookSetTabDetachable panels2 transformPanel True
|
||||
GTK.notebookSetTabReorderable panels2 historyPanel True
|
||||
GTK.notebookSetTabDetachable panels2 historyPanel True
|
||||
GTK.notebookSetTabReorderable panels2 transformPanelBox True
|
||||
GTK.notebookSetTabDetachable panels2 transformPanelBox True
|
||||
GTK.notebookSetTabReorderable panels2 historyPanelBox True
|
||||
GTK.notebookSetTabDetachable panels2 historyPanelBox True
|
||||
|
||||
strokesContent <- GTK.labelNew ( Just "Strokes tab content..." )
|
||||
brushesContent <- GTK.labelNew ( Just "Brushes tab content..." )
|
||||
transformContent <- GTK.labelNew ( Just "Transform tab content..." )
|
||||
historyContent <- GTK.labelNew ( Just "History tab content..." )
|
||||
|
||||
GTK.boxAppend strokesPanel strokesContent
|
||||
GTK.boxAppend brushesPanel brushesContent
|
||||
GTK.boxAppend transformPanel transformContent
|
||||
GTK.boxAppend historyPanel historyContent
|
||||
GTK.boxAppend brushesPanelBox brushesContent
|
||||
GTK.boxAppend transformPanelBox transformContent
|
||||
GTK.boxAppend historyPanelBox historyContent
|
||||
|
||||
pure ()
|
||||
--GTK.boxAppend strokesPanelBox strokesListView
|
||||
|
||||
return $
|
||||
PanelsBar { strokesPanelBox, strokesListView = error "todo"
|
||||
, brushesPanelBox, transformPanelBox, historyPanelBox }
|
||||
|
|
0
src/app/MetaBrush/UI/StrokeTreeView.hs
Normal file
0
src/app/MetaBrush/UI/StrokeTreeView.hs
Normal file
|
@ -34,7 +34,7 @@ import MetaBrush.Asset.Cursor
|
|||
( drawCursorIcon )
|
||||
import MetaBrush.Asset.Tools
|
||||
( drawBug, drawBrush, drawMeta, drawPath, drawPen )
|
||||
import MetaBrush.Context
|
||||
import MetaBrush.Application.Context
|
||||
( Variables(..) )
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass )
|
||||
|
|
|
@ -17,7 +17,7 @@ import qualified GI.Gtk as GTK
|
|||
-- MetaBrush
|
||||
import MetaBrush.GTK.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import MetaBrush.Document
|
||||
import MetaBrush.Guide
|
||||
( Ruler(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
1060
src/metabrushes/MetaBrush/Action.hs
Normal file
1060
src/metabrushes/MetaBrush/Action.hs
Normal file
File diff suppressed because it is too large
Load diff
|
@ -18,6 +18,16 @@ import Data.Kind
|
|||
( Type )
|
||||
import GHC.TypeLits
|
||||
( Symbol )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- brush-strokes
|
||||
import Math.Linear
|
||||
|
@ -29,10 +39,6 @@ import Math.Module
|
|||
, norm
|
||||
)
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- metabrushes
|
||||
import MetaBrush.Records
|
||||
( Record(..) )
|
||||
|
@ -91,7 +97,8 @@ data WhatScale
|
|||
= ScaleXY
|
||||
| ScaleX
|
||||
| ScaleY
|
||||
deriving stock ( Eq, Ord, Show )
|
||||
deriving stock ( Eq, Ord, Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Keep track of state in a brush widget action, e.g.
|
||||
-- scaling or rotating a brush.
|
||||
|
@ -99,7 +106,8 @@ data WidgetAction
|
|||
= ScaleAction WhatScale
|
||||
| RotateAction
|
||||
--{ windingNumber :: Int }
|
||||
deriving stock ( Eq, Ord, Show )
|
||||
deriving stock ( Eq, Ord, Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
describeWidgetAction :: WidgetAction -> Text
|
||||
describeWidgetAction ( ScaleAction {} ) = "scaling"
|
||||
|
|
|
@ -1,453 +1,145 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.Document
|
||||
( AABB(..), mkAABB
|
||||
, Document(..), DocumentContent(..)
|
||||
, emptyDocument
|
||||
, Stroke(..), StrokeHierarchy(..), visibleStrokes
|
||||
, StrokeSpline, _strokeSpline, overStrokeSpline
|
||||
, PointData(..), BrushPointData(..), DiffPointData(..)
|
||||
, FocusState(..), Hoverable(..), HoverContext(..)
|
||||
, Guide(..), Ruler(..)
|
||||
, _selection, _coords, coords
|
||||
, addGuide, selectedGuide
|
||||
)
|
||||
where
|
||||
module MetaBrush.Document where
|
||||
|
||||
-- base
|
||||
import Control.Monad.ST
|
||||
( RealWorld )
|
||||
import Data.Coerce
|
||||
( coerce )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Semigroup
|
||||
( Arg(..), Min(..), ArgMin )
|
||||
import Data.Typeable
|
||||
( Typeable )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1 )
|
||||
import GHC.TypeLits
|
||||
( Symbol )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act(..), Torsor(..) )
|
||||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( empty, insert )
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Sequence as Seq
|
||||
( empty, singleton )
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..), NFData1, deepseq )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group(..) )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( Lens'
|
||||
, set, view, over
|
||||
)
|
||||
|
||||
-- stm
|
||||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
( NFData(..) )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Reader
|
||||
( ReaderT, runReaderT )
|
||||
-- brush-strokes
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), KnownSplineType )
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke )
|
||||
import Math.Module
|
||||
( Module
|
||||
( origin, (^+^), (^-^), (*^) )
|
||||
, Inner((^.^))
|
||||
, squaredNorm, quadrance
|
||||
, closestPointOnSegment
|
||||
)
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..), Segment(..) )
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush, PointFields )
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Layer
|
||||
( LayerMetadata, emptyHierarchy )
|
||||
import MetaBrush.Stroke
|
||||
( StrokeHierarchy, PointIndex )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, Unique, freshUnique )
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data AABB
|
||||
= AABB
|
||||
{ topLeft, botRight :: !( ℝ 2 ) }
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
mkAABB :: ℝ 2 -> ℝ 2 -> AABB
|
||||
mkAABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) = AABB ( ℝ2 xmin ymin ) ( ℝ2 xmax ymax )
|
||||
where
|
||||
( xmin, xmax )
|
||||
| x1 > x2 = ( x2, x1 )
|
||||
| otherwise = ( x1, x2 )
|
||||
( ymin, ymax )
|
||||
| y1 > y2 = ( y2, y1 )
|
||||
| otherwise = ( y1, y2 )
|
||||
|
||||
-- | Document, together with some extra metadata.
|
||||
data Document
|
||||
= Document
|
||||
{ displayName :: !Text
|
||||
, mbFilePath :: !( Maybe FilePath )
|
||||
, viewportCenter :: !( ℝ 2 )
|
||||
, zoomFactor :: !Double
|
||||
, documentUnique :: Unique
|
||||
, documentContent :: !DocumentContent
|
||||
{ documentContent :: !DocumentContent
|
||||
-- ^ Main document content, which we keep track throughout history.
|
||||
, documentMetadata :: !DocumentMetadata
|
||||
-- ^ Metadata about the document, that we don't track throughout history.
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Main content of document (data which we kept track of throughout history).
|
||||
newtype Zoom = Zoom { zoomFactor :: Double }
|
||||
deriving stock ( Show, Eq, Ord )
|
||||
deriving newtype NFData
|
||||
|
||||
-- | A collection of points, indexed first by the stroke they belong to
|
||||
-- and then their position in that stroke.
|
||||
newtype StrokePoints = StrokePoints { strokePoints :: Map Unique ( Set PointIndex ) }
|
||||
deriving newtype ( Eq, Show, NFData )
|
||||
-- Invariant: the sets are never empty.
|
||||
|
||||
instance Semigroup StrokePoints where
|
||||
( StrokePoints pts1 ) <> ( StrokePoints pts2 ) =
|
||||
StrokePoints ( Map.unionWith Set.union pts1 pts2 )
|
||||
instance Monoid StrokePoints where
|
||||
mempty = StrokePoints Map.empty
|
||||
|
||||
-- | Remove the second set of points from the first.
|
||||
differenceStrokePoints :: StrokePoints -> StrokePoints -> StrokePoints
|
||||
differenceStrokePoints ( StrokePoints pts1 ) ( StrokePoints pts2 ) =
|
||||
StrokePoints $
|
||||
Map.differenceWith remove pts1 pts2
|
||||
where
|
||||
remove :: Set PointIndex -> Set PointIndex -> Maybe ( Set PointIndex )
|
||||
remove old new =
|
||||
let new' = old Set.\\ new
|
||||
in if null new'
|
||||
then Nothing
|
||||
else Just new'
|
||||
|
||||
noStrokePoints :: StrokePoints -> Bool
|
||||
noStrokePoints ( StrokePoints pts ) = null pts
|
||||
|
||||
elemStrokePoint :: Unique -> PointIndex -> StrokePoints -> Bool
|
||||
elemStrokePoint u i ( StrokePoints pts ) =
|
||||
case Map.lookup u pts of
|
||||
Nothing -> False
|
||||
Just is -> Set.member i is
|
||||
|
||||
-- | Metadata about a document and its content, that we don't track through
|
||||
-- history.
|
||||
data DocumentMetadata =
|
||||
Metadata
|
||||
{ documentName :: !Text
|
||||
, documentFilePath :: !( Maybe FilePath )
|
||||
, viewportCenter :: !( ℝ 2 )
|
||||
, documentZoom :: !Zoom
|
||||
, documentGuides :: !( Map Unique Guide )
|
||||
, layerMetadata :: !LayerMetadata
|
||||
, selectedPoints :: !StrokePoints
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Main content of document (data which we keep track of throughout history).
|
||||
data DocumentContent
|
||||
= Content
|
||||
{ unsavedChanges :: !Bool
|
||||
, latestChange :: !Text
|
||||
, guides :: !( Map Unique Guide )
|
||||
, strokes :: !( Seq StrokeHierarchy )
|
||||
{ unsavedChanges :: !Bool
|
||||
-- ^ Whether this current content is unsaved.
|
||||
, strokeHierarchy :: !StrokeHierarchy
|
||||
-- ^ Hierarchical structure of layers and groups.
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Hierarchy for groups of strokes.
|
||||
data StrokeHierarchy
|
||||
= StrokeGroup
|
||||
{ groupName :: !Text
|
||||
, groupVisible :: !Bool
|
||||
, groupContents :: !( Seq StrokeHierarchy )
|
||||
}
|
||||
| StrokeLeaf
|
||||
{ strokeLeaf :: !Stroke }
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
visibleStrokes :: StrokeHierarchy -> Seq Stroke
|
||||
visibleStrokes ( StrokeGroup { groupVisible, groupContents } )
|
||||
| groupVisible
|
||||
= foldMap visibleStrokes groupContents
|
||||
| otherwise
|
||||
= Empty
|
||||
visibleStrokes ( StrokeLeaf { strokeLeaf } )
|
||||
| strokeVisible strokeLeaf
|
||||
= Seq.singleton strokeLeaf
|
||||
| otherwise
|
||||
= Empty
|
||||
|
||||
type StrokeSpline clo brushParams =
|
||||
Spline clo ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||
|
||||
data Stroke where
|
||||
Stroke
|
||||
:: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
|
||||
. ( KnownSplineType clo
|
||||
, pointParams ~ Record pointFields
|
||||
, PointFields pointFields, Typeable pointFields
|
||||
)
|
||||
=>
|
||||
{ strokeName :: !Text
|
||||
, strokeVisible :: !Bool
|
||||
, strokeUnique :: Unique
|
||||
, strokeBrush :: !( Maybe ( NamedBrush brushFields ) )
|
||||
, strokeSpline :: !( StrokeSpline clo pointParams )
|
||||
}
|
||||
-> Stroke
|
||||
deriving stock instance Show Stroke
|
||||
instance NFData Stroke where
|
||||
rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeBrush, strokeSpline } )
|
||||
= deepseq strokeSpline
|
||||
. deepseq strokeBrush
|
||||
. deepseq strokeUnique
|
||||
. deepseq strokeVisible
|
||||
$ rnf strokeName
|
||||
|
||||
_strokeSpline
|
||||
:: forall f
|
||||
. Functor f
|
||||
=> ( forall clo pointParams ( pointFields :: [ Symbol ] )
|
||||
. ( KnownSplineType clo
|
||||
, pointParams ~ Record pointFields
|
||||
, PointFields pointFields
|
||||
)
|
||||
=> StrokeSpline clo pointParams
|
||||
-> f ( StrokeSpline clo pointParams )
|
||||
)
|
||||
-> Stroke -> f Stroke
|
||||
_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
|
||||
= ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline
|
||||
|
||||
overStrokeSpline
|
||||
:: ( forall clo pointParams ( pointFields :: [ Symbol ] )
|
||||
. ( KnownSplineType clo
|
||||
, pointParams ~ Record pointFields
|
||||
, PointFields pointFields
|
||||
)
|
||||
=> StrokeSpline clo pointParams
|
||||
-> StrokeSpline clo pointParams
|
||||
)
|
||||
-> Stroke -> Stroke
|
||||
overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
|
||||
|
||||
|
||||
data PointData params
|
||||
= PointData
|
||||
{ pointCoords :: !( ℝ 2 )
|
||||
, pointState :: FocusState
|
||||
, brushParams :: !params
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Act (T ( ℝ 2 )) (PointData params) where
|
||||
v • ( dat@( PointData { pointCoords = p } ) ) =
|
||||
dat { pointCoords = v • p }
|
||||
|
||||
data BrushPointData
|
||||
= BrushPointData
|
||||
{ brushPointState :: FocusState }
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
data FocusState
|
||||
= Normal
|
||||
| Hover
|
||||
| Selected
|
||||
deriving stock ( Show, Eq, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Semigroup FocusState where
|
||||
Selected <> _ = Selected
|
||||
Normal <> s = s
|
||||
_ <> Selected = Selected
|
||||
s <> Normal = s
|
||||
_ <> _ = Hover
|
||||
instance Monoid FocusState where
|
||||
mempty = Normal
|
||||
|
||||
emptyDocument :: Text -> Unique -> Document
|
||||
emptyDocument docName unique =
|
||||
Document
|
||||
{ displayName = docName
|
||||
, mbFilePath = Nothing
|
||||
, viewportCenter = ℝ2 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unique
|
||||
, documentContent =
|
||||
Content
|
||||
{ unsavedChanges = False
|
||||
, latestChange = "New document"
|
||||
, strokes = Seq.empty
|
||||
, guides = Map.empty
|
||||
}
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data HoverContext
|
||||
= MouseHover !( ℝ 2 )
|
||||
| RectangleHover !AABB
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Act ( T ( ℝ 2 ) ) HoverContext where
|
||||
v • MouseHover p = MouseHover ( v • p )
|
||||
v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )
|
||||
|
||||
instance Act ( T ( ℝ 2 ) ) ( Maybe HoverContext ) where
|
||||
(•) v = fmap ( v • )
|
||||
|
||||
class Hoverable a where
|
||||
hovered :: Maybe HoverContext -> Double -> a -> FocusState
|
||||
|
||||
instance Hoverable ( ℝ 2 ) where
|
||||
hovered Nothing _ _ = Normal
|
||||
hovered ( Just ( MouseHover p ) ) zoom q
|
||||
| quadrance @( T ( ℝ 2 ) ) p q * zoom ^ ( 2 :: Int ) < 16
|
||||
= Hover
|
||||
| otherwise
|
||||
= Normal
|
||||
hovered ( Just ( RectangleHover ( AABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ) ) ) _ ( ℝ2 x y )
|
||||
| x >= x1 && x <= x2 && y >= y1 && y <= y2
|
||||
= Hover
|
||||
| otherwise
|
||||
= Normal
|
||||
|
||||
instance Hoverable ( Segment ( ℝ 2 ) ) where
|
||||
hovered Nothing _ _ = Normal
|
||||
hovered ( Just ( MouseHover p ) ) zoom seg
|
||||
= hovered ( Just ( MouseHover p ) ) zoom p'
|
||||
where
|
||||
( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg
|
||||
hovered hov@( Just ( RectangleHover {} ) ) zoom ( Segment p0 p1 )
|
||||
-- Only consider a segment to be "hovered" if it lies entirely within the
|
||||
-- hover rectangle, not just if the hover rectangle intersects it.
|
||||
= hovered hov zoom p0 <> hovered hov zoom p1
|
||||
|
||||
class HasSelection pt where
|
||||
_selection :: Lens' pt FocusState
|
||||
instance HasSelection ( PointData brushParams ) where
|
||||
_selection = field' @"pointState"
|
||||
instance HasSelection BrushPointData where
|
||||
_selection = field' @"brushPointState"
|
||||
|
||||
_coords :: Lens' ( PointData brushParams ) ( ℝ 2 )
|
||||
_coords = field' @"pointCoords"
|
||||
|
||||
coords :: PointData brushParams -> ℝ 2
|
||||
coords = view _coords
|
||||
|
||||
data FocusDifference
|
||||
= DifferentFocus
|
||||
| SameFocus
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Semigroup FocusDifference where
|
||||
SameFocus <> SameFocus = SameFocus
|
||||
_ <> _ = DifferentFocus
|
||||
|
||||
instance Monoid FocusDifference where
|
||||
mempty = SameFocus
|
||||
|
||||
instance Group FocusDifference where
|
||||
invert = id
|
||||
|
||||
data DiffPointData diffBrushParams
|
||||
= DiffPointData
|
||||
{ diffVector :: !( T ( ℝ 2 ) )
|
||||
, diffParams :: !diffBrushParams
|
||||
, diffState :: !FocusDifference
|
||||
}
|
||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving anyclass ( NFData, NFData1 )
|
||||
|
||||
instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where
|
||||
DiffPointData v1 p1 s1 <> DiffPointData v2 p2 s2 =
|
||||
DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 ) ( s1 <> s2 )
|
||||
instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where
|
||||
mempty = DiffPointData mempty origin mempty
|
||||
instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where
|
||||
invert ( DiffPointData v1 p1 s1 ) =
|
||||
DiffPointData ( invert v1 ) ( -1 *^ p1 ) ( invert s1 )
|
||||
|
||||
instance ( Module Double diffBrushParams, Act diffBrushParams brushParams )
|
||||
=> Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
|
||||
(•) ( DiffPointData { diffVector = dp, diffParams = db, diffState = focusDiff } )
|
||||
= over _coords ( dp • )
|
||||
. over ( field' @"brushParams" ) ( db • )
|
||||
. ( case focusDiff of { SameFocus -> id; DifferentFocus -> set ( field' @"pointState" ) Normal } )
|
||||
instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams )
|
||||
=> Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
|
||||
( PointData { pointCoords = p1, brushParams = b1, pointState = s1 } ) <-- ( PointData { pointCoords = p2, brushParams = b2, pointState = s2 } ) =
|
||||
DiffPointData
|
||||
{ diffVector = p1 <-- p2
|
||||
, diffParams = b1 <-- b2
|
||||
, diffState = if s1 == s2 then SameFocus else DifferentFocus
|
||||
}
|
||||
instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where
|
||||
origin = mempty
|
||||
(^+^) = (<>)
|
||||
x ^-^ y = x <> invert y
|
||||
d *^ DiffPointData v1 p1 s1 = DiffPointData ( d *^ v1 ) ( d *^ p1 ) s1
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Guides.
|
||||
|
||||
-- | A guide, i.e. a horizontal or vertical line used for alignment.
|
||||
data Guide
|
||||
= Guide
|
||||
{ guidePoint :: !( ℝ 2 ) -- ^ point on the guide line
|
||||
, guideNormal :: !( T ( ℝ 2 ) ) -- ^ /normalised/ normal vector of the guide
|
||||
, guideFocus :: !FocusState
|
||||
, guideUnique :: Unique
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
data Ruler
|
||||
= RulerCorner
|
||||
| LeftRuler
|
||||
| TopRuler
|
||||
deriving stock Show
|
||||
emptyDocument :: Text -> Document
|
||||
emptyDocument docName =
|
||||
Document
|
||||
{ documentContent = emptyDocumentContent
|
||||
, documentMetadata = emptyDocumentMetadata docName
|
||||
}
|
||||
|
||||
-- | Try to select a guide at the given document coordinates.
|
||||
selectedGuide :: ℝ 2 -> Document -> Maybe Guide
|
||||
selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =
|
||||
\case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides
|
||||
emptyDocumentContent :: DocumentContent
|
||||
emptyDocumentContent =
|
||||
Content
|
||||
{ strokeHierarchy = emptyHierarchy
|
||||
, unsavedChanges = False
|
||||
}
|
||||
|
||||
selectGuide_maybe :: ℝ 2 -> Double -> Guide -> Maybe ( ArgMin Double Guide )
|
||||
selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
|
||||
| sqDist * zoom ^ ( 2 :: Int ) < 4
|
||||
= Just ( Min ( Arg sqDist guide ) )
|
||||
| otherwise
|
||||
= Nothing
|
||||
where
|
||||
t :: Double
|
||||
t = ( c --> p ) ^.^ n
|
||||
sqDist :: Double
|
||||
sqDist = t ^ ( 2 :: Int ) / squaredNorm n
|
||||
|
||||
-- | Add new guide after a mouse drag from a ruler area.
|
||||
addGuide :: UniqueSupply -> Ruler -> ℝ 2 -> Document -> STM Document
|
||||
addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc
|
||||
where
|
||||
insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
|
||||
insertNewGuides gs = case ruler of
|
||||
RulerCorner
|
||||
-> do
|
||||
uniq1 <- freshUnique
|
||||
uniq2 <- freshUnique
|
||||
let
|
||||
guide1, guide2 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = V2 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
||||
guide2 = Guide { guidePoint = p, guideNormal = V2 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
||||
pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
|
||||
TopRuler
|
||||
-> do
|
||||
uniq1 <- freshUnique
|
||||
let
|
||||
guide1 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = V2 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
||||
pure ( Map.insert uniq1 guide1 gs )
|
||||
LeftRuler
|
||||
-> do
|
||||
uniq2 <- freshUnique
|
||||
let
|
||||
guide2 :: Guide
|
||||
guide2 = Guide { guidePoint = p, guideNormal = V2 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
||||
pure ( Map.insert uniq2 guide2 gs )
|
||||
|
||||
instance Hoverable Guide where
|
||||
hovered ( Just ( MouseHover c ) ) zoom guide
|
||||
| Just _ <- selectGuide_maybe c zoom guide
|
||||
= Hover
|
||||
| otherwise
|
||||
= Normal
|
||||
hovered _ _ _ = Normal
|
||||
emptyDocumentMetadata :: Text -> DocumentMetadata
|
||||
emptyDocumentMetadata docName =
|
||||
Metadata
|
||||
{ documentName = docName
|
||||
, documentFilePath = Nothing
|
||||
, viewportCenter = ℝ2 0 0
|
||||
, documentZoom = Zoom { zoomFactor = 1 }
|
||||
, documentGuides = Map.empty
|
||||
, layerMetadata = mempty
|
||||
, selectedPoints = mempty
|
||||
}
|
||||
|
|
176
src/metabrushes/MetaBrush/Document/Diff.hs
Normal file
176
src/metabrushes/MetaBrush/Document/Diff.hs
Normal file
|
@ -0,0 +1,176 @@
|
|||
module MetaBrush.Document.Diff where
|
||||
|
||||
-- base
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Set
|
||||
( Set )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..) )
|
||||
|
||||
-- brush-strokes
|
||||
import Math.Bezier.Spline
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import qualified MetaBrush.Brush.Widget as Brush
|
||||
( WidgetAction(..) )
|
||||
import MetaBrush.Document
|
||||
( StrokePoints )
|
||||
import MetaBrush.Layer
|
||||
import MetaBrush.Stroke
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A change to a document.
|
||||
data Diff
|
||||
= TrivialDiff
|
||||
| HistoryDiff !HistoryDiff
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | A change to a document that affects history.
|
||||
data HistoryDiff
|
||||
= DocumentDiff !DocumentDiff
|
||||
| HierarchyDiff !HierarchyDiff
|
||||
| ContentDiff !ContentDiff
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | A change of document (e.g. new document).
|
||||
data DocumentDiff
|
||||
= DocumentCreated
|
||||
| DocumentOpened
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | A change in the layer hierarchy of a document.
|
||||
data HierarchyDiff
|
||||
= NewLayer
|
||||
{ newUnique :: !Unique
|
||||
, newPosition :: !ChildLayerPosition
|
||||
}
|
||||
| DeleteLayer
|
||||
{ delUnique :: !Unique
|
||||
, delPosition :: !ChildLayerPosition
|
||||
}
|
||||
| MoveLayer
|
||||
{ moveUnique :: !Unique
|
||||
, srcPos :: !ChildLayerPosition
|
||||
, dstPos :: !ChildLayerPosition
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | A subdivision of a single stroke.
|
||||
data Subdivision
|
||||
= Subdivision
|
||||
{ subdividedStroke :: !Unique
|
||||
, subdivisions :: !( NE.NonEmpty ( Curve Open () (), Double ) )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
data SelectionMode
|
||||
= New
|
||||
| Add
|
||||
| Subtract
|
||||
deriving stock ( Show, Eq, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Semigroup SelectionMode where
|
||||
Subtract <> _ = Subtract
|
||||
_ <> Subtract = Subtract
|
||||
New <> m = m
|
||||
m <> New = m
|
||||
Add <> Add = Add
|
||||
|
||||
instance Monoid SelectionMode where
|
||||
mempty = New
|
||||
|
||||
-- | A change in the content of strokes in the document.
|
||||
data ContentDiff
|
||||
= Translation
|
||||
{ translationVector :: !( T ( ℝ 2 ) )
|
||||
, translatedPoints :: !StrokePoints
|
||||
}
|
||||
| DragMove
|
||||
{ dragMoveSelection :: !DragMoveSelect
|
||||
, dragVector :: !( T ( ℝ 2 ) )
|
||||
, draggedPoints :: !StrokePoints
|
||||
}
|
||||
| CloseStroke
|
||||
{ closedStroke :: !Unique }
|
||||
| ContinueStroke
|
||||
{ continuedStroke :: !Unique
|
||||
, newSegment :: !( Spline Open () () )
|
||||
}
|
||||
| DeletePoints
|
||||
{ deletedPoints :: !StrokePoints
|
||||
, deletedStrokes :: !( Set Unique)
|
||||
}
|
||||
| UpdateBrushParameters
|
||||
{ updateBrushStroke :: !Unique
|
||||
, updateBrushPoint :: !PointIndex
|
||||
, updateBrushAction :: !Brush.WidgetAction
|
||||
}
|
||||
| SubdivideStroke !Subdivision
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Type of a drag move selection: point drag or curve drag.
|
||||
data DragMoveSelect
|
||||
-- | User initiated drag by clicking on a point.
|
||||
= ClickedOnPoint
|
||||
{ dragPoint :: !( Unique, PointIndex )
|
||||
, dragPointWasSelected :: !Bool
|
||||
-- ^ Whether the drag point was already selected
|
||||
-- before beginning the drag.
|
||||
}
|
||||
-- | User initiated drag by clicking on an interior point of a curve;
|
||||
-- start a curve drag, selection is preserved.
|
||||
| ClickedOnCurve
|
||||
{ dragStrokeUnique :: !Unique
|
||||
, dragCurve :: !Rational
|
||||
, dragCurveIndex :: !Int
|
||||
, dragCurveParameter :: !Double
|
||||
}
|
||||
deriving stock ( Show, Eq, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
{-
|
||||
changeText :: LayerMetadata -> ChangeDescription -> Text
|
||||
changeText metadata = \case
|
||||
TrivialChange -> "(trivial change)"
|
||||
HistoryChange ch -> historyChangeText metadata ch
|
||||
|
||||
historyChangeText :: LayerMetadata -> HistoryChangeDescription -> Text
|
||||
historyChangeText metadata = \case
|
||||
DocumentCreated -> "Create document"
|
||||
DocumentOpened -> "Open document"
|
||||
Translation pathPointsAffected controlPointsAffected strokesAffected ->
|
||||
let
|
||||
ppMv, cpMv :: Maybe Text
|
||||
ppMv
|
||||
| pathPointsAffected == 0
|
||||
= Nothing
|
||||
| otherwise
|
||||
= Just ( Text.pack ( show pathPointsAffected ) <> " path points" )
|
||||
cpMv
|
||||
| controlPointsAffected == 0
|
||||
= Nothing
|
||||
| otherwise
|
||||
= Just ( Text.pack ( show controlPointsAffected ) <> " control points" )
|
||||
in "Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
|
||||
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
|
||||
DragCurveSegment strokeUnique ->
|
||||
"Drag curve segment of stroke " <> ( layerNames metadata Map.! strokeUnique )
|
||||
-}
|
|
@ -1,262 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module MetaBrush.Document.Draw
|
||||
( DrawAnchor(..), anchorsAreComplementary
|
||||
, getOrCreateDrawAnchor, addToAnchor
|
||||
, withAnchorBrushData
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Coerce
|
||||
( coerce )
|
||||
import Data.Functor
|
||||
( ($>) )
|
||||
import Data.Semigroup
|
||||
( First(..) )
|
||||
import GHC.TypeLits
|
||||
( Symbol )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Torsor((-->)) )
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field, field' )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( set, over, mapped )
|
||||
|
||||
-- stm
|
||||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( State, runState, get, put )
|
||||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), Curves(..)
|
||||
, SplineType(..), SSplineType(..)
|
||||
, SplineTypeI(ssplineType)
|
||||
, reverseSpline, splineEnd
|
||||
, openCurveEnd
|
||||
)
|
||||
import Math.Module
|
||||
( squaredNorm )
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Assert
|
||||
( assert )
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush(..), PointFields )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..)
|
||||
, Stroke(..), StrokeHierarchy(..), StrokeSpline
|
||||
, FocusState(..), PointData(..)
|
||||
, _selection, _strokeSpline
|
||||
, coords, overStrokeSpline
|
||||
)
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Unique
|
||||
( Unique, UniqueSupply, freshUnique, uniqueText )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data DrawAnchor
|
||||
= AnchorAtStart { anchorStrokeUnique :: Unique }
|
||||
| AnchorAtEnd { anchorStrokeUnique :: Unique }
|
||||
deriving stock Show
|
||||
|
||||
-- | Computes whether two anchors are the two ends of the same stroke.
|
||||
anchorsAreComplementary :: DrawAnchor -> DrawAnchor -> Bool
|
||||
anchorsAreComplementary ( AnchorAtStart uniq1 ) ( AnchorAtEnd uniq2 )
|
||||
| uniq1 == uniq2
|
||||
= True
|
||||
anchorsAreComplementary ( AnchorAtEnd uniq1 ) ( AnchorAtStart uniq2 )
|
||||
| uniq1 == uniq2
|
||||
= True
|
||||
anchorsAreComplementary _ _ = False
|
||||
|
||||
getOrCreateDrawAnchor
|
||||
:: UniqueSupply
|
||||
-> ℝ 2
|
||||
-> Document
|
||||
-> STM ( Document, DrawAnchor, ℝ 2, Maybe Text )
|
||||
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
|
||||
case
|
||||
( `runState` Nothing )
|
||||
$ ( field' @"documentContent" . field' @"strokes" . traverse )
|
||||
updateStrokeHierarchy
|
||||
doc
|
||||
of
|
||||
-- Anchor found: use it.
|
||||
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) ->
|
||||
pure ( newDoc, anchor, anchorPt, Just anchorName )
|
||||
-- No anchor found: start a new stroke (on a new stroke layer).
|
||||
( newDoc, Nothing ) -> do
|
||||
uniq <- runReaderT freshUnique uniqueSupply
|
||||
let
|
||||
newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
|
||||
newSpline =
|
||||
Spline { splineStart = PointData c Normal ( MkR ℝ0 )
|
||||
, splineCurves = OpenCurves Empty
|
||||
}
|
||||
newStroke :: Stroke
|
||||
newStroke =
|
||||
Stroke
|
||||
{ strokeName = "Stroke " <> uniqueText uniq
|
||||
, strokeVisible = True
|
||||
, strokeUnique = uniq
|
||||
, strokeSpline = newSpline
|
||||
, strokeBrush = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) )
|
||||
}
|
||||
newDoc' :: Document
|
||||
newDoc'
|
||||
= over ( field' @"documentContent" . field' @"strokes" )
|
||||
( StrokeLeaf newStroke :<| )
|
||||
newDoc
|
||||
pure ( newDoc', AnchorAtEnd uniq, c, Nothing )
|
||||
where
|
||||
-- Deselect all points, and try to find a valid anchor for drawing
|
||||
-- (a path start/end point at mouse click point).
|
||||
|
||||
updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) StrokeHierarchy
|
||||
updateStrokeHierarchy ( StrokeGroup { .. } ) = do
|
||||
newContents <- traverse updateStrokeHierarchy groupContents
|
||||
pure ( StrokeGroup { groupContents = newContents, .. } )
|
||||
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
|
||||
|
||||
updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) Stroke
|
||||
updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke
|
||||
|
||||
where
|
||||
updateStrokeSpline
|
||||
:: forall clo brushParams
|
||||
. SplineTypeI clo
|
||||
=> StrokeSpline clo brushParams
|
||||
-> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) ( StrokeSpline clo brushParams )
|
||||
updateStrokeSpline spline = do
|
||||
|
||||
mbAnchor <- get
|
||||
case mbAnchor of
|
||||
-- If we haven't already found an anchor,
|
||||
-- and the current point is a valid candidate,
|
||||
-- then select it as an anchor for the drawing operation.
|
||||
Nothing
|
||||
| strokeVisible
|
||||
, Just anchor <- endpointAnchor strokeUnique spline
|
||||
-> put ( Just ( anchor, strokeName ) )
|
||||
$> set ( mapped . _selection ) Normal spline
|
||||
-- Otherwise, just deselect.
|
||||
_ -> pure $ set ( mapped . _selection ) Normal spline
|
||||
|
||||
where
|
||||
-- See if we can anchor a drawing operation on a given (visible) stroke.
|
||||
endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, ℝ 2 )
|
||||
endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
|
||||
SOpen
|
||||
| let
|
||||
p0 :: ℝ 2
|
||||
p0 = coords splineStart
|
||||
, inPointClickRange p0
|
||||
-> Just ( AnchorAtStart uniq, p0 )
|
||||
| OpenCurves ( _ :|> lastCurve ) <- splineCurves
|
||||
, let
|
||||
pn :: ℝ 2
|
||||
pn = coords ( openCurveEnd lastCurve )
|
||||
, inPointClickRange pn
|
||||
-> Just ( AnchorAtEnd uniq, pn )
|
||||
_ -> Nothing
|
||||
inPointClickRange :: ℝ 2 -> Bool
|
||||
inPointClickRange p =
|
||||
squaredNorm ( c --> p :: T ( ℝ 2 ) ) < 16 / ( zoomFactor * zoomFactor )
|
||||
|
||||
addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
|
||||
addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) updateStrokeHierarchy
|
||||
where
|
||||
|
||||
updateStrokeHierarchy :: StrokeHierarchy -> StrokeHierarchy
|
||||
updateStrokeHierarchy ( StrokeGroup { .. } ) =
|
||||
let
|
||||
newContents = fmap updateStrokeHierarchy groupContents
|
||||
in
|
||||
StrokeGroup { groupContents = newContents, .. }
|
||||
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf $ updateStroke strokeLeaf
|
||||
|
||||
updateStroke :: Stroke -> Stroke
|
||||
updateStroke stroke@( Stroke { strokeUnique } )
|
||||
| strokeUnique == anchorStrokeUnique anchor
|
||||
, let
|
||||
updateSpline
|
||||
:: forall clo brushData
|
||||
. SplineTypeI clo
|
||||
=> StrokeSpline clo brushData -> StrokeSpline clo brushData
|
||||
updateSpline prevSpline
|
||||
| SOpen <- ssplineType @clo
|
||||
= case anchor of
|
||||
AnchorAtStart _ ->
|
||||
let
|
||||
setBrushData :: PointData () -> PointData brushData
|
||||
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
|
||||
in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline
|
||||
AnchorAtEnd _ ->
|
||||
let
|
||||
setBrushData :: PointData () -> PointData brushData
|
||||
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
|
||||
in prevSpline <> fmap setBrushData newSpline
|
||||
| otherwise
|
||||
= assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
|
||||
prevSpline -- should never add to a closed spline
|
||||
= overStrokeSpline updateSpline stroke
|
||||
| otherwise
|
||||
= stroke
|
||||
|
||||
withAnchorBrushData
|
||||
:: forall r
|
||||
. DrawAnchor
|
||||
-> Document
|
||||
-> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
|
||||
. ( pointParams ~ Record pointFields
|
||||
, PointFields pointFields
|
||||
)
|
||||
=> Maybe ( NamedBrush brushFields )
|
||||
-> pointParams
|
||||
-> r
|
||||
)
|
||||
-> r
|
||||
withAnchorBrushData anchor ( Document { documentContent = Content { strokes } } ) f =
|
||||
splineAnchor . coerce $ foldMap getFirstRelevantStroke strokes
|
||||
where
|
||||
|
||||
getFirstRelevantStroke :: StrokeHierarchy -> Maybe ( First Stroke )
|
||||
getFirstRelevantStroke ( StrokeGroup { groupContents } ) =
|
||||
foldMap getFirstRelevantStroke groupContents
|
||||
getFirstRelevantStroke ( StrokeLeaf { strokeLeaf } )
|
||||
| strokeUnique strokeLeaf == anchorStrokeUnique anchor
|
||||
= Just ( First strokeLeaf )
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
splineAnchor :: Maybe Stroke -> r
|
||||
splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) )
|
||||
| SOpen <- ssplineType @clo
|
||||
= case anchor of
|
||||
AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) )
|
||||
AnchorAtEnd {} -> f strokeBrush ( brushParams ( splineEnd strokeSpline ) )
|
||||
splineAnchor _
|
||||
= f @_ @'[] @'[] Nothing ( MkR ℝ0 )
|
|
@ -11,10 +11,16 @@ module MetaBrush.Document.Serialise
|
|||
-- base
|
||||
import Control.Monad
|
||||
( unless )
|
||||
import Control.Monad.ST
|
||||
( stToIO )
|
||||
import qualified Data.Bifunctor as Bifunctor
|
||||
( first )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Maybe
|
||||
( fromMaybe )
|
||||
import Data.STRef
|
||||
( newSTRef )
|
||||
import Data.Version
|
||||
( Version(versionBranch) )
|
||||
import GHC.Exts
|
||||
|
@ -38,6 +44,9 @@ import qualified Data.ByteString.Lazy as Lazy
|
|||
import qualified Data.ByteString.Builder as Lazy.ByteString.Builder
|
||||
( toLazyByteString )
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
-- directory
|
||||
import System.Directory
|
||||
( canonicalizePath, createDirectoryIfMissing, doesFileExist )
|
||||
|
@ -65,8 +74,7 @@ import Control.Monad.IO.Class
|
|||
( MonadIO(liftIO) )
|
||||
import Control.Monad.Trans.Class
|
||||
( MonadTrans(lift) )
|
||||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
import qualified Control.Monad.Trans.Reader as Reader
|
||||
|
||||
-- waargonaut
|
||||
import qualified Waargonaut.Attoparsec as JSON.Decoder
|
||||
|
@ -76,13 +84,9 @@ import qualified Waargonaut.Decode as JSON
|
|||
import qualified Waargonaut.Decode.Error as JSON
|
||||
( DecodeError(ParseFailed) )
|
||||
import qualified Waargonaut.Decode as JSON.Decoder
|
||||
( atKey, atKeyOptional, bool, text, list )
|
||||
import qualified Waargonaut.Encode as JSON
|
||||
( Encoder )
|
||||
import qualified Waargonaut.Encode as JSON.Encoder
|
||||
( runEncoder
|
||||
, atKey', bool, int, list, mapLikeObj, text
|
||||
)
|
||||
import qualified Waargonaut.Encode.Builder as JSON.Builder
|
||||
( waargonautBuilder, bsBuilder )
|
||||
import qualified Waargonaut.Encode.Builder.Whitespace as JSON.Builder
|
||||
|
@ -102,32 +106,32 @@ import Waargonaut.Types.Json
|
|||
import qualified Waargonaut.Types.Whitespace as JSON
|
||||
( WS )
|
||||
|
||||
-- metabrushes
|
||||
-- brush-strokes
|
||||
import Math.Bezier.Spline
|
||||
( SplineType(..), SSplineType(..), SplineTypeI(..) )
|
||||
( SplineType(..), SSplineType(..), SplineTypeI(..) )
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..) )
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Asset.Brushes
|
||||
( lookupBrush )
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush(..), SomeBrush(..), provePointFields, duplicates )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..), Guide(..)
|
||||
, Stroke(..), StrokeHierarchy(..), StrokeSpline
|
||||
, PointData(..), FocusState(..)
|
||||
)
|
||||
import MetaBrush.Layer ( LayerMetadata(..) )
|
||||
import MetaBrush.Serialisable
|
||||
( Serialisable(..)
|
||||
, encodeSequence, decodeSequence
|
||||
, encodeUniqueMap, decodeUniqueMap
|
||||
, encodeSpline, decodeSpline
|
||||
)
|
||||
import MetaBrush.Stroke
|
||||
import MetaBrush.Records
|
||||
( Record, knownSymbols )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, freshUnique )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
( version )
|
||||
|
||||
|
@ -204,12 +208,8 @@ decodePointData
|
|||
=> JSON.Decoder m ( PointData brushParams )
|
||||
decodePointData = do
|
||||
pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( ℝ 2 ) )
|
||||
let
|
||||
pointState :: FocusState
|
||||
pointState = Normal
|
||||
brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Record flds ) )
|
||||
pure ( PointData { pointCoords, pointState, brushParams } )
|
||||
|
||||
pure ( PointData { pointCoords, brushParams } )
|
||||
|
||||
encodeFields :: Monad f => JSON.Encoder f [ Text ]
|
||||
encodeFields = JSON.Encoder.list JSON.Encoder.text
|
||||
|
@ -223,12 +223,12 @@ decodeFields = do
|
|||
dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups )
|
||||
|
||||
|
||||
encodeBrush :: Applicative f => JSON.Encoder f (NamedBrush brushFields)
|
||||
encodeBrush :: Applicative f => JSON.Encoder f ( NamedBrush brushFields )
|
||||
encodeBrush = JSON.Encoder.mapLikeObj
|
||||
\ ( NamedBrush { brushName } ) ->
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
|
||||
|
||||
decodeBrush :: MonadIO m => JSON.Decoder m SomeBrush
|
||||
decodeBrush :: Monad m => JSON.Decoder m SomeBrush
|
||||
decodeBrush = do
|
||||
brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
case lookupBrush brushName of
|
||||
|
@ -239,9 +239,7 @@ decodeBrush = do
|
|||
encodeStroke :: Monad f => JSON.Encoder f Stroke
|
||||
encodeStroke = JSON.Encoder.mapLikeObj
|
||||
\ ( Stroke
|
||||
{ strokeName
|
||||
, strokeVisible
|
||||
, strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields )
|
||||
{ strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields )
|
||||
, strokeBrush
|
||||
}
|
||||
) ->
|
||||
|
@ -255,18 +253,22 @@ encodeStroke = JSON.Encoder.mapLikeObj
|
|||
Nothing -> id
|
||||
Just brush -> JSON.Encoder.atKey' "brush" encodeBrush brush
|
||||
in
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
|
||||
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible
|
||||
. JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed
|
||||
JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed
|
||||
. JSON.Encoder.atKey' "pointFields" encodeFields ( knownSymbols @pointFields )
|
||||
. mbEncodeBrush
|
||||
. JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline
|
||||
|
||||
decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
|
||||
decodeStroke uniqueSupply = do
|
||||
strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
|
||||
strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
|
||||
newCurveData :: MonadIO m => ( Integer -> m CurveData )
|
||||
newCurveData i = do
|
||||
noCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
|
||||
return $
|
||||
CurveData
|
||||
{ curveIndex = fromInteger i
|
||||
, cachedStroke = noCache
|
||||
}
|
||||
|
||||
decodeStroke :: MonadIO m => JSON.Decoder m Stroke
|
||||
decodeStroke = do
|
||||
strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
|
||||
mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" decodeBrush
|
||||
pointFields <- JSON.Decoder.atKey "pointFields" decodeFields
|
||||
|
@ -274,97 +276,122 @@ decodeStroke uniqueSupply = do
|
|||
provePointFields pointFields \ ( _ :: Proxy# pointFields ) ->
|
||||
if strokeClosed
|
||||
then do
|
||||
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData )
|
||||
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData newCurveData )
|
||||
pure $ case mbSomeBrush of
|
||||
Nothing ->
|
||||
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
|
||||
Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
|
||||
Just (SomeBrush brush) ->
|
||||
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
|
||||
Stroke { strokeSpline, strokeBrush = Just brush }
|
||||
else do
|
||||
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) decodePointData )
|
||||
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) decodePointData newCurveData )
|
||||
pure $ case mbSomeBrush of
|
||||
Nothing ->
|
||||
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
|
||||
Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
|
||||
Just (SomeBrush brush) ->
|
||||
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
|
||||
|
||||
|
||||
encodeStrokeHierarchy :: Monad f => JSON.Encoder f StrokeHierarchy
|
||||
encodeStrokeHierarchy = JSON.Encoder.mapLikeObj \case
|
||||
StrokeGroup { groupName, groupVisible, groupContents } ->
|
||||
JSON.Encoder.atKey' "tag" JSON.Encoder.text "group"
|
||||
. JSON.Encoder.atKey' "name" JSON.Encoder.text groupName
|
||||
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool groupVisible
|
||||
. JSON.Encoder.atKey' "contents" ( encodeSequence encodeStrokeHierarchy ) groupContents
|
||||
StrokeLeaf { strokeLeaf } ->
|
||||
JSON.Encoder.atKey' "tag" JSON.Encoder.text "leaf"
|
||||
. JSON.Encoder.atKey' "stroke" encodeStroke strokeLeaf
|
||||
|
||||
decodeStrokeHierarchy :: MonadIO m => UniqueSupply -> JSON.Decoder m StrokeHierarchy
|
||||
decodeStrokeHierarchy uniqueSupply = do
|
||||
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
|
||||
case tag of
|
||||
"group" -> do
|
||||
groupName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
groupVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
|
||||
groupContents <- JSON.Decoder.atKey "contents" ( decodeSequence $ decodeStrokeHierarchy uniqueSupply )
|
||||
pure ( StrokeGroup { groupName, groupVisible, groupContents } )
|
||||
"leaf" -> do
|
||||
strokeLeaf <- JSON.Decoder.atKey "stroke" ( decodeStroke uniqueSupply )
|
||||
pure ( StrokeLeaf { strokeLeaf } )
|
||||
_ -> throwError ( JSON.ParseFailed $ "Unsupported stroke hierarchy type with tag " <> tag )
|
||||
Stroke { strokeSpline, strokeBrush = Just brush }
|
||||
|
||||
encodeLayer :: Monad f => JSON.Encoder f Layer
|
||||
encodeLayer =
|
||||
JSON.Encoder.mapLikeObj \ layer ->
|
||||
let
|
||||
encodeLayerData = case layer of
|
||||
GroupLayer { groupChildren } ->
|
||||
JSON.Encoder.atKey' "contents" ( JSON.Encoder.list encodeLayer ) groupChildren
|
||||
StrokeLayer { layerStroke } ->
|
||||
JSON.Encoder.atKey' "stroke" encodeStroke layerStroke
|
||||
in
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text ( layerName layer )
|
||||
. JSON.Encoder.atOptKey' "visible" JSON.Encoder.bool ( if layerVisible layer then Nothing else Just False )
|
||||
. JSON.Encoder.atOptKey' "locked" JSON.Encoder.bool ( if layerLocked layer then Just True else Nothing )
|
||||
. encodeLayerData
|
||||
|
||||
decodeLayer :: MonadIO m => UniqueSupply -> JSON.Decoder m Layer
|
||||
decodeLayer uniqueSupply = do
|
||||
layerUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply )
|
||||
mbLayerName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text
|
||||
mbLayerVisible <- JSON.Decoder.atKeyOptional "visible" JSON.Decoder.bool
|
||||
mbLayerLocked <- JSON.Decoder.atKeyOptional "locked" JSON.Decoder.bool
|
||||
let layerVisible = fromMaybe True mbLayerVisible
|
||||
layerLocked = fromMaybe False mbLayerLocked
|
||||
mbLayerStroke <- JSON.Decoder.atKeyOptional "stroke" decodeStroke
|
||||
case mbLayerStroke of
|
||||
Nothing -> do
|
||||
let layerName = fromMaybe "Group" mbLayerName
|
||||
groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list ( decodeLayer uniqueSupply ) )
|
||||
pure ( GroupLayer { layerUnique, layerName, layerVisible, layerLocked, groupChildren } )
|
||||
Just layerStroke -> do
|
||||
let layerName = fromMaybe "Stroke" mbLayerName
|
||||
pure ( StrokeLayer { layerUnique, layerName, layerVisible, layerLocked, layerStroke } )
|
||||
|
||||
encodeGuide :: Applicative f => JSON.Encoder f Guide
|
||||
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
|
||||
JSON.Encoder.atKey' "point" ( encoder @( ℝ 2 ) ) guidePoint
|
||||
. JSON.Encoder.atKey' "normal" ( encoder @( T ( ℝ 2 ) ) ) guideNormal
|
||||
|
||||
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
|
||||
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m ( Unique, Guide )
|
||||
decodeGuide uniqueSupply = do
|
||||
guideUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply )
|
||||
guidePoint <- JSON.Decoder.atKey "point" ( decoder @( ℝ 2 ) )
|
||||
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) )
|
||||
let
|
||||
guideFocus :: FocusState
|
||||
guideFocus = Normal
|
||||
guideUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
|
||||
pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
|
||||
pure ( guideUnique, Guide { guidePoint, guideNormal } )
|
||||
|
||||
encodeDocumentContent :: Applicative f => JSON.Encoder f ( LayerMetadata, DocumentContent )
|
||||
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( layerMetadata, Content { strokeHierarchy } ) ->
|
||||
JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) $
|
||||
strokeHierarchyLayers layerMetadata strokeHierarchy
|
||||
|
||||
|
||||
encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
|
||||
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
|
||||
JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides
|
||||
. JSON.Encoder.atKey' "strokes" ( encodeSequence encodeStrokeHierarchy ) strokes
|
||||
|
||||
decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent
|
||||
decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m ( LayerMetadata, DocumentContent )
|
||||
decodeDocumentContent uniqueSupply = do
|
||||
let
|
||||
unsavedChanges :: Bool
|
||||
unsavedChanges = False
|
||||
latestChange :: Text
|
||||
latestChange = "Load document"
|
||||
strokes <- JSON.Decoder.atKey "strokes" ( decodeSequence ( decodeStrokeHierarchy uniqueSupply ) )
|
||||
guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) )
|
||||
pure ( Content { unsavedChanges, latestChange, strokes, guides } )
|
||||
layers <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list $ decodeLayer uniqueSupply )
|
||||
let ( layerMetadata, strokeHierarchy ) = layersStrokeHierarchy layers
|
||||
pure ( layerMetadata, Content { unsavedChanges, strokeHierarchy } )
|
||||
|
||||
|
||||
encodeDocumentMetadata :: Applicative f => JSON.Encoder f DocumentMetadata
|
||||
encodeDocumentMetadata =
|
||||
JSON.Encoder.mapLikeObj
|
||||
\ ( Metadata { documentName, viewportCenter, documentZoom, documentGuides } ) ->
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text documentName
|
||||
. JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor documentZoom )
|
||||
. JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems documentGuides )
|
||||
|
||||
|
||||
decodeDocumentMetadata
|
||||
:: MonadIO m
|
||||
=> UniqueSupply
|
||||
-> Maybe FilePath
|
||||
-> LayerMetadata
|
||||
-> JSON.Decoder m DocumentMetadata
|
||||
decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do
|
||||
documentName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) )
|
||||
zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
|
||||
guides <- JSON.Decoder.atKey "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply )
|
||||
pure $
|
||||
Metadata
|
||||
{ documentName
|
||||
, documentFilePath = mbFilePath
|
||||
, viewportCenter
|
||||
, documentZoom = Zoom { zoomFactor }
|
||||
, documentGuides = Map.fromList guides
|
||||
, layerMetadata
|
||||
, selectedPoints = mempty
|
||||
}
|
||||
|
||||
encodeDocument :: Applicative f => JSON.Encoder f Document
|
||||
encodeDocument = JSON.Encoder.mapLikeObj
|
||||
\ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
|
||||
\ ( Document { documentMetadata, documentContent } ) ->
|
||||
JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version )
|
||||
. JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
|
||||
. JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor
|
||||
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
|
||||
. JSON.Encoder.atKey' "metadata" encodeDocumentMetadata documentMetadata
|
||||
. JSON.Encoder.atKey' "content" encodeDocumentContent ( layerMetadata documentMetadata, documentContent )
|
||||
|
||||
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
|
||||
decodeDocument uniqueSupply mbFilePath = do
|
||||
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) )
|
||||
zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
|
||||
documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
|
||||
documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
|
||||
pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } )
|
||||
( layerMetadata, documentContent ) <-
|
||||
JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
|
||||
documentMetadata <- JSON.Decoder.atKey "metadata" $ decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
|
||||
pure ( Document { documentMetadata, documentContent } )
|
||||
|
|
|
@ -1,164 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module MetaBrush.Document.SubdivideStroke
|
||||
( subdivide )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad.ST
|
||||
( RealWorld )
|
||||
import Data.Semigroup
|
||||
( Min(..), Arg(..) )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act((•)) )
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Sequence as Seq
|
||||
( singleton )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( invert )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( State, runState, put )
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier(..), closestPoint, subdivide )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..), closestPoint, subdivide )
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplineType(..), Curve(..), Curves(..), NextPoint(..)
|
||||
, KnownSplineType(bifoldSpline, adjustSplineType)
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..), invalidateCache )
|
||||
import Math.Module
|
||||
( Interpolatable, lerp, quadrance, closestPointOnSegment )
|
||||
import Math.Linear
|
||||
( Segment(..), ℝ(..), T(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline
|
||||
, PointData(..), DiffPointData(..)
|
||||
, coords, _strokeSpline
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Subdivide a path at the given center, provided a path indeed lies there.
|
||||
subdivide :: ℝ 2 -> Document -> Maybe ( Document, Text )
|
||||
subdivide c doc@( Document { zoomFactor } ) =
|
||||
let
|
||||
updatedDoc :: Document
|
||||
mbSubdivLoc :: Maybe Text
|
||||
( updatedDoc, mbSubdivLoc ) =
|
||||
( `runState` Nothing )
|
||||
$ ( field' @"documentContent" . field' @"strokes" . traverse )
|
||||
updateStrokeHierarchy
|
||||
doc
|
||||
in ( updatedDoc , ) <$> mbSubdivLoc
|
||||
where
|
||||
updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe Text ) StrokeHierarchy
|
||||
updateStrokeHierarchy ( StrokeGroup { .. } ) = do
|
||||
newContents <- traverse updateStrokeHierarchy groupContents
|
||||
pure ( StrokeGroup { groupContents = newContents, .. } )
|
||||
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
|
||||
|
||||
updateStroke :: Stroke -> State ( Maybe Text ) Stroke
|
||||
updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke
|
||||
|
||||
where
|
||||
updateSpline
|
||||
:: forall clo brushParams
|
||||
. ( KnownSplineType clo, Interpolatable Double brushParams )
|
||||
=> StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams )
|
||||
updateSpline spline@( Spline { splineStart } )
|
||||
| not strokeVisible
|
||||
= pure spline
|
||||
| otherwise
|
||||
= fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } )
|
||||
$ bifoldSpline
|
||||
( updateCurve ( "stroke " <> strokeName ) ( V2 0 0 ) )
|
||||
( const $ pure Empty )
|
||||
( adjustSplineType @Open spline )
|
||||
|
||||
where
|
||||
updateCurve
|
||||
:: Text
|
||||
-> T ( ℝ 2 )
|
||||
-> PointData brushParams
|
||||
-> Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||
-> State ( Maybe Text )
|
||||
( Seq ( Curve Open ( CachedStroke RealWorld ) ( PointData brushParams ) ) )
|
||||
updateCurve txt offset sp0 curve = case curve of
|
||||
line@( LineTo ( NextPoint sp1 ) dat ) ->
|
||||
let
|
||||
p0, p1, s :: ℝ 2
|
||||
t :: Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
( t, s ) = closestPointOnSegment @( T ( ℝ 2 ) ) ( invert offset • c ) ( Segment p0 p1 )
|
||||
sqDist :: Double
|
||||
sqDist = quadrance @( T ( ℝ 2 ) ) c ( offset • s )
|
||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then
|
||||
let
|
||||
subdiv :: PointData brushParams
|
||||
subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1
|
||||
in do
|
||||
put ( Just txt )
|
||||
pure ( LineTo ( NextPoint subdiv ) ( invalidateCache dat ) :<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) :<| Empty )
|
||||
else pure $ Seq.singleton line
|
||||
bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
|
||||
let
|
||||
p0, p1, p2 :: ℝ 2
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
sqDist :: Double
|
||||
Min ( Arg sqDist ( t, _ ) )
|
||||
= Quadratic.closestPoint @( T ( ℝ 2 ) ) ( Quadratic.Bezier {..} ) ( invert offset • c )
|
||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
|
||||
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
|
||||
let
|
||||
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
|
||||
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat )
|
||||
put ( Just txt )
|
||||
pure ( bez_start :<| bez_end :<| Empty )
|
||||
else pure $ Seq.singleton bez2
|
||||
bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
|
||||
let
|
||||
p0, p1, p2, p3 :: ℝ 2
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
p3 = coords sp3
|
||||
Min ( Arg sqDist ( t, _ ) )
|
||||
= Cubic.closestPoint @( T ( ℝ 2 ) ) ( Cubic.Bezier {..} ) ( invert offset • c )
|
||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
|
||||
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
|
||||
let
|
||||
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
|
||||
bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( invalidateCache dat )
|
||||
put ( Just txt )
|
||||
pure ( bez_start :<| bez_end :<| Empty )
|
||||
else pure $ Seq.singleton bez3
|
282
src/metabrushes/MetaBrush/Draw.hs
Normal file
282
src/metabrushes/MetaBrush/Draw.hs
Normal file
|
@ -0,0 +1,282 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module MetaBrush.Draw
|
||||
( DrawAnchor(..), anchorsAreComplementary
|
||||
, getOrCreateDrawAnchor, addToAnchor
|
||||
, withAnchorBrushData
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( when )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
import GHC.TypeLits
|
||||
( Symbol )
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field, field' )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( set, over )
|
||||
|
||||
-- stm
|
||||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Except
|
||||
( Except )
|
||||
import qualified Control.Monad.Trans.Except as Except
|
||||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
import Math.Linear
|
||||
( ℝ(..) )
|
||||
import MetaBrush.Assert
|
||||
( assert )
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush(..), PointFields )
|
||||
import MetaBrush.Document
|
||||
import MetaBrush.Hover
|
||||
( inPointClickRange )
|
||||
import MetaBrush.Layer
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Stroke
|
||||
import MetaBrush.Unique
|
||||
( Unique, UniqueSupply, freshUnique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A draw anchor, to continue drawing from one end of an existing stroke.
|
||||
data DrawAnchor
|
||||
= DrawAnchor
|
||||
{ anchorIsNew :: !Bool
|
||||
, anchorStroke :: !Unique
|
||||
, anchorIsAtEnd :: !Bool
|
||||
, anchorPos :: !( ℝ 2 )
|
||||
, anchorIndex :: !PointIndex
|
||||
}
|
||||
deriving stock ( Show, Eq, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Computes whether two anchors are the two ends of the same stroke.
|
||||
anchorsAreComplementary :: DrawAnchor -> DrawAnchor -> Bool
|
||||
anchorsAreComplementary
|
||||
( DrawAnchor { anchorStroke = uniq1, anchorIndex = end1 } )
|
||||
( DrawAnchor { anchorStroke = uniq2, anchorIndex = end2 } )
|
||||
= uniq1 == uniq2 && end1 /= end2
|
||||
|
||||
-- | Compute a draw anchor at the given position, e.g. to continue
|
||||
-- drawing a stroke or to start a new one.
|
||||
getOrCreateDrawAnchor
|
||||
:: UniqueSupply
|
||||
-> ℝ 2
|
||||
-> Document
|
||||
-> STM ( Document, DrawAnchor )
|
||||
getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldContent, documentMetadata } ) =
|
||||
|
||||
-- Deselect all points, and try to find a valid anchor for drawing
|
||||
-- (a path start/end point at mouse click point).
|
||||
|
||||
case
|
||||
Except.runExcept $
|
||||
forStrokeHierarchy
|
||||
( layerMetadata documentMetadata )
|
||||
( strokeHierarchy oldContent )
|
||||
findAnchor
|
||||
of
|
||||
-- Anchor found: use it.
|
||||
Left anchor@( DrawAnchor { anchorStroke, anchorIndex }) ->
|
||||
let newSel = StrokePoints $ Map.singleton anchorStroke ( Set.singleton anchorIndex )
|
||||
newMeta :: DocumentMetadata
|
||||
newMeta = documentMetadata { selectedPoints = newSel }
|
||||
in pure ( doc { documentMetadata = newMeta }
|
||||
, anchor )
|
||||
-- No anchor found: start a new stroke (on a new stroke layer).
|
||||
Right {} -> do
|
||||
newStrokeUnique <- runReaderT freshUnique uniqueSupply
|
||||
let
|
||||
newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
|
||||
newSpline =
|
||||
Spline { splineStart = PointData c ( MkR ℝ0 )
|
||||
, splineCurves = OpenCurves Empty
|
||||
}
|
||||
newStroke :: Stroke
|
||||
newStroke =
|
||||
Stroke
|
||||
{ strokeSpline = newSpline
|
||||
, strokeBrush = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) )
|
||||
}
|
||||
newSel = StrokePoints $ Map.singleton newStrokeUnique ( Set.singleton FirstPoint )
|
||||
newMeta :: DocumentMetadata
|
||||
newMeta =
|
||||
set ( field' @"selectedPoints" ) newSel
|
||||
. over ( field' @"layerMetadata" . field' @"layerNames" ) ( Map.insert newStrokeUnique "Stroke" )
|
||||
$ documentMetadata
|
||||
newHierarchy :: StrokeHierarchy
|
||||
newHierarchy =
|
||||
( strokeHierarchy oldContent )
|
||||
{ topLevel = newStrokeUnique : topLevel ( strokeHierarchy oldContent )
|
||||
, content = Map.insert newStrokeUnique newStroke ( content ( strokeHierarchy oldContent ) )
|
||||
}
|
||||
newContent :: DocumentContent
|
||||
newContent = oldContent { strokeHierarchy = newHierarchy }
|
||||
newDoc' :: Document
|
||||
newDoc' =
|
||||
doc { documentMetadata = newMeta
|
||||
, documentContent = newContent
|
||||
}
|
||||
anchor =
|
||||
DrawAnchor
|
||||
{ anchorIsNew = True
|
||||
, anchorStroke = newStrokeUnique
|
||||
, anchorIsAtEnd = True
|
||||
, anchorPos = c
|
||||
, anchorIndex = FirstPoint
|
||||
}
|
||||
pure ( newDoc', anchor )
|
||||
where
|
||||
zoom = documentZoom documentMetadata
|
||||
|
||||
findAnchor :: Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
|
||||
findAnchor strokeUnique ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||
when ( strokeVisible && not strokeLocked ) $
|
||||
findAnchorSpline strokeSpline
|
||||
return PreserveStroke
|
||||
|
||||
where
|
||||
findAnchorSpline
|
||||
:: forall clo brushParams
|
||||
. SplineTypeI clo
|
||||
=> StrokeSpline clo brushParams
|
||||
-> Except DrawAnchor ()
|
||||
findAnchorSpline spline =
|
||||
for_ ( endpointAnchor strokeUnique spline ) Except.throwE
|
||||
where
|
||||
-- See if we can anchor a drawing operation on a given (visible) stroke.
|
||||
endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe DrawAnchor
|
||||
endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
|
||||
SOpen
|
||||
| let
|
||||
p0 = coords splineStart
|
||||
, inPointClickRange zoom c p0
|
||||
, let anchor =
|
||||
DrawAnchor
|
||||
{ anchorIsNew = False
|
||||
, anchorStroke = uniq
|
||||
, anchorIsAtEnd = False
|
||||
, anchorPos = p0
|
||||
, anchorIndex = FirstPoint
|
||||
}
|
||||
-> Just anchor
|
||||
| OpenCurves ( _ :|> lastCurve ) <- splineCurves
|
||||
, let
|
||||
pn :: ℝ 2
|
||||
pn = coords ( openCurveEnd lastCurve )
|
||||
, inPointClickRange zoom c pn
|
||||
, let anchor =
|
||||
DrawAnchor
|
||||
{ anchorIsNew = False
|
||||
, anchorStroke = uniq
|
||||
, anchorIsAtEnd = True
|
||||
, anchorPos = pn
|
||||
, anchorIndex = PointIndex
|
||||
( curveIndex $ curveData lastCurve )
|
||||
PathPoint
|
||||
}
|
||||
-> Just anchor
|
||||
_ -> Nothing
|
||||
|
||||
addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
|
||||
addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = oldContent } ) =
|
||||
let
|
||||
strokes' =
|
||||
runIdentity $
|
||||
forStrokeHierarchy
|
||||
( layerMetadata documentMetadata )
|
||||
( strokeHierarchy oldContent )
|
||||
( \ u s _ -> Identity $ updateStroke u s )
|
||||
in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
|
||||
where
|
||||
|
||||
updateStroke :: Unique -> Stroke -> UpdateStroke
|
||||
updateStroke strokeUnique stroke
|
||||
| strokeUnique == anchorStroke anchor
|
||||
, let
|
||||
updateSpline
|
||||
:: forall clo brushData
|
||||
. SplineTypeI clo
|
||||
=> StrokeSpline clo brushData -> StrokeSpline clo brushData
|
||||
updateSpline prevSpline
|
||||
| SOpen <- ssplineType @clo
|
||||
= if anchorIsAtEnd anchor
|
||||
then
|
||||
let
|
||||
setBrushData :: PointData () -> PointData brushData
|
||||
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
|
||||
in prevSpline <> fmap setBrushData newSpline
|
||||
else
|
||||
let
|
||||
setBrushData :: PointData () -> PointData brushData
|
||||
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
|
||||
in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline
|
||||
| otherwise
|
||||
= assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
|
||||
prevSpline -- should never add to a closed spline
|
||||
= UpdateStrokeTo $ overStrokeSpline updateSpline stroke
|
||||
| otherwise
|
||||
= PreserveStroke
|
||||
|
||||
withAnchorBrushData
|
||||
:: forall r
|
||||
. DrawAnchor
|
||||
-> Document
|
||||
-> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
|
||||
. ( pointParams ~ Record pointFields
|
||||
, PointFields pointFields
|
||||
)
|
||||
=> Maybe ( NamedBrush brushFields )
|
||||
-> pointParams
|
||||
-> r
|
||||
)
|
||||
-> r
|
||||
withAnchorBrushData anchor ( Document { documentMetadata = Metadata { layerMetadata }, documentContent = Content { strokeHierarchy } } ) f =
|
||||
splineAnchor $ Except.runExcept $ forStrokeHierarchy layerMetadata strokeHierarchy relevantStroke
|
||||
where
|
||||
|
||||
relevantStroke :: Unique -> Stroke -> StrokeMetadata -> Except Stroke UpdateStroke
|
||||
relevantStroke strokeUnique stroke _
|
||||
| strokeUnique == anchorStroke anchor
|
||||
= Except.throwE stroke
|
||||
| otherwise
|
||||
= return PreserveStroke
|
||||
|
||||
splineAnchor :: Either Stroke other -> r
|
||||
splineAnchor ( Left ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) )
|
||||
| SOpen <- ssplineType @clo
|
||||
= if anchorIsAtEnd anchor
|
||||
then f strokeBrush ( brushParams ( splineEnd strokeSpline ) )
|
||||
else f strokeBrush ( brushParams ( splineStart strokeSpline ) )
|
||||
splineAnchor _
|
||||
= f @_ @'[] @'[] Nothing ( MkR ℝ0 )
|
107
src/metabrushes/MetaBrush/Guide.hs
Normal file
107
src/metabrushes/MetaBrush/Guide.hs
Normal file
|
@ -0,0 +1,107 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module MetaBrush.Guide where
|
||||
|
||||
-- base
|
||||
import Data.Semigroup
|
||||
( Arg(..), Min(..), ArgMin )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Torsor(..) )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- stm
|
||||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Reader
|
||||
( ReaderT, runReaderT )
|
||||
|
||||
-- brush-strokes
|
||||
import Math.Module
|
||||
( Inner((^.^))
|
||||
, squaredNorm
|
||||
)
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Document
|
||||
import MetaBrush.Hover
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, Unique, freshUnique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Guides.
|
||||
|
||||
data Ruler
|
||||
= RulerCorner
|
||||
| LeftRuler
|
||||
| TopRuler
|
||||
deriving stock Show
|
||||
|
||||
-- | Try to select a guide at the given document coordinates.
|
||||
selectedGuide :: ℝ 2 -> Zoom -> Map Unique Guide -> Maybe ( Unique, Guide )
|
||||
selectedGuide c zoom guides =
|
||||
\case { Min ( Arg _ g ) -> g } <$> Map.foldMapWithKey ( selectGuide_maybe c zoom ) guides
|
||||
|
||||
selectGuide_maybe :: ℝ 2 -> Zoom -> unique -> Guide -> Maybe ( ArgMin Double ( unique, Guide ) )
|
||||
selectGuide_maybe c ( Zoom { zoomFactor } ) u guide@( Guide { guidePoint = p, guideNormal = n } )
|
||||
| sqDist * zoomFactor ^ ( 2 :: Int ) < 4
|
||||
= Just ( Min ( Arg sqDist ( u, guide ) ) )
|
||||
| otherwise
|
||||
= Nothing
|
||||
where
|
||||
t :: Double
|
||||
t = ( c --> p ) ^.^ n
|
||||
sqDist :: Double
|
||||
sqDist = t ^ ( 2 :: Int ) / squaredNorm n
|
||||
|
||||
-- | Add new guide after a mouse drag from a ruler area.
|
||||
addGuide :: UniqueSupply -> Ruler -> ℝ 2 -> Document -> STM Document
|
||||
addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentMetadata" . field' @"documentGuides" ) insertNewGuides doc
|
||||
where
|
||||
insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
|
||||
insertNewGuides gs = case ruler of
|
||||
RulerCorner
|
||||
-> do
|
||||
uniq1 <- freshUnique
|
||||
uniq2 <- freshUnique
|
||||
let
|
||||
guide1, guide2 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = V2 0 1 }
|
||||
guide2 = Guide { guidePoint = p, guideNormal = V2 1 0 }
|
||||
pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
|
||||
TopRuler
|
||||
-> do
|
||||
uniq1 <- freshUnique
|
||||
let
|
||||
guide1 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = V2 0 1 }
|
||||
pure ( Map.insert uniq1 guide1 gs )
|
||||
LeftRuler
|
||||
-> do
|
||||
uniq2 <- freshUnique
|
||||
let
|
||||
guide2 :: Guide
|
||||
guide2 = Guide { guidePoint = p, guideNormal = V2 1 0 }
|
||||
pure ( Map.insert uniq2 guide2 gs )
|
||||
|
||||
instance Hoverable Guide where
|
||||
hovered ( MouseHover c ) zoom guide
|
||||
| Just {} <- selectGuide_maybe c zoom () guide
|
||||
= True
|
||||
| otherwise
|
||||
= False
|
||||
hovered ( RectangleHover {} ) _ _
|
||||
= False
|
82
src/metabrushes/MetaBrush/Hover.hs
Normal file
82
src/metabrushes/MetaBrush/Hover.hs
Normal file
|
@ -0,0 +1,82 @@
|
|||
module MetaBrush.Hover where
|
||||
|
||||
-- base
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act(..) )
|
||||
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..) )
|
||||
|
||||
-- brush-strokes
|
||||
import Math.Module
|
||||
( quadrance
|
||||
, closestPointOnSegment
|
||||
)
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..), Segment(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Document
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | An axis-aligned bounding box.
|
||||
data AABB
|
||||
= AABB
|
||||
{ topLeft, botRight :: !( ℝ 2 ) }
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Create an 'AABB'.
|
||||
mkAABB :: ℝ 2 -> ℝ 2 -> AABB
|
||||
mkAABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) = AABB ( ℝ2 xmin ymin ) ( ℝ2 xmax ymax )
|
||||
where
|
||||
( xmin, xmax )
|
||||
| x1 > x2 = ( x2, x1 )
|
||||
| otherwise = ( x1, x2 )
|
||||
( ymin, ymax )
|
||||
| y1 > y2 = ( y2, y1 )
|
||||
| otherwise = ( y1, y2 )
|
||||
|
||||
-- | A hover (mouse cursor or entire rectangle).
|
||||
data HoverContext
|
||||
= MouseHover !( ℝ 2 )
|
||||
| RectangleHover !AABB
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Act ( T ( ℝ 2 ) ) HoverContext where
|
||||
v • MouseHover p = MouseHover ( v • p )
|
||||
v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )
|
||||
|
||||
instance Act ( T ( ℝ 2 ) ) ( Maybe HoverContext ) where
|
||||
(•) v = fmap ( v • )
|
||||
|
||||
class Hoverable a where
|
||||
hovered :: HoverContext -> Zoom -> a -> Bool
|
||||
|
||||
instance Hoverable ( ℝ 2 ) where
|
||||
hovered ( MouseHover p ) zoom q
|
||||
= inPointClickRange zoom p q
|
||||
hovered ( RectangleHover ( AABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ) ) _ ( ℝ2 x y )
|
||||
= x >= x1 && x <= x2 && y >= y1 && y <= y2
|
||||
|
||||
instance Hoverable ( Segment ( ℝ 2 ) ) where
|
||||
hovered ( MouseHover p ) zoom seg
|
||||
= hovered ( MouseHover p ) zoom p'
|
||||
where
|
||||
( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg
|
||||
hovered hov@(RectangleHover {} ) zoom ( Segment p0 p1 )
|
||||
-- Only consider a segment to be "hovered" if it lies entirely within the
|
||||
-- hover rectangle, not just if the hover rectangle intersects it.
|
||||
= hovered hov zoom p0 && hovered hov zoom p1
|
||||
|
||||
inPointClickRange :: Zoom -> ℝ 2 -> ℝ 2 -> Bool
|
||||
inPointClickRange ( Zoom { zoomFactor } ) c p =
|
||||
quadrance @( T ( ℝ 2 ) ) c p < 16 / ( zoomFactor * zoomFactor )
|
88
src/metabrushes/MetaBrush/Layer.hs
Normal file
88
src/metabrushes/MetaBrush/Layer.hs
Normal file
|
@ -0,0 +1,88 @@
|
|||
module MetaBrush.Layer where
|
||||
|
||||
-- base
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
( Generically(..), Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Set
|
||||
( Set )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..) )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A layer: either a stroke or a group.
|
||||
data Layer
|
||||
= StrokeLayer { layerUnique :: !Unique }
|
||||
| GroupLayer { layerUnique :: !Unique }
|
||||
deriving stock ( Show, Eq, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Metadata about layers, e.g. their names and their visibilities.
|
||||
data LayerMetadata =
|
||||
LayerMetadata
|
||||
{ layerNames :: !( Map Unique Text )
|
||||
, invisibleLayers :: !( Set Unique )
|
||||
, lockedLayers :: !( Set Unique )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
deriving ( Semigroup, Monoid )
|
||||
via Generically LayerMetadata
|
||||
|
||||
-- | A parent of a layer.
|
||||
data Parent a
|
||||
-- | The layer is at the top level.
|
||||
= Root
|
||||
-- | The layer has this parent.
|
||||
| Parent !a
|
||||
deriving stock ( Show, Eq, Ord, Functor, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | An item within a parent.
|
||||
data WithinParent a =
|
||||
WithinParent
|
||||
{ parent :: !( Parent Unique )
|
||||
, item :: !a
|
||||
}
|
||||
deriving stock ( Show, Eq, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | A child layer within a parent.
|
||||
type ChildLayer = WithinParent Unique
|
||||
-- | A child layer, with its index among the list of children of its parent.
|
||||
type ChildLayerPosition = WithinParent Word32
|
||||
|
||||
-- | Content in a hierarchical tree-like structure.
|
||||
data Hierarchy a =
|
||||
Hierarchy
|
||||
{ topLevel :: ![ Unique ]
|
||||
, groups :: !( Map Unique [ Unique ] )
|
||||
, content :: !( Map Unique a )
|
||||
}
|
||||
deriving stock ( Show, Eq, Functor, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
emptyHierarchy :: Hierarchy a
|
||||
emptyHierarchy =
|
||||
Hierarchy
|
||||
{ topLevel = []
|
||||
, groups = Map.empty
|
||||
, content = Map.empty
|
||||
}
|
|
@ -5,7 +5,6 @@
|
|||
module MetaBrush.Serialisable
|
||||
( Serialisable(..)
|
||||
, encodeSequence, decodeSequence
|
||||
, encodeUniqueMap, decodeUniqueMap
|
||||
, encodeCurve, decodeCurve
|
||||
, encodeCurves, decodeCurves
|
||||
, encodeSpline, decodeSpline
|
||||
|
@ -13,10 +12,7 @@ module MetaBrush.Serialisable
|
|||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( (&&&) )
|
||||
import Control.Monad.ST
|
||||
( RealWorld, stToIO )
|
||||
|
||||
import Data.Foldable
|
||||
( toList )
|
||||
import Data.Functor
|
||||
|
@ -25,29 +21,17 @@ import Data.Functor.Contravariant
|
|||
( contramap )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.STRef
|
||||
( newSTRef )
|
||||
import Data.IORef
|
||||
( newIORef, atomicModifyIORef' )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( elems, fromList )
|
||||
import Data.Sequence
|
||||
( Seq )
|
||||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
|
||||
-- scientific
|
||||
import qualified Data.Scientific as Scientific
|
||||
( fromFloatDigits, toRealFloat )
|
||||
|
@ -66,26 +50,20 @@ import Control.Monad.Trans.Class
|
|||
import qualified Waargonaut.Decode as JSON
|
||||
( Decoder )
|
||||
import qualified Waargonaut.Decode as JSON.Decoder
|
||||
( atKey, atKeyOptional, list, scientific, text )
|
||||
import qualified Waargonaut.Encode as JSON
|
||||
( Encoder )
|
||||
import qualified Waargonaut.Encode as JSON.Encoder
|
||||
( atKey', keyValueTupleFoldable, list, mapLikeObj, scientific, text, either )
|
||||
|
||||
-- meta-brushes
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplineType(..), SSplineType(..), SplineTypeI(..)
|
||||
, Curves(..), Curve(..), NextPoint(..)
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..) )
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..)
|
||||
, Fin(..), Representable(tabulate, index)
|
||||
)
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -101,13 +79,15 @@ instance Serialisable ( ℝ 2 ) where
|
|||
encoder = JSON.Encoder.mapLikeObj \ ( ℝ2 x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = ℝ2 <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
decoder = ℝ2 <$> JSON.Decoder.atKey "x" decoder
|
||||
<*> JSON.Decoder.atKey "y" decoder
|
||||
instance Serialisable ( T ( ℝ 2 ) ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( V2 x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = V2 <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
decoder = V2 <$> JSON.Decoder.atKey "x" decoder
|
||||
<*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) )
|
||||
=> Serialisable ( Record ks ) where
|
||||
encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) )
|
||||
|
@ -131,16 +111,6 @@ encodeSequence enc = contramap toList ( JSON.Encoder.list enc )
|
|||
decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a )
|
||||
decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
|
||||
|
||||
|
||||
|
||||
encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
|
||||
encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
|
||||
|
||||
decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
|
||||
decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
|
||||
|
||||
|
||||
|
||||
{-
|
||||
encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
|
||||
encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
|
||||
|
@ -202,36 +172,35 @@ encodeCurve encodePtData = case ssplineType @clo of
|
|||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
|
||||
decodeCurve
|
||||
:: forall clo ptData m
|
||||
:: forall clo ptData crvData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeCurve decodePtData = do
|
||||
noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
|
||||
-> JSON.Decoder m crvData
|
||||
-> JSON.Decoder m ( Curve clo crvData ptData )
|
||||
decodeCurve decodePtData decodeCrvData = do
|
||||
crv <- decodeCrvData
|
||||
case ssplineType @clo of
|
||||
SOpen -> do
|
||||
p1 <- JSON.Decoder.atKey "p1" decodePtData
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing ->
|
||||
pure ( LineTo ( NextPoint p1 ) noCache )
|
||||
pure ( LineTo ( NextPoint p1 ) crv)
|
||||
Just p2 -> do
|
||||
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
|
||||
case mb_p3 of
|
||||
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) noCache )
|
||||
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
|
||||
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) crv )
|
||||
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) crv )
|
||||
SClosed -> do
|
||||
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
|
||||
case mb_p1 of
|
||||
Nothing ->
|
||||
pure ( LineTo BackToStart noCache )
|
||||
pure ( LineTo BackToStart crv )
|
||||
Just p1 -> do
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing -> pure ( Bezier2To p1 BackToStart noCache )
|
||||
Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
|
||||
|
||||
|
||||
Nothing -> pure ( Bezier2To p1 BackToStart crv )
|
||||
Just p2 -> pure ( Bezier3To p1 p2 BackToStart crv )
|
||||
|
||||
encodeCurves
|
||||
:: forall clo crvData ptData f
|
||||
|
@ -250,19 +219,20 @@ encodeCurves encodePtData = case ssplineType @clo of
|
|||
. JSON.Encoder.atKey' "lastClosedCurve" ( encodeCurve @Closed encodePtData ) closedCurve
|
||||
|
||||
decodeCurves
|
||||
:: forall clo ptData m
|
||||
:: forall clo ptData crvData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curves clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeCurves decodePtData = case ssplineType @clo of
|
||||
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
|
||||
-> JSON.Decoder m crvData
|
||||
-> JSON.Decoder m ( Curves clo crvData ptData )
|
||||
decodeCurves decodePtData decodeCrvData = case ssplineType @clo of
|
||||
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData decodeCrvData )
|
||||
SClosed -> do
|
||||
mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
|
||||
case mbNoCurves of
|
||||
Just _ -> pure NoCurves
|
||||
Nothing -> do
|
||||
prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData )
|
||||
lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData )
|
||||
prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData decodeCrvData )
|
||||
lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData decodeCrvData )
|
||||
pure ( ClosedCurves prevCurves lastCurve )
|
||||
|
||||
|
||||
|
@ -277,11 +247,17 @@ encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, sp
|
|||
. JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
|
||||
|
||||
decodeSpline
|
||||
:: forall clo ptData m
|
||||
:: forall clo ptData crvData m
|
||||
. ( SplineTypeI clo, MonadIO m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
|
||||
decodeSpline decodePtData = do
|
||||
-> ( Integer -> m crvData )
|
||||
-> JSON.Decoder m ( Spline clo crvData ptData )
|
||||
decodeSpline decodePtData newCurve = do
|
||||
ref <- lift $ liftIO $ newIORef 0
|
||||
let newCrvData :: m crvData
|
||||
newCrvData = do
|
||||
i <- liftIO $ atomicModifyIORef' ref ( \ o -> ( o + 1, o ) )
|
||||
newCurve i
|
||||
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
|
||||
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
|
||||
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData ( lift newCrvData ) )
|
||||
pure ( Spline { splineStart, splineCurves } )
|
||||
|
|
366
src/metabrushes/MetaBrush/Stroke.hs
Normal file
366
src/metabrushes/MetaBrush/Stroke.hs
Normal file
|
@ -0,0 +1,366 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.Stroke where
|
||||
|
||||
-- base
|
||||
import Control.Monad.ST
|
||||
( RealWorld )
|
||||
import Data.Coerce
|
||||
( coerce )
|
||||
import Data.Foldable
|
||||
( foldr' )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Typeable
|
||||
( Typeable )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1 )
|
||||
import GHC.Stack
|
||||
( HasCallStack )
|
||||
import GHC.TypeLits
|
||||
( Symbol )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act(..), Torsor(..) )
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..), NFData1 )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group(..) )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( Lens'
|
||||
, view, over
|
||||
)
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.State.Strict
|
||||
( State )
|
||||
import qualified Control.Monad.State.Strict as State
|
||||
|
||||
-- brush-strokes
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), KnownSplineType
|
||||
, PointType(..)
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke )
|
||||
import Math.Module
|
||||
( Module
|
||||
( origin, (^+^), (^-^), (*^) )
|
||||
)
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Brush
|
||||
( NamedBrush, PointFields )
|
||||
import MetaBrush.Layer hiding ( Layer(..) )
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Data attached to each point on a spline.
|
||||
data PointData params
|
||||
= PointData
|
||||
{ pointCoords :: !( ℝ 2 )
|
||||
, brushParams :: !params
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
-- | Data attached to each curve in a spline.
|
||||
data CurveData =
|
||||
CurveData
|
||||
{ curveIndex :: !Rational
|
||||
, cachedStroke :: !( CachedStroke RealWorld )
|
||||
}
|
||||
deriving stock Generic
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Show CurveData where
|
||||
show ( CurveData { curveIndex } ) = show curveIndex
|
||||
instance Eq CurveData where
|
||||
( CurveData { curveIndex = i1 } ) == ( CurveData { curveIndex = i2 } )
|
||||
= i1 == i2
|
||||
instance Ord CurveData where
|
||||
compare ( CurveData { curveIndex = i1 } ) ( CurveData { curveIndex = i2 } )
|
||||
= compare i1 i2
|
||||
|
||||
-- | An index for a point on a spline.
|
||||
data PointIndex
|
||||
= FirstPoint
|
||||
| PointIndex
|
||||
-- | Which curve the point belongs to.
|
||||
{ pointCurve :: !Rational
|
||||
-- | Index within a curve.
|
||||
, pointType :: !PointType
|
||||
}
|
||||
deriving stock ( Show, Eq, Ord, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
_coords :: Lens' ( PointData brushParams ) ( ℝ 2 )
|
||||
_coords = field' @"pointCoords"
|
||||
|
||||
coords :: PointData brushParams -> ℝ 2
|
||||
coords = view _coords
|
||||
|
||||
type StrokeSpline clo brushParams =
|
||||
Spline clo CurveData ( PointData brushParams )
|
||||
|
||||
data Stroke where
|
||||
Stroke
|
||||
:: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
|
||||
. ( KnownSplineType clo
|
||||
, pointParams ~ Record pointFields
|
||||
, PointFields pointFields, Typeable pointFields
|
||||
)
|
||||
=>
|
||||
{ strokeBrush :: !( Maybe ( NamedBrush brushFields ) )
|
||||
, strokeSpline :: !( StrokeSpline clo pointParams )
|
||||
}
|
||||
-> Stroke
|
||||
deriving stock instance Show Stroke
|
||||
instance NFData Stroke where
|
||||
rnf ( Stroke { strokeBrush, strokeSpline } )
|
||||
= rnf strokeBrush `seq` rnf strokeSpline
|
||||
|
||||
_strokeSpline
|
||||
:: forall f
|
||||
. Functor f
|
||||
=> ( forall clo pointParams ( pointFields :: [ Symbol ] )
|
||||
. ( KnownSplineType clo
|
||||
, pointParams ~ Record pointFields
|
||||
, PointFields pointFields
|
||||
)
|
||||
=> StrokeSpline clo pointParams
|
||||
-> f ( StrokeSpline clo pointParams )
|
||||
)
|
||||
-> Stroke -> f Stroke
|
||||
_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
|
||||
= ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline
|
||||
|
||||
overStrokeSpline
|
||||
:: ( forall clo pointParams ( pointFields :: [ Symbol ] )
|
||||
. ( KnownSplineType clo
|
||||
, pointParams ~ Record pointFields
|
||||
, PointFields pointFields
|
||||
)
|
||||
=> StrokeSpline clo pointParams
|
||||
-> StrokeSpline clo pointParams
|
||||
)
|
||||
-> Stroke -> Stroke
|
||||
overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
|
||||
|
||||
instance Act ( T ( ℝ 2 ) ) ( PointData params ) where
|
||||
v • ( dat@( PointData { pointCoords = p } ) ) =
|
||||
dat { pointCoords = v • p }
|
||||
|
||||
data DiffPointData diffBrushParams
|
||||
= DiffPointData
|
||||
{ diffVector :: !( T ( ℝ 2 ) )
|
||||
, diffParams :: !diffBrushParams
|
||||
}
|
||||
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving anyclass ( NFData, NFData1 )
|
||||
|
||||
instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where
|
||||
DiffPointData v1 p1 <> DiffPointData v2 p2 =
|
||||
DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 )
|
||||
instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where
|
||||
mempty = DiffPointData mempty origin
|
||||
instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where
|
||||
invert ( DiffPointData v1 p1 ) =
|
||||
DiffPointData ( invert v1 ) ( -1 *^ p1 )
|
||||
|
||||
instance ( Module Double diffBrushParams, Act diffBrushParams brushParams )
|
||||
=> Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
|
||||
(•) ( DiffPointData { diffVector = dp, diffParams = db } )
|
||||
= over _coords ( dp • )
|
||||
. over ( field' @"brushParams" ) ( db • )
|
||||
instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams )
|
||||
=> Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
|
||||
( PointData
|
||||
{ pointCoords = p1
|
||||
, brushParams = b1
|
||||
} ) <--
|
||||
( PointData
|
||||
{ pointCoords = p2
|
||||
, brushParams = b2 } ) =
|
||||
DiffPointData
|
||||
{ diffVector = p1 <-- p2
|
||||
, diffParams = b1 <-- b2
|
||||
}
|
||||
|
||||
instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where
|
||||
origin = mempty
|
||||
(^+^) = (<>)
|
||||
x ^-^ y = x <> invert y
|
||||
d *^ DiffPointData v1 p1 =
|
||||
DiffPointData ( d *^ v1 ) ( d *^ p1 )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Metadata about a stroke, such as its name or its visibility.
|
||||
data StrokeMetadata
|
||||
= StrokeMetadata
|
||||
{ strokeName :: !Text
|
||||
, strokeVisible :: !Bool
|
||||
, strokeLocked :: !Bool
|
||||
}
|
||||
|
||||
type StrokeHierarchy = Hierarchy Stroke
|
||||
|
||||
data UpdateStroke
|
||||
= PreserveStroke
|
||||
| DeleteStroke
|
||||
| UpdateStrokeTo !Stroke
|
||||
deriving stock Show
|
||||
|
||||
-- | Traverse through a stroke hierarchy.
|
||||
forStrokeHierarchy
|
||||
:: forall f
|
||||
. ( HasCallStack, Applicative f )
|
||||
=> LayerMetadata
|
||||
-> StrokeHierarchy
|
||||
-> ( Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
|
||||
-> f StrokeHierarchy
|
||||
forStrokeHierarchy
|
||||
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f =
|
||||
foldr' ( g Nothing ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
|
||||
where
|
||||
|
||||
insertMaybe :: Maybe Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
|
||||
insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
|
||||
PreserveStroke -> old
|
||||
UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
|
||||
DeleteStroke ->
|
||||
let newStrokes = Map.delete u oldStrokes
|
||||
in case mbPar of
|
||||
Nothing ->
|
||||
Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
|
||||
Just par ->
|
||||
Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes
|
||||
|
||||
|
||||
g :: Maybe Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
|
||||
g par ( vis, lock ) u acc =
|
||||
let vis' = vis && not ( u `Set.member` invisibleLayers )
|
||||
lock' = lock || u `Set.member` lockedLayers
|
||||
in
|
||||
case Map.lookup u ( groups hierarchy0 ) of
|
||||
Nothing ->
|
||||
let
|
||||
meta =
|
||||
StrokeMetadata
|
||||
{ strokeName = layerNames Map.! u
|
||||
, strokeVisible = vis'
|
||||
, strokeLocked = lock'
|
||||
}
|
||||
in
|
||||
insertMaybe par u <$> acc <*> f u ( content hierarchy0 Map.! u ) meta
|
||||
Just ds ->
|
||||
foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Recursive representation of a stroke hierarchy.
|
||||
--
|
||||
-- Used for serialisation/deserialisation only.
|
||||
type Layers = [ Layer ]
|
||||
|
||||
-- | Layer in a recursive representation of a stroke hierarchy.
|
||||
--
|
||||
-- Used for serialisation/deserialisation only.
|
||||
data Layer
|
||||
= StrokeLayer
|
||||
{ layerUnique :: !Unique
|
||||
, layerName :: !Text
|
||||
, layerVisible :: !Bool
|
||||
, layerLocked :: !Bool
|
||||
, layerStroke :: !Stroke
|
||||
}
|
||||
| GroupLayer
|
||||
{ layerUnique :: !Unique
|
||||
, layerName :: !Text
|
||||
, layerVisible :: !Bool
|
||||
, layerLocked :: !Bool
|
||||
, groupChildren :: !Layers
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
strokeHierarchyLayers :: LayerMetadata -> StrokeHierarchy -> Layers
|
||||
strokeHierarchyLayers
|
||||
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
|
||||
( Hierarchy topLevel hierarchy content ) = map go topLevel
|
||||
where
|
||||
go :: Unique -> Layer
|
||||
go layerUnique =
|
||||
let
|
||||
layerName = layerNames Map.! layerUnique
|
||||
layerVisible = not $ layerUnique `Set.member` invisibleLayers
|
||||
layerLocked = layerUnique `Set.member` lockedLayers
|
||||
in
|
||||
case Map.lookup layerUnique hierarchy of
|
||||
Nothing ->
|
||||
StrokeLayer
|
||||
{ layerUnique, layerName, layerVisible, layerLocked
|
||||
, layerStroke = content Map.! layerUnique
|
||||
}
|
||||
Just cs ->
|
||||
GroupLayer
|
||||
{ layerUnique, layerName, layerVisible, layerLocked
|
||||
, groupChildren = map go cs
|
||||
}
|
||||
|
||||
layersStrokeHierarchy :: Layers -> ( LayerMetadata, StrokeHierarchy )
|
||||
layersStrokeHierarchy lays = ( `State.execState` ( mempty, emptyHierarchy ) ) $ do
|
||||
us <- traverse go lays
|
||||
State.modify' ( \ ( meta, hierarchy ) -> ( meta, hierarchy { topLevel = us } ) )
|
||||
where
|
||||
go :: Layer -> State ( LayerMetadata, StrokeHierarchy ) Unique
|
||||
go l = do
|
||||
( LayerMetadata { layerNames = nms, invisibleLayers = invis, lockedLayers = locked }
|
||||
, oldHierarchy@( Hierarchy _topLevel oldGroups oldStrokes )
|
||||
) <- State.get
|
||||
let u = layerUnique l
|
||||
newMeta =
|
||||
LayerMetadata
|
||||
{ layerNames = Map.insert u ( layerName l ) nms
|
||||
, invisibleLayers = if layerVisible l then invis else Set.insert u invis
|
||||
, lockedLayers = if layerLocked l then Set.insert u locked else locked
|
||||
}
|
||||
newHierarchy <-
|
||||
case l of
|
||||
StrokeLayer { layerStroke } ->
|
||||
return $
|
||||
oldHierarchy
|
||||
{ content = Map.insert u layerStroke oldStrokes }
|
||||
GroupLayer { groupChildren } -> do
|
||||
us <- traverse go groupChildren
|
||||
return $
|
||||
oldHierarchy { groups = Map.insert u us oldGroups }
|
||||
State.put ( newMeta, newHierarchy )
|
||||
return u
|
||||
|
||||
--------------------------------------------------------------------------------
|
|
@ -1,19 +1,8 @@
|
|||
module MetaBrush.Util
|
||||
( traverseMaybe
|
||||
, Exists(..)
|
||||
( Exists(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
traverseMaybe :: Applicative f => ( a -> f ( Maybe b ) ) -> Seq a -> f ( Seq b )
|
||||
traverseMaybe _ Empty = pure Empty
|
||||
traverseMaybe f ( a :<| as ) = ( \ case { Nothing -> id; Just b -> ( b :<| ) } ) <$> f a <*> traverseMaybe f as
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Exists c where
|
||||
|
|
Loading…
Reference in a new issue