Refactors in preparation for stroke hierarchy

This commit is contained in:
sheaf 2024-09-27 17:21:24 +02:00
parent 8b3705b8d1
commit 0eb0724dde
42 changed files with 3256 additions and 2734 deletions

View file

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

View file

@ -56,6 +56,8 @@ main = withCP65001 do
when (isNothing mbGdkScale) $
setEnv "GDK_SCALE" "2"
setEnv "GSK_RENDERER" "cairo"
---------------------------------------------------------
-- Run GTK application

View file

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

View file

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

View file

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

View file

@ -72,7 +72,7 @@ import Math.Linear
import MetaBrush.DSL.Interpolation
( Interpolatable(Diff) )
import MetaBrush.Document
( PointData(..), FocusState(Normal) )
( PointData(..) )
--------------------------------------------------------------------------------

View file

@ -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"

View file

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

View file

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

View file

@ -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(..) )

View file

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

View file

@ -1,4 +1,4 @@
module MetaBrush.Context
module MetaBrush.Application.Context
( UIElements, Variables
, Modifier(..), LR(..) )
where

View file

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

View file

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

View file

@ -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(..) )

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -17,7 +17,7 @@ import qualified GI.Gtk as GTK
-- MetaBrush
import MetaBrush.GTK.Util
( widgetAddClass, widgetAddClasses )
import MetaBrush.Document
import MetaBrush.Guide
( Ruler(..) )
--------------------------------------------------------------------------------

File diff suppressed because it is too large Load diff

View file

@ -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"

View file

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

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

View file

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

View file

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

View file

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

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

View 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

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

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

View file

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

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

View file

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