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

continue interval arithmetic integration

Browse source
This commit is contained in:
sheaf 2023-01-13 15:23:33 +01:00
parent a4e9c1cf32
commit 09c1bdd948
5 changed files with 115 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
MetaBrush.cabal
View file

@ -76,6 +76,7 @@ common common
PatternSynonyms PatternSynonyms
RankNTypes RankNTypes
RecordWildCards RecordWildCards
RoleAnnotations
StandaloneDeriving StandaloneDeriving
StandaloneKindSignatures StandaloneKindSignatures
TupleSections TupleSections

11
src/splines/Math/Bezier/Spline.hs
View file

@ -18,7 +18,7 @@ import Data.Functor.Const
import Data.Functor.Identity import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.Kind import Data.Kind
( Constraint ) ( Type, Constraint )
import Data.Monoid import Data.Monoid
( Ap(..) ) ( Ap(..) )
import Data.Semigroup import Data.Semigroup
@ -87,7 +87,8 @@ instance SplineTypeI Open where
instance SplineTypeI Closed where instance SplineTypeI Closed where
ssplineType = SClosed ssplineType = SClosed
data family NextPoint ( clo :: SplineType ) ptData type NextPoint :: SplineType -> Type -> Type
data family NextPoint clo
newtype instance NextPoint Open ptData = NextPoint { nextPoint :: ptData } newtype instance NextPoint Open ptData = NextPoint { nextPoint :: ptData }
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass ( NFData, NFData1 ) deriving anyclass ( NFData, NFData1 )
@ -111,7 +112,8 @@ toNextPoint pt = case ssplineType @clo of
SOpen -> NextPoint pt SOpen -> NextPoint pt
SClosed -> BackToStart SClosed -> BackToStart
data Curve ( clo :: SplineType ) crvData ptData type Curve :: SplineType -> Type -> Type -> Type
data Curve clo crvData ptData
= LineTo = LineTo
{ curveEnd :: !( NextPoint clo ptData ) { curveEnd :: !( NextPoint clo ptData )
, curveData :: !crvData , curveData :: !crvData
@ -157,7 +159,8 @@ openCurveStart ( LineTo ( NextPoint p ) _ ) = p
openCurveStart ( Bezier2To p _ _ ) = p openCurveStart ( Bezier2To p _ _ ) = p
openCurveStart ( Bezier3To p _ _ _ ) = p openCurveStart ( Bezier3To p _ _ _ ) = p
data family Curves ( clo :: SplineType ) crvData ptData type Curves :: SplineType -> Type -> Type -> Type
data family Curves clo
newtype instance Curves Open crvData ptData newtype instance Curves Open crvData ptData
= OpenCurves { openCurves :: Seq ( Curve Open crvData ptData ) } = OpenCurves { openCurves :: Seq ( Curve Open crvData ptData ) }

163
src/splines/Math/Bezier/Stroke.hs
View file

@ -1,8 +1,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Math.Bezier.Stroke module Math.Bezier.Stroke
( Offset(..) ( Offset(..)
@ -32,11 +31,13 @@ import Control.Monad.ST
import Data.Bifunctor import Data.Bifunctor
( Bifunctor(bimap) ) ( Bifunctor(bimap) )
import Data.Coerce import Data.Coerce
( coerce ) ( Coercible, coerce )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import Data.Functor.Identity import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.Kind
( Type )
import Data.List.NonEmpty import Data.List.NonEmpty
( unzip ) ( unzip )
import Data.Maybe import Data.Maybe
@ -434,13 +435,16 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
case crv of case crv of
LineTo { curveEnd = NextPoint sp1 } LineTo { curveEnd = NextPoint sp1 }
| let seg = Segment sp0 sp1 | let seg = Segment sp0 sp1
-> ( line ( fmap coords seg ), line ( fmap ptParams seg ) ) -> ( line @Point ( fmap coords seg )
, line @Point ( fmap ptParams seg ) )
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 } Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
| let bez2 = Quadratic.Bezier sp0 sp1 sp2 | let bez2 = Quadratic.Bezier sp0 sp1 sp2
-> ( bezier2 ( fmap coords bez2 ), bezier2 ( fmap ptParams bez2 ) ) -> ( bezier2 @Point ( fmap coords bez2 )
, bezier2 @Point ( fmap ptParams bez2 ) )
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 } Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
| let bez3 = Cubic.Bezier sp0 sp1 sp2 sp3 | let bez3 = Cubic.Bezier sp0 sp1 sp2 sp3
-> ( bezier3 ( fmap coords bez3 ), bezier3 ( fmap ptParams bez3 ) ) -> ( bezier3 @Point ( fmap coords bez3 )
, bezier3 @Point ( fmap ptParams bez3 ) )
fwdBwd :: OutlineFn fwdBwd :: OutlineFn
fwdBwd t fwdBwd t
@ -449,8 +453,12 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
-- , ( offset bwdOffset • path_t, -1 *^ path'_t ) ) -- , ( offset bwdOffset • path_t, -1 *^ path'_t ) )
where where
curves :: Seq ( ℝ 1 -> StrokeDatum ) curves :: Seq ( ℝ 1 -> StrokeDatum Point )
curves = brushStrokeData path ( usedParams `chainRule` toBrushParams ) brushFromParams t curves = brushStrokeData @Point @brushParams
path
( usedParams `chainRule` toBrushParams )
brushFromParams
t
fwdOffset = withTangent path'_t brush_t fwdOffset = withTangent path'_t brush_t
bwdOffset = withTangent ( -1 *^ path'_t ) brush_t bwdOffset = withTangent ( -1 *^ path'_t ) brush_t
@ -771,7 +779,7 @@ brushStroke ( D1 p dpdt d2pdt2 ) ( D2 b dbdt dbds d2bdt2 d2bdtds d2bds2 ) =
-- | The envelope equation -- | The envelope equation
-- --
-- \[ E = \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} = 0, ] -- \[ E = \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} = 0, \]
-- --
-- together with the total derivative -- together with the total derivative
-- --
@ -782,12 +790,13 @@ brushStroke ( D1 p dpdt d2pdt2 ) ( D2 b dbdt dbds d2bdt2 d2bdtds d2bds2 ) =
-- \[ \frac{\partial E}{\partial s}, \qquad \frac{\partial E}{\partial s}. \] -- \[ \frac{\partial E}{\partial s}, \qquad \frac{\partial E}{\partial s}. \]
-- --
-- NB: if \( \frac{\partial E}{\partial s} \) is zero, the total derivative is ill-defined. -- NB: if \( \frac{\partial E}{\partial s} \) is zero, the total derivative is ill-defined.
envelopeEquation :: ( D ( i ( ℝ 2 ) ) ~ D ( ℝ 2 ) envelopeEquation :: forall i
, Cross ( i Double ) ( T ( i ( ℝ 2 ) ) ) . ( D ( I i ( ℝ 2 ) ) ~ D ( ℝ 2 )
, Fractional ( i Double ) , Cross ( I i Double ) ( T ( I i ( ℝ 2 ) ) )
, Fractional ( I i Double )
) )
=> D ( i ( ℝ 2 ) ) ( i ( ℝ 2 ) ) => D ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) )
-> ( i Double, T ( i ( ℝ 2 ) ), i Double, i Double ) -> ( I i Double, T ( I i ( ℝ 2 ) ), I i Double, I i Double )
envelopeEquation ( D2 _ dcdt dcds d2cdt2 d2cdtds d2cds2 ) = envelopeEquation ( D2 _ dcdt dcds d2cdt2 d2cdtds d2cds2 ) =
let ee = dcdt `cross` dcds let ee = dcdt `cross` dcds
dEdt = d2cdt2 `cross` dcds + dcdt `cross` d2cdtds dEdt = d2cdt2 `cross` dcds + dcdt `cross` d2cdtds
@ -802,30 +811,47 @@ envelopeEquation ( D2 _ dcdt dcds d2cdt2 d2cdtds d2cds2 ) =
-- ∂E/∂s dc/dt = ∂E/∂s ∂c/∂t - ∂E/∂t ∂c/∂s. -- ∂E/∂s dc/dt = ∂E/∂s ∂c/∂t - ∂E/∂t ∂c/∂s.
-- | Linear interpolation, as a differentiable function. -- | Linear interpolation, as a differentiable function.
line :: forall b. ( Module Double ( T b ), Torsor ( T b ) b ) line :: forall i b
=> Segment b -> ℝ 1 ~> b . ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
line ( Segment a b ) = D \ ( ℝ1 t ) -> , D ( I i ( ℝ 1 ) ) ~ D ( ℝ 1 )
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
)
=> Segment b -> I i ( ℝ 1 ) ~> b
line ( Segment a b ) = D \ ( coerce -> t ) ->
D1 ( lerp @( T b ) t a b ) D1 ( lerp @( T b ) t a b )
( a --> b ) ( a --> b )
origin origin
-- | A quadratic Bézier curve, as a differentiable function. -- | A quadratic Bézier curve, as a differentiable function.
bezier2 :: forall b. ( Module Double ( T b ), Torsor ( T b ) b ) bezier2 :: forall i b
=> Quadratic.Bezier b -> ℝ 1 ~> b . ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
bezier2 bez = D \ ( ℝ1 t ) -> , D ( I i ( ℝ 1 ) ) ~ D ( ℝ 1 )
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
)
=> Quadratic.Bezier b -> I i ( ℝ 1 ) ~> b
bezier2 bez = D \ ( coerce -> t ) ->
D1 ( Quadratic.bezier @( T b ) bez t ) D1 ( Quadratic.bezier @( T b ) bez t )
( Quadratic.bezier' bez t ) ( Quadratic.bezier' bez t )
( Quadratic.bezier'' bez ) ( Quadratic.bezier'' bez )
-- | A cubic Bézier curve, as a differentiable function. -- | A cubic Bézier curve, as a differentiable function.
bezier3 :: forall b. ( Module Double ( T b ), Torsor ( T b ) b ) bezier3 :: forall i b
=> Cubic.Bezier b -> ℝ 1 ~> b . ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
bezier3 bez = D \ ( ℝ1 t ) -> , D ( I i ( ℝ 1 ) ) ~ D ( ℝ 1 )
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
)
=> Cubic.Bezier b -> I i ( ℝ 1 ) ~> b
bezier3 bez = D \ ( coerce -> t ) ->
D1 ( Cubic.bezier @( T b ) bez t ) D1 ( Cubic.bezier @( T b ) bez t )
( Cubic.bezier' bez t ) ( Cubic.bezier' bez t )
( Cubic.bezier'' bez t ) ( Cubic.bezier'' bez t )
splineCurveFns :: SplinePts Closed -> Seq ( ℝ 1 ~> ℝ 2 ) splineCurveFns :: forall i
. ( D ( I i ( ℝ 1 ) ) ~ D ( ℝ 1 )
, Module ( I i Double ) ( T ( I i ( ℝ 2 ) ) )
, Torsor ( T ( I i ( ℝ 2 ) ) ) ( I i ( ℝ 2 ) )
, Coercible ( I i ( ℝ 1 ) ) ( I i Double ) )
=> Spline Closed () ( I i ( ℝ 2 ) ) -> Seq ( I i ( ℝ 1 ) ~> I i ( ℝ 2 ) )
splineCurveFns spls splineCurveFns spls
= runIdentity = runIdentity
. bifoldSpline . bifoldSpline
@ -834,21 +860,23 @@ splineCurveFns spls
. adjustSplineType @Open . adjustSplineType @Open
$ spls $ spls
where where
curveFn :: ℝ 2 -> Curve Open () ( ℝ 2 ) -> ( ℝ 1 ~> ℝ 2 ) curveFn :: I i ( ℝ 2 )
-> Curve Open () ( I i ( ℝ 2 ) )
-> ( I i ( ℝ 1 ) ~> I i ( ℝ 2 ) )
curveFn p0 = \case curveFn p0 = \case
LineTo { curveEnd = NextPoint p1 } LineTo { curveEnd = NextPoint p1 }
-> line $ Segment p0 p1 -> line @i $ Segment p0 p1
Bezier2To { controlPoint = p1, curveEnd = NextPoint p2 } Bezier2To { controlPoint = p1, curveEnd = NextPoint p2 }
-> bezier2 $ Quadratic.Bezier p0 p1 p2 -> bezier2 @i $ Quadratic.Bezier p0 p1 p2
Bezier3To { controlPoint1 = p1, controlPoint2 = p2, curveEnd = NextPoint p3 } Bezier3To { controlPoint1 = p1, controlPoint2 = p2, curveEnd = NextPoint p3 }
-> bezier3 $ Cubic.Bezier p0 p1 p2 p3 -> bezier3 @i $ Cubic.Bezier p0 p1 p2 p3
-- | Solve the envelope equations at a given point \( t = t_0 \), to find -- | Solve the envelope equations at a given point \( t = t_0 \), to find
-- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke. -- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke.
solveEnvelopeEquations :: ℝ 2 solveEnvelopeEquations :: ℝ 2
-> T ( ℝ 2 ) -> T ( ℝ 2 )
-> ( Offset, Offset ) -> ( Offset, Offset )
-> Seq ( ℝ 1 -> StrokeDatum ) -> Seq ( ℝ 1 -> StrokeDatum Point )
-> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) ) -> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) )
solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData
= ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) ) = ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) )
@ -909,7 +937,7 @@ solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData
| otherwise | otherwise
= i + 1 = i + 1
sol :: Double -> ( ℝ 1 -> StrokeDatum ) -> ( Bool, ℝ 1, ℝ 2, T ( ℝ 2 ) ) sol :: Double -> ( ℝ 1 -> StrokeDatum Point ) -> ( Bool, ℝ 1, ℝ 2, T ( ℝ 2 ) )
sol initialGuess f = sol initialGuess f =
let (good, s) = case newtonRaphson maxIters precision domain ( eqn f ) initialGuess of let (good, s) = case newtonRaphson maxIters precision domain ( eqn f ) initialGuess of
Nothing -> ( False, initialGuess ) Nothing -> ( False, initialGuess )
@ -937,7 +965,7 @@ solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData
-- ] ) -- ] )
( good, ℝ1 s, value @Double @( ℝ 2 ) dstroke, totDeriv ) ( good, ℝ1 s, value @Double @( ℝ 2 ) dstroke, totDeriv )
eqn :: ( ℝ 1 -> StrokeDatum ) -> ( Double -> ( Double, Double ) ) eqn :: ( ℝ 1 -> StrokeDatum Point ) -> ( Double -> ( Double, Double ) )
eqn f s = eqn f s =
case f ( ℝ1 s ) of case f ( ℝ1 s ) of
StrokeDatum { ee, 𝛿E𝛿s } -> StrokeDatum { ee, 𝛿E𝛿s } ->
@ -956,36 +984,47 @@ instance Applicative ZipSeq where
pure _ = error "only use Applicative ZipSeq with non-empty Traversable functors" pure _ = error "only use Applicative ZipSeq with non-empty Traversable functors"
liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys ) liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys )
brushStrokeData :: forall brushParams brushStrokeData :: forall i brushParams
. ( Diffy Double brushParams, Show brushParams ) . ( Diffy ( I i Double ) ( I i brushParams )
=> ( ℝ 1 ~> ℝ 2 ) -- ^ path , Fractional ( I i Double )
-> ( ℝ 1 ~> brushParams ) -- ^ brush parameters , D ( I i ( ℝ 1 ) ) ~ D ( ℝ 1 )
-> ( brushParams ~> SplinePts Closed ) -- ^ brush from parameters , D ( I i ( ℝ 2 ) ) ~ D ( ℝ 2 )
-> ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum ) ) , Cross ( I i Double ) ( T ( I i ( ℝ 2 ) ) )
, Torsor ( T ( I i ( ℝ 2 ) ) ) ( I i ( ℝ 2 ) )
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
, Show brushParams
)
=> ( I i ( ℝ 1 ) ~> I i ( ℝ 2 ) )
-- ^ path
-> ( I i ( ℝ 1 ) ~> I i brushParams )
-- ^ brush parameters
-> ( I i brushParams ~> Spline Closed () ( I i ( ℝ 2 ) ) )
-- ^ brush from parameters
-> ( I i ( ℝ 1 ) -> Seq ( I i ( ℝ 1 ) -> StrokeDatum i ) )
brushStrokeData path params brush = brushStrokeData path params brush =
\ t -> \ t ->
let let
dpath_t :: D ( ℝ 1 ) ( ℝ 2 ) dpath_t :: D ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) )
!dpath_t = runD path t !dpath_t = runD path t
dparams_t :: D ( ℝ 1 ) brushParams dparams_t :: D ( I i ( ℝ 1 ) ) ( I i brushParams )
!dparams_t@( D1 { v = params_t } ) = runD params t !dparams_t@( D1 { v = params_t } ) = runD params t
dbrush_params :: D brushParams ( SplinePts Closed ) dbrush_params :: D ( I i brushParams ) ( Spline Closed () ( I i ( ℝ 2 ) ) )
!dbrush_params = runD brush params_t !dbrush_params = runD brush params_t
splines :: Seq ( D brushParams ( ℝ 1 ~> ℝ 2 ) ) splines :: Seq ( D ( I i brushParams ) ( I i ( ℝ 1 ) ~> I i ( ℝ 2 ) ) )
!splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns ) dbrush_params !splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns @i ) dbrush_params
dbrushes_t :: Seq ( ℝ 1 -> D ( ℝ 2 ) ( ℝ 2 ) ) dbrushes_t :: Seq ( I i ( ℝ 1 ) -> D ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) ) )
!dbrushes_t = force $ fmap ( uncurryD . ( dparams_t `chain` ) ) splines !dbrushes_t = force $ fmap ( uncurryD . ( dparams_t `chain` ) ) splines
in fmap ( mkStrokeDatum dpath_t ) dbrushes_t in fmap ( mkStrokeDatum dpath_t ) dbrushes_t
where where
mkStrokeDatum :: D ( ℝ 1 ) ( ℝ 2 ) mkStrokeDatum :: D ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) )
-> ( ℝ 1 -> D ( ℝ 2 ) ( ℝ 2 ) ) -> ( I i ( ℝ 1 ) -> D ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) ) )
-> ( ℝ 1 -> StrokeDatum ) -> ( I i ( ℝ 1 ) -> StrokeDatum i )
mkStrokeDatum dpath_t dbrush_t s = mkStrokeDatum dpath_t dbrush_t s =
let dbrush_t_s = dbrush_t s let dbrush_t_s = dbrush_t s
dstroke@( D2 _c _𝛿c𝛿t _𝛿c𝛿s _ _ _ ) = brushStroke dpath_t dbrush_t_s dstroke@( D2 _c _𝛿c𝛿t _𝛿c𝛿s _ _ _ ) = brushStroke dpath_t dbrush_t_s
( ee, dcdt, 𝛿E𝛿t, 𝛿E𝛿s ) = coerce $ envelopeEquation @Identity $ coerce dstroke ( ee, dcdt, 𝛿E𝛿t, 𝛿E𝛿s ) = envelopeEquation @i dstroke
in -- trace in -- trace
-- ( unlines -- ( unlines
-- [ "envelopeEquation:" -- [ "envelopeEquation:"
@ -1004,34 +1043,46 @@ brushStrokeData path params brush =
, dstroke , dstroke
, ee, dcdt, 𝛿E𝛿t, 𝛿E𝛿s } , ee, dcdt, 𝛿E𝛿t, 𝛿E𝛿s }
-- | The value and derivative of a brush stroke at a given coordinate -- | The value and derivative of a brush stroke at a given coordinate
-- \( (t_0, s_0) \), together with the value of the envelope equation at that -- \( (t_0, s_0) \), together with the value of the envelope equation at that
-- point. -- point.
data StrokeDatum data StrokeDatum i
= StrokeDatum = StrokeDatum
{ -- | Path \( p(t_0) \) (with its 1st and 2nd derivatives). { -- | Path \( p(t_0) \) (with its 1st and 2nd derivatives).
dpath :: D ( ℝ 1 ) ( ℝ 2 ) dpath :: D ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) )
-- | Brush shape \( b(t_0, s_0) \) (with its 1st and 2nd derivatives). -- | Brush shape \( b(t_0, s_0) \) (with its 1st and 2nd derivatives).
, dbrush :: D ( ℝ 2 ) ( ℝ 2 ) , dbrush :: D ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) )
-- Everything below can be computed in terms of the first two fields. -- Everything below can be computed in terms of the first two fields.
-- | Stroke \( c(t_0,s_0) = p(t_0) + b(t_0,s_0) \) (with its 1st and 2nd derivatives). -- | Stroke \( c(t_0,s_0) = p(t_0) + b(t_0,s_0) \) (with its 1st and 2nd derivatives).
, dstroke :: D ( ℝ 2 ) ( ℝ 2 ) , dstroke :: D ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) )
-- | Envelope -- | Envelope
-- --
-- \[ 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 :: Double , ee :: I i Double
-- | \( \left ( \frac{\partial E}{\partial s} \right )_{(t_0,s_0)}. \) -- | \( \left ( \frac{\partial E}{\partial s} \right )_{(t_0,s_0)}. \)
, 𝛿E𝛿s :: Double , 𝛿E𝛿s :: I i Double
-- | \( \left ( \frac{\partial E}{\partial t} \right )_{(t_0,s_0)}. \) -- | \( \left ( \frac{\partial E}{\partial t} \right )_{(t_0,s_0)}. \)
, 𝛿E𝛿t :: Double , 𝛿E𝛿t :: I i Double
-- | Total derivative -- | Total derivative
-- --
-- \[ \left ( \frac{\mathrm{d} c}{\mathrm{d} t} \right )_{(t_0,s_0)}. \] -- \[ \left ( \frac{\mathrm{d} c}{\mathrm{d} t} \right )_{(t_0,s_0)}. \]
-- --
-- This is ill-defined when \( \frac{\partial E}{\partial s} = 0 \). -- This is ill-defined when \( \frac{\partial E}{\partial s} = 0 \).
, dcdt :: T ( ℝ 2 ) , dcdt :: T ( I i ( ℝ 2 ) )
} }
deriving stock Show
deriving stock instance Show ( StrokeDatum Point )
deriving stock instance Show ( StrokeDatum Interval )
-- Handling points and intervals uniformly.
data Extent = Point | Interval
type I :: Extent -> Type -> Type
type family I i a where
I Point a = a
I Interval a = 𝕀 a

