improvements to brush params when changing brush

This commit is contained in:
sheaf 2024-10-12 15:41:52 +02:00
parent c1d6dd4151
commit 1a8f4b5f5d
15 changed files with 286 additions and 68 deletions

View file

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

View file

@ -213,8 +213,8 @@ tearDropBrushFn :: forall {t} (i :: t) k nbParams
tearDropBrushFn _ mkI1 mkI2 = tearDropBrushFn _ mkI1 mkI2 =
D \ params -> D \ params ->
let w, h :: D k nbParams ( I i Double ) let w, h :: D k nbParams ( I i Double )
w = runD ( var @_ @k ( Fin 1 ) ) params w = 2 * runD ( var @_ @k ( Fin 1 ) ) params
h = runD ( var @_ @k ( Fin 2 ) ) params h = 2 * runD ( var @_ @k ( Fin 2 ) ) params
mkPt :: Double -> Double -> D k nbParams ( I i 2 ) mkPt :: Double -> Double -> D k nbParams ( I i 2 )
mkPt x y mkPt x y
-- 1. translate the teardrop so that the centre of mass is at the origin -- 1. translate the teardrop so that the centre of mass is at the origin

View file

@ -25,6 +25,8 @@ module Math.Bezier.Stroke
where where
-- base -- base
import Prelude
hiding ( unzip )
import Control.Arrow import Control.Arrow
( first, (***) ) ( first, (***) )
import Control.Monad import Control.Monad
@ -40,7 +42,7 @@ import Data.Fixed
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import Data.Functor import Data.Functor
( (<&>) ) ( (<&>), unzip )
import Data.Functor.Identity import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.List import Data.List
@ -48,7 +50,7 @@ import Data.List
import Data.List.NonEmpty import Data.List.NonEmpty
( NonEmpty ) ( NonEmpty )
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
( cons, singleton, unzip ) ( cons, singleton )
import Data.Maybe import Data.Maybe
( fromMaybe, isJust, listToMaybe, mapMaybe ) ( fromMaybe, isJust, listToMaybe, mapMaybe )
import Data.Proxy import Data.Proxy
@ -721,7 +723,7 @@ joinBetweenOffsets
= let = let
pcs, lastAndRest :: Maybe ( SplinePts Open ) pcs, lastAndRest :: Maybe ( SplinePts Open )
( pcs, lastAndRest ) ( pcs, lastAndRest )
= NE.unzip = unzip
$ ( discardCurveData *** discardCurveData ) $ ( discardCurveData *** discardCurveData )
. splitSplineAt ( i2 - i1 ) . splitSplineAt ( i2 - i1 )
<$> dropCurves i1 openSpline <$> dropCurves i1 openSpline

View file

@ -9,7 +9,7 @@ module Math.Root.Isolation.Utils
import Prelude hiding ( unzip ) import Prelude hiding ( unzip )
import Data.Foldable import Data.Foldable
( toList ) ( toList )
import Data.List.NonEmpty import Data.Functor
( unzip ) ( unzip )
-- MetaBrush -- MetaBrush

View file

@ -214,6 +214,7 @@ runApplication application = do
modifiersTVar <- STM.newTVarIO Set.empty modifiersTVar <- STM.newTVarIO Set.empty
toolTVar <- STM.newTVarIO Selection toolTVar <- STM.newTVarIO Selection
modeTVar <- STM.newTVarIO PathMode modeTVar <- STM.newTVarIO PathMode
selectedBrushTVar <- STM.newTVarIO Nothing
debugTVar <- STM.newTVarIO False debugTVar <- STM.newTVarIO False
partialPathTVar <- STM.newTVarIO Nothing partialPathTVar <- STM.newTVarIO Nothing
fileBarTabsTVar <- STM.newTVarIO Map.empty fileBarTabsTVar <- STM.newTVarIO Map.empty
@ -479,7 +480,7 @@ runApplication application = do
--------------------------------------------------------- ---------------------------------------------------------
-- Brushes view -- Brushes view
brushesListView <- newBrushView window DragBrush brushesListView <- newBrushView window variables DragBrush
GTK.scrolledWindowSetChild GTK.scrolledWindowSetChild
( brushesScrolledWindow panelsBar ) ( brushesScrolledWindow panelsBar )
( Just brushesListView ) ( Just brushesListView )

View file

