improve D to use Nat for domain

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

View file

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

View file

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

View file

@ -64,14 +64,15 @@ data Brush nbBrushParams
-- Some convenience type synonyms for brush types... a bit horrible
type ParamsICt :: Nat -> k -> Nat -> Constraint
type ParamsICt k i rec =
type ParamsICt k i nbParams =
( Module
( D k ( I i rec ) ( I i Double ) )
( D k ( I i rec ) ( I i 2 ) )
( D k nbParams ( I i Double ) )
( D k nbParams ( I i 2 ) )
, Module ( I i Double ) ( T ( I i Double ) )
, HasChainRule ( I i Double ) k ( I i rec )
, Representable ( I i Double ) ( I i rec )
, Applicative ( D k ( I i rec ) )
, HasChainRule ( I i Double ) k ( I i nbParams )
, Representable ( I i Double ) ( I i nbParams )
, Applicative ( D k nbParams )
, Dim ( I i nbParams ) ~ nbParams
)
{-# INLINEABLE circleBrush #-}
@ -137,19 +138,19 @@ circleBrushFn :: forall {t} (i :: t) k nbParams
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
circleBrushFn _ mkI1 mkI2 =
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
mkPt :: Double -> Double -> D k ( I i nbParams ) ( I i 2 )
mkPt :: Double -> Double -> D k nbParams ( I i 2 )
mkPt x y
= ( r `scaledBy` x ) *^ e_x
^+^ ( r `scaledBy` y ) *^ e_y
in circleSpline mkPt
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_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
{-# INLINEABLE circleBrushFn #-}
@ -160,25 +161,24 @@ ellipseBrushFn :: forall {t} (i :: t) k nbParams
=> Proxy# i
-> ( Double -> I i Double )
-> ( I 2 -> I i 2 )
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
ellipseBrushFn _ mkI1 mkI2 =
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
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
= let !x' = a `scaledBy` x
!y' = b `scaledBy` y
in x' *^ e_x ^+^ y' *^ e_y
in circleSpline mkPt
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_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
{-# INLINEABLE ellipseBrushFn #-}
@ -212,10 +212,10 @@ tearDropBrushFn :: forall {t} (i :: t) k nbParams
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
tearDropBrushFn _ mkI1 mkI2 =
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
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
-- 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
@ -232,10 +232,10 @@ tearDropBrushFn _ mkI1 mkI2 =
( mkPt -0.5 sqrt3_over_2 )
BackToStart () }
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_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
{-# INLINEABLE tearDropBrushFn #-}

View file

@ -1,4 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
@ -7,7 +8,7 @@
{-# OPTIONS_GHC -Wno-orphans -O2 #-}
module Math.Algebra.Dual
( C(..), D
( C(..), D, Dim
, HasChainRule(..), chainRule
, uncurryD2, uncurryD3
, 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@.
type C :: Nat -> Type -> Type -> Type
newtype C k u v = D { runD :: u -> D k u v }
deriving stock instance Functor ( D k u ) => Functor ( C k u )
newtype C k u v = D { runD :: u -> D k ( Dim u ) v }
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@,
-- 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 \]
--
-- when @u@ is of dimension @n@.
type D :: Nat -> Type -> Type -> Type
type D :: Nat -> Nat -> Type -> Type
type family D k u
type instance D k ( 0 ) = D𝔸0
type instance D 0 ( 1 ) = D𝔸0
type instance D 0 ( 2 ) = D𝔸0
type instance D 0 ( 3 ) = D𝔸0
type instance D 0 ( 4 ) = D𝔸0
type instance D k 0 = D𝔸0
type instance D 0 1 = D𝔸0
type instance D 0 2 = D𝔸0
type instance D 0 3 = D𝔸0
type instance D 0 4 = D𝔸0
type instance D 1 ( 1 ) = D1𝔸1
type instance D 1 ( 2 ) = D1𝔸2
type instance D 1 ( 3 ) = D1𝔸3
type instance D 1 ( 4 ) = D1𝔸4
type instance D 1 1 = D1𝔸1
type instance D 1 2 = D1𝔸2
type instance D 1 3 = D1𝔸3
type instance D 1 4 = D1𝔸4
type instance D 2 ( 1 ) = D2𝔸1
type instance D 2 ( 2 ) = D2𝔸2
type instance D 2 ( 3 ) = D2𝔸3
type instance D 2 ( 4 ) = D2𝔸4
type instance D 2 1 = D2𝔸1
type instance D 2 2 = D2𝔸2
type instance D 2 3 = D2𝔸3
type instance D 2 4 = D2𝔸4
type instance D 3 ( 1 ) = D3𝔸1
type instance D 3 ( 2 ) = D3𝔸2
type instance D 3 ( 3 ) = D3𝔸3
type instance D 3 ( 4 ) = D3𝔸4
type instance D 3 1 = D3𝔸1
type instance D 3 2 = D3𝔸2
type instance D 3 3 = D3𝔸3
type instance D 3 4 = D3𝔸4
--------------------------------------------------------------------------------
-- Weird instance needed in just one place;
-- 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
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 )
@ -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@.
class HasChainRule r k v where
chain :: Module r ( T w )
=> D k ( 1 ) v -> D k v w -> D k ( 1 ) w
konst :: AbelianGroup w => w -> D k v w
value :: D k v w -> w
linearD :: Module r ( T w ) => ( v -> w ) -> v -> D k v w
=> D k 1 v -> D k ( Dim v ) w -> D k 1 w
konst :: AbelianGroup w => w -> D k ( Dim v ) w
value :: D k ( Dim v ) w -> w
linearD :: Module r ( T w ) => ( v -> w ) -> v -> D k ( Dim v ) w
linear :: forall k r v 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
. ( 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
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 )
uncurryD2 :: D 2 a ~ D 2 ( 1 )
=> D 2 ( 1 ) ( C 2 a b ) -> a -> D 2 ( 2 ) b
uncurryD2 :: Dim a ~ 1
=> 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 =
let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_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 d2bdt2_t0s0 ) d2bdtds_t0s0 d2bds2_t0s0
uncurryD3 :: D 3 a ~ D 3 ( 1 )
=> D 3 ( 1 ) ( C 3 a b ) -> a -> D 3 ( 2 ) b
uncurryD3 :: Dim a ~ 1
=> 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 =
let D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 = b_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 )@.
type ApAp :: Type -> ( Type -> Type ) -> Type -> Type
newtype ApAp r dr v = ApAp { unApAp :: dr v }
instance ( Ring ( dr r ), Module r ( T v ), Applicative dr )
@ -199,9 +205,9 @@ deriving via ApAp r D3𝔸4 v
--------------------------------------------------------------------------------
-- 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
, HasChainRule Double k u
) => AbelianGroup ( ApAp2 k u r ) where

View file

@ -62,7 +62,7 @@ import GHC.STRef
import GHC.Generics
( Generic, Generic1, Generically(..) )
import GHC.TypeNats
( Nat, type (-) )
( Nat )
-- acts
import Data.Act
@ -213,7 +213,7 @@ data Cusp
= Cusp
{ cuspParameters :: !( 2 )
-- ^ @(t,s)@ parameter values of the cusp
, cuspPathCoords :: !( D 2 ( 1 ) ( 2 ) )
, cuspPathCoords :: !( D 2 1 ( 2 ) )
-- ^ path point coordinates and tangent
, cuspStrokeCoords :: !( 2 )
-- ^ brush stroke point coordinates
@ -243,7 +243,8 @@ computeStrokeOutline ::
, HasChainRule 𝕀 3 ( 𝕀 nbUsedParams )
, HasChainRule Double 2 ( nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀 nbBrushParams )
, Traversable ( D 2 ( nbBrushParams ) )
, Traversable ( D 2 nbBrushParams )
, Traversable ( D 3 nbBrushParams )
, Representable Double ( nbUsedParams )
, Representable 𝕀 ( 𝕀 nbUsedParams )
, Module 𝕀 (T ( 𝕀 nbUsedParams ) )
@ -526,7 +527,8 @@ outlineFunction
, HasChainRule 𝕀 3 ( 𝕀 nbUsedParams )
, HasChainRule Double 2 ( nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀 nbBrushParams )
, Traversable ( D 2 ( nbBrushParams ) )
, Traversable ( D 2 nbBrushParams )
, Traversable ( D 3 nbBrushParams )
, Module 𝕀 ( T ( 𝕀 nbUsedParams ) )
-- Computing AABBs
@ -624,7 +626,6 @@ pathAndUsedParams :: forall k i (nbUsedParams :: Nat) arr crvData ptData
. ( HasType ( 2 ) ptData
, HasBézier k i
, arr ~ C k
, D k ( I i 1 ) ~ D k ( 1 )
, Module ( I i Double ) ( T ( I i 2 ) )
, Torsor ( T ( I i 2 ) ) ( I i 2 )
, Module ( I i Double ) ( T ( I i nbUsedParams ) )
@ -955,7 +956,6 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
splineCurveFns :: forall k i
. ( HasBézier k i
, D k ( I i 1 ) ~ D k ( 1 )
, Module ( I i Double ) ( T ( I i 2 ) )
, Torsor ( T ( I i 2 ) ) ( I i 2 ) )
=> ( 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
, Differentiable k i nbBrushParams
, 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 )
, Module ( I i Double ) ( T ( I i 1 ) )
, 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 =
\ t ->
let
dpath_t :: D k ( I i 1 ) ( I i 2 )
dpath_t :: D k 1 ( I i 2 )
!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
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
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
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
-- This is the crucial use of the chain rule.
in fmap ( mkStrokeDatum dpath_t dparams_t ) dbrushes_t
where
mkStrokeDatum :: D k ( I i 1 ) ( I i 2 )
-> D k ( I i 1 ) ( I i nbBrushParams )
-> ( I i 1 -> D k ( I i 2 ) ( I i 2 ) )
mkStrokeDatum :: D k 1 ( I i 2 )
-> D k 1 ( I i nbBrushParams )
-> ( I i 1 -> D k 2 ( I i 2 ) )
-> ( I i 1 -> StrokeDatum k i )
mkStrokeDatum dpath_t dparams_t dbrush_t s =
let dbrush_t_s = dbrush_t s

View file

@ -45,11 +45,11 @@ type StrokeDatum :: Nat -> k -> Type
data StrokeDatum k i
= StrokeDatum
{ -- | Path \( p(t) \).
dpath :: D k ( I i 1 ) ( I i 2 )
dpath :: D k 1 ( I i 2 )
-- | 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) \).
, 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.
@ -58,19 +58,19 @@ data StrokeDatum k i
-- | \( u(t,s) = R(-\theta(t)) \frac{\partial c}{\partial t} \),
-- \( 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
--
-- \[ 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}, \]
--
-- where \( \frac{\mathrm{d} c}{\mathrm{d} t} \)
--
-- 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 )
@ -85,7 +85,6 @@ class HasBézier k i where
line :: forall ( n :: Nat )
. ( Module Double ( T ( n ) ), Torsor ( T ( n ) ) ( 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 )
-> 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 )
, Representable Double ( n )
, Representable 𝕀 ( 𝕀 n )
, D k ( I i 1 ) ~ D k ( 1 )
)
=> ( I i 1 -> I i Double )
-> 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 )
, Representable Double ( n )
, Representable 𝕀 ( 𝕀 n )
, D k ( I i 1 ) ~ D k ( 1 )
)
=> ( I i 1 -> I i Double )
-> 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
class HasEnvelopeEquation k where
uncurryD :: D k a ~ D k ( 1 )
=> D k ( 1 ) ( C k a b ) -> a -> D k ( 2 ) b
uncurryD :: Dim a ~ 1
=> D k 1 ( C k a b ) -> a -> D k 2 b
-- | The envelope function
--
@ -130,11 +127,7 @@ class HasEnvelopeEquation k where
--
-- denotes a total derivative.
envelopeEquation :: forall i
. ( D ( k - 2 ) ( I i 2 ) ~ D ( k - 2 ) ( 2 )
, 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 ) )
. ( Module ( I i Double ) ( T ( I i 1 ) )
, Cross ( I i Double ) ( T ( I i 2 ) )
, Transcendental ( I i Double )
, Representable ( I i Double ) ( I i 2 )
@ -142,9 +135,9 @@ class HasEnvelopeEquation k where
)
=> Proxy i
-> ( I i Double -> I i 1 )
-> D k ( I i 1 ) ( I i 2 )
-> D k ( I i 2 ) ( I i 2 )
-> Maybe ( D k ( I i 1 ) ( I i Double ) )
-> D k 1 ( I i 2 )
-> D k 2 ( I i 2 )
-> Maybe ( D k 1 ( I i Double ) )
-> StrokeDatum k i
instance HasBézier 2 where

