From 9ff25a25aa0e9f5da595947a109467ad80a68428 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 29 Aug 2024 01:46:50 +0200 Subject: [PATCH] cleanups --- MetaBrush.cabal | 4 +- brush-strokes/src/lib/Math/Differentiable.hs | 4 +- src/app/MetaBrush/Document/Selection.hs | 4 +- src/app/MetaBrush/Render/Document.hs | 8 ++- src/metabrushes/MetaBrush/Asset/Brushes.hs | 11 +--- src/metabrushes/MetaBrush/Brush.hs | 29 ++++++---- src/metabrushes/MetaBrush/Records.hs | 58 ++++---------------- 7 files changed, 42 insertions(+), 76 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 69eb3e2..f1d355b 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -135,7 +135,7 @@ common extras , stm ^>= 2.5.0.0 , text - ^>= 2.1.1 + >= 2.0 && < 3 , unordered-containers >= 0.2.11 && < 0.3 , waargonaut @@ -151,7 +151,7 @@ common gtk , gi-gdk >= 4.0.2 && < 4.1 , gi-gio - >= 2.0.27 && < 2.1 + >= 2.0.34 && < 2.1 , gi-glib >= 2.0.23 && < 2.1 , gi-gobject diff --git a/brush-strokes/src/lib/Math/Differentiable.hs b/brush-strokes/src/lib/Math/Differentiable.hs index 8c2c489..8196803 100644 --- a/brush-strokes/src/lib/Math/Differentiable.hs +++ b/brush-strokes/src/lib/Math/Differentiable.hs @@ -38,11 +38,13 @@ class ( Module ( I i Double ) ( T ( I i u ) ) , HasChainRule ( I i Double ) k ( I i u ) , Traversable ( D k u ) + , Representable ( I i Double ) ( I i u ) ) => Differentiable k i u instance ( Module ( I i Double ) ( T ( I i u ) ) , HasChainRule ( I i Double ) k ( I i u ) , Traversable ( D k u ) + , Representable ( I i Double ) ( I i u ) ) => Differentiable k i u type DiffInterp :: Nat -> k -> Nat -> Constraint @@ -55,7 +57,6 @@ class , Transcendental ( D k u ( I i Double ) ) , Applicative ( D k u ) , Representable ( I i Double ) ( I i u ) - , RepDim ( I i u ) ~ RepDim u ) => DiffInterp k i u instance ( Differentiable k i u @@ -66,5 +67,4 @@ instance , Transcendental ( D k u ( I i Double ) ) , Applicative ( D k u ) , Representable ( I i Double ) ( I i u ) - , RepDim ( I i u ) ~ RepDim u ) => DiffInterp k i u diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 1d8b9ff..812b48c 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -120,7 +120,7 @@ import MetaBrush.Document import {-# SOURCE #-} MetaBrush.Document.Update ( DocChange(..) ) import MetaBrush.Records - ( Record + ( Record(..) , Intersection(..), intersect ) import MetaBrush.Unique @@ -890,7 +890,7 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } | otherwise -> case intersect @pointFields @brushFields of Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do - let embedUsedParams = updateBrushParams ( defaultParams $ brushFunction brush ) + let embedUsedParams = updateBrushParams ( MkR $ defaultParams $ brushFunction brush ) toBrushParams = embedUsedParams . ptParamsToUsedParams updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' ) spline' <- updateSpline brush toBrushParams updatePointParams strokeUnique spline0 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 991b5b5..f92081d 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -11,6 +11,8 @@ import Control.Monad ( guard, when, unless ) import Control.Monad.ST ( RealWorld, ST ) +import Data.Coerce + ( coerce ) import Data.Fixed ( mod' ) import Data.Foldable @@ -319,12 +321,12 @@ strokeRenderData rootAlgo mbCuspOptions fitParams { inject2 , project1 = toUsedParams :: Record pointFields -> Record usedFields } -> do - let embedUsedParams = inject2 brush_defaults + let embedUsedParams = inject2 $ MkR brush_defaults -- Compute the outline using the brush function. ( outline, fitPts, cusps ) <- computeStrokeOutline @clo rootAlgo mbCuspOptions fitParams - ( toUsedParams . brushParams ) embedUsedParams + ( coerce toUsedParams . brushParams ) ( coerce embedUsedParams ) brush spline pure $ StrokeWithOutlineRenderData @@ -332,7 +334,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams , strokeOutlineData = ( outline, fitPts, cusps ) , strokeBrushFunction = \ params -> - let brushParams = embedUsedParams $ toUsedParams params + let MkR brushParams = embedUsedParams $ toUsedParams params shape = fun @Double brushBaseShape brushParams -- TODO: remove this logic which is duplicated -- from elsewhere. The type should make it diff --git a/src/metabrushes/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs index 013da58..1822a31 100644 --- a/src/metabrushes/MetaBrush/Asset/Brushes.hs +++ b/src/metabrushes/MetaBrush/Asset/Brushes.hs @@ -41,8 +41,6 @@ import MetaBrush.Brush ( NamedBrush(..), SomeBrush(..), WithParams(..) ) import qualified MetaBrush.Brush.Widget as Brush ( Widget(..) ) -import MetaBrush.Records - ( Record(MkR) ) -------------------------------------------------------------------------------- @@ -69,8 +67,7 @@ circle = , brushWidget = Brush.SquareWidget } where - deflts :: Record CircleBrushFields - deflts = MkR ( ℝ1 1 ) + deflts = ℝ1 1 {-# INLINE circle #-} type EllipseBrushFields = '[ "a", "b", "phi" ] @@ -84,8 +81,7 @@ ellipse = , brushWidget = Brush.RotatableRectangleWidget } where - deflts :: Record EllipseBrushFields - deflts = MkR ( ℝ3 1 1 0 ) + deflts = ℝ3 1 1 0 {-# INLINE ellipse #-} type TearDropBrushFields = '[ "w", "h", "phi" ] @@ -98,6 +94,5 @@ tearDrop = , brushWidget = Brush.RotatableRectangleWidget } where - deflts :: Record TearDropBrushFields - deflts = MkR ( ℝ3 1 2.25 0 ) + deflts = ℝ3 1 2.25 0 {-# INLINE tearDrop #-} diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index 912201d..fdea194 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/src/metabrushes/MetaBrush/Brush.hs @@ -24,6 +24,8 @@ import GHC.TypeLits ( Symbol, someSymbolVal , SomeSymbol(..) ) +import GHC.TypeNats + ( Nat ) -- deepseq import Control.DeepSeq @@ -59,11 +61,11 @@ import MetaBrush.Serialisable -------------------------------------------------------------------------------- -- | A brush, with default parameter values. -type WithParams :: Type -> Type -data WithParams params = +type WithParams :: Nat -> Type +data WithParams nbParams = WithParams - { defaultParams :: params - , withParams :: Brush params + { defaultParams :: ℝ nbParams + , withParams :: Brush nbParams } -------------------------------------------------------------------------------- @@ -71,7 +73,7 @@ data WithParams params = -- | A brush function: a function from a record of parameters to a closed spline. type BrushFunction :: [ Symbol ] -> Type type BrushFunction brushFields = - WithParams ( Record brushFields ) + WithParams ( Length brushFields ) type NamedBrush :: [ Symbol ] -> Type data NamedBrush brushFields where @@ -79,8 +81,9 @@ data NamedBrush brushFields where :: forall brushFields . ( KnownSymbols brushFields , Representable Double ( ℝ ( Length brushFields ) ) - , DiffInterp 2 () ( ℝ ( Length brushFields ) ) - , DiffInterp 3 𝕀 ( ℝ ( Length brushFields ) ) + , DiffInterp 2 ℝ ( Length brushFields ) + , DiffInterp 3 𝕀 ( Length brushFields ) + , Show ( ℝ ( Length brushFields ) ) ) => { brushName :: !Text , brushFunction :: !( BrushFunction brushFields ) @@ -118,19 +121,23 @@ type PointFields :: [ Symbol ] -> Constraint class ( KnownSymbols pointFields, Typeable pointFields , Serialisable ( Record pointFields ) , Show ( Record pointFields ) + , Show ( ℝ ( Length pointFields ) ) , NFData ( Record pointFields ) , Representable Double ( ℝ ( Length pointFields ) ) - , DiffInterp 2 () ( ℝ ( Length pointFields ) ) - , DiffInterp 3 𝕀 ( ℝ ( Length pointFields ) ) + , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields + , DiffInterp 2 ℝ ( Length pointFields ) + , DiffInterp 3 𝕀 ( Length pointFields ) ) => PointFields pointFields where { } instance ( KnownSymbols pointFields, Typeable pointFields , Serialisable ( Record pointFields ) , Show ( Record pointFields ) + , Show ( ℝ ( Length pointFields ) ) , NFData ( Record pointFields ) , Representable Double ( ℝ ( Length pointFields ) ) - , DiffInterp 2 () ( ℝ ( Length pointFields ) ) - , DiffInterp 3 𝕀 ( ℝ ( Length pointFields ) ) + , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields + , DiffInterp 2 ℝ ( Length pointFields ) + , DiffInterp 3 𝕀 ( Length pointFields ) ) => PointFields pointFields where { } diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index 86220aa..13f21c5 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/src/metabrushes/MetaBrush/Records.hs @@ -48,7 +48,6 @@ import qualified Data.Text as Text ( pack, unpack ) -- MetaBrush -import Math.Algebra.Dual import Math.Differentiable import Math.Interval import Math.Linear @@ -99,19 +98,6 @@ deriving via ( T ( ℝ ( Length ks ) ) ) instance Module Double ( T ( ℝ ( Length ks ) ) ) => Module Double ( T ( Record ks ) ) -deriving via ( T ( 𝕀ℝ ( Length ks ) ) ) - instance Semigroup ( T ( 𝕀ℝ ( Length ks ) ) ) - => Semigroup ( T ( 𝕀 ( Record ks ) ) ) -deriving via ( T ( 𝕀ℝ ( Length ks ) ) ) - instance Monoid ( T ( 𝕀ℝ ( Length ks ) ) ) - => Monoid ( T ( 𝕀 ( Record ks ) ) ) -deriving via ( T ( 𝕀ℝ ( Length ks ) ) ) - instance Group ( T ( 𝕀ℝ ( Length ks ) ) ) - => Group ( T ( 𝕀 ( Record ks ) ) ) -deriving via ( T ( 𝕀ℝ ( Length ks ) ) ) - instance Module ( 𝕀 Double ) ( T ( 𝕀ℝ ( Length ks ) ) ) - => Module ( 𝕀 Double ) ( T ( 𝕀 ( Record ks ) ) ) - instance ( Act ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) ) , Semigroup ( T ( ℝ ( Length ks ) ) ) ) => Act ( T ( Record ks ) ) ( Record ks ) where @@ -121,39 +107,11 @@ instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) ) => Torsor ( T ( Record ks ) ) ( Record ks ) where MkR g --> MkR a = T $ MkR $ unT $ g --> a -instance ( Act ( T ( 𝕀ℝ ( Length ks ) ) ) ( 𝕀ℝ ( Length ks ) ) - , Semigroup ( T ( 𝕀ℝ ( Length ks ) ) ) ) - => Act ( T ( 𝕀 ( Record ks ) ) ) ( 𝕀 ( Record ks ) ) where - T ( 𝕀 ( MkR g_lo ) ( MkR g_hi ) ) - • 𝕀 ( MkR a_lo ) ( MkR a_hi ) - = case T ( 𝕀 g_lo g_hi ) • 𝕀 a_lo a_hi of - 𝕀 b_lo b_hi -> - 𝕀 ( MkR b_lo ) ( MkR b_hi ) -instance ( Torsor ( T ( 𝕀ℝ ( Length ks ) ) ) ( 𝕀ℝ ( Length ks ) ) - , Group ( T ( 𝕀ℝ ( Length ks ) ) ) ) - => Torsor ( T ( 𝕀 ( Record ks ) ) ) ( 𝕀 ( Record ks ) ) where - 𝕀 ( MkR a_lo ) ( MkR a_hi ) - --> 𝕀 ( MkR b_lo ) ( MkR b_hi ) - = case 𝕀 a_lo a_hi --> 𝕀 b_lo b_hi of - T ( 𝕀 c_lo c_hi ) -> - T ( 𝕀 ( MkR c_lo ) ( MkR c_hi ) ) - type instance RepDim ( Record ks ) = Length ks deriving newtype instance ( KnownNat (Length ks) , Representable r ( ℝ ( Length ks ) ) ) => Representable r ( Record ks ) -type instance D k ( Record ks ) = D k ( ℝ ( Length ks ) ) -deriving newtype instance HasChainRule Double 2 ( ℝ ( Length ks ) ) - => HasChainRule Double 2 ( Record ks ) - -deriving via 𝕀ℝ ( Length ks ) - instance HasChainRule ( 𝕀 Double ) 2 ( 𝕀ℝ ( Length ks ) ) - => HasChainRule ( 𝕀 Double ) 2 ( 𝕀 ( Record ks ) ) -deriving via 𝕀ℝ ( Length ks ) - instance HasChainRule ( 𝕀 Double ) 3 ( 𝕀ℝ ( Length ks ) ) - => HasChainRule ( 𝕀 Double ) 3 ( 𝕀 ( Record ks ) ) - -------------------------------------------------------------------------------- type Length :: [ k ] -> Nat @@ -180,8 +138,10 @@ intersect :: forall r1 r2 l1 l2 , l1 ~ Length r1, l2 ~ Length r2 , Representable Double ( ℝ l1 ) , Representable Double ( ℝ l2 ) - , Differentiable 2 () ( ℝ l2 ) - , Differentiable 3 𝕀 ( ℝ l2 ) + , Show ( ℝ l1 ) + , Show ( ℝ l2 ) + , Differentiable 2 ℝ l2 + , Differentiable 3 𝕀 l2 ) => Intersection r1 r2 intersect @@ -211,8 +171,9 @@ data Intersection r1 r2 where . ( l12 ~ Length r1r2 , KnownSymbols r1r2 , Representable Double ( ℝ l12 ) - , Differentiable 2 () ( ℝ l12 ) - , Differentiable 3 𝕀 ( ℝ l12 ) + , Show ( ℝ l12 ) + , Differentiable 2 ℝ l12 + , Differentiable 3 𝕀 l12 ) => { project1 :: Record r1 -> Record r1r2 -- ^ project out fields present in both rows @@ -237,9 +198,10 @@ doIntersection => ( forall r1r2 l12. ( r1r2 ~ Intersect r1 r2 , KnownSymbols r1r2, l12 ~ Length r1r2 - , Differentiable 2 () ( ℝ l12 ) - , Differentiable 3 𝕀 ( ℝ l12 ) + , Differentiable 2 ℝ l12 + , Differentiable 3 𝕀 l12 , Representable Double ( ℝ l12 ) + , Show ( ℝ l12 ) ) => Proxy# r1r2 -> Vec l12 ( Fin l1 ) -> Vec l12 ( Fin l2 ) -> kont ) -> kont