@ -939,13 +939,14 @@ instance HandleAction MouseClick where
Pen -> do Pen -> do
-- Pen tool in path mode: start or continue a drawing operation. -- Pen tool in path mode: start or continue a drawing operation.
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
mbSelBrush <- STM.readTVar selectedBrushTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
case mbPartialPath of case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do Nothing -> do
( newDocument, drawAnchor ) <- ( newDocument, drawAnchor ) <-
getOrCreateDrawAnchor uniqueSupply pos doc getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc
let firstPos = anchorPos drawAnchor doc let firstPos = anchorPos drawAnchor newDocument
STM.writeTVar partialPathTVar STM.writeTVar partialPathTVar
( Just $ PartialPath ( Just $ PartialPath
{ partialPathAnchor = drawAnchor { partialPathAnchor = drawAnchor
@ -1159,6 +1160,7 @@ instance HandleAction MouseRelease where
Pen -> case mode of Pen -> case mode of
PathMode -> do PathMode -> do
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
mbSelBrush <- STM.readTVar selectedBrushTVar
case mbPartialPath of case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor. -- Normal pen mode mouse click should have created an anchor.
-- If no anchor exists, then just ignore the mouse release event. -- 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 ) = ( holdPos, Just $ ( pos --> holdPos :: T ( 2 ) ) holdPos, Just pos )
| otherwise | otherwise
= ( pos, Nothing, Nothing ) = ( pos, Nothing, Nothing )
( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply mbSelBrush pathPoint doc
if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path. -- Close path.
then do then do

View file

@ -58,6 +58,8 @@ import MetaBrush.Action
( BrushWidgetActionState ) ( BrushWidgetActionState )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Brush
( SomeBrush )
import MetaBrush.Document.Diff import MetaBrush.Document.Diff
( DragMoveSelect ) ( DragMoveSelect )
import MetaBrush.Draw import MetaBrush.Draw
@ -74,6 +76,7 @@ import MetaBrush.Unique
( UniqueSupply, Unique ) ( UniqueSupply, Unique )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data UIElements data UIElements
@ -113,6 +116,8 @@ data Variables
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'. -- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
, listModelUpToDateTMVar :: !( STM.TMVar () ) , listModelUpToDateTMVar :: !( STM.TMVar () )
, selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( 2 ) ) ) , mousePosTVar :: !( STM.TVar ( Maybe ( 2 ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) )

View file

@ -175,6 +175,7 @@ getDocumentRender
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
, Just p1 <- mbMousePos , Just p1 <- mbMousePos
, p0 /= p1 , p0 /= p1
-- Non-trivial drag in progress.
, let , let
alternateMode :: Bool alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
@ -197,6 +198,7 @@ getDocumentRender
| otherwise | otherwise
= ( mbMousePos, Nothing ) = ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint , Just finalPoint <- mbFinalPoint
-- Path drawing operation in progress.
, let , let
previewSpline :: Spline Open () ( PointData () ) previewSpline :: Spline Open () ( PointData () )
previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) () previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()

View file

@ -33,27 +33,46 @@ import qualified GI.Gtk as GTK
import qualified Data.GI.Base as GI import qualified Data.GI.Base as GI
import qualified Data.GI.Base.GValue as GI import qualified Data.GI.Base.GValue as GI
-- stm
import qualified Control.Concurrent.STM as STM
-- text -- text
import Data.Text import Data.Text
( Text ) ( Text )
import qualified Data.Text as Text import qualified Data.Text as Text
( toLower ) ( null, toLower )
-- unordered-containers -- unordered-containers
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
-- MetaBrush -- MetaBrush
import MetaBrush.Application.Context
( Variables(selectedBrushTVar) )
import MetaBrush.Brush
( SomeBrush )
import qualified MetaBrush.Asset.Brushes as Brushes import qualified MetaBrush.Asset.Brushes as Brushes
( 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 -- -- GTK StringList --
-------------------- --------------------
-- | Create a new 'GTK.StringList' with 'GTK.SingleSelection' to hold -- | Create a new 'GTK.StringList' with 'GTK.SingleSelection' to hold
-- the given brush names. -- the given brush names.
newBrushListModel :: [ Text ] -> IO GTK.SingleSelection newBrushListModel :: Variables -> [ Text ] -> IO GTK.SingleSelection
newBrushListModel brushNames = do newBrushListModel vars brushNames = do
stringList <- GTK.stringListNew ( Just brushNames ) stringList <- GTK.stringListNew ( Just brushNames )
@ -61,6 +80,17 @@ newBrushListModel brushNames = do
GI.withNewObject slPtr $ \ slCopy -> GI.withNewObject slPtr $ \ slCopy ->
GTK.singleSelectionNew ( Just 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 return selectionModel
------------------ ------------------
@ -70,12 +100,13 @@ newBrushListModel brushNames = do
-- | Create a new 'GTK.ListView' that displays brush names. -- | Create a new 'GTK.ListView' that displays brush names.
newBrushView :: Typeable dnd_data newBrushView :: Typeable dnd_data
=> GTK.ApplicationWindow => GTK.ApplicationWindow
-> Variables
-> ( Maybe Text -> dnd_data ) -> ( Maybe Text -> dnd_data )
-- ^ drag and drop data for the brush -- ^ drag and drop data for the brush
-> IO GTK.ListView -> 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 brushesListFactory <- GTK.signalListItemFactoryNew

View file

@ -52,7 +52,7 @@ import qualified Data.Set as Set
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
( field' ) ( field, field' )
-- groups -- groups
import Data.Group import Data.Group
@ -924,7 +924,9 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
zoom = documentZoom $ documentMetadata zoom = documentZoom $ documentMetadata
updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke 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 | strokeVisible
, not strokeLocked , not strokeLocked
-- If we have already started a widget action, only continue an action -- 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 } , case mbPrevAction of { Just act -> brushWidgetStrokeUnique act == u; Nothing -> True }
-- Don't touch strokes without brushes. -- Don't touch strokes without brushes.
, Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush , Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
= case intersect @pointFields @brushFields of , Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams }
Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do <- intersect @pointFields @brushFields
let embedUsedParams = updateBrushParams ( MkR $ defaultParams $ brushFunction brush ) , Union @pointFields' unionWith
<- union @pointFields @brushFields
= do let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
embedUsedParams = updateBrushParams defaultBrushParams
toBrushParams = embedUsedParams . ptParamsToUsedParams 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' <- spline' <-
bitraverseSpline bitraverseSpline
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams u ) ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint ) ( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint )
oldSpline oldSpline
( mbAct, _ ) <- State.get ( mbAct, _ ) <- State.get
case mbAct of case mbAct of
Nothing -> return PreserveStroke Nothing -> return PreserveStroke
Just {} -> return $ UpdateStrokeTo $ stroke { strokeSpline = spline' } Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
| otherwise | otherwise
= return PreserveStroke = return PreserveStroke
updateSplineCurve updateSplineCurve
:: forall clo' pointParams brushFields :: forall clo' pointParams brushFields pointParams'
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) . ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
=> PointData pointParams => PointData pointParams
-> NamedBrush brushFields -> NamedBrush brushFields
-> ( pointParams -> Record brushFields ) -> ( pointParams -> Record brushFields )
-> ( Record brushFields -> pointParams -> pointParams ) -> ( pointParams -> pointParams' )
-> ( Record brushFields -> pointParams -> pointParams' )
-> Unique -> Unique
-> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
-> State ( Maybe BrushWidgetActionState, Bool ) -> State ( Maybe BrushWidgetActionState, Bool )
( Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) ) ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
( mbAct, prevCurveAct ) <- State.get ( mbAct, prevCurveAct ) <- State.get
-- We can only perform a brush widget update if: -- We can only perform a brush widget update if:
-- - we aren't already updating another point, -- - we aren't already updating another point,
@ -979,24 +988,24 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
if canAct if canAct
then do then do
case curve of case curve of
line@( LineTo sp1 dat ) -> do LineTo sp1 dat -> do
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1 sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1
pure ( line { curveEnd = sp1', curveData = invalidateCache dat } ) pure ( LineTo { curveEnd = sp1', curveData = invalidateCache dat } )
bez2@( Bezier2To sp1 sp2 dat ) -> do Bezier2To sp1 sp2 dat -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1 sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2 sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2
pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } ) pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do Bezier3To sp1 sp2 sp3 dat -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1 sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2 sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3 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 else do
State.put ( mbAct, False ) State.put ( mbAct, False )
let curve' = if prevCurveAct let curve' = if prevCurveAct
then curve { curveData = invalidateCache $ curveData curve } then curve { curveData = invalidateCache $ curveData curve }
else curve else curve
return curve' return $ bimapCurve id ( \ _ -> fmap noUpdatePointParams ) curve'
where where
crvIx = curveIndex ( curveData curve ) crvIx = curveIndex ( curveData curve )
@ -1011,14 +1020,14 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
inPointClickRange zoom c q inPointClickRange zoom c q
updateSplinePoint updateSplinePoint
:: forall pointParams brushFields :: forall pointParams brushFields pointParams'
. NamedBrush brushFields . NamedBrush brushFields
-> ( pointParams -> Record brushFields ) -> ( pointParams -> Record brushFields )
-> ( Record brushFields -> pointParams -> pointParams ) -> ( Record brushFields -> pointParams -> pointParams' )
-> Unique -> PointIndex -> Unique -> PointIndex
-> PointData pointParams -> PointData pointParams
-> State ( Maybe BrushWidgetActionState, Bool ) -> State ( Maybe BrushWidgetActionState, Bool )
( PointData pointParams ) ( PointData pointParams' )
updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do
let let
currentBrushParams :: Record brushFields currentBrushParams :: Record brushFields
@ -1069,4 +1078,4 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
case newBrushWidgetAction of case newBrushWidgetAction of
Just a -> State.put ( Just a, True ) Just a -> State.put ( Just a, True )
_ -> State.modify' ( \ ( a, _ ) -> ( a, False ) ) _ -> State.modify' ( \ ( a, _ ) -> ( a, False ) )
pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt ) pure ( set ( field @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )

View file

@ -23,6 +23,8 @@ import GHC.Exts
-- text -- text
import Data.Text import Data.Text
( Text ) ( Text )
import qualified Data.Text as Text
( toLower )
-- unordered-containers -- unordered-containers
import Data.HashMap.Strict import Data.HashMap.Strict
@ -45,7 +47,7 @@ import qualified MetaBrush.Brush.Widget as Brush
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
lookupBrush :: Text -> Maybe SomeBrush lookupBrush :: Text -> Maybe SomeBrush
lookupBrush nm = HashMap.lookup nm brushes lookupBrush nm = HashMap.lookup ( Text.toLower nm ) brushes
-- | All brushes supported by this application. -- | All brushes supported by this application.
brushes :: HashMap Text SomeBrush brushes :: HashMap Text SomeBrush
@ -57,7 +59,7 @@ brushes = HashMap.fromList
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type CircleBrushFields = '[ "r" ] type CircleBrushFields = '[ "a" ]
-- | A circular brush with the given radius. -- | A circular brush with the given radius.
circle :: NamedBrush CircleBrushFields circle :: NamedBrush CircleBrushFields
circle = circle =
@ -67,7 +69,7 @@ circle =
, brushWidget = Brush.SquareWidget , brushWidget = Brush.SquareWidget
} }
where where
deflts = 1 1 deflts = 1 10
{-# INLINE circle #-} {-# INLINE circle #-}
type EllipseBrushFields = '[ "a", "b", "phi" ] type EllipseBrushFields = '[ "a", "b", "phi" ]
@ -81,11 +83,11 @@ ellipse =
, brushWidget = Brush.RotatableRectangleWidget , brushWidget = Brush.RotatableRectangleWidget
} }
where where
deflts = 3 1 1 0 deflts = 3 10 7 0
{-# INLINE ellipse #-} {-# INLINE ellipse #-}
type TearDropBrushFields = '[ "w", "h", "phi" ] type TearDropBrushFields = '[ "a", "b", "phi" ]
-- | A tear-drop shape with the given width, height and angle of rotation. -- | A tear-drop shape with the given half-width, half-height and angle of rotation.
tearDrop :: NamedBrush TearDropBrushFields tearDrop :: NamedBrush TearDropBrushFields
tearDrop = tearDrop =
NamedBrush NamedBrush
@ -94,5 +96,5 @@ tearDrop =
, brushWidget = Brush.RotatableRectangleWidget , brushWidget = Brush.RotatableRectangleWidget
} }
where where
deflts = 3 1 2.25 0 deflts = 3 10 7 0
{-# INLINE tearDrop #-} {-# INLINE tearDrop #-}

View file

@ -84,6 +84,7 @@ data NamedBrush brushFields where
, DiffInterp 2 ( Length brushFields ) , DiffInterp 2 ( Length brushFields )
, DiffInterp 3 𝕀 ( Length brushFields ) , DiffInterp 3 𝕀 ( Length brushFields )
, Show ( ( Length brushFields ) ) , Show ( ( Length brushFields ) )
, NFData ( ( Length brushFields ) )
) )
=> { brushName :: !Text => { brushName :: !Text
, brushFunction :: !( BrushFunction brushFields ) , brushFunction :: !( BrushFunction brushFields )

View file

@ -17,6 +17,8 @@ import Data.Foldable
( for_ ) ( for_ )
import GHC.Generics import GHC.Generics
( Generic ) ( Generic )
import GHC.Stack
( HasCallStack )
import GHC.TypeLits import GHC.TypeLits
( Symbol ) ( Symbol )
@ -58,7 +60,7 @@ import Math.Linear
-- MetaBrush -- MetaBrush
import MetaBrush.Brush import MetaBrush.Brush
( NamedBrush(..) ) ( SomeBrush(..), NamedBrush (..), WithParams (defaultParams) )
import MetaBrush.Document import MetaBrush.Document
import MetaBrush.Hover import MetaBrush.Hover
( inPointClickRange ) ( inPointClickRange )
@ -91,10 +93,11 @@ anchorsAreComplementary
-- drawing a stroke or to start a new one. -- drawing a stroke or to start a new one.
getOrCreateDrawAnchor getOrCreateDrawAnchor
:: UniqueSupply :: UniqueSupply
-> Maybe SomeBrush
-> 2 -> 2
-> Document -> Document
-> STM ( Document, DrawAnchor ) -> 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 -- Deselect all points, and try to find a valid anchor for drawing
-- (a path start/end point at mouse click point). -- (a path start/end point at mouse click point).
@ -116,16 +119,34 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
Right {} -> do Right {} -> do
newStrokeUnique <- runReaderT freshUnique uniqueSupply newStrokeUnique <- runReaderT freshUnique uniqueSupply
let let
newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
newSpline =
Spline { splineStart = PointData c ( MkR 0 )
, splineCurves = OpenCurves Empty
}
newStroke :: Stroke newStroke :: Stroke
newStroke = newStroke =
case mbBrush of
Nothing ->
let
newSpline :: StrokeSpline Open ( Record @Symbol '[] )
newSpline =
Spline
{ splineStart = PointData c ( MkR 0 )
, splineCurves = OpenCurves Empty
}
in
Stroke Stroke
{ strokeSpline = newSpline { strokeSpline = newSpline
, strokeBrush = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) ) , 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 ) newSel = StrokePoints $ Map.singleton newStrokeUnique ( Set.singleton FirstPoint )
newMeta :: DocumentMetadata newMeta :: DocumentMetadata
@ -199,7 +220,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
-> Just anchor -> Just anchor
_ -> Nothing _ -> Nothing
anchorPos :: DrawAnchor -> Document -> 2 anchorPos :: HasCallStack => DrawAnchor -> Document -> 2
anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } ) anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } )
( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) = ( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) =
case Map.lookup anchorStroke strokes of case Map.lookup anchorStroke strokes of

