mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 06:43:37 +00:00
cleanups
This commit is contained in:
parent
2bae92dc5e
commit
9ff25a25aa
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 #-}
|
||||
|
|
|
@ -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 { }
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue