diff --git a/MetaBrush.cabal b/MetaBrush.cabal index f1d355b..c9c5d0f 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 19c43fe..bc88f12 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -56,6 +56,8 @@ main = withCP65001 do when (isNothing mbGdkScale) $ setEnv "GDK_SCALE" "2" + setEnv "GSK_RENDERER" "cairo" + --------------------------------------------------------- -- Run GTK application diff --git a/brush-strokes/brush-strokes.cabal b/brush-strokes/brush-strokes.cabal index 734724b..c840d78 100644 --- a/brush-strokes/brush-strokes.cabal +++ b/brush-strokes/brush-strokes.cabal @@ -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 diff --git a/brush-strokes/src/cusps/inspect/Math/Interval/Abstract.hs b/brush-strokes/src/cusps/inspect/Math/Interval/Abstract.hs index 4be86c6..bfb2464 100644 --- a/brush-strokes/src/cusps/inspect/Math/Interval/Abstract.hs +++ b/brush-strokes/src/cusps/inspect/Math/Interval/Abstract.hs @@ -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 diff --git a/brush-strokes/src/lib/Math/Bezier/Spline.hs b/brush-strokes/src/lib/Math/Bezier/Spline.hs index d2dee7d..331aa61 100644 --- a/brush-strokes/src/lib/Math/Bezier/Spline.hs +++ b/brush-strokes/src/lib/Math/Bezier/Spline.hs @@ -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) diff --git a/brush-strokes/src/metafont/MetaBrush/MetaFont/Convert.hs b/brush-strokes/src/metafont/MetaBrush/MetaFont/Convert.hs index c4ce757..ea0a050 100644 --- a/brush-strokes/src/metafont/MetaBrush/MetaFont/Convert.hs +++ b/brush-strokes/src/metafont/MetaBrush/MetaFont/Convert.hs @@ -72,7 +72,7 @@ import Math.Linear import MetaBrush.DSL.Interpolation ( Interpolatable(Diff) ) import MetaBrush.Document - ( PointData(..), FocusState(Normal) ) + ( PointData(..) ) -------------------------------------------------------------------------------- diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index 2d2a538..0000000 --- a/hie.yaml +++ /dev/null @@ -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" diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index bf0dd97..cc82c8c 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Application/Action.hs similarity index 76% rename from src/app/MetaBrush/Action.hs rename to src/app/MetaBrush/Application/Action.hs index 52b644b..51c6243 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -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 -- diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Application/Action.hs-boot similarity index 96% rename from src/app/MetaBrush/Action.hs-boot rename to src/app/MetaBrush/Application/Action.hs-boot index 23922a7..7c973cd 100644 --- a/src/app/MetaBrush/Action.hs-boot +++ b/src/app/MetaBrush/Application/Action.hs-boot @@ -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(..) ) diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Application/Context.hs similarity index 63% rename from src/app/MetaBrush/Context.hs rename to src/app/MetaBrush/Application/Context.hs index c506676..1f344ee 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Application/Context.hs @@ -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 diff --git a/src/app/MetaBrush/Context.hs-boot b/src/app/MetaBrush/Application/Context.hs-boot similarity index 87% rename from src/app/MetaBrush/Context.hs-boot rename to src/app/MetaBrush/Application/Context.hs-boot index c3a2481..4f321b8 100644 --- a/src/app/MetaBrush/Context.hs-boot +++ b/src/app/MetaBrush/Application/Context.hs-boot @@ -1,4 +1,4 @@ -module MetaBrush.Context +module MetaBrush.Application.Context ( UIElements, Variables , Modifier(..), LR(..) ) where diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Application/UpdateDocument.hs similarity index 64% rename from src/app/MetaBrush/Document/Update.hs rename to src/app/MetaBrush/Application/UpdateDocument.hs index 0490b9b..1e9134a 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/src/app/MetaBrush/Application/UpdateDocument.hs @@ -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 () diff --git a/src/app/MetaBrush/Document/Update.hs-boot b/src/app/MetaBrush/Application/UpdateDocument.hs-boot similarity index 59% rename from src/app/MetaBrush/Document/Update.hs-boot rename to src/app/MetaBrush/Application/UpdateDocument.hs-boot index affc419..6425406 100644 --- a/src/app/MetaBrush/Document/Update.hs-boot +++ b/src/app/MetaBrush/Application/UpdateDocument.hs-boot @@ -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 + } diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs deleted file mode 100644 index 812b48c..0000000 --- a/src/app/MetaBrush/Document/Selection.hs +++ /dev/null @@ -1,1025 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module MetaBrush.Document.Selection - ( SelectionMode(..), selectionMode, pressingControl - , selectAt, selectRectangle - , DragMoveSelect(.., PointDrag), dragMoveSelect - , UpdateInfo(..) - , translateSelection, deleteSelected - , dragUpdate - , BrushWidgetActionState(..) - , applyBrushWidgetAction - ) - where - --- base -import Control.Monad - ( guard, unless ) -import Control.Monad.ST - ( RealWorld ) -import Data.Functor - ( ($>) ) -import Data.Functor.Identity - ( runIdentity ) -import Data.Maybe - ( catMaybes, isNothing, listToMaybe ) -import Data.Monoid - ( Sum(..) ) -import Data.Semigroup - ( Arg(..), Min(..) ) -import GHC.Exts - ( dataToTag#, (>#), (<#), isTrue# ) -import GHC.Generics - ( Generic, Generically(..) ) - --- acts -import Data.Act - ( Act((•)), Torsor((-->)) ) - --- containers -import Data.Sequence - ( Seq(..) ) -import Data.Set - ( Set ) -import qualified Data.Set as Set - ( insert ) - --- generic-lens -import Data.Generics.Product.Fields - ( field' ) - --- lens -import Control.Lens - ( view, set, over, mapped ) - --- tardis -import Control.Monad.Trans.Tardis - ( Tardis ) -import qualified Control.Monad.Trans.Tardis as Tardis - ( runTardisT, getPast, getFuture, sendPast, sendFuture ) - --- text -import Data.Text - ( Text ) -import qualified Data.Text as Text - ( intercalate, pack ) - --- transformers -import Control.Monad.Trans.Class - ( lift ) -import Control.Monad.Trans.Maybe - ( MaybeT(..) ) -import Control.Monad.Trans.State.Strict as State - ( StateT(..), State - , evalState, evalStateT, runState - , get, put, modify' - ) -import Control.Monad.Trans.Writer.CPS - ( WriterT, runWriterT, tell ) - --- MetaBrush -import qualified Math.Bezier.Cubic as Cubic - ( Bezier(..), bezier, closestPoint, fromQuadratic, drag ) -import qualified Math.Bezier.Quadratic as Quadratic - ( Bezier(..), closestPoint, interpolate ) -import Math.Bezier.Spline - ( Spline(..), SplineType(..), SSplineType(..), NextPoint(..) - , Curve(..), Curves(..), PointType(..) - , splitSplineAt - , SplineTypeI(ssplineType) - , CurrentStart(..), WitherResult(..) - , KnownSplineType - ( lastPoint, adjustSplineType, biwitherSpline, ibitraverseSpline, bitraverseSpline ) - , fromNextPoint - ) -import Math.Bezier.Stroke - ( CachedStroke(..), invalidateCache ) -import Math.Module - ( Module, lerp, squaredNorm, closestPointOnSegment ) -import Math.Linear - ( Segment(..), ℝ(..), T(..) ) - --- metabrush -import MetaBrush.Brush - ( NamedBrush(..), WithParams(defaultParams) ) -import qualified MetaBrush.Brush.Widget as Brush - ( Widget(..), WidgetAction(..), WidgetElements(..) - , WhatScale(..) - , widgetElements, widgetUpdate - ) -import {-# SOURCE #-} MetaBrush.Context - ( Modifier(..) ) -import MetaBrush.Document - ( Document(..), Stroke(..), StrokeHierarchy(..) - , PointData(..), DiffPointData - , FocusState(..), _selection - , StrokeSpline, _strokeSpline, overStrokeSpline - , _coords, coords - ) -import {-# SOURCE #-} MetaBrush.Document.Update - ( DocChange(..) ) -import MetaBrush.Records - ( Record(..) - , Intersection(..), intersect - ) -import MetaBrush.Unique - ( Unique ) -import MetaBrush.Util - ( traverseMaybe ) - --------------------------------------------------------------------------------- - -data SelectionMode - = New - | Add - | Subtract - deriving stock Show - -instance Semigroup SelectionMode where - Subtract <> _ = Subtract - New <> m = m - _ <> Subtract = Subtract - m <> New = m - Add <> Add = Add - -instance Monoid SelectionMode where - mempty = New - -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 - --- | Updates the selected objects on a single click selection event. -selectAt :: SelectionMode -> ℝ 2 -> Document -> Document -selectAt selMode c doc@( Document { zoomFactor } ) = - ( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc - where - - updateStrokeHierarchy :: StrokeHierarchy -> State Bool StrokeHierarchy - updateStrokeHierarchy ( StrokeGroup { .. } ) = do - newContents <- traverse updateStrokeHierarchy groupContents - pure ( StrokeGroup { groupContents = newContents, .. } ) - updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf - - updateStroke :: Stroke -> State Bool Stroke - updateStroke stroke@( Stroke { strokeVisible } ) = _strokeSpline updateSpline stroke - where - updateSpline - :: forall clo brushParams - . ( KnownSplineType clo ) - => StrokeSpline clo brushParams -> State Bool ( StrokeSpline clo brushParams ) - updateSpline oldSpline = - traverse - ( updateSplinePoint strokeVisible ) - oldSpline - - updateSplinePoint :: Bool -> PointData brushParams -> State Bool ( PointData brushParams ) - updateSplinePoint isVisible pt = do - anotherPointHasAlreadyBeenSelected <- get - if selected && not anotherPointHasAlreadyBeenSelected - then put True $> case selMode of - Subtract -> set _selection Normal pt - _ -> set _selection Selected pt - else pure $ case selMode of - New -> set _selection Normal pt - _ -> pt - where - selected :: Bool - selected - | not isVisible = False - | otherwise = squaredNorm ( c --> coords pt :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16 - --- | Type of a drag move selection: --- --- - user initiated drag by clicking on an unselected point: select this point and deselect the previous selection, --- - user initiated drag by clicking on an already selected point: selection is preserved; --- - user initiated drag by clicking on an interior point of a curve: start a curve drag, selection is preserved. -data DragMoveSelect - = ClickedOnSelected - | ClickedOnUnselected - | ClickedOnCurve - { dragStrokeUnique :: !Unique - , dragSegmentIndex :: !Int - , dragSegmentParameter :: !Double - } - deriving stock Show - -{-# COMPLETE PointDrag, ClickedOnCurve #-} -pattern PointDrag :: DragMoveSelect -pattern PointDrag <- ( ( \x -> isTrue# ( dataToTag# x <# 2# ) ) -> True ) - -instance Semigroup DragMoveSelect where - x <> y - | isTrue# ( dataToTag# x ># dataToTag# y ) - = y - | otherwise - = x - --- | Checks whether a mouse click can initiate a drag move event, --- and if so returns an updated document with the selection modified from the start of the drag move. -dragMoveSelect :: ℝ 2 -> Document -> Maybe ( DragMoveSelect, Document ) -dragMoveSelect c doc@( Document { zoomFactor } ) = - let - res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document - res = do - newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc - lift $ Tardis.getPast >>= Tardis.sendPast - pure newDoc - in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) . runWriterT $ res of - ( ( newDoc, Just dragMove ), _ ) - -> Just ( dragMove, newDoc ) - _ -> Nothing - - where - updateStrokeHierarchy :: StrokeHierarchy -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) StrokeHierarchy - updateStrokeHierarchy ( StrokeGroup { .. } ) = do - newContents <- traverse updateStrokeHierarchy groupContents - pure ( StrokeGroup { groupContents = newContents, .. } ) - updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf - - updateStroke :: Stroke -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Stroke - updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke - where - updateSpline - :: forall clo brushParams - . KnownSplineType clo - => StrokeSpline clo brushParams - -> WriterT ( Maybe DragMoveSelect ) - ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) - ( StrokeSpline clo brushParams ) - updateSpline oldSpline = - ibitraverseSpline - ( updateSplineCurve ( splineStart oldSpline ) strokeVisible strokeUnique ) - ( updateSplinePoint strokeVisible ) - oldSpline - - updateSplineCurve - :: forall clo' brushParams - . ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) - => PointData brushParams -> Bool -> Unique - -> Int -> PointData brushParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) - -> WriterT ( Maybe DragMoveSelect ) - ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) - ( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) ) - updateSplineCurve start isVisible uniq i sp0 curve = case curve of - line@( LineTo sp1 _ ) -> do - let - mbCurveDrag :: Maybe DragMoveSelect - mbCurveDrag = do - let - t :: Double - p :: ℝ 2 - ( t, p ) - = closestPointOnSegment @( T ( ℝ 2 ) ) c ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) ) - guard ( inSelectionRange isVisible p ) - pure $ - ClickedOnCurve - { dragStrokeUnique = uniq - , dragSegmentIndex = i - , dragSegmentParameter = t - } - tell mbCurveDrag - sp1' <- traverse ( updateSplinePoint isVisible ) sp1 - pure ( line { curveEnd = sp1' } ) - bez2@( Bezier2To sp1 sp2 _ ) -> do - let - mbCurveDrag :: Maybe DragMoveSelect - mbCurveDrag = do - let - bez :: Quadratic.Bezier ( ℝ 2 ) - bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 ) - sq_d :: Double - t :: Double - Min ( Arg sq_d (t, _) ) - = Quadratic.closestPoint @( T ( ℝ 2 ) ) bez c - guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) - pure $ - ClickedOnCurve - { dragStrokeUnique = uniq - , dragSegmentIndex = i - , dragSegmentParameter = t - } - tell mbCurveDrag - sp1' <- updateSplinePoint isVisible sp1 - sp2' <- traverse ( updateSplinePoint isVisible ) sp2 - pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } ) - bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do - let - mbCurveDrag :: Maybe DragMoveSelect - mbCurveDrag = do - let - bez :: Cubic.Bezier ( ℝ 2 ) - bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 ) - sq_d :: Double - t :: Double - Min ( Arg sq_d (t, _) ) - = Cubic.closestPoint @( T ( ℝ 2 ) ) bez c - guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) - pure $ - ClickedOnCurve - { dragStrokeUnique = uniq - , dragSegmentIndex = i - , dragSegmentParameter = t - } - tell mbCurveDrag - sp1' <- updateSplinePoint isVisible sp1 - sp2' <- updateSplinePoint isVisible sp2 - sp3' <- traverse ( updateSplinePoint isVisible ) sp3 - pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } ) - - inSelectionRange :: Bool -> ℝ 2 -> Bool - inSelectionRange isVisible p - | not isVisible = False - | otherwise = squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16 - - updateSplinePoint - :: Bool -> PointData brushParams - -> WriterT ( Maybe DragMoveSelect ) - ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) - ( PointData brushParams ) - updateSplinePoint strokeVisible pt - | inSelectionRange strokeVisible ( coords pt ) - = do - mbPreviousSelect <- lift Tardis.getPast - case mbPreviousSelect of - -- Already clicked on a point: don't select further points. - Just dragSelect - | ClickedOnSelected <- dragSelect - -> pure pt - | ClickedOnUnselected <- dragSelect - -> pure pt - -- First click on a point: record this. - _ -> do - let - mbDrag :: Maybe DragMoveSelect - mbDrag = case view _selection pt of - Selected -> Just ClickedOnSelected - _ -> Just ClickedOnUnselected - lift ( Tardis.sendFuture mbDrag ) - tell mbDrag - -- Select this point (whether it was previously selected or not). - pure ( set _selection Selected pt ) - | otherwise - = do - mbDragClick <- lift Tardis.getFuture - let - -- needs to be lazy - newPointState :: FocusState - newPointState = case mbDragClick of - -- User clicked on a selected point or a curve segment: preserve selection. - Just dragMove - | ClickedOnSelected <- dragMove - -> view _selection pt - | ClickedOnCurve {} <- dragMove - -> view _selection pt - -- User clicked on an unselected point, or not on a point at all: discard selection. - _ -> Normal - pure ( set _selection newPointState pt ) - --- | Updates the selected objects on a rectangular selection event. -selectRectangle :: SelectionMode -> ℝ 2 -> ℝ 2 -> Document -> Document -selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) - = over ( field' @"documentContent" . field' @"strokes" . mapped ) - updateStrokeHierarchy - where - xMin, xMax, yMin, yMax :: Double - ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 ) - ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 ) - - 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 { strokeVisible } ) = - overStrokeSpline - ( fmap ( updateSplinePoint strokeVisible ) ) - stroke - updateSplinePoint :: Bool -> PointData brushParams -> PointData brushParams - updateSplinePoint isVisible pt - | selected = case selMode of - Subtract -> set _selection Normal pt - _ -> set _selection Selected pt - | otherwise = case selMode of - New -> set _selection Normal pt - _ -> pt - where - x, y :: Double - ℝ2 x y = coords pt - selected :: Bool - selected - | not isVisible = False - | otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax - -data UpdateInfo - = UpdateInfo - { pathPointsAffected :: !( Sum Int ) - , controlPointsAffected :: !( Sum Int ) - , strokesAffected :: !( Set Unique ) - } - deriving stock ( Show, Generic ) - deriving ( Semigroup, Monoid ) - via Generically UpdateInfo - --- | Translate all selected points by the given vector. --- --- Returns the updated document, together with info about how many points were translated. -translateSelection :: T ( ℝ 2 ) -> Document -> ( Document, UpdateInfo ) -translateSelection t doc = - ( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc - where - - updateStrokeHierarchy :: StrokeHierarchy -> StateT Bool ( State UpdateInfo ) StrokeHierarchy - updateStrokeHierarchy ( StrokeGroup { .. } ) = do - newContents <- traverse updateStrokeHierarchy groupContents - pure ( StrokeGroup { groupContents = newContents, .. } ) - updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf - - updateStroke :: Stroke -> StateT Bool ( State UpdateInfo ) Stroke - updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke - where - updateSpline - :: forall clo brushParams - . KnownSplineType clo - => StrokeSpline clo brushParams - -> StateT Bool ( State UpdateInfo ) ( StrokeSpline clo brushParams ) - updateSpline oldSpline - | not strokeVisible - = pure oldSpline - | otherwise - = bitraverseSpline - ( const $ updateSplineCurve ( splineStart oldSpline ) ) - ( updatePoint PathPoint ) - oldSpline - where - updateSplineCurve - :: forall clo' - . SplineTypeI clo' - => PointData brushParams - -> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) - -> StateT Bool ( State UpdateInfo ) ( Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) ) - updateSplineCurve start crv = do - prevMod <- get - case crv of - LineTo p1 dat -> do - p1' <- traverse ( updatePoint PathPoint ) p1 - let - dat' :: CachedStroke RealWorld - dat' - | prevMod || ( view _selection ( fromNextPoint start p1 ) == Selected ) - = invalidateCache dat - | otherwise - = dat - pure $ LineTo p1' dat' - Bezier2To p1 p2 dat -> do - p1' <- updatePoint ControlPoint p1 - p2' <- traverse ( updatePoint PathPoint ) p2 - let - dat' :: CachedStroke RealWorld - dat' - | prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, fromNextPoint start p2 ] - = invalidateCache dat - | otherwise - = dat - pure $ Bezier2To p1' p2' dat' - Bezier3To p1 p2 p3 dat -> do - p1' <- updatePoint ControlPoint p1 - p2' <- updatePoint ControlPoint p2 - p3' <- traverse ( updatePoint PathPoint ) p3 - let - dat' :: CachedStroke RealWorld - dat' - | prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, p2, fromNextPoint start p3 ] - = invalidateCache dat - | otherwise - = dat - pure $ Bezier3To p1' p2' p3' dat' - - updatePoint :: PointType -> PointData brushParams -> StateT Bool ( State UpdateInfo ) ( PointData brushParams ) - updatePoint PathPoint pt - | Selected <- view _selection pt - = do - lift . modify' $ - ( over ( field' @"pathPointsAffected" ) (<>1) - . over ( field' @"strokesAffected" ) ( Set.insert strokeUnique ) - ) - put True $> over _coords ( t • ) pt - | otherwise - = put False $> pt - updatePoint ControlPoint pt - | Selected <- view _selection pt - = do - lift . modify' $ - ( over ( field' @"controlPointsAffected" ) (<>1) - . over ( field' @"strokesAffected" ) ( Set.insert strokeUnique ) - ) - pure $ over _coords ( t • ) pt - | otherwise - = pure pt - --- | Delete the selected points. --- --- Returns the updated document, together with info about how many points were deleted. -deleteSelected :: Document -> ( Document, UpdateInfo ) -deleteSelected doc = - ( `runState` mempty ) $ - ( field' @"documentContent" . field' @"strokes" ) - ( traverseMaybe updateStrokeHierarchy ) - doc - - where - - updateStrokeHierarchy :: StrokeHierarchy -> State UpdateInfo ( Maybe StrokeHierarchy ) - updateStrokeHierarchy ( StrokeGroup { .. } ) = do - newContents <- traverseMaybe updateStrokeHierarchy groupContents - pure ( Just $ StrokeGroup { groupContents = newContents, .. } ) - updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = fmap StrokeLeaf <$> updateStroke strokeLeaf - - updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke ) - updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke - where - updateSpline - :: forall clo brushParams - . KnownSplineType clo - => StrokeSpline clo brushParams - -> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams ) - updateSpline oldSpline - | not strokeVisible - = pure oldSpline - | otherwise - = MaybeT - $ biwitherSpline - ( updateSplineCurve strokeUnique ) - ( updateSplinePoint strokeUnique ) - oldSpline - where - - updateSplinePoint - :: Unique - -> PointData brushParams - -> State UpdateInfo - ( Maybe ( PointData brushParams ) ) - updateSplinePoint uniq pt - | Selected <- view _selection pt - = do - modify' - ( over ( field' @"pathPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure Nothing - | otherwise - = do - pure ( Just pt ) - - updateSplineCurve - :: forall clo' hasStart. SplineTypeI clo' - => Unique - -> CurrentStart hasStart ( PointData brushParams ) - -> Curve clo' ( CachedStroke RealWorld ) ( PointData brushParams ) - -> State UpdateInfo - ( WitherResult hasStart clo' ( CachedStroke RealWorld ) ( PointData brushParams ) ) - updateSplineCurve uniq mbPrevPt crv = case crv of - - LineTo p1 _ -> - case ssplineType @clo' of - SOpen - | NextPoint pt <- p1 - , Selected <- view _selection pt - -> do - modify' - ( over ( field' @"pathPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure Dismiss - | NextPoint pt <- p1 - , NoStartFound <- mbPrevPt - -> pure ( UseStartPoint pt Nothing ) -- no need to update "strokesAffected" - SClosed - | NoStartFound <- mbPrevPt - -> pure Dismiss - _ | CurrentStart _ <- mbPrevPt - -> pure ( UseCurve crv ) - - Bezier2To cp1 p2 dat -> - case ssplineType @clo' of - SOpen - | NextPoint pt <- p2 - , Selected <- view _selection pt - -> do - modify' - ( over ( field' @"pathPointsAffected" ) ( <> 1 ) - . over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure Dismiss - | NextPoint pt <- p2 - , NoStartFound <- mbPrevPt - -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( UseStartPoint pt Nothing ) - SClosed - | NoStartFound <- mbPrevPt - -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure Dismiss - _ | CurrentStart _ <- mbPrevPt - -> case view _selection cp1 of - Normal -> pure ( UseCurve crv ) - _ -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( UseCurve ( LineTo p2 ( invalidateCache dat ) ) ) - - Bezier3To cp1 cp2 p3 dat -> - case ssplineType @clo' of - SOpen - | NextPoint pt <- p3 - , Selected <- view _selection pt - -> do - modify' - ( over ( field' @"pathPointsAffected" ) ( <> 1 ) - . over ( field' @"controlPointsAffected" ) ( <> 2 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure Dismiss - | NextPoint pt <- p3 - , NoStartFound <- mbPrevPt - -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 2 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( UseStartPoint pt Nothing ) - SClosed - | NoStartFound <- mbPrevPt - -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 2 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure Dismiss - _ | CurrentStart _ <- mbPrevPt - -> case ( view _selection cp1, view _selection cp2 ) of - ( Normal, Normal ) -> - pure ( UseCurve crv ) - ( Normal, _ ) -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( UseCurve $ Bezier2To cp1 p3 ( invalidateCache dat ) ) - ( _, Normal ) -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 1 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( UseCurve $ Bezier2To cp2 p3 ( invalidateCache dat ) ) - _ -> do - modify' - ( over ( field' @"controlPointsAffected" ) ( <> 2 ) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - pure ( UseCurve $ LineTo p3 ( invalidateCache dat ) ) - - --- | Perform a drag move action on a document. -dragUpdate :: ℝ 2 -> ℝ 2 -> DragMoveSelect -> Bool -> Document -> Maybe DocChange -dragUpdate p0 p PointDrag _ doc = do - let - ( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc - case updateInfo of - UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected } - | null strokesAffected - -> Nothing - | 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" ) - changeText :: Text - changeText = - "Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] ) - <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes" - -> Just ( HistoryChange { newDocument, changeText } ) -dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc = - let - ( newDocument, mbStrokeName ) = - ( `runState` Nothing ) $ - ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc - in case mbStrokeName of - Just name -> do - let - changeText :: Text - changeText = "Drag curve segment of " <> name - Just ( HistoryChange { newDocument, changeText } ) - _ -> Nothing - 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 { strokeUnique, strokeName } ) - | strokeUnique /= dragStrokeUnique - = pure stroke - | otherwise - = _strokeSpline updateSpline stroke - where - updateSpline - :: forall clo pointParams - . ( KnownSplineType clo, Module Double ( T pointParams ), Torsor ( T pointParams ) pointParams ) - => StrokeSpline clo pointParams - -> State ( Maybe Text ) ( StrokeSpline clo pointParams ) - updateSpline - = fmap ( adjustSplineType @clo ) - . updateSplineCurves strokeName - . adjustSplineType @Open - - where - - updateSplineCurves - :: Text - -> StrokeSpline Open pointParams - -> State ( Maybe Text ) ( StrokeSpline Open pointParams ) - updateSplineCurves name spline = case splitSplineAt dragSegmentIndex spline of - ( _ , Spline { splineCurves = OpenCurves Empty } ) -> pure spline - ( bef, Spline { splineStart, splineCurves = OpenCurves ( curve :<| next ) } ) -> do - put ( Just name ) - let - curve' :: Curve Open ( CachedStroke RealWorld ) ( PointData pointParams ) - curve' = updateCurve ( lastPoint bef ) curve - pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ curve':<| next } ) - - where - updateCurve - :: PointData pointParams - -> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams ) - -> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams ) - updateCurve sp0 curve = case curve of - LineTo ( NextPoint sp1 ) dat -> do - let - bez2 :: Quadratic.Bezier ( PointData pointParams ) - bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( T pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1 - if alternateMode - then quadraticDragCurve dat bez2 - else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 ) - Bezier2To sp1 ( NextPoint sp2 ) dat -> do - let - bez2 :: Quadratic.Bezier ( PointData pointParams ) - bez2 = Quadratic.Bezier sp0 sp1 sp2 - if alternateMode - then cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 - else quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 ) - Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do - let - bez3 :: Cubic.Bezier ( PointData pointParams ) - bez3 = Cubic.Bezier sp0 sp1 sp2 sp3 - if alternateMode - then quadraticDragCurve dat - ( Quadratic.Bezier - sp0 - ( Cubic.bezier @( DiffPointData ( T pointParams ) ) bez3 dragSegmentParameter ) - sp3 - ) - else cubicDragCurve dat bez3 - where - quadraticDragCurve - :: CachedStroke RealWorld - -> Quadratic.Bezier ( PointData pointParams ) - -> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams ) - quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) = - let - cp :: ℝ 2 - Quadratic.Bezier { Quadratic.p1 = cp } = - Quadratic.interpolate @( T ( ℝ 2 ) ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p - in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat ) - cubicDragCurve - :: CachedStroke RealWorld - -> Cubic.Bezier ( PointData pointParams ) - -> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams ) - cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) = - let - cp1, cp2 :: ℝ 2 - Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } = - Cubic.drag @( T ( ℝ 2 ) ) - ( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) ) - dragSegmentParameter - p - in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat ) - - --------------------------------------------------------------------------------- --- Brush widget - -data BrushWidgetActionState - = BrushWidgetActionState - { brushWidgetAction :: !Brush.WidgetAction - , brushWidgetStrokeUnique :: !Unique - , brushWidgetCurveIndex :: !Int - , brushWidgetPointIndex :: !Int - , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) ) - } - deriving stock ( Eq, Show ) -instance Semigroup BrushWidgetActionState where - a <> b - | a == b - = a - | otherwise - = error "internal error: trying to combine incompatible brush widget action states" - --- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point. -applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( BrushWidgetActionState, Document ) -applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } ) = - let - res :: State ( Maybe BrushWidgetActionState ) Document - res = ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc - in case ( `runState` Nothing ) res of - ( newDoc, Just brushWidgetAction ) - -> Just ( brushWidgetAction, newDoc ) - _ -> Nothing - - where - updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe BrushWidgetActionState ) StrokeHierarchy - updateStrokeHierarchy ( StrokeGroup { .. } ) = do - newContents <- traverse updateStrokeHierarchy groupContents - pure ( StrokeGroup { groupContents = newContents, .. } ) - updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf - - updateStroke :: Stroke -> State ( Maybe BrushWidgetActionState ) Stroke - updateStroke stroke@( Stroke { strokeVisible, strokeUnique, strokeBrush, strokeSpline = ( spline0 :: StrokeSpline _clo ( Record pointFields ) ) } ) = - case strokeBrush of - -- Don't touch strokes without brushes. - Nothing -> pure stroke - Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) - | -- Don't touch invisible strokes - not strokeVisible - -- If we have already started a widget action, only continue an action - -- for the stroke with the correct unique. - || case mbPrevAction of { Just act -> brushWidgetStrokeUnique act /= strokeUnique ; Nothing -> False } - -> pure stroke - | otherwise - -> case intersect @pointFields @brushFields of - Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do - let embedUsedParams = updateBrushParams ( MkR $ defaultParams $ brushFunction brush ) - toBrushParams = embedUsedParams . ptParamsToUsedParams - updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' ) - spline' <- updateSpline brush toBrushParams updatePointParams strokeUnique spline0 - pure $ stroke { strokeSpline = spline' } - where - updateSpline - :: forall clo pointParams brushFields - . ( KnownSplineType clo ) - => NamedBrush brushFields - -> ( pointParams -> Record brushFields ) - -> ( Record brushFields -> pointParams -> pointParams ) - -> Unique - -> StrokeSpline clo pointParams - -> State ( Maybe BrushWidgetActionState ) ( StrokeSpline clo pointParams ) - updateSpline brush toBrushParams updatePointParams uniq oldSpline = - ibitraverseSpline - ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams uniq ) - ( updateSplinePoint brush toBrushParams updatePointParams uniq 0 0 ) - oldSpline - - updateSplineCurve - :: forall clo' pointParams brushFields - . ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) - => PointData pointParams - -> NamedBrush brushFields - -> ( pointParams -> Record brushFields ) - -> ( Record brushFields -> pointParams -> pointParams ) - -> Unique -> Int - -> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) - -> State ( Maybe BrushWidgetActionState ) - ( Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) ) - updateSplineCurve _start brush toBrushParams updatePointParams uniq i _sp0 curve - -- If we have already started a widget action, only continue an action - -- at the point with the correct index in the stroke. - | case mbPrevAction of - Just act -> - case ssplineType @clo' of - SClosed -> brushWidgetCurveIndex act /= i && brushWidgetCurveIndex act /= 0 - SOpen -> brushWidgetCurveIndex act /= i - Nothing -> False - = case mbPrevAction of - Just act - | abs ( i - brushWidgetCurveIndex act ) <= 1 - -> pure $ curve { curveData = invalidateCache $ curveData curve } - _ -> pure curve - | otherwise - , let i' :: Int - j' :: Int -> Int - ( i', j' ) = case ssplineType @clo' of { SClosed -> ( 0, const 0 ) ; SOpen -> ( i, id ) } - = case curve of - line@( LineTo sp1 dat ) -> do - sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i' ( j' 1 ) ) sp1 - pure ( line { curveEnd = sp1', curveData = invalidateCache dat } ) - bez2@( Bezier2To sp1 sp2 dat ) -> do - sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1 - sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 2 ) ) sp2 - pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } ) - bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do - sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1 - sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 2 sp2 - sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 3 ) ) sp3 - pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } ) - - inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool - inSelectionRange p cp = - squaredNorm ( c --> ( cp • p ) :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16 - - lineInSelectionRange :: ℝ 2 -> Segment ( T ( ℝ 2 ) ) -> Bool - lineInSelectionRange p seg = - case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of - ( _, q ) -> squaredNorm ( c --> q :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16 - - updateSplinePoint - :: forall pointParams brushFields - . NamedBrush brushFields - -> ( pointParams -> Record brushFields ) - -> ( Record brushFields -> pointParams -> pointParams ) - -> Unique -> Int -> Int - -> PointData pointParams - -> State ( Maybe BrushWidgetActionState ) - ( PointData pointParams ) - updateSplinePoint brush toBrushParams updatePointParams uniq i j pt = do - let - currentBrushParams :: Record brushFields - currentBrushParams = toBrushParams ( brushParams pt ) - brushWidgetElts :: Brush.WidgetElements - brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams - newBrushWidgetAction :: Maybe BrushWidgetActionState - ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of - -- Continue the current brush widget action. - Just prevAction@( BrushWidgetActionState - { brushWidgetPointBeingMoved = oldPt - , brushWidgetPointIndex = j' - , brushWidgetAction = act }) -> - if j /= j' - -- If we have already started a widget action, only continue an action - -- at the point with the correct index in the stroke. - then ( Just prevAction, currentBrushParams ) - else - let newPt = pointCoords pt --> c - newParams = - Brush.widgetUpdate ( brushWidget brush ) act - ( oldPt, newPt ) - currentBrushParams - in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams ) - Nothing -> - -- See if we can start a new brush widget action. - case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of - Just cp -> - let newAction = - BrushWidgetActionState - { brushWidgetPointBeingMoved = cp - , brushWidgetStrokeUnique = uniq - , brushWidgetCurveIndex = i - , brushWidgetPointIndex = j - , brushWidgetAction = case brushWidget brush of - Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY - Brush.RotatableRectangleWidget -> - if pressingCtrl - then Brush.RotateAction - else Brush.ScaleAction Brush.ScaleXY - } - in ( Just newAction, currentBrushParams ) - Nothing -> ( Nothing, currentBrushParams ) - -- TODO: handle clicking on an edge. - -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of - -- Just ln -> error "todo" - -- Nothing -> Nothing - - unless ( isNothing newBrushWidgetAction ) $ - State.put newBrushWidgetAction - pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt ) diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index a259f66..23cb032 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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(..) ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index f92081d..9ecdc68 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 } diff --git a/src/app/MetaBrush/Render/Rulers.hs b/src/app/MetaBrush/Render/Rulers.hs index 597de17..a17c325 100644 --- a/src/app/MetaBrush/Render/Rulers.hs +++ b/src/app/MetaBrush/Render/Rulers.hs @@ -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 ) diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index ff62a28..fc7206e 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -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 diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 100a79b..5a96a49 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -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 diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index 62f4d18..9d7fb7c 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -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 () diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 2f6646e..cf99059 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -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 diff --git a/src/app/MetaBrush/UI/InfoBar.hs-boot b/src/app/MetaBrush/UI/InfoBar.hs-boot index a63ddc5..6e5e194 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs-boot +++ b/src/app/MetaBrush/UI/InfoBar.hs-boot @@ -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 () diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index cb31ad8..be10c83 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -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 ) diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 111546a..37f53d8 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -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 } diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index d1bbeba..92ebddf 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -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 ) diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 89e3072..8d38af6 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -17,7 +17,7 @@ import qualified GI.Gtk as GTK -- MetaBrush import MetaBrush.GTK.Util ( widgetAddClass, widgetAddClasses ) -import MetaBrush.Document +import MetaBrush.Guide ( Ruler(..) ) -------------------------------------------------------------------------------- diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs new file mode 100644 index 0000000..e8a1183 --- /dev/null +++ b/src/metabrushes/MetaBrush/Action.hs @@ -0,0 +1,1060 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module MetaBrush.Action + ( -- * Subdividing a stroke + subdivide + -- * Selection + , selectAt, selectRectangle + -- * Drag + , dragMoveSelect, dragUpdate + -- * Translation + , translateSelection + -- * Deletion + , deleteSelected + -- * Brush widget actions + , BrushWidgetActionState(..) + , applyBrushWidgetAction + ) where + +-- base +import Control.Arrow + ( second ) +import Control.Monad + ( guard, when ) +import Data.Foldable + ( for_, traverse_ ) +import Data.Functor + ( (<&>) ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe + ( fromMaybe, isNothing, listToMaybe ) +import Data.Semigroup + ( Arg(..), Min(..) ) +import Data.Traversable + ( for ) + +-- acts +import Data.Act + ( Act((•)), Torsor((-->)) ) + +-- containers +import qualified Data.Map.Strict as Map +import Data.Sequence + ( Seq ) +import qualified Data.Sequence as Seq +import Data.Set + ( Set ) +import qualified Data.Set as Set + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- groups +import Data.Group + ( invert ) + +-- lens +import Control.Lens + ( set, over ) + +-- transformers +import Control.Monad.Trans.Except + ( Except ) +import qualified Control.Monad.Trans.Except as Except +import Control.Monad.Trans.State.Strict + ( State ) +import qualified Control.Monad.Trans.State.Strict as State +import Control.Monad.Trans.Writer.CPS + ( Writer ) +import qualified Control.Monad.Trans.Writer.CPS as Writer + +-- brush-strokes +import qualified Math.Bezier.Cubic as Cubic +import qualified Math.Bezier.Quadratic as Quadratic +import Math.Bezier.Spline +import Math.Bezier.Stroke + ( invalidateCache ) +import Math.Module + ( lerp, quadrance, closestPointOnSegment + , squaredNorm + ) +import Math.Linear + ( Segment(..), ℝ(..), T(..) ) + +-- MetaBrush +import MetaBrush.Brush +import qualified MetaBrush.Brush.Widget as Brush +import MetaBrush.Document +import MetaBrush.Document.Diff +import MetaBrush.Hover + ( inPointClickRange ) +import MetaBrush.Records +import MetaBrush.Stroke +import MetaBrush.Unique + ( Unique ) + +-------------------------------------------------------------------------------- +-- Subdivision. + +-- | Subdivide a path at the given center, provided a path indeed lies there. +subdivide :: ℝ 2 -> Document -> Maybe ( Document, Subdivision ) +subdivide c doc@( Document { documentMetadata, documentContent }) = + let + updatedStrokes :: StrokeHierarchy + mbSubdivStroke :: Maybe Subdivision + ( updatedStrokes, mbSubdivStroke ) + = ( `State.runState` Nothing ) + $ forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + subdivideStroke + in mbSubdivStroke <&> \ subdiv -> + ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) updatedStrokes + . set ( field' @"documentMetadata" . field' @"selectedPoints" ) mempty + $ doc + , subdiv ) + where + + Zoom { zoomFactor } = documentZoom documentMetadata + + stripData :: Curve Open crvData ( PointData ptData ) -> Curve Open () () + stripData = bimapCurve ( \ _ -> () ) ( \ _ _ -> () ) + + subdivideStroke :: Unique -> Stroke -> StrokeMetadata + -> State + ( Maybe Subdivision ) + UpdateStroke + subdivideStroke u stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do + mbPrevSubdivision <- State.get + let ( curves', subdivs ) = + Writer.runWriter $ + bifoldSpline @Open + ( subdivideCurve ( V2 0 0 ) ) + ( const $ pure Seq.Empty ) + ( adjustSplineType @Open strokeSpline ) + if | strokeVisible + , not strokeLocked + , Nothing <- mbPrevSubdivision + , Just nonEmptySubdivs <- NE.nonEmpty subdivs + -> do State.put $ Just $ Subdivision u nonEmptySubdivs + let spline' = adjustSplineType @clo + $ strokeSpline { splineStart = splineStart strokeSpline + , splineCurves = OpenCurves curves' } + return $ UpdateStrokeTo stroke0 { strokeSpline = spline' } + | otherwise + -> return PreserveStroke + + where + -- Note that if the user clicks on a point of self-intersection, + -- the code below will subdivide the curve on both branches. + -- This seems desirable. + subdivideCurve + :: T ( ℝ 2 ) + -> PointData brushParams + -> Curve Open CurveData ( PointData brushParams ) + -> Writer [ ( Curve Open () (), Double ) ] + ( Seq ( Curve Open CurveData ( PointData brushParams ) ) ) + subdivideCurve offset sp0 crv = + case crv of + LineTo ( NextPoint sp1 ) dat -> do + 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 ) + if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then do + Writer.tell [ ( stripData crv, t ) ] + let + subdiv :: PointData brushParams + subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1 + return $ + LineTo ( NextPoint subdiv ) ( invalidateCache dat ) + Seq.:<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) + Seq.:<| Seq.Empty + else return $ Seq.singleton crv + Bezier2To sp1 ( NextPoint sp2 ) dat -> do + 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 ) + 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 + Writer.tell [ ( stripData crv, t ) ] + let + bez_start, bez_end :: Curve Open CurveData ( PointData brushParams ) + bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat ) + bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat ) + return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty ) + else return $ Seq.singleton crv + Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do + 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 ) + if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then do + case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of + ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do + Writer.tell [ ( stripData crv, t ) ] + let + bez_start, bez_end :: Curve Open CurveData ( PointData brushParams ) + bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat ) + bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( invalidateCache dat ) + return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty ) + else + return $ Seq.singleton crv + +-------------------------------------------------------------------------------- +-- Selection. + +-- | Updates the selection on a single-click selection or deselection event. +selectAt :: SelectionMode -> ℝ 2 -> Document -> Maybe ( Document, StrokePoints ) +selectAt selMode c doc@( Document { documentContent, documentMetadata } ) = + let mbSel = + Except.runExcept $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + computeSelected + selPts = case mbSel of + Left ( u, i ) -> StrokePoints $ Map.singleton u ( Set.singleton i ) + Right {} -> mempty + in if noStrokePoints selPts && selMode /= New + then Nothing + else + let doc' = + over ( field' @"documentMetadata" . field' @"selectedPoints" ) + ( addOrRemove selMode selPts ) + doc + in Just ( doc', selPts ) + where + Zoom { zoomFactor } = documentZoom documentMetadata + + computeSelected :: Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke + computeSelected strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do + when ( strokeVisible ) $ + Except.withExcept ( strokeUnique , ) $ + bifoldSpline + ( \ _ -> selectSplineCurve ) + ( selectSplinePoint FirstPoint ) + strokeSpline + return PreserveStroke + + selectSplineCurve :: SplineTypeI clo + => Curve clo CurveData ( PointData ptData ) + -> Except PointIndex () + selectSplineCurve = \case + LineTo p1 ( CurveData { curveIndex } ) -> + traverse_ ( selectSplinePoint ( PointIndex curveIndex PathPoint ) ) p1 + Bezier2To cp1 p2 ( CurveData { curveIndex } ) -> do + selectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) cp1 + traverse_ ( selectSplinePoint ( PointIndex curveIndex PathPoint ) ) p2 + Bezier3To cp1 cp2 p3 ( CurveData { curveIndex } ) -> do + selectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) cp1 + selectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) cp2 + traverse_ ( selectSplinePoint ( PointIndex curveIndex PathPoint ) ) p3 + + selectSplinePoint :: PointIndex -> PointData brushParams -> Except PointIndex () + selectSplinePoint ptIx pt = do + let + selected :: Bool + selected = + squaredNorm ( c --> coords pt :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16 + when selected $ + Except.throwE ptIx + +-- | Checks whether a mouse click can initiate a drag move event. +dragMoveSelect :: ℝ 2 -> Document -> Maybe DragMoveSelect +dragMoveSelect c ( Document { documentContent, documentMetadata } ) = + ( \case { Left drag -> Just drag; Right {} -> Nothing } ) $ + Except.runExcept $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + dragSelect + + where + Zoom { zoomFactor } = documentZoom documentMetadata + + inSelectionRange :: ℝ 2 -> Bool + inSelectionRange p = + squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16 + + dragSelect :: Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke + dragSelect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do + when ( strokeVisible && not strokeLocked ) $ + ibifoldSpline + ( dragSelectSplineCurve strokeUnique ( splineStart strokeSpline ) ) + ( dragSelectSplinePoint strokeUnique FirstPoint ) + strokeSpline + return PreserveStroke + + dragSelectSplineCurve + :: forall clo' brushParams + . ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) + => Unique + -> PointData brushParams + -> Int + -> PointData brushParams -> Curve clo' CurveData ( PointData brushParams ) + -> Except DragMoveSelect () + dragSelectSplineCurve uniq start i sp0 = \case + LineTo sp1 ( CurveData { curveIndex } ) -> do + -- Check endpoints first. + traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp1 + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do + let + t :: Double + p :: ℝ 2 + ( t, p ) = + closestPointOnSegment @( T ( ℝ 2 ) ) + c + ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) ) + guard ( inSelectionRange p ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragCurve = curveIndex + , dragCurveIndex = i + , dragCurveParameter = t + } + for_ mbCurveDrag Except.throwE + Bezier2To sp1 sp2 ( CurveData { curveIndex } ) -> do + -- Check endpoints first. + dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) sp1 + traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp2 + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do + let + bez :: Quadratic.Bezier ( ℝ 2 ) + bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 ) + sq_d :: Double + t :: Double + Min ( Arg sq_d (t, _) ) = + Quadratic.closestPoint @( T ( ℝ 2 ) ) bez c + guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragCurve = curveIndex + , dragCurveIndex = i + , dragCurveParameter = t + } + for_ mbCurveDrag Except.throwE + Bezier3To sp1 sp2 sp3 ( CurveData { curveIndex } ) -> do + -- Check endpoints first. + dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) sp1 + dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) sp2 + traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp3 + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do + let + bez :: Cubic.Bezier ( ℝ 2 ) + bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 ) + sq_d :: Double + t :: Double + Min ( Arg sq_d (t, _) ) = + Cubic.closestPoint @( T ( ℝ 2 ) ) bez c + guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragCurve = curveIndex + , dragCurveIndex = i + , dragCurveParameter = t + } + for_ mbCurveDrag Except.throwE + + dragSelectSplinePoint :: Unique -> PointIndex -> PointData brushParams -> Except DragMoveSelect () + dragSelectSplinePoint u ptIx pt = + when ( inSelectionRange ( coords pt ) ) do + let + drag :: DragMoveSelect + drag = ClickedOnPoint + { dragPoint = ( u, ptIx ) + , dragPointWasSelected = + elemStrokePoint u ptIx ( selectedPoints documentMetadata ) + } + Except.throwE drag + + +addOrRemove :: SelectionMode + -> StrokePoints -- ^ items to add or remove + -> StrokePoints -- ^ base collection + -> StrokePoints +addOrRemove selMode new old = + case selMode of + New -> new + Add -> old <> new + Subtract -> old `differenceStrokePoints` new + +-- | Updates the selected objects on a rectangular selection event. +selectRectangle :: SelectionMode -> ℝ 2 -> ℝ 2 -> Document -> Maybe ( Document, StrokePoints ) +selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) doc@( Document { documentContent, documentMetadata } ) = + let + selPts = + Writer.execWriter $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + selectRect + in if noStrokePoints selPts && selMode /= New + then Nothing + else + let doc' = over ( field' @"documentMetadata" . field' @"selectedPoints" ) + ( addOrRemove selMode selPts ) + doc + in Just ( doc', selPts ) + + where + + xMin, xMax, yMin, yMax :: Double + ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 ) + ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 ) + + selectRect :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke + selectRect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do + when strokeVisible $ + Writer.mapWriter ( second $ \ is -> StrokePoints ( Map.singleton strokeUnique is ) ) $ + bifoldSpline + ( \ _ -> selectRectSplineCurve ) + ( selectRectSplinePoint FirstPoint ) + strokeSpline + return PreserveStroke + + selectRectSplineCurve :: SplineTypeI clo + => Curve clo CurveData ( PointData ptData ) + -> Writer ( Set PointIndex ) () + selectRectSplineCurve = \case + LineTo p1 ( CurveData { curveIndex } ) -> + traverse_ ( selectRectSplinePoint ( PointIndex curveIndex PathPoint ) ) p1 + Bezier2To cp1 p2 ( CurveData { curveIndex } ) -> do + selectRectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) cp1 + traverse_ ( selectRectSplinePoint ( PointIndex curveIndex PathPoint ) ) p2 + Bezier3To cp1 cp2 p3 ( CurveData { curveIndex } ) -> do + selectRectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) cp1 + selectRectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) cp2 + traverse_ ( selectRectSplinePoint ( PointIndex curveIndex PathPoint ) ) p3 + + selectRectSplinePoint :: PointIndex -> PointData brushParams -> Writer ( Set PointIndex ) () + selectRectSplinePoint ptIx pt = do + let + x, y :: Double + ℝ2 x y = coords pt + selected :: Bool + selected = + x >= xMin && x <= xMax && y >= yMin && y <= yMax + when selected $ + Writer.tell $ Set.singleton ptIx + +-- | Translate all selected points by the given vector. +-- +-- Returns the updated document, together with info about how many points were translated. +translateSelection :: T ( ℝ 2 ) -> Document -> Maybe ( Document, StrokePoints ) +translateSelection t doc@( Document { documentContent, documentMetadata } ) = + let + ( newStrokes, movedPts ) = + Writer.runWriter $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + updateStroke + in + if noStrokePoints movedPts + then Nothing + else Just ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc + , movedPts + ) + where + + selPts :: StrokePoints + selPts = selectedPoints documentMetadata + + updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke + updateStroke u stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do + let strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts ) + firstPointSel = FirstPoint `Set.member` strokeSelPts + ( spline', ( modPts, _ ) ) = + ( `State.runState` ( mempty, False ) ) $ + bitraverseSpline @_ @_ @CurveData @( PointData _ ) + ( \ _ -> updateSplineCurve firstPointSel strokeSelPts ) + ( \ pt -> do { ( NextPoint pt', _ ) <- updatePoint firstPointSel strokeSelPts FirstPoint ( NextPoint pt ) ; return pt' } ) + strokeSpline + if strokeVisible && not strokeLocked && not ( null modPts ) + then do + Writer.tell ( StrokePoints $ Map.singleton u modPts ) + return $ UpdateStrokeTo ( stroke { strokeSpline = spline' } ) + else + return PreserveStroke + + updateSplineCurve + :: forall clo' brushParams + . SplineTypeI clo' + => Bool + -> Set PointIndex + -> Curve clo' CurveData ( PointData brushParams ) + -> State ( Set PointIndex, Bool ) + ( Curve clo' CurveData ( PointData brushParams ) ) + updateSplineCurve startPtSel strokeSelPts = \case + LineTo p1 dat@( CurveData { curveIndex } ) -> do + ( _, sel0 ) <- State.get + ( p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p1 + let + dat' :: CurveData + dat' + | sel0 || sel1 + = invalidateCache dat + | otherwise + = dat + State.modify' ( \ ( pts, _ ) -> ( pts, sel1 ) ) + pure $ LineTo p1' dat' + Bezier2To p1 p2 dat@( CurveData { curveIndex } ) -> do + ( _, sel0 ) <- State.get + ( NextPoint p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez2Cp )) ( NextPoint p1 ) + ( p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p2 + let + dat' :: CurveData + dat' + | sel0 || sel1 || sel2 + = invalidateCache dat + | otherwise + = dat + State.modify' ( \ ( pts, _ ) -> ( pts, sel2 ) ) + pure $ Bezier2To p1' p2' dat' + Bezier3To p1 p2 p3 dat@( CurveData { curveIndex } ) -> do + ( _, sel0 ) <- State.get + ( NextPoint p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez3Cp1 )) ( NextPoint p1 ) + ( NextPoint p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez3Cp2 )) ( NextPoint p2 ) + ( p3', sel3 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p3 + let + dat' :: CurveData + dat' + | sel0 || sel1 || sel2 || sel3 + = invalidateCache dat + | otherwise + = dat + State.modify' ( \ ( pts, _ ) -> ( pts, sel3 ) ) + pure $ Bezier3To p1' p2' p3' dat' + + updatePoint :: forall clo brushParams + . SplineTypeI clo + => Bool + -> Set PointIndex + -> PointIndex + -> NextPoint clo ( PointData brushParams ) + -> State ( Set PointIndex, Bool ) ( NextPoint clo ( PointData brushParams ), Bool ) + updatePoint startPtSel strokeSelPts i nextPt = do + if i `Set.member` strokeSelPts + then do + nextPt' <- for nextPt $ \ pt -> do + State.modify' ( \ ( pts, _ ) -> ( Set.insert i pts, True ) ) + return $ over _coords ( t • ) pt + return ( nextPt', True ) + else do + let endPtSel :: Bool + endPtSel = case ssplineType @clo of + SOpen -> False + SClosed -> case nextPt of + BackToStart -> startPtSel + State.modify' ( \ ( pts, _ ) -> ( pts, endPtSel ) ) + return ( nextPt, endPtSel ) + +-- | Delete the selected points. +-- +-- Returns the updated document, together with info about how many points +-- and strokes were deleted. +deleteSelected :: Document -> Maybe ( Document, StrokePoints, Set Unique ) +deleteSelected doc@( Document { documentContent, documentMetadata } ) = + let + ( newStrokes, ( delPts, delStrokes ) ) = + Writer.runWriter $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + updateStroke + in + if noStrokePoints delPts + then Nothing + else Just ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes $ doc + -- NB: not removing metadata about the layer from the LayerMetadata, + -- as it might be useful to keep it around if we undo the action. + , delPts + , delStrokes + ) + where + + updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Set Unique ) UpdateStroke + updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) + | not strokeVisible || strokeLocked + = return PreserveStroke + | otherwise + = let + ( mbSpline, delPts ) = + Writer.runWriter $ + biwitherSpline + updateSplineCurve + ( updateSplinePoint FirstPoint ) + oldSpline + in if null delPts + then + return PreserveStroke + else case mbSpline of + Nothing -> do + Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.singleton u ) + return DeleteStroke + Just spline' -> do + Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.empty ) + return $ UpdateStrokeTo $ stroke { strokeSpline = spline' } + + where + strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints $ selectedPoints documentMetadata ) + + updateSplinePoint + :: PointIndex + -> PointData brushParams + -> Writer ( Set PointIndex ) + ( Maybe ( PointData brushParams ) ) + updateSplinePoint i pt = + if i `Set.member` strokeSelPts + then + do Writer.tell ( Set.singleton i ) + return Nothing + else + return ( Just pt ) + + updateSplineCurve + :: forall clo' hasStart. SplineTypeI clo' + => CurrentStart hasStart ( PointData brushParams ) + -> Curve clo' CurveData ( PointData brushParams ) + -> Writer ( Set PointIndex ) + ( WitherResult hasStart clo' CurveData ( PointData brushParams ) ) + updateSplineCurve mbPrevPt crv = case crv of + + LineTo p1 ( CurveData { curveIndex } ) -> + let i = PointIndex curveIndex PathPoint + in + case ssplineType @clo' of + SOpen + | i `Set.member` strokeSelPts + -> do + Writer.tell ( Set.singleton i ) + pure Dismiss + | NextPoint pt <- p1 + , NoStartFound <- mbPrevPt + -> pure ( UseStartPoint pt Nothing ) + SClosed + | NoStartFound <- mbPrevPt + -> pure Dismiss + _ | CurrentStart wasOrigPt _ <- mbPrevPt + -> let crv' = if wasOrigPt + then crv + else crv { curveData = invalidateCache $ curveData crv } + in pure $ UseCurve crv' + + Bezier2To _cp1 p2 dat@( CurveData { curveIndex } ) -> + let i = PointIndex curveIndex PathPoint + j = PointIndex curveIndex ( ControlPoint Bez2Cp ) + in + case ssplineType @clo' of + SOpen + | i `Set.member` strokeSelPts + -> do + Writer.tell ( Set.fromList [ i, j ] ) + pure Dismiss + | NextPoint pt <- p2 + , NoStartFound <- mbPrevPt + -> do Writer.tell ( Set.singleton j ) + pure ( UseStartPoint pt Nothing ) + SClosed + | NoStartFound <- mbPrevPt + -> do Writer.tell ( Set.singleton j ) + pure Dismiss + _ | CurrentStart wasOrigPt _ <- mbPrevPt + -> if j `Set.member` strokeSelPts + then do + Writer.tell ( Set.singleton j ) + pure ( UseCurve ( LineTo p2 ( invalidateCache dat ) ) ) + else + let crv' = if wasOrigPt + then crv + else crv { curveData = invalidateCache $ curveData crv } + in pure $ UseCurve crv' + + Bezier3To cp1 cp2 p3 dat@( CurveData { curveIndex } ) -> + let i = PointIndex curveIndex PathPoint + j1 = PointIndex curveIndex ( ControlPoint Bez3Cp1 ) + j2 = PointIndex curveIndex ( ControlPoint Bez3Cp2 ) + in + case ssplineType @clo' of + SOpen + | i `Set.member` strokeSelPts + -> do + Writer.tell ( Set.fromList [ i, j1, j2 ] ) + pure Dismiss + | NextPoint pt <- p3 + , NoStartFound <- mbPrevPt + -> do + Writer.tell ( Set.fromList [ j1, j2 ] ) + pure ( UseStartPoint pt Nothing ) + SClosed + | NoStartFound <- mbPrevPt + -> do + Writer.tell ( Set.fromList [ j1, j2 ] ) + pure Dismiss + _ | CurrentStart wasOrigPt _ <- mbPrevPt + -> case ( j1 `Set.member` strokeSelPts + , j2 `Set.member` strokeSelPts ) of + ( False, False ) -> + let crv' = if wasOrigPt + then crv + else crv { curveData = invalidateCache $ curveData crv } + in pure $ UseCurve crv' + ( False, _ ) -> do + Writer.tell ( Set.singleton j2 ) + pure ( UseCurve $ Bezier2To cp1 p3 ( invalidateCache dat ) ) + ( _, False ) -> do + Writer.tell ( Set.singleton j1 ) + pure ( UseCurve $ Bezier2To cp2 p3 ( invalidateCache dat ) ) + _ -> do + Writer.tell ( Set.fromList [ j1, j2 ] ) + pure ( UseCurve $ LineTo p3 ( invalidateCache dat ) ) + +-- | Perform a drag move action on a document. +dragUpdate :: ℝ 2 -> ℝ 2 -> DragMoveSelect -> Bool -> Document -> Maybe ( Document, StrokePoints ) +dragUpdate p0 p ( ClickedOnPoint {} ) _ doc = translateSelection ( p0 --> p ) doc +dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurveParameter } ) alternateMode + doc@( Document { documentContent, documentMetadata } ) = + let + ( newStrokes, movedPts ) = + Writer.runWriter $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + updateStroke + in + if noStrokePoints movedPts + then Nothing + else Just ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc + , movedPts + ) + where + + updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke + updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) + | not strokeVisible || strokeLocked || u /= dragStrokeUnique + = return PreserveStroke + | otherwise + = let + ( spline', movedPts ) = + Writer.runWriter + $ fmap ( adjustSplineType @clo ) + $ updateSplineCurves + $ adjustSplineType @Open oldSpline + in if null movedPts + then return PreserveStroke + else do + Writer.tell ( StrokePoints $ Map.singleton u movedPts ) + return $ UpdateStrokeTo $ stroke { strokeSpline = spline' } + + where + + updateSplineCurves + :: StrokeSpline Open pointParams + -> Writer ( Set PointIndex ) ( StrokeSpline Open pointParams ) + updateSplineCurves spline = + case splitSplineAt dragCurveIndex spline of + ( _ , Spline { splineCurves = OpenCurves Seq.Empty } ) -> pure spline + ( bef, Spline { splineStart, splineCurves = OpenCurves ( curve Seq.:<| next ) } ) -> do + curve' <- updateCurve ( lastPoint bef ) curve + pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ curve' Seq.:<| next } ) + + updateCurve + :: PointData pointParams + -> Curve Open CurveData ( PointData pointParams ) + -> Writer ( Set PointIndex ) + ( Curve Open CurveData ( PointData pointParams ) ) + updateCurve sp0 curve = case curve of + LineTo ( NextPoint sp1 ) dat@( CurveData { curveIndex } ) -> do + let + bez2 :: Quadratic.Bezier ( PointData pointParams ) + bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( T pointParams ) ) dragCurveParameter sp0 sp1 ) sp1 + Writer.tell ( Set.singleton ( PointIndex curveIndex PathPoint ) ) + pure $ + if alternateMode + then quadraticDragCurve dat bez2 + else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 ) + Bezier2To sp1 ( NextPoint sp2 ) dat@( CurveData { curveIndex } ) -> do + let + bez2 :: Quadratic.Bezier ( PointData pointParams ) + bez2 = Quadratic.Bezier sp0 sp1 sp2 + if alternateMode + then do + Writer.tell $ + Set.fromList + [ PointIndex curveIndex PathPoint + , PointIndex curveIndex ( ControlPoint Bez2Cp ) + , PointIndex curveIndex ( ControlPoint Bez3Cp1 ) + , PointIndex curveIndex ( ControlPoint Bez3Cp2 ) + ] + pure $ cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 + else do + Writer.tell $ + Set.fromList + [ PointIndex curveIndex PathPoint + , PointIndex curveIndex ( ControlPoint Bez2Cp ) + ] + pure $ quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 ) + Bezier3To sp1 sp2 ( NextPoint sp3 ) dat@( CurveData { curveIndex } ) -> do + let + bez3 :: Cubic.Bezier ( PointData pointParams ) + bez3 = Cubic.Bezier sp0 sp1 sp2 sp3 + if alternateMode + then do + Writer.tell $ + Set.fromList + [ PointIndex curveIndex PathPoint + , PointIndex curveIndex ( ControlPoint Bez2Cp ) + , PointIndex curveIndex ( ControlPoint Bez3Cp1 ) + , PointIndex curveIndex ( ControlPoint Bez3Cp2 ) + ] + pure $ quadraticDragCurve dat + ( Quadratic.Bezier + sp0 + ( Cubic.bezier @( DiffPointData ( T pointParams ) ) bez3 dragCurveParameter ) + sp3 + ) + else do + Writer.tell $ + Set.fromList + [ PointIndex curveIndex PathPoint + , PointIndex curveIndex ( ControlPoint Bez3Cp1 ) + , PointIndex curveIndex ( ControlPoint Bez3Cp2 ) + ] + pure $ cubicDragCurve dat bez3 + where + quadraticDragCurve + :: CurveData + -> Quadratic.Bezier ( PointData pointParams ) + -> Curve Open CurveData ( PointData pointParams ) + quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) = + let + cp :: ℝ 2 + Quadratic.Bezier { Quadratic.p1 = cp } = + Quadratic.interpolate @( T ( ℝ 2 ) ) ( coords sp0 ) ( coords sp2 ) dragCurveParameter p + in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat ) + cubicDragCurve + :: CurveData + -> Cubic.Bezier ( PointData pointParams ) + -> Curve Open CurveData ( PointData pointParams ) + cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) = + let + cp1, cp2 :: ℝ 2 + Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } = + Cubic.drag @( T ( ℝ 2 ) ) + ( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) ) + dragCurveParameter + p + in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat ) + +-------------------------------------------------------------------------------- +-- Brush widget + +data BrushWidgetActionState + = BrushWidgetActionState + { brushWidgetAction :: !Brush.WidgetAction + , brushWidgetStrokeUnique :: !Unique + , brushWidgetPointIndex :: !PointIndex + , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) ) + } + deriving stock ( Eq, Show ) +instance Semigroup BrushWidgetActionState where + a <> b + | a == b + = a + | otherwise + = error "internal error: trying to combine incompatible brush widget action states" + +-- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point. +applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( Document, BrushWidgetActionState ) +applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentContent, documentMetadata } ) = + let + ( newStrokes, ( mbAct, _ ) ) = + ( `State.runState` ( Nothing, False ) ) $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + updateStroke + in mbAct <&> \ act -> + ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc + , act + ) + where + + zoom = documentZoom $ documentMetadata + + updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke + updateStroke u stroke@( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline _clo ( Record pointFields ) } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) + | strokeVisible + , not strokeLocked + -- If we have already started a widget action, only continue an action + -- for the stroke with the correct unique. + , case mbPrevAction of { Just act -> brushWidgetStrokeUnique act == u; Nothing -> True } + -- Don't touch strokes without brushes. + , Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush + = case intersect @pointFields @brushFields of + Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do + let embedUsedParams = updateBrushParams ( MkR $ defaultParams $ brushFunction brush ) + toBrushParams = embedUsedParams . ptParamsToUsedParams + updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' ) + spline' <- + bitraverseSpline + ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams u ) + ( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint ) + oldSpline + ( mbAct, _ ) <- State.get + case mbAct of + Nothing -> return PreserveStroke + Just {} -> return $ UpdateStrokeTo $ stroke { strokeSpline = spline' } + | otherwise + = return PreserveStroke + + updateSplineCurve + :: forall clo' pointParams brushFields + . ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) + => PointData pointParams + -> NamedBrush brushFields + -> ( pointParams -> Record brushFields ) + -> ( Record brushFields -> pointParams -> pointParams ) + -> Unique + -> PointData pointParams -> Curve clo' CurveData ( PointData pointParams ) + -> State ( Maybe BrushWidgetActionState, Bool ) + ( Curve clo' CurveData ( PointData pointParams ) ) + updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do + ( mbAct, prevCurveAct ) <- State.get + -- We can only perform a brush widget update if: + -- - we aren't already updating another point, + -- - either: + -- - we are starting a new operation, or + -- - we are continuing an operation, and we have the right curve index + let canAct + | isNothing mbAct + = case mbPrevAction of + Just prevAct -> case ssplineType @clo' of + SClosed -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx + SOpen -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx + Nothing -> True + | otherwise + = False + if canAct + then do + case curve of + line@( LineTo sp1 dat ) -> do + sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1 + pure ( line { curveEnd = sp1', curveData = invalidateCache dat } ) + bez2@( Bezier2To sp1 sp2 dat ) -> do + sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1 + sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2 + pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } ) + bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do + sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1 + sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2 + sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3 + pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } ) + else do + State.put ( mbAct, False ) + let curve' = if prevCurveAct + then curve { curveData = invalidateCache $ curveData curve } + else curve + return curve' + where + crvIx = curveIndex ( curveData curve ) + + inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool + inSelectionRange p cp = + inPointClickRange zoom c ( cp • p ) + + lineInSelectionRange :: ℝ 2 -> Segment ( T ( ℝ 2 ) ) -> Bool + lineInSelectionRange p seg = + case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of + ( _, q ) -> + inPointClickRange zoom c q + + updateSplinePoint + :: forall pointParams brushFields + . NamedBrush brushFields + -> ( pointParams -> Record brushFields ) + -> ( Record brushFields -> pointParams -> pointParams ) + -> Unique -> PointIndex + -> PointData pointParams + -> State ( Maybe BrushWidgetActionState, Bool ) + ( PointData pointParams ) + updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do + let + currentBrushParams :: Record brushFields + currentBrushParams = toBrushParams ( brushParams pt ) + brushWidgetElts :: Brush.WidgetElements + brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams + newBrushWidgetAction :: Maybe BrushWidgetActionState + ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of + -- Continue the current brush widget action. + Just prevAction@( BrushWidgetActionState + { brushWidgetPointBeingMoved = oldPt + , brushWidgetPointIndex = j' + , brushWidgetAction = act }) -> + if j /= j' + -- If we have already started a widget action, only continue an action + -- at the point with the correct index in the stroke. + then ( Nothing, currentBrushParams ) + else + let newPt = pointCoords pt --> c + newParams = + Brush.widgetUpdate ( brushWidget brush ) act + ( oldPt, newPt ) + currentBrushParams + in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams ) + Nothing -> + -- See if we can start a new brush widget action. + case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of + Just cp -> + let newAction = + BrushWidgetActionState + { brushWidgetPointBeingMoved = cp + , brushWidgetStrokeUnique = uniq + , brushWidgetPointIndex = j + , brushWidgetAction = case brushWidget brush of + Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY + Brush.RotatableRectangleWidget -> + if pressingCtrl + then Brush.RotateAction + else Brush.ScaleAction Brush.ScaleXY + } + in ( Just newAction, currentBrushParams ) + Nothing -> ( Nothing, currentBrushParams ) + -- TODO: handle clicking on an edge. + -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of + -- Just ln -> error "todo" + -- Nothing -> Nothing + + case newBrushWidgetAction of + Just a -> State.put ( Just a, True ) + _ -> State.modify' ( \ ( a, _ ) -> ( a, False ) ) + pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt ) diff --git a/src/metabrushes/MetaBrush/Brush/Widget.hs b/src/metabrushes/MetaBrush/Brush/Widget.hs index 56db7a3..bf66db1 100644 --- a/src/metabrushes/MetaBrush/Brush/Widget.hs +++ b/src/metabrushes/MetaBrush/Brush/Widget.hs @@ -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" diff --git a/src/metabrushes/MetaBrush/Document.hs b/src/metabrushes/MetaBrush/Document.hs index 7301608..542af77 100644 --- a/src/metabrushes/MetaBrush/Document.hs +++ b/src/metabrushes/MetaBrush/Document.hs @@ -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 + } diff --git a/src/metabrushes/MetaBrush/Document/Diff.hs b/src/metabrushes/MetaBrush/Document/Diff.hs new file mode 100644 index 0000000..354389b --- /dev/null +++ b/src/metabrushes/MetaBrush/Document/Diff.hs @@ -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 ) +-} \ No newline at end of file diff --git a/src/metabrushes/MetaBrush/Document/Draw.hs b/src/metabrushes/MetaBrush/Document/Draw.hs deleted file mode 100644 index 1f577e8..0000000 --- a/src/metabrushes/MetaBrush/Document/Draw.hs +++ /dev/null @@ -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 ) diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index 993a386..2826f71 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/src/metabrushes/MetaBrush/Document/Serialise.hs @@ -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 } ) diff --git a/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs b/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs deleted file mode 100644 index 8975d00..0000000 --- a/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs +++ /dev/null @@ -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 diff --git a/src/metabrushes/MetaBrush/Draw.hs b/src/metabrushes/MetaBrush/Draw.hs new file mode 100644 index 0000000..7fcd144 --- /dev/null +++ b/src/metabrushes/MetaBrush/Draw.hs @@ -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 ) diff --git a/src/metabrushes/MetaBrush/Guide.hs b/src/metabrushes/MetaBrush/Guide.hs new file mode 100644 index 0000000..a27255c --- /dev/null +++ b/src/metabrushes/MetaBrush/Guide.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Hover.hs b/src/metabrushes/MetaBrush/Hover.hs new file mode 100644 index 0000000..98a3f5e --- /dev/null +++ b/src/metabrushes/MetaBrush/Hover.hs @@ -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 ) diff --git a/src/metabrushes/MetaBrush/Layer.hs b/src/metabrushes/MetaBrush/Layer.hs new file mode 100644 index 0000000..40c8f90 --- /dev/null +++ b/src/metabrushes/MetaBrush/Layer.hs @@ -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 + } diff --git a/src/metabrushes/MetaBrush/Serialisable.hs b/src/metabrushes/MetaBrush/Serialisable.hs index d7c75a8..caf305b 100644 --- a/src/metabrushes/MetaBrush/Serialisable.hs +++ b/src/metabrushes/MetaBrush/Serialisable.hs @@ -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 } ) diff --git a/src/metabrushes/MetaBrush/Stroke.hs b/src/metabrushes/MetaBrush/Stroke.hs new file mode 100644 index 0000000..dd37978 --- /dev/null +++ b/src/metabrushes/MetaBrush/Stroke.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/metabrushes/MetaBrush/Util.hs b/src/metabrushes/MetaBrush/Util.hs index 55e9e22..f0b9646 100644 --- a/src/metabrushes/MetaBrush/Util.hs +++ b/src/metabrushes/MetaBrush/Util.hs @@ -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