From 1a8f4b5f5deeebfad2e33348ed1ddec3031f20a8 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 12 Oct 2024 15:41:52 +0200 Subject: [PATCH] improvements to brush params when changing brush --- app/Main.hs | 2 +- brush-strokes/src/lib/Calligraphy/Brushes.hs | 4 +- brush-strokes/src/lib/Math/Bezier/Stroke.hs | 8 +- .../src/lib/Math/Root/Isolation/Utils.hs | 2 +- src/app/MetaBrush/Application.hs | 3 +- src/app/MetaBrush/Application/Action.hs | 8 +- src/app/MetaBrush/Application/Context.hs | 5 + src/app/MetaBrush/Render/Document.hs | 2 + src/app/MetaBrush/UI/BrushList.hs | 41 ++++- src/metabrushes/MetaBrush/Action.hs | 55 ++++--- src/metabrushes/MetaBrush/Asset/Brushes.hs | 16 +- src/metabrushes/MetaBrush/Brush.hs | 1 + src/metabrushes/MetaBrush/Draw.hs | 45 ++++-- src/metabrushes/MetaBrush/Records.hs | 149 +++++++++++++++++- src/metabrushes/MetaBrush/Stroke.hs | 13 +- 15 files changed, 286 insertions(+), 68 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index bc88f12..3e66a47 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -56,7 +56,7 @@ main = withCP65001 do when (isNothing mbGdkScale) $ setEnv "GDK_SCALE" "2" - setEnv "GSK_RENDERER" "cairo" + setEnv "GSK_RENDERER" "vulkan" --------------------------------------------------------- -- Run GTK application diff --git a/brush-strokes/src/lib/Calligraphy/Brushes.hs b/brush-strokes/src/lib/Calligraphy/Brushes.hs index fbaf1d5..38f2fbb 100644 --- a/brush-strokes/src/lib/Calligraphy/Brushes.hs +++ b/brush-strokes/src/lib/Calligraphy/Brushes.hs @@ -213,8 +213,8 @@ tearDropBrushFn :: forall {t} (i :: t) k nbParams tearDropBrushFn _ mkI1 mkI2 = D \ params -> let w, h :: D k nbParams ( I i Double ) - w = runD ( var @_ @k ( Fin 1 ) ) params - h = runD ( var @_ @k ( Fin 2 ) ) params + w = 2 * runD ( var @_ @k ( Fin 1 ) ) params + h = 2 * runD ( var @_ @k ( Fin 2 ) ) params mkPt :: Double -> Double -> D k nbParams ( I i 2 ) mkPt x y -- 1. translate the teardrop so that the centre of mass is at the origin diff --git a/brush-strokes/src/lib/Math/Bezier/Stroke.hs b/brush-strokes/src/lib/Math/Bezier/Stroke.hs index 98c3795..92a8fb5 100644 --- a/brush-strokes/src/lib/Math/Bezier/Stroke.hs +++ b/brush-strokes/src/lib/Math/Bezier/Stroke.hs @@ -25,6 +25,8 @@ module Math.Bezier.Stroke where -- base +import Prelude + hiding ( unzip ) import Control.Arrow ( first, (***) ) import Control.Monad @@ -40,7 +42,7 @@ import Data.Fixed import Data.Foldable ( for_ ) import Data.Functor - ( (<&>) ) + ( (<&>), unzip ) import Data.Functor.Identity ( Identity(..) ) import Data.List @@ -48,7 +50,7 @@ import Data.List import Data.List.NonEmpty ( NonEmpty ) import qualified Data.List.NonEmpty as NE - ( cons, singleton, unzip ) + ( cons, singleton ) import Data.Maybe ( fromMaybe, isJust, listToMaybe, mapMaybe ) import Data.Proxy @@ -721,7 +723,7 @@ joinBetweenOffsets = let pcs, lastAndRest :: Maybe ( SplinePts Open ) ( pcs, lastAndRest ) - = NE.unzip + = unzip $ ( discardCurveData *** discardCurveData ) . splitSplineAt ( i2 - i1 ) <$> dropCurves i1 openSpline diff --git a/brush-strokes/src/lib/Math/Root/Isolation/Utils.hs b/brush-strokes/src/lib/Math/Root/Isolation/Utils.hs index 4a6e931..abd6755 100644 --- a/brush-strokes/src/lib/Math/Root/Isolation/Utils.hs +++ b/brush-strokes/src/lib/Math/Root/Isolation/Utils.hs @@ -9,7 +9,7 @@ module Math.Root.Isolation.Utils import Prelude hiding ( unzip ) import Data.Foldable ( toList ) -import Data.List.NonEmpty +import Data.Functor ( unzip ) -- MetaBrush diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index a23c9fd..a395d82 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -214,6 +214,7 @@ runApplication application = do modifiersTVar <- STM.newTVarIO Set.empty toolTVar <- STM.newTVarIO Selection modeTVar <- STM.newTVarIO PathMode + selectedBrushTVar <- STM.newTVarIO Nothing debugTVar <- STM.newTVarIO False partialPathTVar <- STM.newTVarIO Nothing fileBarTabsTVar <- STM.newTVarIO Map.empty @@ -479,7 +480,7 @@ runApplication application = do --------------------------------------------------------- -- Brushes view - brushesListView <- newBrushView window DragBrush + brushesListView <- newBrushView window variables DragBrush GTK.scrolledWindowSetChild ( brushesScrolledWindow panelsBar ) ( Just brushesListView ) diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index cac9fc1..f057449 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -939,13 +939,14 @@ instance HandleAction MouseClick where Pen -> do -- Pen tool in path mode: start or continue a drawing operation. mbPartialPath <- STM.readTVar partialPathTVar + mbSelBrush <- STM.readTVar selectedBrushTVar STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) case mbPartialPath of -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). Nothing -> do ( newDocument, drawAnchor ) <- - getOrCreateDrawAnchor uniqueSupply pos doc - let firstPos = anchorPos drawAnchor doc + getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc + let firstPos = anchorPos drawAnchor newDocument STM.writeTVar partialPathTVar ( Just $ PartialPath { partialPathAnchor = drawAnchor @@ -1159,6 +1160,7 @@ instance HandleAction MouseRelease where Pen -> case mode of PathMode -> do mbPartialPath <- STM.readTVar partialPathTVar + mbSelBrush <- STM.readTVar selectedBrushTVar case mbPartialPath of -- Normal pen mode mouse click should have created an anchor. -- If no anchor exists, then just ignore the mouse release event. @@ -1186,7 +1188,7 @@ instance HandleAction MouseRelease where = ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos ) | otherwise = ( pos, Nothing, Nothing ) - ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc + ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply mbSelBrush pathPoint doc if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor -- Close path. then do diff --git a/src/app/MetaBrush/Application/Context.hs b/src/app/MetaBrush/Application/Context.hs index ab6a829..337392e 100644 --- a/src/app/MetaBrush/Application/Context.hs +++ b/src/app/MetaBrush/Application/Context.hs @@ -58,6 +58,8 @@ import MetaBrush.Action ( BrushWidgetActionState ) import MetaBrush.Asset.Colours ( Colours ) +import MetaBrush.Brush + ( SomeBrush ) import MetaBrush.Document.Diff ( DragMoveSelect ) import MetaBrush.Draw @@ -74,6 +76,7 @@ import MetaBrush.Unique ( UniqueSupply, Unique ) + -------------------------------------------------------------------------------- data UIElements @@ -113,6 +116,8 @@ data Variables -- is kept in-sync between the application and the UI's 'GTK.TreeListModel'. , listModelUpToDateTMVar :: !( STM.TMVar () ) + , selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) ) + , mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 191de7d..3afa395 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -175,6 +175,7 @@ getDocumentRender | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent , Just p1 <- mbMousePos , p0 /= p1 + -- Non-trivial drag in progress. , let alternateMode :: Bool alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers @@ -197,6 +198,7 @@ getDocumentRender | otherwise = ( mbMousePos, Nothing ) , Just finalPoint <- mbFinalPoint + -- Path drawing operation in progress. , let previewSpline :: Spline Open () ( PointData () ) previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) () diff --git a/src/app/MetaBrush/UI/BrushList.hs b/src/app/MetaBrush/UI/BrushList.hs index d0a3d93..c37bf19 100644 --- a/src/app/MetaBrush/UI/BrushList.hs +++ b/src/app/MetaBrush/UI/BrushList.hs @@ -33,27 +33,46 @@ import qualified GI.Gtk as GTK import qualified Data.GI.Base as GI import qualified Data.GI.Base.GValue as GI +-- stm +import qualified Control.Concurrent.STM as STM + -- text import Data.Text ( Text ) import qualified Data.Text as Text - ( toLower ) + ( null, toLower ) -- unordered-containers import qualified Data.HashMap.Strict as HashMap -- MetaBrush +import MetaBrush.Application.Context + ( Variables(selectedBrushTVar) ) +import MetaBrush.Brush + ( SomeBrush ) import qualified MetaBrush.Asset.Brushes as Brushes ( brushes ) + +-------------------------------------------------------------------------------- +-- Brush lookup -- +------------------ + +brushFromName :: Text -> Maybe SomeBrush +brushFromName str + | Text.null str || Text.toLower str == "no brush" + = Nothing + | otherwise + = HashMap.lookup str Brushes.brushes + -------------------------------------------------------------------------------- -- GTK StringList -- -------------------- -- | Create a new 'GTK.StringList' with 'GTK.SingleSelection' to hold -- the given brush names. -newBrushListModel :: [ Text ] -> IO GTK.SingleSelection -newBrushListModel brushNames = do +newBrushListModel :: Variables -> [ Text ] -> IO GTK.SingleSelection +newBrushListModel vars brushNames = do stringList <- GTK.stringListNew ( Just brushNames ) @@ -61,6 +80,17 @@ newBrushListModel brushNames = do GI.withNewObject slPtr $ \ slCopy -> GTK.singleSelectionNew ( Just slCopy ) + void $ GI.after selectionModel ( GI.PropertyNotify #selected ) $ \ _ -> do + selObj <- GTK.singleSelectionGetSelectedItem selectionModel + selBrush <- + case selObj of + Nothing -> return Nothing + Just obj -> do + strObj <- GTK.unsafeCastTo GTK.StringObject obj + str <- GTK.stringObjectGetString strObj + return $ brushFromName str + STM.atomically $ STM.writeTVar ( selectedBrushTVar vars ) selBrush + return selectionModel ------------------ @@ -70,12 +100,13 @@ newBrushListModel brushNames = do -- | Create a new 'GTK.ListView' that displays brush names. newBrushView :: Typeable dnd_data => GTK.ApplicationWindow + -> Variables -> ( Maybe Text -> dnd_data ) -- ^ drag and drop data for the brush -> IO GTK.ListView -newBrushView rootWindow mkDND_data = mdo +newBrushView rootWindow vars mkDND_data = mdo - brushListModel <- newBrushListModel ( "No brush" : HashMap.keys Brushes.brushes ) + brushListModel <- newBrushListModel vars ( "No brush" : HashMap.keys Brushes.brushes ) brushesListFactory <- GTK.signalListItemFactoryNew diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs index 4657c6c..b289cf2 100644 --- a/src/metabrushes/MetaBrush/Action.hs +++ b/src/metabrushes/MetaBrush/Action.hs @@ -52,7 +52,7 @@ import qualified Data.Set as Set -- generic-lens import Data.Generics.Product.Fields - ( field' ) + ( field, field' ) -- groups import Data.Group @@ -924,7 +924,9 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont 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 } ) + updateStroke u + ( 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 @@ -932,35 +934,42 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont , 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 ) + , Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams } + <- intersect @pointFields @brushFields + , Union @pointFields' unionWith + <- union @pointFields @brushFields + = do let defaultBrushParams = MkR $ defaultParams $ brushFunction brush + embedUsedParams = updateBrushParams defaultBrushParams toBrushParams = embedUsedParams . ptParamsToUsedParams - updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' ) + noUpdatePointParams :: Record pointFields -> Record pointFields' + noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams + updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields' + updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b spline' <- bitraverseSpline - ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams u ) + ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u ) ( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint ) oldSpline ( mbAct, _ ) <- State.get case mbAct of Nothing -> return PreserveStroke - Just {} -> return $ UpdateStrokeTo $ stroke { strokeSpline = spline' } + Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' } | otherwise = return PreserveStroke updateSplineCurve - :: forall clo' pointParams brushFields + :: forall clo' pointParams brushFields pointParams' . ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) => PointData pointParams -> NamedBrush brushFields -> ( pointParams -> Record brushFields ) - -> ( Record brushFields -> pointParams -> pointParams ) + -> ( pointParams -> pointParams' ) + -> ( Record brushFields -> pointParams -> pointParams' ) -> Unique -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) -> State ( Maybe BrushWidgetActionState, Bool ) - ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) ) - updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do + ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) ) + updateSplineCurve _start brush toBrushParams noUpdatePointParams 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, @@ -979,24 +988,24 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont if canAct then do case curve of - line@( LineTo sp1 dat ) -> do + 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 + pure ( LineTo { curveEnd = sp1', curveData = invalidateCache dat } ) + 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 + pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } ) + 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 } ) + pure ( Bezier3To { 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' + return $ bimapCurve id ( \ _ -> fmap noUpdatePointParams ) curve' where crvIx = curveIndex ( curveData curve ) @@ -1011,14 +1020,14 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont inPointClickRange zoom c q updateSplinePoint - :: forall pointParams brushFields + :: forall pointParams brushFields pointParams' . NamedBrush brushFields -> ( pointParams -> Record brushFields ) - -> ( Record brushFields -> pointParams -> pointParams ) + -> ( Record brushFields -> pointParams -> pointParams' ) -> Unique -> PointIndex -> PointData pointParams -> State ( Maybe BrushWidgetActionState, Bool ) - ( PointData pointParams ) + ( PointData pointParams' ) updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do let currentBrushParams :: Record brushFields @@ -1069,4 +1078,4 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont case newBrushWidgetAction of Just a -> State.put ( Just a, True ) _ -> State.modify' ( \ ( a, _ ) -> ( a, False ) ) - pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt ) + pure ( set ( field @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt ) diff --git a/src/metabrushes/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs index 1822a31..ae33021 100644 --- a/src/metabrushes/MetaBrush/Asset/Brushes.hs +++ b/src/metabrushes/MetaBrush/Asset/Brushes.hs @@ -23,6 +23,8 @@ import GHC.Exts -- text import Data.Text ( Text ) +import qualified Data.Text as Text + ( toLower ) -- unordered-containers import Data.HashMap.Strict @@ -45,7 +47,7 @@ import qualified MetaBrush.Brush.Widget as Brush -------------------------------------------------------------------------------- lookupBrush :: Text -> Maybe SomeBrush -lookupBrush nm = HashMap.lookup nm brushes +lookupBrush nm = HashMap.lookup ( Text.toLower nm ) brushes -- | All brushes supported by this application. brushes :: HashMap Text SomeBrush @@ -57,7 +59,7 @@ brushes = HashMap.fromList -------------------------------------------------------------------------------- -type CircleBrushFields = '[ "r" ] +type CircleBrushFields = '[ "a" ] -- | A circular brush with the given radius. circle :: NamedBrush CircleBrushFields circle = @@ -67,7 +69,7 @@ circle = , brushWidget = Brush.SquareWidget } where - deflts = ℝ1 1 + deflts = ℝ1 10 {-# INLINE circle #-} type EllipseBrushFields = '[ "a", "b", "phi" ] @@ -81,11 +83,11 @@ ellipse = , brushWidget = Brush.RotatableRectangleWidget } where - deflts = ℝ3 1 1 0 + deflts = ℝ3 10 7 0 {-# INLINE ellipse #-} -type TearDropBrushFields = '[ "w", "h", "phi" ] --- | A tear-drop shape with the given width, height and angle of rotation. +type TearDropBrushFields = '[ "a", "b", "phi" ] +-- | A tear-drop shape with the given half-width, half-height and angle of rotation. tearDrop :: NamedBrush TearDropBrushFields tearDrop = NamedBrush @@ -94,5 +96,5 @@ tearDrop = , brushWidget = Brush.RotatableRectangleWidget } where - deflts = ℝ3 1 2.25 0 + deflts = ℝ3 10 7 0 {-# INLINE tearDrop #-} diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index 88d1bb2..264672f 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/src/metabrushes/MetaBrush/Brush.hs @@ -84,6 +84,7 @@ data NamedBrush brushFields where , DiffInterp 2 ℝ ( Length brushFields ) , DiffInterp 3 𝕀 ( Length brushFields ) , Show ( ℝ ( Length brushFields ) ) + , NFData ( ℝ ( Length brushFields ) ) ) => { brushName :: !Text , brushFunction :: !( BrushFunction brushFields ) diff --git a/src/metabrushes/MetaBrush/Draw.hs b/src/metabrushes/MetaBrush/Draw.hs index f942529..fea2a9d 100644 --- a/src/metabrushes/MetaBrush/Draw.hs +++ b/src/metabrushes/MetaBrush/Draw.hs @@ -17,6 +17,8 @@ import Data.Foldable ( for_ ) import GHC.Generics ( Generic ) +import GHC.Stack + ( HasCallStack ) import GHC.TypeLits ( Symbol ) @@ -58,7 +60,7 @@ import Math.Linear -- MetaBrush import MetaBrush.Brush - ( NamedBrush(..) ) + ( SomeBrush(..), NamedBrush (..), WithParams (defaultParams) ) import MetaBrush.Document import MetaBrush.Hover ( inPointClickRange ) @@ -91,10 +93,11 @@ anchorsAreComplementary -- drawing a stroke or to start a new one. getOrCreateDrawAnchor :: UniqueSupply + -> Maybe SomeBrush -> ℝ 2 -> Document -> STM ( Document, DrawAnchor ) -getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldContent, documentMetadata } ) = +getOrCreateDrawAnchor uniqueSupply mbBrush 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). @@ -116,17 +119,35 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte 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 ] ) ) - } + case mbBrush of + Nothing -> + let + newSpline :: StrokeSpline Open ( Record @Symbol '[] ) + newSpline = + Spline + { splineStart = PointData c ( MkR ℝ0 ) + , splineCurves = OpenCurves Empty + } + in + Stroke + { strokeSpline = newSpline + , strokeBrush = Nothing + } + Just ( SomeBrush ( b@( NamedBrush { brushFunction = fn } ) :: NamedBrush brushFields ) ) -> + let + newSpline :: StrokeSpline Open ( Record brushFields ) + newSpline = + Spline + { splineStart = PointData c ( MkR $ defaultParams fn ) + , splineCurves = OpenCurves Empty + } + in + Stroke + { strokeSpline = newSpline + , strokeBrush = Just b + } newSel = StrokePoints $ Map.singleton newStrokeUnique ( Set.singleton FirstPoint ) newMeta :: DocumentMetadata newMeta = @@ -199,7 +220,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte -> Just anchor _ -> Nothing -anchorPos :: DrawAnchor -> Document -> ℝ 2 +anchorPos :: HasCallStack => DrawAnchor -> Document -> ℝ 2 anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } ) ( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) = case Map.lookup anchorStroke strokes of diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index 13f21c5..b4f921a 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/src/metabrushes/MetaBrush/Records.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -11,7 +12,9 @@ import Data.Functor import Data.Kind ( Type, Constraint ) import Data.List - ( findIndex, intersperse ) + ( findIndex, intersperse, sortBy ) +import Data.Ord + ( comparing ) import Data.Typeable ( Typeable, eqT ) import Data.Type.Equality @@ -33,6 +36,9 @@ import Unsafe.Coerce import Data.Act ( Act(..), Torsor(..) ) +-- containers +import qualified Data.Map.Strict as Map + -- deepseq import Control.DeepSeq ( NFData(..) ) @@ -291,3 +297,144 @@ type family Elem k ks where Elem _ '[] = False Elem k ( k ': _ ) = True Elem k ( _ ': ks ) = Elem k ks + +-------------------------------------------------------------------------------- +-- Union of two records. + +data Union r1 r2 where + Union + :: forall r1r2_rocky r1 r2 l12_rocky + . ( l12_rocky ~ Length r1r2_rocky + , KnownSymbols r1r2_rocky + , Representable Double ( ℝ l12_rocky ) + , Show ( ℝ l12_rocky ) + , NFData ( ℝ l12_rocky ) + , DiffInterp 2 ℝ l12_rocky + , DiffInterp 3 𝕀 l12_rocky + ) + => { unionWith :: ( Double -> Double -> Double ) + -> Record r1 -> Record r2 -> Record r1r2_rocky + -- ^ union of two records + } -> Union r1 r2 + +{-# INLINE union #-} +union :: forall r1 r2 l1 l2 + . ( KnownSymbols r1, KnownSymbols r2 + , l1 ~ Length r1, l2 ~ Length r2 + , Representable Double ( ℝ l1 ) + , Representable Double ( ℝ l2 ) + , Show ( ℝ l1 ) + , Show ( ℝ l2 ) + , NFData ( ℝ l2 ) + , DiffInterp 2 ℝ l2 + , DiffInterp 3 𝕀 l2 + ) + => Union r1 r2 +union + -- Shortcut when the two rows are equal. + | Just Refl <- eqT @r1 @r2 + = Union { unionWith = \ f ( MkR l ) ( MkR r ) -> MkR @Symbol @r1 ( tabulate $ \ i -> f ( index l i ) ( index r i ) ) } + | otherwise + = doUnion @r1 @r2 \ ( _ :: Proxy# r1r2 ) idxs -> + let + unionWith :: ( Double -> Double -> Double ) + -> Record r1 -> Record r2 -> Record r1r2 + unionWith f = \ ( MkR r1 ) ( MkR r2 ) -> MkR $ tabulate $ \ i -> + case idxs ! i of + InBoth i1 i2 -> f ( index r1 i1 ) ( index r2 i2 ) + InL i1 -> index r1 i1 + InR i2 -> index r2 i2 + in Union { unionWith } + + +data LR l r + = InL !l + | InR !r + | InBoth !l !r + deriving stock ( Eq, Show ) + +bimapLR :: ( l1 -> l2 ) -> ( r1 -> r2 ) -> LR l1 r1 -> LR l2 r2 +bimapLR f g = \case + InL l -> InL ( f l ) + InR r -> InR ( g r ) + InBoth l r -> InBoth ( f l ) ( g r ) + +instance ( Ord l, Ord r ) => Ord ( LR l r ) where + compare a b = compare ( getL a, getR a ) ( getL b, getR b ) + where + getL :: LR l r -> Maybe l + getL ( InL l ) = Just l + getL ( InBoth l _ ) = Just l + getL ( InR {} ) = Nothing + getR :: LR l r -> Maybe r + getR ( InL {} ) = Nothing + getR ( InBoth _ r ) = Just r + getR ( InR r ) = Just r + +{-# INLINE doUnion #-} +doUnion + :: forall r1 r2 l1 l2 kont + . ( KnownSymbols r1, KnownSymbols r2 + , l1 ~ Length r1, l2 ~ Length r2 + ) + => ( forall r1r2 l12. + ( KnownSymbols r1r2, l12 ~ Length r1r2 + , DiffInterp 2 ℝ l12 + , DiffInterp 3 𝕀 l12 + , Representable Double ( ℝ l12 ) + , Show ( ℝ l12 ) + , NFData ( ℝ l12 ) + ) + => Proxy# r1r2 -> Vec l12 ( LR ( Fin l1 ) ( Fin l2 ) ) -> kont ) + -> kont +doUnion k = + case knownSymbols @r1 `unionLists` knownSymbols @r2 of + + [ ] + | ( _ :: Proxy# r1r2 ) <- proxy# @'[ ] + , Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 ) + -> k @r1r2 proxy# + ( Vec [] ) + + [ ( f1, i1 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1 ] + -> k @r1r2 proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1 ] ) + + [ ( f1, i1 ), ( f2, i2 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2 ] + -> k @r1r2 proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2 ] ) + + [ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3 ] + -> k @r1r2 proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3 ] ) + + [ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ), ( f4, i4 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + , SomeSymbol @f4 _ <- someSymbolVal ( Text.unpack f4 ) + , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3, f4 ] + -> k @r1r2 proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3, i4 ] ) + + other -> error $ "Union not defined in dimension " ++ show ( length other ) + +unionLists :: forall k. Ord k => [ k ] -> [ k ] -> [ ( k, LR Word Word ) ] +unionLists l r = sortBy ( comparing snd ) + $ Map.toList + $ Map.unionWith f + ( Map.fromList [ ( k, InL i ) | k <- l | i <- [ 0 .. ] ] ) + ( Map.fromList [ ( k, InR i ) | k <- r | i <- [ 0 .. ] ] ) + where + f :: LR Word Word -> LR Word Word -> LR Word Word + f ( InL i ) ( InR j ) = InBoth i j + f _ _ = error "unionList: internal error" diff --git a/src/metabrushes/MetaBrush/Stroke.hs b/src/metabrushes/MetaBrush/Stroke.hs index b0b0ea7..7eac60f 100644 --- a/src/metabrushes/MetaBrush/Stroke.hs +++ b/src/metabrushes/MetaBrush/Stroke.hs @@ -14,8 +14,6 @@ import Data.Foldable ( foldr' ) import Data.Functor.Identity ( Identity(..) ) -import Data.Typeable - ( Typeable ) import GHC.Generics ( Generic, Generic1 ) import GHC.Stack @@ -97,7 +95,7 @@ data PointData params { pointCoords :: !( ℝ 2 ) , brushParams :: !params } - deriving stock ( Show, Generic ) + deriving stock ( Show, Generic, Functor, Foldable, Traversable ) deriving anyclass NFData -- | Data attached to each curve in a spline. @@ -141,14 +139,11 @@ type StrokeSpline clo brushParams = data Stroke where Stroke - :: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] ) - . ( KnownSplineType clo - , pointParams ~ Record pointFields - , PointFields pointFields, Typeable pointFields - ) + :: forall clo ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] ) + . ( KnownSplineType clo , PointFields pointFields ) => { strokeBrush :: !( Maybe ( NamedBrush brushFields ) ) - , strokeSpline :: !( StrokeSpline clo pointParams ) + , strokeSpline :: !( StrokeSpline clo ( Record pointFields ) ) } -> Stroke deriving stock instance Show Stroke