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) $
setEnv "GDK_SCALE" "2"
setEnv "GSK_RENDERER" "cairo"
setEnv "GSK_RENDERER" "vulkan"
---------------------------------------------------------
-- Run GTK application

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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,16 +119,34 @@ 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 =
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 :: 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 )
newMeta :: DocumentMetadata
@ -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

View file

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

View file

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