View file

@ -37,12 +37,12 @@ type Differentiable :: Nat -> k -> Nat -> Constraint
class
( Module ( I i Double ) ( T ( 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
instance
( Module ( I i Double ) ( T ( 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
type DiffInterp :: Nat -> k -> Nat -> Constraint
@ -50,10 +50,10 @@ class
( Differentiable k i u
, Interpolatable ( I i Double ) ( I i u )
, Module ( I i Double ) ( T ( I i Double ) )
, Module ( D k ( I i u ) ( I i Double ) )
( D k ( I i u ) ( I i 2 ) )
, Transcendental ( D k ( I i u ) ( I i Double ) )
, Applicative ( D k ( I i u ) )
, Module ( D k u ( I i Double ) )
( D k u ( I i 2 ) )
, 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
@ -61,10 +61,10 @@ instance
( Differentiable k i u
, Interpolatable ( I i Double ) ( I i u )
, Module ( I i Double ) ( T ( I i Double ) )
, Module ( D k ( I i u ) ( I i Double ) )
( D k ( I i u ) ( I i 2 ) )
, Transcendental ( D k ( I i u ) ( I i Double ) )
, Applicative ( D k ( I i u ) )
, Module ( D k u ( I i Double ) )
( D k u ( I i 2 ) )
, 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

View file

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

View file

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

View file

@ -74,7 +74,7 @@ instance BoxCt n d => RootIsolationAlgorithm Bisection n d where
:: RootIsolationAlgorithmOptions Bisection 2 3
-> [ ( RootIsolationStep, Box 2 ) ]
-> BoxHistory 2
-> ( 𝕀 2 -> D 1 ( 𝕀 2 ) ( 𝕀 3 ) )
-> ( 𝕀 2 -> D 1 2 ( 𝕀 3 ) )
-> Box 2
-> Writer ( DoneBoxes 2 ) ( StepDescription Bisection, [ Box 2 ] ) #-}
-- 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
-- (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.
--
-- 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
= [ ( RootIsolationStep, Box n ) ]
-> BoxHistory n
-> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> ( 𝕀 n -> D 1 n ( 𝕀 d ) )
-> forall r. ( NE.NonEmpty ( Fin n, r ) -> ( r, String ) )
-- | Default options for the bisection method.

View file

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

View file

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

View file

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