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

improve D to use Nat for domain

Browse source
This commit is contained in:
sheaf 2024-08-05 17:49:04 +02:00
parent 5f98165276
commit ed8720555f
13 changed files with 137 additions and 146 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
brush-strokes/src/cusps/bench/Bench/Types.hs
View file

@ -61,18 +61,18 @@ type ParamsCt nbParams
= ( Show ( ℝ nbParams ) = ( Show ( ℝ nbParams )
, HasChainRule Double 2 ( ℝ nbParams ) , HasChainRule Double 2 ( ℝ nbParams )
, HasChainRule 𝕀 3 ( 𝕀ℝ nbParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbParams )
, Applicative ( D 2 ( ℝ nbParams ) ) , Applicative ( D 2 nbParams )
, Applicative ( D 3 ( ℝ nbParams ) ) , Applicative ( D 3 nbParams )
, Traversable ( D 2 ( ℝ nbParams ) ) , Traversable ( D 2 nbParams )
, Traversable ( D 3 ( ℝ nbParams ) ) , Traversable ( D 3 nbParams )
, Representable Double ( ℝ nbParams ) , Representable Double ( ℝ nbParams )
, Representable 𝕀 ( 𝕀ℝ nbParams ) , Representable 𝕀 ( 𝕀ℝ nbParams )
, Module Double ( T ( ℝ nbParams ) ) , Module Double ( T ( ℝ nbParams ) )
, Module 𝕀 ( T ( 𝕀ℝ nbParams ) ) , Module 𝕀 ( T ( 𝕀ℝ nbParams ) )
, Module ( D 2 ( ℝ nbParams ) Double ) ( D 2 ( ℝ nbParams ) ( ℝ 2 ) ) , Module ( D 2 nbParams Double ) ( D 2 nbParams ( ℝ 2 ) )
, Module ( D 3 ( ℝ nbParams ) 𝕀 ) ( D 3 ( ℝ nbParams ) ( 𝕀ℝ 2 ) ) , Module ( D 3 nbParams 𝕀 ) ( D 3 nbParams ( 𝕀ℝ 2 ) )
, Transcendental ( D 2 ( ℝ nbParams ) Double ) , Transcendental ( D 2 nbParams Double )
, Transcendental ( D 3 ( ℝ nbParams ) 𝕀 ) , Transcendental ( D 3 nbParams 𝕀 )
) )
newtype Params nbParams = Params { getParams :: ( ℝ nbParams ) } newtype Params nbParams = Params { getParams :: ( ℝ nbParams ) }

11
brush-strokes/src/cusps/inspect/Main.hs
View file

@ -75,10 +75,6 @@ data PointData params
outlineFunction outlineFunction
:: forall {t} (i :: t) brushParams :: forall {t} (i :: t) brushParams
. ( Show brushParams . ( Show brushParams
, D 1 ( I i 2 ) ~ D 1 ( ℝ 2 )
, D 2 ( I i 2 ) ~ D 2 ( ℝ 2 )
, D 3 ( I i 1 ) ~ D 3 ( ℝ 1 )
, D 3 ( I i 2 ) ~ D 3 ( ℝ 2 )
, HasType ( ℝ 2 ) ( PointData brushParams ) , HasType ( ℝ 2 ) ( PointData brushParams )
, Cross ( I i Double ) ( T ( I i 2 ) ) , Cross ( I i Double ) ( T ( I i 2 ) )
, Module ( I i Double ) ( T ( I i brushParams ) ) , Module ( I i Double ) ( T ( I i brushParams ) )
@ -90,7 +86,6 @@ outlineFunction
, HasChainRule ( I i Double ) 3 ( I i 1 ) , HasChainRule ( I i Double ) 3 ( I i 1 )
, HasChainRule ( I i Double ) 3 ( I i brushParams ) , HasChainRule ( I i Double ) 3 ( I i brushParams )
, Traversable ( D 3 brushParams ) , Traversable ( D 3 brushParams )
, Traversable ( D 3 ( I i brushParams ) )
, HasBézier 3 i , HasBézier 3 i
) )
=> ( I i Double -> I i 1 ) => ( I i Double -> I i 1 )
@ -263,9 +258,9 @@ instance HasBézier 3 AI where
κ = 0.5519150244935105707435627227925 κ = 0.5519150244935105707435627227925
circleSpline :: forall {t} (i :: t) k u v circleSpline :: forall {t} (i :: t) k u v
. Applicative ( D k ( I i u ) ) . Applicative ( D k ( Dim u ) )
=> ( Double -> Double -> D k ( I i u ) ( I i v ) ) => ( Double -> Double -> D k ( Dim u ) ( I i v ) )
-> D k ( I i u ) ( Spline 'Closed () ( I i v ) ) -> D k ( Dim u ) ( Spline 'Closed () ( I i v ) )
circleSpline p = sequenceA $ circleSpline p = sequenceA $
Spline { splineStart = p 1 0 Spline { splineStart = p 1 0
, splineCurves = ClosedCurves crvs lastCrv } , splineCurves = ClosedCurves crvs lastCrv }

38
brush-strokes/src/lib/Calligraphy/Brushes.hs
View file