3
src/splines/Math/Linear/Dual.hs
View file

@ -11,8 +11,6 @@ import Control.Applicative
( liftA2 ) ( liftA2 )
import Data.Coerce import Data.Coerce
( coerce ) ( coerce )
import Data.Functor.Identity
( Identity(..) )
import Data.Kind import Data.Kind
( Type, Constraint ) ( Type, Constraint )
import GHC.Generics import GHC.Generics
@ -45,7 +43,6 @@ type instance D ( ℝ 1 ) = Dℝ1
type instance D ( ℝ 2 ) = Dℝ2 type instance D ( ℝ 2 ) = Dℝ2
type instance D ( ℝ 3 ) = Dℝ3 type instance D ( ℝ 3 ) = Dℝ3
type instance D ( Identity a ) = D a
type instance D ( 𝕀 u ) = D u type instance D ( 𝕀 u ) = D u
newtype Dℝ0 v = D0 { v :: v } newtype Dℝ0 v = D0 { v :: v }

14
src/splines/Math/Module.hs
View file

@ -18,10 +18,6 @@ import Control.Applicative
( liftA2 ) ( liftA2 )
import Control.Monad import Control.Monad
( guard ) ( guard )
import Data.Coerce
( coerce )
import Data.Functor.Identity
( Identity(..) )
import Data.Kind import Data.Kind
( Type, Constraint ) ( Type, Constraint )
import Data.Monoid import Data.Monoid
@ -176,16 +172,6 @@ instance Inner Double ( T ( ℝ 2 ) ) where
instance Cross Double ( T ( ℝ 2 ) ) where instance Cross Double ( T ( ℝ 2 ) ) where
cross ( V2 x1 y1 ) ( V2 x2 y2 ) = x1 * y2 - x2 * y1 cross ( V2 x1 y1 ) ( V2 x2 y2 ) = x1 * y2 - x2 * y1
instance Module r ( T m ) => Module ( Identity r ) ( T ( Identity m ) ) where
origin = coerce $ origin @r @( T m )
(^+^) = coerce $ (^+^) @r @( T m )
(^-^) = coerce $ (^-^) @r @( T m )
(*^) = coerce $ (*^) @r @( T m )
instance Inner r ( T m ) => Inner ( Identity r ) ( T ( Identity m ) ) where
(^.^) = coerce $ (^.^) @r @( T m )
instance Cross r ( T m ) => Cross ( Identity r ) ( T ( Identity m ) ) where
cross = coerce $ cross @r @( T m )
-- | Compute whether two vectors point in the same direction, -- | Compute whether two vectors point in the same direction,
-- that is, whether each vector is a (strictly) positive multiple of the other. -- that is, whether each vector is a (strictly) positive multiple of the other.
-- --