hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

cleanups

Browse source
This commit is contained in:
sheaf 2024-08-29 01:46:50 +02:00
parent 2bae92dc5e
commit 9ff25a25aa
7 changed files with 42 additions and 76 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
MetaBrush.cabal
View file

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

4
brush-strokes/src/lib/Math/Differentiable.hs
View file

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

4
src/app/MetaBrush/Document/Selection.hs
View file

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

8
src/app/MetaBrush/Render/Document.hs
View file

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

11
src/metabrushes/MetaBrush/Asset/Brushes.hs
View file

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

29
src/metabrushes/MetaBrush/Brush.hs
View file

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

58
src/metabrushes/MetaBrush/Records.hs
View file

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