View file

@ -1,4 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
@ -11,7 +12,9 @@ import Data.Functor
import Data.Kind import Data.Kind
( Type, Constraint ) ( Type, Constraint )
import Data.List import Data.List
( findIndex, intersperse ) ( findIndex, intersperse, sortBy )
import Data.Ord
( comparing )
import Data.Typeable import Data.Typeable
( Typeable, eqT ) ( Typeable, eqT )
import Data.Type.Equality import Data.Type.Equality
@ -33,6 +36,9 @@ import Unsafe.Coerce
import Data.Act import Data.Act
( Act(..), Torsor(..) ) ( Act(..), Torsor(..) )
-- containers
import qualified Data.Map.Strict as Map
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
( NFData(..) ) ( NFData(..) )
@ -291,3 +297,144 @@ type family Elem k ks where
Elem _ '[] = False Elem _ '[] = False
Elem k ( k ': _ ) = True Elem k ( k ': _ ) = True
Elem k ( _ ': ks ) = Elem k ks 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"

View file

@ -14,8 +14,6 @@ import Data.Foldable
( foldr' ) ( foldr' )
import Data.Functor.Identity import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.Typeable
( Typeable )
import GHC.Generics import GHC.Generics
( Generic, Generic1 ) ( Generic, Generic1 )
import GHC.Stack import GHC.Stack
@ -97,7 +95,7 @@ data PointData params
{ pointCoords :: !( 2 ) { pointCoords :: !( 2 )
, brushParams :: !params , brushParams :: !params
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic, Functor, Foldable, Traversable )
deriving anyclass NFData deriving anyclass NFData
-- | Data attached to each curve in a spline. -- | Data attached to each curve in a spline.
@ -141,14 +139,11 @@ type StrokeSpline clo brushParams =
data Stroke where data Stroke where
Stroke Stroke
:: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] ) :: forall clo ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
. ( KnownSplineType clo . ( KnownSplineType clo , PointFields pointFields )
, pointParams ~ Record pointFields
, PointFields pointFields, Typeable pointFields
)
=> =>
{ strokeBrush :: !( Maybe ( NamedBrush brushFields ) ) { strokeBrush :: !( Maybe ( NamedBrush brushFields ) )
, strokeSpline :: !( StrokeSpline clo pointParams ) , strokeSpline :: !( StrokeSpline clo ( Record pointFields ) )
} }
-> Stroke -> Stroke
deriving stock instance Show Stroke deriving stock instance Show Stroke