@ -64,14 +64,15 @@ data Brush nbBrushParams
-- Some convenience type synonyms for brush types... a bit horrible -- Some convenience type synonyms for brush types... a bit horrible
type ParamsICt :: Nat -> k -> Nat -> Constraint type ParamsICt :: Nat -> k -> Nat -> Constraint
type ParamsICt k i rec = type ParamsICt k i nbParams =
( Module ( Module
( D k ( I i rec ) ( I i Double ) ) ( D k nbParams ( I i Double ) )
( D k ( I i rec ) ( I i 2 ) ) ( D k nbParams ( I i 2 ) )
, Module ( I i Double ) ( T ( I i Double ) ) , Module ( I i Double ) ( T ( I i Double ) )
, HasChainRule ( I i Double ) k ( I i rec ) , HasChainRule ( I i Double ) k ( I i nbParams )
, Representable ( I i Double ) ( I i rec ) , Representable ( I i Double ) ( I i nbParams )
, Applicative ( D k ( I i rec ) ) , Applicative ( D k nbParams )
, Dim ( I i nbParams ) ~ nbParams
) )
{-# INLINEABLE circleBrush #-} {-# INLINEABLE circleBrush #-}
@ -137,19 +138,19 @@ circleBrushFn :: forall {t} (i :: t) k nbParams
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
circleBrushFn _ mkI1 mkI2 = circleBrushFn _ mkI1 mkI2 =
D \ params -> D \ params ->
let r :: D k ( I i nbParams ) ( I i Double ) let r :: D k nbParams ( I i Double )
r = runD ( var @_ @k $ Fin 1 ) params r = runD ( var @_ @k $ Fin 1 ) params
mkPt :: Double -> Double -> D k ( I i nbParams ) ( I i 2 ) mkPt :: Double -> Double -> D k nbParams ( I i 2 )
mkPt x y mkPt x y
= ( r `scaledBy` x ) *^ e_x = ( r `scaledBy` x ) *^ e_x
^+^ ( r `scaledBy` y ) *^ e_y ^+^ ( r `scaledBy` y ) *^ e_y
in circleSpline mkPt in circleSpline mkPt
where where
e_x, e_y :: D k ( I i nbParams ) ( I i 2 ) e_x, e_y :: D k nbParams ( I i 2 )
e_x = pure $ mkI2 $ ℝ2 1 0 e_x = pure $ mkI2 $ ℝ2 1 0
e_y = pure $ mkI2 $ ℝ2 0 1 e_y = pure $ mkI2 $ ℝ2 0 1
scaledBy :: D k ( I i nbParams ) ( I i Double ) -> Double -> D k ( I i nbParams ) ( I i Double ) scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
scaledBy d x = fmap ( mkI1 x * ) d scaledBy d x = fmap ( mkI1 x * ) d
{-# INLINEABLE circleBrushFn #-} {-# INLINEABLE circleBrushFn #-}
@ -160,25 +161,24 @@ ellipseBrushFn :: forall {t} (i :: t) k nbParams
=> Proxy# i => Proxy# i
-> ( Double -> I i Double ) -> ( Double -> I i Double )
-> ( I ℝ 2 -> I i 2 ) -> ( I ℝ 2 -> I i 2 )
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
ellipseBrushFn _ mkI1 mkI2 = ellipseBrushFn _ mkI1 mkI2 =
D \ params -> D \ params ->
let a, b :: D k ( I i nbParams ) ( I i Double ) let a, b :: D k nbParams ( I i Double )
a = runD ( var @_ @k $ Fin 1 ) params a = runD ( var @_ @k $ Fin 1 ) params
b = runD ( var @_ @k $ Fin 2 ) params b = runD ( var @_ @k $ Fin 2 ) params
mkPt :: Double -> Double -> D k ( I i nbParams ) ( I i 2 ) mkPt :: Double -> Double -> D k nbParams ( I i 2 )
mkPt x y mkPt x y
= let !x' = a `scaledBy` x = let !x' = a `scaledBy` x
!y' = b `scaledBy` y !y' = b `scaledBy` y
in x' *^ e_x ^+^ y' *^ e_y in x' *^ e_x ^+^ y' *^ e_y
in circleSpline mkPt in circleSpline mkPt
where where
e_x, e_y :: D k ( I i nbParams ) ( I i 2 ) e_x, e_y :: D k nbParams ( I i 2 )
e_x = pure $ mkI2 $ ℝ2 1 0 e_x = pure $ mkI2 $ ℝ2 1 0
e_y = pure $ mkI2 $ ℝ2 0 1 e_y = pure $ mkI2 $ ℝ2 0 1
scaledBy :: D k ( I i nbParams ) ( I i Double ) -> Double -> D k ( I i nbParams ) ( I i Double ) scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
scaledBy d x = fmap ( mkI1 x * ) d scaledBy d x = fmap ( mkI1 x * ) d
{-# INLINEABLE ellipseBrushFn #-} {-# INLINEABLE ellipseBrushFn #-}
@ -212,10 +212,10 @@ tearDropBrushFn :: forall {t} (i :: t) k nbParams
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
tearDropBrushFn _ mkI1 mkI2 = tearDropBrushFn _ mkI1 mkI2 =
D \ params -> D \ params ->
let w, h :: D k ( I i nbParams ) ( I i Double ) let w, h :: D k nbParams ( I i Double )
w = runD ( var @_ @k ( Fin 1 ) ) params w = runD ( var @_ @k ( Fin 1 ) ) params
h = runD ( var @_ @k ( Fin 2 ) ) params h = runD ( var @_ @k ( Fin 2 ) ) params
mkPt :: Double -> Double -> D k ( I i 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
-- 2. scale the teardrop so that it has the requested width/height -- 2. scale the teardrop so that it has the requested width/height
@ -232,10 +232,10 @@ tearDropBrushFn _ mkI1 mkI2 =
( mkPt -0.5 sqrt3_over_2 ) ( mkPt -0.5 sqrt3_over_2 )
BackToStart () } BackToStart () }
where where
e_x, e_y :: D k ( I i nbParams ) ( I i 2 ) e_x, e_y :: D k nbParams ( I i 2 )
e_x = pure $ mkI2 $ ℝ2 1 0 e_x = pure $ mkI2 $ ℝ2 1 0
e_y = pure $ mkI2 $ ℝ2 0 1 e_y = pure $ mkI2 $ ℝ2 0 1
scaledBy :: D k ( I i nbParams ) ( I i Double ) -> Double -> D k ( I i nbParams ) ( I i Double ) scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
scaledBy d x = fmap ( mkI1 x * ) d scaledBy d x = fmap ( mkI1 x * ) d
{-# INLINEABLE tearDropBrushFn #-} {-# INLINEABLE tearDropBrushFn #-}

72
brush-strokes/src/lib/Math/Algebra/Dual.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
@ -7,7 +8,7 @@
{-# OPTIONS_GHC -Wno-orphans -O2 #-} {-# OPTIONS_GHC -Wno-orphans -O2 #-}
module Math.Algebra.Dual module Math.Algebra.Dual
( C(..), D ( C(..), D, Dim
, HasChainRule(..), chainRule , HasChainRule(..), chainRule
, uncurryD2, uncurryD3 , uncurryD2, uncurryD3
, linear, fun, var , linear, fun, var
@ -45,8 +46,12 @@ import Math.Ring
-- | @C n u v@ is the space of @C^k@-differentiable maps from @u@ to @v@. -- | @C n u v@ is the space of @C^k@-differentiable maps from @u@ to @v@.
type C :: Nat -> Type -> Type -> Type type C :: Nat -> Type -> Type -> Type
newtype C k u v = D { runD :: u -> D k u v } newtype C k u v = D { runD :: u -> D k ( Dim u ) v }
deriving stock instance Functor ( D k u ) => Functor ( C k u ) deriving stock instance Functor ( D k ( Dim u ) ) => Functor ( C k u )
type Dim :: k -> Nat
type family Dim u
type instance Dim ( ℝ n ) = n
-- | @D k u v@ is the space of @k@-th order germs of functions from @u@ to @v@, -- | @D k u v@ is the space of @k@-th order germs of functions from @u@ to @v@,
-- represented by the algebra: -- represented by the algebra:
@ -54,35 +59,35 @@ deriving stock instance Functor ( D k u ) => Functor ( C k u )
-- \[ \mathbb{Z}[x_1, \ldots, x_n]/(x_1, \ldots, x_n)^{k+1} \otimes_\mathbb{Z} v \] -- \[ \mathbb{Z}[x_1, \ldots, x_n]/(x_1, \ldots, x_n)^{k+1} \otimes_\mathbb{Z} v \]
-- --
-- when @u@ is of dimension @n@. -- when @u@ is of dimension @n@.
type D :: Nat -> Type -> Type -> Type type D :: Nat -> Nat -> Type -> Type
type family D k u type family D k u
type instance D k ( ℝ 0 ) = D𝔸0 type instance D k 0 = D𝔸0
type instance D 0 ( ℝ 1 ) = D𝔸0 type instance D 0 1 = D𝔸0
type instance D 0 ( ℝ 2 ) = D𝔸0 type instance D 0 2 = D𝔸0
type instance D 0 ( ℝ 3 ) = D𝔸0 type instance D 0 3 = D𝔸0
type instance D 0 ( ℝ 4 ) = D𝔸0 type instance D 0 4 = D𝔸0
type instance D 1 ( ℝ 1 ) = D1𝔸1 type instance D 1 1 = D1𝔸1
type instance D 1 ( ℝ 2 ) = D1𝔸2 type instance D 1 2 = D1𝔸2
type instance D 1 ( ℝ 3 ) = D1𝔸3 type instance D 1 3 = D1𝔸3
type instance D 1 ( ℝ 4 ) = D1𝔸4 type instance D 1 4 = D1𝔸4
type instance D 2 ( ℝ 1 ) = D2𝔸1 type instance D 2 1 = D2𝔸1
type instance D 2 ( ℝ 2 ) = D2𝔸2 type instance D 2 2 = D2𝔸2
type instance D 2 ( ℝ 3 ) = D2𝔸3 type instance D 2 3 = D2𝔸3
type instance D 2 ( ℝ 4 ) = D2𝔸4 type instance D 2 4 = D2𝔸4
type instance D 3 ( ℝ 1 ) = D3𝔸1 type instance D 3 1 = D3𝔸1
type instance D 3 ( ℝ 2 ) = D3𝔸2 type instance D 3 2 = D3𝔸2
type instance D 3 ( ℝ 3 ) = D3𝔸3 type instance D 3 3 = D3𝔸3
type instance D 3 ( ℝ 4 ) = D3𝔸4 type instance D 3 4 = D3𝔸4
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Weird instance needed in just one place; -- Weird instance needed in just one place;
-- see use of chain in 'Math.Bezier.Stroke.brushStrokeData'. -- see use of chain in 'Math.Bezier.Stroke.brushStrokeData'.
instance ( Applicative ( D k u ), Module r ( T v ) ) instance ( Applicative ( D k ( Dim u ) ), Module r ( T v ) )
=> Module r ( T ( C k u v ) ) where => Module r ( T ( C k u v ) ) where
origin = T $ D \ _ -> pure $ coerce $ origin @r @( T v ) origin = T $ D \ _ -> pure $ coerce $ origin @r @( T v )
T ( D f ) ^+^ T ( D g ) = T $ D \ t -> liftA2 ( coerce $ (^+^) @r @( T v ) ) ( f t ) ( g t ) T ( D f ) ^+^ T ( D g ) = T $ D \ t -> liftA2 ( coerce $ (^+^) @r @( T v ) ) ( f t ) ( g t )
@ -98,10 +103,10 @@ instance ( Applicative ( D k u ), Module r ( T v ) )
-- with @D k v w@ in the middle, for any @r@-module @w@. -- with @D k v w@ in the middle, for any @r@-module @w@.
class HasChainRule r k v where class HasChainRule r k v where
chain :: Module r ( T w ) chain :: Module r ( T w )
=> D k ( ℝ 1 ) v -> D k v w -> D k ( ℝ 1 ) w => D k 1 v -> D k ( Dim v ) w -> D k 1 w
konst :: AbelianGroup w => w -> D k v w konst :: AbelianGroup w => w -> D k ( Dim v ) w
value :: D k v w -> w value :: D k ( Dim v ) w -> w
linearD :: Module r ( T w ) => ( v -> w ) -> v -> D k v w linearD :: Module r ( T w ) => ( v -> w ) -> v -> D k ( Dim v ) w
linear :: forall k r v w linear :: forall k r v w
. ( HasChainRule r k v, Module r ( T w ) ) . ( HasChainRule r k v, Module r ( T w ) )
@ -110,7 +115,7 @@ linear f = D \ x -> linearD @r @k @v @w f x
chainRule :: forall r k u v w chainRule :: forall r k u v w
. ( HasChainRule r k v, Module r ( T w ) . ( HasChainRule r k v, Module r ( T w )
, D k u ~ D k ( ℝ 1 ), HasChainRule r k u , Dim u ~ 1, HasChainRule r k u
) )
=> C k u v -> C k v w -> C k u w => C k u v -> C k v w -> C k u w
chainRule ( D df ) ( D dg ) = chainRule ( D df ) ( D dg ) =
@ -120,8 +125,8 @@ chainRule ( D df ) ( D dg ) =
chain @r @k @v df_x ( dg $ value @r @k @u df_x ) chain @r @k @v df_x ( dg $ value @r @k @u df_x )
uncurryD2 :: D 2 a ~ D 2 ( ℝ 1 ) uncurryD2 :: Dim a ~ 1
=> D 2 ( ℝ 1 ) ( C 2 a b ) -> a -> D 2 ( ℝ 2 ) b => D 2 1 ( C 2 a b ) -> a -> D 2 2 b
uncurryD2 ( D21 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 = uncurryD2 ( D21 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 =
let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_t0 s0 let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_t0 s0
D21 dbdt_t0s0 d2bdtds_t0s0 _ = dbdt_t0 s0 D21 dbdt_t0s0 d2bdtds_t0s0 _ = dbdt_t0 s0
@ -131,8 +136,8 @@ uncurryD2 ( D21 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 =
( T dbdt_t0s0 ) dbds_t0s0 ( T dbdt_t0s0 ) dbds_t0s0
( T d2bdt2_t0s0 ) d2bdtds_t0s0 d2bds2_t0s0 ( T d2bdt2_t0s0 ) d2bdtds_t0s0 d2bds2_t0s0
uncurryD3 :: D 3 a ~ D 3 ( ℝ 1 ) uncurryD3 :: Dim a ~ 1
=> D 3 ( ℝ 1 ) ( C 3 a b ) -> a -> D 3 ( ℝ 2 ) b => D 3 1 ( C 3 a b ) -> a -> D 3 2 b
uncurryD3 ( D31 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ( T ( D d3bdt3_t0 ) ) ) s0 = uncurryD3 ( D31 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ( T ( D d3bdt3_t0 ) ) ) s0 =
let D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 = b_t0 s0 let D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 = b_t0 s0
D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ = dbdt_t0 s0 D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ = dbdt_t0 s0
@ -159,6 +164,7 @@ var i = D $ linearD @r @k @v ( `index` i )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Newtype for the module instance @Module r v => Module ( dr r ) ( dr v )@. -- | Newtype for the module instance @Module r v => Module ( dr r ) ( dr v )@.
type ApAp :: Type -> ( Type -> Type ) -> Type -> Type
newtype ApAp r dr v = ApAp { unApAp :: dr v } newtype ApAp r dr v = ApAp { unApAp :: dr v }
instance ( Ring ( dr r ), Module r ( T v ), Applicative dr ) instance ( Ring ( dr r ), Module r ( T v ), Applicative dr )
@ -199,9 +205,9 @@ deriving via ApAp r D3𝔸4 v
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- AbelianGroup instances -- AbelianGroup instances
newtype ApAp2 k u r = ApAp2 { unApAp2 :: D k u r } newtype ApAp2 k u r = ApAp2 { unApAp2 :: D k ( Dim u ) r }
instance ( Applicative ( D k u ) instance ( Applicative ( D k ( Dim u ) )
, AbelianGroup r , AbelianGroup r
, HasChainRule Double k u , HasChainRule Double k u
) => AbelianGroup ( ApAp2 k u r ) where ) => AbelianGroup ( ApAp2 k u r ) where

42
brush-strokes/src/lib/Math/Bezier/Stroke.hs
View file

@ -62,7 +62,7 @@ import GHC.STRef
import GHC.Generics import GHC.Generics
( Generic, Generic1, Generically(..) ) ( Generic, Generic1, Generically(..) )
import GHC.TypeNats import GHC.TypeNats
( Nat, type (-) ) ( Nat )
-- acts -- acts
import Data.Act import Data.Act
@ -213,7 +213,7 @@ data Cusp
= Cusp = Cusp
{ cuspParameters :: !( ℝ 2 ) { cuspParameters :: !( ℝ 2 )
-- ^ @(t,s)@ parameter values of the cusp -- ^ @(t,s)@ parameter values of the cusp
, cuspPathCoords :: !( D 2 ( ℝ 1 ) ( ℝ 2 ) ) , cuspPathCoords :: !( D 2 1 ( ℝ 2 ) )
-- ^ path point coordinates and tangent -- ^ path point coordinates and tangent
, cuspStrokeCoords :: !( ℝ 2 ) , cuspStrokeCoords :: !( ℝ 2 )
-- ^ brush stroke point coordinates -- ^ brush stroke point coordinates
@ -243,10 +243,11 @@ computeStrokeOutline ::
, HasChainRule 𝕀 3 ( 𝕀ℝ nbUsedParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbUsedParams )
, HasChainRule Double 2 ( ℝ nbBrushParams ) , HasChainRule Double 2 ( ℝ nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀ℝ nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbBrushParams )
, Traversable ( D 2 ( ℝ nbBrushParams ) ) , Traversable ( D 2 nbBrushParams )
, Traversable ( D 3 nbBrushParams )
, Representable Double ( ℝ nbUsedParams ) , Representable Double ( ℝ nbUsedParams )
, Representable 𝕀 ( 𝕀ℝ nbUsedParams ) , Representable 𝕀 ( 𝕀ℝ nbUsedParams )
, Module 𝕀 (T (𝕀ℝ nbUsedParams)) , Module 𝕀 (T ( 𝕀ℝ nbUsedParams ) )
-- Debugging. -- Debugging.
, Show ptData, Show ( ℝ nbBrushParams ) , Show ptData, Show ( ℝ nbBrushParams )
@ -526,8 +527,9 @@ outlineFunction
, HasChainRule 𝕀 3 ( 𝕀ℝ nbUsedParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbUsedParams )
, HasChainRule Double 2 ( ℝ nbBrushParams ) , HasChainRule Double 2 ( ℝ nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀ℝ nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbBrushParams )
, Traversable ( D 2 ( ℝ nbBrushParams ) ) , Traversable ( D 2 nbBrushParams )
, Module 𝕀 (T (𝕀ℝ nbUsedParams)) , Traversable ( D 3 nbBrushParams )
, Module 𝕀 ( T ( 𝕀ℝ nbUsedParams ) )
-- Computing AABBs -- Computing AABBs
, Representable Double ( ℝ nbUsedParams ) , Representable Double ( ℝ nbUsedParams )
@ -624,7 +626,6 @@ pathAndUsedParams :: forall k i (nbUsedParams :: Nat) arr crvData ptData
. ( HasType ( ℝ 2 ) ptData . ( HasType ( ℝ 2 ) ptData
, HasBézier k i , HasBézier k i
, arr ~ C k , arr ~ C k
, D k ( I i 1 ) ~ D k ( ℝ 1 )
, Module ( I i Double ) ( T ( I i 2 ) ) , Module ( I i Double ) ( T ( I i 2 ) )
, Torsor ( T ( I i 2 ) ) ( I i 2 ) , Torsor ( T ( I i 2 ) ) ( I i 2 )
, Module ( I i Double ) ( T ( I i nbUsedParams ) ) , Module ( I i Double ) ( T ( I i nbUsedParams ) )
@ -955,7 +956,6 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
splineCurveFns :: forall k i splineCurveFns :: forall k i
. ( HasBézier k i . ( HasBézier k i
, D k ( I i 1 ) ~ D k ( ℝ 1 )
, Module ( I i Double ) ( T ( I i 2 ) ) , Module ( I i Double ) ( T ( I i 2 ) )
, Torsor ( T ( I i 2 ) ) ( I i 2 ) ) , Torsor ( T ( I i 2 ) ) ( I i 2 ) )
=> ( I i 1 -> I i Double ) => ( I i 1 -> I i Double )
@ -992,13 +992,11 @@ brushStrokeData :: forall {kd} (k :: Nat) (nbBrushParams :: Nat) (i :: kd) arr
, HasBézier k i, HasEnvelopeEquation k , HasBézier k i, HasEnvelopeEquation k
, Differentiable k i nbBrushParams , Differentiable k i nbBrushParams
, HasChainRule ( I i Double ) k ( I i 1 ) , HasChainRule ( I i Double ) k ( I i 1 )
, Applicative ( D k ( ℝ 1 ) ) , Applicative ( D k 1 )
, Dim ( I i 1 ) ~ 1
, Dim ( I i nbBrushParams ) ~ nbBrushParams
, Traversable ( D k nbBrushParams )
, D ( k - 2 ) ( I i 2 ) ~ D ( k - 2 ) ( ℝ 2 )
, D ( k - 1 ) ( I i 2 ) ~ D ( k - 1 ) ( ℝ 2 )
, D k ( I i 1 ) ~ D k ( ℝ 1 )
, D k ( I i 1 ) ~ D k ( ℝ 1 )
, D k ( I i 2 ) ~ D k ( ℝ 2 )
, Transcendental ( I i Double ) , Transcendental ( I i Double )
, Module ( I i Double ) ( T ( I i 1 ) ) , Module ( I i Double ) ( T ( I i 1 ) )
, Cross ( I i Double ) ( T ( I i 2 ) ) , Cross ( I i Double ) ( T ( I i 2 ) )
@ -1020,24 +1018,24 @@ brushStrokeData :: forall {kd} (k :: Nat) (nbBrushParams :: Nat) (i :: kd) arr
brushStrokeData co1 co2 path params brush mbBrushRotation = brushStrokeData co1 co2 path params brush mbBrushRotation =
\ t -> \ t ->
let let
dpath_t :: D k ( I i 1 ) ( I i 2 ) dpath_t :: D k 1 ( I i 2 )
!dpath_t = runD path t !dpath_t = runD path t
dparams_t :: D k ( I i 1 ) ( I i nbBrushParams ) dparams_t :: D k 1 ( I i nbBrushParams )
!dparams_t = runD params t !dparams_t = runD params t
dbrush_params :: D k ( I i nbBrushParams ) ( Spline Closed () ( I i 2 ) ) dbrush_params :: D k nbBrushParams ( Spline Closed () ( I i 2 ) )
!dbrush_params = runD brush $ value @( I i Double ) @k @( I i 1 ) dparams_t !dbrush_params = runD brush $ value @( I i Double ) @k @( I i 1 ) dparams_t
splines :: Seq ( D k ( I i nbBrushParams ) ( I i 1 `arr` I i 2 ) ) splines :: Seq ( D k nbBrushParams ( I i 1 `arr` I i 2 ) )
!splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns @k @i co2 ) dbrush_params !splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns @k @i co2 ) dbrush_params
dbrushes_t :: Seq ( I i 1 -> D k ( I i 2 ) ( I i 2 ) ) dbrushes_t :: Seq ( I i 1 -> D k 2 ( I i 2 ) )
!dbrushes_t = force $ fmap ( uncurryD @k . chain @( I i Double ) @k dparams_t ) splines !dbrushes_t = force $ fmap ( uncurryD @k . chain @( I i Double ) @k dparams_t ) splines
-- This is the crucial use of the chain rule. -- This is the crucial use of the chain rule.
in fmap ( mkStrokeDatum dpath_t dparams_t ) dbrushes_t in fmap ( mkStrokeDatum dpath_t dparams_t ) dbrushes_t
where where
mkStrokeDatum :: D k ( I i 1 ) ( I i 2 ) mkStrokeDatum :: D k 1 ( I i 2 )
-> D k ( I i 1 ) ( I i nbBrushParams ) -> D k 1 ( I i nbBrushParams )
-> ( I i 1 -> D k ( I i 2 ) ( I i 2 ) ) -> ( I i 1 -> D k 2 ( I i 2 ) )
-> ( I i 1 -> StrokeDatum k i ) -> ( I i 1 -> StrokeDatum k i )
mkStrokeDatum dpath_t dparams_t dbrush_t s = mkStrokeDatum dpath_t dparams_t dbrush_t s =
let dbrush_t_s = dbrush_t s let dbrush_t_s = dbrush_t s

31
brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs
View file

@ -45,11 +45,11 @@ type StrokeDatum :: Nat -> k -> Type
data StrokeDatum k i data StrokeDatum k i
= StrokeDatum = StrokeDatum
{ -- | Path \( p(t) \). { -- | Path \( p(t) \).
dpath :: D k ( I i 1 ) ( I i 2 ) dpath :: D k 1 ( I i 2 )
-- | Brush shape \( b(t, s) \). -- | Brush shape \( b(t, s) \).
, dbrush :: D k ( I i 2 ) ( I i 2 ) , dbrush :: D k 2 ( I i 2 )
-- | (Optional) rotation angle \( \theta(t) \). -- | (Optional) rotation angle \( \theta(t) \).
, mbRotation :: Maybe ( D k ( I i 1 ) ( I i Double ) ) , mbRotation :: Maybe ( D k 1 ( I i Double ) )
-- Everything below is computed in terms of the first three fields. -- Everything below is computed in terms of the first three fields.
@ -58,19 +58,19 @@ data StrokeDatum k i
-- | \( u(t,s) = R(-\theta(t)) \frac{\partial c}{\partial t} \), -- | \( u(t,s) = R(-\theta(t)) \frac{\partial c}{\partial t} \),
-- \( v(t,s) = R(-\theta(t)) \frac{\partial c}{\partial s} \) -- \( v(t,s) = R(-\theta(t)) \frac{\partial c}{\partial s} \)
, du, dv :: D ( k - 1 ) ( I i 2 ) ( I i 2 ) , du, dv :: D ( k - 1 ) 2 ( I i 2 )
-- | Envelope function -- | Envelope function
-- --
-- \[ E(t_0,s_0) = \left ( \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} \right )_{(t_0,s_0)}. \] -- \[ E(t_0,s_0) = \left ( \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} \right )_{(t_0,s_0)}. \]
, ee :: D ( k - 1 ) ( I i 2 ) ( I i 1 ) , ee :: D ( k - 1 ) 2 ( I i 1 )
-- \[ \frac{\partial E}{\partial s} \frac{\mathrm{d} c}{\mathrm{d} t}, \] -- \[ \frac{\partial E}{\partial s} \frac{\mathrm{d} c}{\mathrm{d} t}, \]
-- --
-- where \( \frac{\mathrm{d} c}{\mathrm{d} t} \) -- where \( \frac{\mathrm{d} c}{\mathrm{d} t} \)
-- --
-- denotes a total derivative. -- denotes a total derivative.
, 𝛿E𝛿sdcdt :: D ( k - 2 ) ( I i 2 ) ( T ( I i 2 ) ) , 𝛿E𝛿sdcdt :: D ( k - 2 ) 2 ( T ( I i 2 ) )
} }
deriving stock instance Show ( StrokeDatum 2 ℝ ) deriving stock instance Show ( StrokeDatum 2 ℝ )
@ -85,7 +85,6 @@ class HasBézier k i where
line :: forall ( n :: Nat ) line :: forall ( n :: Nat )
. ( Module Double ( T ( ℝ n ) ), Torsor ( T ( ℝ n ) ) ( ℝ n ) . ( Module Double ( T ( ℝ n ) ), Torsor ( T ( ℝ n ) ) ( ℝ n )
, Module ( I i Double ) ( T ( I i n ) ), Torsor ( T ( I i n ) ) ( I i n ) , Module ( I i Double ) ( T ( I i n ) ), Torsor ( T ( I i n ) ) ( I i n )
, D k ( I i 1 ) ~ D k ( ℝ 1 )
) )
=> ( I i 1 -> I i Double ) => ( I i 1 -> I i Double )
-> Segment ( I i n ) -> C k ( I i 1 ) ( I i n ) -> Segment ( I i n ) -> C k ( I i 1 ) ( I i n )
@ -96,7 +95,6 @@ class HasBézier k i where
, Module ( I i Double ) ( T ( I i n ) ), Torsor ( T ( I i n ) ) ( I i n ) , Module ( I i Double ) ( T ( I i n ) ), Torsor ( T ( I i n ) ) ( I i n )
, Representable Double ( ℝ n ) , Representable Double ( ℝ n )
, Representable 𝕀 ( 𝕀ℝ n ) , Representable 𝕀 ( 𝕀ℝ n )
, D k ( I i 1 ) ~ D k ( ℝ 1 )
) )
=> ( I i 1 -> I i Double ) => ( I i 1 -> I i Double )
-> Quadratic.Bezier ( I i n ) -> C k ( I i 1 ) ( I i n ) -> Quadratic.Bezier ( I i n ) -> C k ( I i 1 ) ( I i n )
@ -107,7 +105,6 @@ class HasBézier k i where
, Module ( I i Double ) ( T ( I i n ) ), Torsor ( T ( I i n ) ) ( I i n ) , Module ( I i Double ) ( T ( I i n ) ), Torsor ( T ( I i n ) ) ( I i n )
, Representable Double ( ℝ n ) , Representable Double ( ℝ n )
, Representable 𝕀 ( 𝕀ℝ n ) , Representable 𝕀 ( 𝕀ℝ n )
, D k ( I i 1 ) ~ D k ( ℝ 1 )
) )
=> ( I i 1 -> I i Double ) => ( I i 1 -> I i Double )
-> Cubic.Bezier ( I i n ) -> C k ( I i 1 ) ( I i n ) -> Cubic.Bezier ( I i n ) -> C k ( I i 1 ) ( I i n )
@ -115,8 +112,8 @@ class HasBézier k i where
type HasEnvelopeEquation :: Nat -> Constraint type HasEnvelopeEquation :: Nat -> Constraint
class HasEnvelopeEquation k where class HasEnvelopeEquation k where
uncurryD :: D k a ~ D k ( ℝ 1 ) uncurryD :: Dim a ~ 1
=> D k ( ℝ 1 ) ( C k a b ) -> a -> D k ( ℝ 2 ) b => D k 1 ( C k a b ) -> a -> D k 2 b
-- | The envelope function -- | The envelope function
-- --
@ -130,11 +127,7 @@ class HasEnvelopeEquation k where
-- --
-- denotes a total derivative. -- denotes a total derivative.
envelopeEquation :: forall i envelopeEquation :: forall i
. ( D ( k - 2 ) ( I i 2 ) ~ D ( k - 2 ) ( ℝ 2 ) . ( Module ( I i Double ) ( T ( I i 1 ) )
, D ( k - 1 ) ( I i 2 ) ~ D ( k - 1 ) ( ℝ 2 )
, D k ( I i 2 ) ~ D k ( ℝ 2 )
, D k ( I i 1 ) ~ D k ( ℝ 1 )
, Module ( I i Double ) ( T ( I i 1 ) )
, Cross ( I i Double ) ( T ( I i 2 ) ) , Cross ( I i Double ) ( T ( I i 2 ) )
, Transcendental ( I i Double ) , Transcendental ( I i Double )
, Representable ( I i Double ) ( I i 2 ) , Representable ( I i Double ) ( I i 2 )
@ -142,9 +135,9 @@ class HasEnvelopeEquation k where
) )
=> Proxy i => Proxy i
-> ( I i Double -> I i 1 ) -> ( I i Double -> I i 1 )
-> D k ( I i 1 ) ( I i 2 ) -> D k 1 ( I i 2 )
-> D k ( I i 2 ) ( I i 2 ) -> D k 2 ( I i 2 )
-> Maybe ( D k ( I i 1 ) ( I i Double ) ) -> Maybe ( D k 1 ( I i Double ) )
-> StrokeDatum k i -> StrokeDatum k i
instance HasBézier 2 ℝ where instance HasBézier 2 ℝ where

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

@ -37,12 +37,12 @@ type Differentiable :: Nat -> k -> Nat -> Constraint
class class
( Module ( I i Double ) ( T ( I i u ) ) ( Module ( I i Double ) ( T ( I i u ) )
, HasChainRule ( I i Double ) k ( I i u ) , HasChainRule ( I i Double ) k ( I i u )
, Traversable ( D k ( I i u ) ) , Traversable ( D k u )
) => Differentiable k i u ) => Differentiable k i u
instance instance
( Module ( I i Double ) ( T ( I i u ) ) ( Module ( I i Double ) ( T ( I i u ) )
, HasChainRule ( I i Double ) k ( I i u ) , HasChainRule ( I i Double ) k ( I i u )
, Traversable ( D k ( I i u ) ) , Traversable ( D k u )
) => Differentiable k i u ) => Differentiable k i u
type DiffInterp :: Nat -> k -> Nat -> Constraint type DiffInterp :: Nat -> k -> Nat -> Constraint
@ -50,10 +50,10 @@ class
( Differentiable k i u ( Differentiable k i u
, Interpolatable ( I i Double ) ( I i u ) , Interpolatable ( I i Double ) ( I i u )
, Module ( I i Double ) ( T ( I i Double ) ) , Module ( I i Double ) ( T ( I i Double ) )
, Module ( D k ( I i u ) ( I i Double ) ) , Module ( D k u ( I i Double ) )
( D k ( I i u ) ( I i 2 ) ) ( D k u ( I i 2 ) )
, Transcendental ( D k ( I i u ) ( I i Double ) ) , Transcendental ( D k u ( I i Double ) )
, Applicative ( D k ( I i u ) ) , Applicative ( D k u )
, Representable ( I i Double ) ( I i u ) , Representable ( I i Double ) ( I i u )
, RepDim ( I i u ) ~ RepDim u , RepDim ( I i u ) ~ RepDim u
) => DiffInterp k i u ) => DiffInterp k i u
@ -61,10 +61,10 @@ instance
( Differentiable k i u ( Differentiable k i u
, Interpolatable ( I i Double ) ( I i u ) , Interpolatable ( I i Double ) ( I i u )
, Module ( I i Double ) ( T ( I i Double ) ) , Module ( I i Double ) ( T ( I i Double ) )
, Module ( D k ( I i u ) ( I i Double ) ) , Module ( D k u ( I i Double ) )
( D k ( I i u ) ( I i 2 ) ) ( D k u ( I i 2 ) )
, Transcendental ( D k ( I i u ) ( I i Double ) ) , Transcendental ( D k u ( I i Double ) )
, Applicative ( D k ( I i u ) ) , Applicative ( D k u )
, Representable ( I i Double ) ( I i u ) , Representable ( I i Double ) ( I i u )
, RepDim ( I i u ) ~ RepDim u , RepDim ( I i u ) ~ RepDim u
) => DiffInterp k i u ) => DiffInterp k i u

3
brush-strokes/src/lib/Math/Interval.hs
View file

@ -58,8 +58,7 @@ import Math.Ring
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Interval arithmetic. -- Interval arithmetic.
type instance D k 𝕀 = D k Double type instance Dim ( 𝕀ℝ n ) = n
type instance D k ( 𝕀ℝ n ) = D k ( ℝ n )
-- | Turn a non-decreasing function into a function on intervals. -- | Turn a non-decreasing function into a function on intervals.
nonDecreasing :: forall n m nonDecreasing :: forall n m

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

@ -188,7 +188,7 @@ isolateRootsIn
. BoxCt n d . BoxCt n d
=> RootIsolationOptions n d => RootIsolationOptions n d
-- ^ configuration (which algorithms to use, and with what parameters) -- ^ configuration (which algorithms to use, and with what parameters)
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-- ^ equations to solve -- ^ equations to solve
-> Box n -> Box n
-- ^ initial search domain -- ^ initial search domain
@ -271,7 +271,7 @@ doStrategy
. RootIsolationAlgorithmWithOptions n d . RootIsolationAlgorithmWithOptions n d
-> [ ( RootIsolationStep, Box n ) ] -> [ ( RootIsolationStep, Box n ) ]
-> BoxHistory n -> BoxHistory n
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-> Box n -> Box n
-> Writer ( DoneBoxes n ) -> Writer ( DoneBoxes n )
( RootIsolationStep, [ Box n ] ) ( RootIsolationStep, [ Box n ] )

6
brush-strokes/src/lib/Math/Root/Isolation/Bisection.hs
View file

@ -74,7 +74,7 @@ instance BoxCt n d => RootIsolationAlgorithm Bisection n d where
:: RootIsolationAlgorithmOptions Bisection 2 3 :: RootIsolationAlgorithmOptions Bisection 2 3
-> [ ( RootIsolationStep, Box 2 ) ] -> [ ( RootIsolationStep, Box 2 ) ]
-> BoxHistory 2 -> BoxHistory 2
-> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) ) -> ( 𝕀ℝ 2 -> D 1 2 ( 𝕀ℝ 3 ) )
-> Box 2 -> Box 2
-> Writer ( DoneBoxes 2 ) ( StepDescription Bisection, [ Box 2 ] ) #-} -> Writer ( DoneBoxes 2 ) ( StepDescription Bisection, [ Box 2 ] ) #-}
-- NB: including this to be safe. The specialiser seems to sometimes -- NB: including this to be safe. The specialiser seems to sometimes
@ -92,7 +92,7 @@ data BisectionOptions n d =
-- --
-- NB: only return 'False' if non-existence of solutions is guaranteed -- NB: only return 'False' if non-existence of solutions is guaranteed
-- (otherwise, the root isolation algorithm might not be consistent). -- (otherwise, the root isolation algorithm might not be consistent).
canHaveSols :: !( ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> Box n -> Bool ) canHaveSols :: !( ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) ) -> Box n -> Bool )
-- | Heuristic to choose which coordinate dimension to bisect. -- | Heuristic to choose which coordinate dimension to bisect.
-- --
-- It's only a fallback, as we prefer to bisect along coordinate dimensions -- It's only a fallback, as we prefer to bisect along coordinate dimensions
@ -104,7 +104,7 @@ data BisectionOptions n d =
type BisectionCoordPicker n d type BisectionCoordPicker n d
= [ ( RootIsolationStep, Box n ) ] = [ ( RootIsolationStep, Box n ) ]
-> BoxHistory n -> BoxHistory n
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-> forall r. ( NE.NonEmpty ( Fin n, r ) -> ( r, String ) ) -> forall r. ( NE.NonEmpty ( Fin n, r ) -> ( r, String ) )
-- | Default options for the bisection method. -- | Default options for the bisection method.

8
brush-strokes/src/lib/Math/Root/Isolation/Core.hs
View file

@ -98,9 +98,9 @@ type BoxCt n d =
, Eq ( ℝ n ) , Eq ( ℝ n )
, Representable Double ( ℝ n ) , Representable Double ( ℝ n )
, Representable 𝕀 ( 𝕀ℝ n ) , Representable 𝕀 ( 𝕀ℝ n )
, MonomialBasis ( D 1 ( ℝ n ) ) , MonomialBasis ( D 1 n )
, Deg ( D 1 ( ℝ n ) ) ~ 1 , Deg ( D 1 n ) ~ 1
, Vars ( D 1 ( ℝ n ) ) ~ n , Vars ( D 1 n ) ~ n
, Module Double ( T ( ℝ n ) ) , Module Double ( T ( ℝ n ) )
, Module 𝕀 ( T ( 𝕀ℝ n ) ) , Module 𝕀 ( T ( 𝕀ℝ n ) )
, NFData ( ℝ n ) , NFData ( ℝ n )
@ -181,7 +181,7 @@ class ( Typeable ty, Show ( StepDescription ty ), BoxCt n d )
-- ^ history of the current round -- ^ history of the current round
-> BoxHistory n -> BoxHistory n
-- ^ previous rounds history -- ^ previous rounds history
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-- ^ equations -- ^ equations
-> Box n -> Box n
-- ^ box -- ^ box

28
brush-strokes/src/lib/Math/Root/Isolation/Narrowing.hs
View file

@ -75,7 +75,7 @@ instance BoxCt n d => RootIsolationAlgorithm Box1 n d where
:: RootIsolationAlgorithmOptions Box1 2 3 :: RootIsolationAlgorithmOptions Box1 2 3
-> [ ( RootIsolationStep, Box 2 ) ] -> [ ( RootIsolationStep, Box 2 ) ]
-> BoxHistory 2 -> BoxHistory 2
-> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) ) -> ( 𝕀ℝ 2 -> D 1 2 ( 𝕀ℝ 3 ) )
-> Box 2 -> Box 2
-> Writer ( DoneBoxes 2 ) ( StepDescription Box1, [ Box 2 ] ) #-} -> Writer ( DoneBoxes 2 ) ( StepDescription Box1, [ Box 2 ] ) #-}
-- NB: including this to be safe. The specialiser seems to sometimes -- NB: including this to be safe. The specialiser seems to sometimes
@ -93,7 +93,7 @@ instance BoxCt n d => RootIsolationAlgorithm Box2 n d where
:: RootIsolationAlgorithmOptions Box2 2 3 :: RootIsolationAlgorithmOptions Box2 2 3
-> [ ( RootIsolationStep, Box 2 ) ] -> [ ( RootIsolationStep, Box 2 ) ]
-> BoxHistory 2 -> BoxHistory 2
-> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) ) -> ( 𝕀ℝ 2 -> D 1 2 ( 𝕀ℝ 3 ) )
-> Box 2 -> Box 2
-> Writer ( DoneBoxes 2 ) ( StepDescription Box2, [ Box 2 ] ) #-} -> Writer ( DoneBoxes 2 ) ( StepDescription Box2, [ Box 2 ] ) #-}
-- NB: including this to be safe. The specialiser seems to sometimes -- NB: including this to be safe. The specialiser seems to sometimes
@ -159,14 +159,14 @@ makeBox1Consistent
:: ( KnownNat n :: ( KnownNat n
, Representable Double ( ℝ n ) , Representable Double ( ℝ n )
, Representable 𝕀 ( 𝕀ℝ n ) , Representable 𝕀 ( 𝕀ℝ n )
, MonomialBasis ( D 1 ( ℝ n ) ) , MonomialBasis ( D 1 n )
, Deg ( D 1 ( ℝ n ) ) ~ 1 , Deg ( D 1 n ) ~ 1
, Vars ( D 1 ( ℝ n ) ) ~ n , Vars ( D 1 n ) ~ n
, Representable Double ( ℝ d ) , Representable Double ( ℝ d )
, Representable 𝕀 ( 𝕀ℝ d ) , Representable 𝕀 ( 𝕀ℝ d )
) )
=> Box1Options n d => Box1Options n d
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-> 𝕀ℝ n -> [ 𝕀ℝ n ] -> 𝕀ℝ n -> [ 𝕀ℝ n ]
makeBox1Consistent box1Options eqs x = makeBox1Consistent box1Options eqs x =
( `State.evalState` False ) $ ( `State.evalState` False ) $
@ -180,14 +180,14 @@ makeBox2Consistent
. ( KnownNat n . ( KnownNat n
, Representable Double ( ℝ n ) , Representable Double ( ℝ n )
, Representable 𝕀 ( 𝕀ℝ n ) , Representable 𝕀 ( 𝕀ℝ n )
, MonomialBasis ( D 1 ( ℝ n ) ) , MonomialBasis ( D 1 n )
, Deg ( D 1 ( ℝ n ) ) ~ 1 , Deg ( D 1 n ) ~ 1
, Vars ( D 1 ( ℝ n ) ) ~ n , Vars ( D 1 n ) ~ n
, Representable Double ( ℝ d ) , Representable Double ( ℝ d )
, Representable 𝕀 ( 𝕀ℝ d ) , Representable 𝕀 ( 𝕀ℝ d )
) )
=> Box2Options n d => Box2Options n d
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-> 𝕀ℝ n -> 𝕀ℝ n -> 𝕀ℝ n -> 𝕀ℝ n
makeBox2Consistent (Box2Options box1Options ε_eq λMin) eqs x0 makeBox2Consistent (Box2Options box1Options ε_eq λMin) eqs x0
= ( `State.evalState` False ) $ doLoop 0.25 x0 = ( `State.evalState` False ) $ doLoop 0.25 x0
@ -261,14 +261,14 @@ allNarrowingOperators
. ( KnownNat n . ( KnownNat n
, Representable Double ( ℝ n ) , Representable Double ( ℝ n )
, Representable 𝕀 ( 𝕀ℝ n ) , Representable 𝕀 ( 𝕀ℝ n )
, MonomialBasis ( D 1 ( ℝ n ) ) , MonomialBasis ( D 1 n )
, Deg ( D 1 ( ℝ n ) ) ~ 1 , Deg ( D 1 n ) ~ 1
, Vars ( D 1 ( ℝ n ) ) ~ n , Vars ( D 1 n ) ~ n
, Representable Double ( ℝ d ) , Representable Double ( ℝ d )
, Representable 𝕀 ( 𝕀ℝ d ) , Representable 𝕀 ( 𝕀ℝ d )
) )
=> Box1Options n d => Box1Options n d
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-> [ 𝕀ℝ n -> State Bool [ 𝕀ℝ n ] ] -> [ 𝕀ℝ n -> State Bool [ 𝕀ℝ n ] ]
allNarrowingOperators ( Box1Options ε_eq ε_bis coordsToNarrow eqsToUse narrowingMethod ) eqs = allNarrowingOperators ( Box1Options ε_eq ε_bis coordsToNarrow eqsToUse narrowingMethod ) eqs =
[ \ cand -> [ \ cand ->

4
brush-strokes/src/lib/Math/Root/Isolation/Newton.hs
View file

@ -63,7 +63,7 @@ instance BoxCt n d => RootIsolationAlgorithm Newton n d where
:: RootIsolationAlgorithmOptions Newton 2 3 :: RootIsolationAlgorithmOptions Newton 2 3
-> [ ( RootIsolationStep, Box 2 ) ] -> [ ( RootIsolationStep, Box 2 ) ]
-> BoxHistory 2 -> BoxHistory 2
-> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) ) -> ( 𝕀ℝ 2 -> D 1 2 ( 𝕀ℝ 3 ) )
-> Box 2 -> Box 2
-> Writer ( DoneBoxes 2 ) ( StepDescription Newton, [ Box 2 ] ) #-} -> Writer ( DoneBoxes 2 ) ( StepDescription Newton, [ Box 2 ] ) #-}
-- NB: including this to be safe. The specialiser seems to sometimes -- NB: including this to be safe. The specialiser seems to sometimes
@ -100,7 +100,7 @@ intervalNewton
:: forall n d :: forall n d
. BoxCt n d . BoxCt n d
=> NewtonOptions n d => NewtonOptions n d
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( 𝕀ℝ n -> D 1 n ( 𝕀ℝ d ) )
-- ^ equations -- ^ equations
-> 𝕀ℝ n -> 𝕀ℝ n
-- ^ box -- ^ box