mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
more work into observability
This commit is contained in:
sheaf
parent
52420a1169
commit
7db3cbef33
|
|
@ -265,7 +265,7 @@ library metabrushes
|
||||||
, bytestring
|
, bytestring
|
||||||
>= 0.10.10.0 && < 0.12
|
>= 0.10.10.0 && < 0.12
|
||||||
|
|
||||||
executable test-cusp-isolation
|
executable cusps
|
||||||
|
|
||||||
import:
|
import:
|
||||||
common
|
common
|
||||||
|
|
@ -273,11 +273,15 @@ executable test-cusp-isolation
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src/cusps
|
src/cusps
|
||||||
|
|
||||||
|
main-is:
|
||||||
|
Main.hs
|
||||||
|
|
||||||
|
other-modules:
|
||||||
|
Math.Interval.Abstract
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
splines
|
splines
|
||||||
|
|
||||||
main-is:
|
|
||||||
Main.hs
|
|
||||||
|
|
||||||
executable convert-metafont
|
executable convert-metafont
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,27 +1,27 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Prelude hiding ( Num(..), Fractional(..), Floating(..), (^) )
|
import Prelude hiding ( Num(..), Fractional(..), Floating(..), (^) )
|
||||||
import qualified Prelude ( Num(..), Fractional(..) )
|
import qualified Prelude
|
||||||
import Data.Coerce
|
|
||||||
( Coercible )
|
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic )
|
( Generic )
|
||||||
|
|
||||||
-- acts
|
-- acts
|
||||||
import Data.Act
|
import Data.Act
|
||||||
( Torsor )
|
( Torsor(..) )
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import Data.Map
|
|
||||||
( Map )
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
( (!) )
|
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
( index )
|
( fromList, index )
|
||||||
|
|
||||||
-- generic-lens
|
-- generic-lens
|
||||||
import Data.Generics.Product.Typed
|
import Data.Generics.Product.Typed
|
||||||
|
|
@ -36,18 +36,22 @@ import Math.Bezier.Stroke.EnvelopeEquation
|
||||||
( StrokeDatum(..) )
|
( StrokeDatum(..) )
|
||||||
import Math.Differentiable
|
import Math.Differentiable
|
||||||
( I )
|
( I )
|
||||||
import Math.Interval
|
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ(..), T(..) )
|
( ℝ(..), T(..)
|
||||||
|
, Fin(..)
|
||||||
|
, Representable(..) )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( Module, Cross )
|
( Module(..), Cross(..) )
|
||||||
import Math.Ring
|
import Math.Ring
|
||||||
( AbelianGroup(..), Ring(..), Field(..), Transcendental(..)
|
( AbelianGroup(..), Ring(..), Transcendental(..) )
|
||||||
, ViaPrelude(..)
|
|
||||||
)
|
import Math.Interval.Abstract
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = print ellipseTest
|
||||||
|
|
||||||
data PointData params
|
data PointData params
|
||||||
= PointData
|
= PointData
|
||||||
{ pointCoords :: !( ℝ 2 )
|
{ pointCoords :: !( ℝ 2 )
|
||||||
|
|
@ -55,33 +59,14 @@ data PointData params
|
||||||
}
|
}
|
||||||
deriving stock ( Show, Generic )
|
deriving stock ( Show, Generic )
|
||||||
|
|
||||||
|
|
||||||
{-
|
|
||||||
|
|
||||||
newtype C k u v = D { runD :: u -> D k u v }
|
|
||||||
|
|
||||||
type instance D k ( ℝ n ) = Dk𝔸n
|
|
||||||
type instance D k ( 𝕀 v ) = D k v
|
|
||||||
|
|
||||||
e.g.
|
|
||||||
|
|
||||||
data D2𝔸2 v =
|
|
||||||
D22 { _D22_v :: !v
|
|
||||||
, _D22_dx, _D22_dy :: !( T v )
|
|
||||||
, _D22_dxdx, _D22_dxdy, _D22_dydy :: !( T v )
|
|
||||||
}
|
|
||||||
|
|
||||||
-}
|
|
||||||
|
|
||||||
|
|
||||||
outlineFunction
|
outlineFunction
|
||||||
:: forall i brushParams
|
:: forall {t} (i :: t) brushParams
|
||||||
. ( Show brushParams
|
. ( Show brushParams
|
||||||
, D 1 ( I i ( ℝ 2 ) ) ~ D 1 ( ℝ 2 )
|
, D 1 ( I i ( ℝ 2 ) ) ~ D 1 ( ℝ 2 )
|
||||||
, D 2 ( I i ( ℝ 2 ) ) ~ D 2 ( ℝ 2 )
|
, D 2 ( I i ( ℝ 2 ) ) ~ D 2 ( ℝ 2 )
|
||||||
, D 3 ( I i ( ℝ 1 ) ) ~ D 3 ( ℝ 1 )
|
, D 3 ( I i ( ℝ 1 ) ) ~ D 3 ( ℝ 1 )
|
||||||
, D 3 ( I i ( ℝ 2 ) ) ~ D 3 ( ℝ 2 )
|
, D 3 ( I i ( ℝ 2 ) ) ~ D 3 ( ℝ 2 )
|
||||||
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
-- , Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
||||||
, 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 ) )
|
||||||
|
|
@ -92,118 +77,200 @@ outlineFunction
|
||||||
, Traversable ( D 3 brushParams )
|
, Traversable ( D 3 brushParams )
|
||||||
, Traversable ( D 3 ( I i brushParams ) )
|
, Traversable ( D 3 ( I i brushParams ) )
|
||||||
)
|
)
|
||||||
=> ( forall a. a -> I i a )
|
=> ( I i Double -> I i ( ℝ 1 ) )
|
||||||
|
-> ( I i ( ℝ 1 ) -> I i Double )
|
||||||
|
-> ( forall a. a -> I i a )
|
||||||
-> C 3 ( I i brushParams ) ( Spline Closed () ( I i ( ℝ 2 ) ) )
|
-> C 3 ( I i brushParams ) ( Spline Closed () ( I i ( ℝ 2 ) ) )
|
||||||
-- ^ brush shape
|
-- ^ brush shape
|
||||||
-> Int -- ^ brush segment index to consider
|
-> Int -- ^ brush segment index to consider
|
||||||
-> PointData brushParams -> Curve Open () ( PointData brushParams )
|
-> PointData brushParams -> Curve Open () ( PointData brushParams )
|
||||||
-- ^ stroke path
|
-- ^ stroke path
|
||||||
-> ( I i ( ℝ 1 ) -> I i ( ℝ 1 ) -> StrokeDatum 3 i )
|
-> ( I i ( ℝ 1 ) -> I i ( ℝ 1 ) -> StrokeDatum 3 i )
|
||||||
outlineFunction single brush brush_index sp0 crv = strokeData
|
outlineFunction co1 co2 single brush brush_index sp0 crv = strokeData
|
||||||
|
|
||||||
where
|
where
|
||||||
path :: C 3 ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) )
|
path :: C 3 ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) )
|
||||||
params :: C 3 ( I i ( ℝ 1 ) ) ( I i brushParams )
|
params :: C 3 ( I i ( ℝ 1 ) ) ( I i brushParams )
|
||||||
(path, params) =
|
(path, params) =
|
||||||
pathAndUsedParams @3 @i single brushParams sp0 crv
|
pathAndUsedParams @3 @i co2 single brushParams sp0 crv
|
||||||
|
|
||||||
strokeData :: I i ( ℝ 1 ) -> I i ( ℝ 1 ) -> StrokeDatum 3 i
|
strokeData :: I i ( ℝ 1 ) -> I i ( ℝ 1 ) -> StrokeDatum 3 i
|
||||||
strokeData =
|
strokeData =
|
||||||
fmap ( `Seq.index` brush_index ) $
|
fmap ( `Seq.index` brush_index ) $
|
||||||
brushStrokeData @3 @brushParams @i path params brush
|
brushStrokeData @3 @brushParams @i co1 co2 path params brush
|
||||||
|
|
||||||
main :: IO ()
|
boo :: ( HasType ( ℝ 2 ) ( PointData brushParams )
|
||||||
main = return ()
|
, Show brushParams
|
||||||
|
, Module ( AI Double ) ( T ( AI brushParams ) )
|
||||||
|
, Torsor ( T ( AI brushParams ) ) ( AI brushParams )
|
||||||
|
, HasChainRule ( AI Double ) 3 ( AI brushParams )
|
||||||
|
, Traversable ( D 3 brushParams )
|
||||||
|
)
|
||||||
|
=> C 3 ( AI brushParams ) ( Spline Closed () ( AI ( ℝ 2 ) ) )
|
||||||
|
-> Int
|
||||||
|
-> PointData brushParams -> Curve Open () ( PointData brushParams )
|
||||||
|
-> StrokeDatum 3 AI
|
||||||
|
boo x i y z
|
||||||
|
= outlineFunction @AI
|
||||||
|
Coerce1 Coerce2 (Pt . Val)
|
||||||
|
x i y z
|
||||||
|
(Coerce1 $ Pt $ Var "t") (Coerce1 $ Pt $ Var "s")
|
||||||
|
|
||||||
|
ellipseTest :: StrokeDatum 3 AI
|
||||||
|
ellipseTest =
|
||||||
|
boo ( ellipseBrush @AI ( Pt . Val ) scaleI ) 1
|
||||||
|
( mkPoint ( ℝ2 10 -20 ) 2 1 0 )
|
||||||
|
( LineTo { curveEnd = NextPoint $ mkPoint ( ℝ2 10 10 ) 10 5 ( pi Prelude./ 4 )
|
||||||
|
, curveData = () } )
|
||||||
|
where
|
||||||
|
mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( ℝ 3 )
|
||||||
|
mkPoint pt a b phi = PointData pt ( ℝ3 a b phi )
|
||||||
|
scaleI :: Double -> AI Double -> AI Double
|
||||||
|
scaleI x iv = Scale (Pt $ Val x) iv
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- EDSL for inspection
|
-- EDSL for inspection
|
||||||
|
|
||||||
type instance I AA a = AA a
|
instance HasChainRule ( AI Double ) 3 ( AI ( ℝ 1 ) ) where
|
||||||
|
|
||||||
data AAVal a where
|
konst x = D31 x o o o
|
||||||
Val :: a -> AAVal a
|
where o = T $ fromInteger (0 :: Integer)
|
||||||
Var :: String -> AAVal Double
|
value ( D31 { _D31_v = x } ) = x
|
||||||
|
linearD f x = D31 (f x) (T $ f $ Pt $ Val $ ℝ1 1) o o
|
||||||
|
where o = origin
|
||||||
|
|
||||||
instance Show a => Show ( AAVal a ) where
|
chain :: forall w. Module ( AI Double ) ( T w ) => D3𝔸1 ( AI ( ℝ 1 ) ) -> D3𝔸1 w -> D3𝔸1 w
|
||||||
show (Val v) = show v
|
chain !df !dg =
|
||||||
show (Var v) = show v
|
let !o = origin @( AI Double ) @( T w )
|
||||||
|
!p = (^+^) @( AI Double ) @( T w )
|
||||||
|
!s = (^*) @( AI Double ) @( T w )
|
||||||
|
in $$( chainRule1NQ
|
||||||
|
[|| o ||] [|| p ||] [|| s ||]
|
||||||
|
[|| df ||] [|| dg ||] )
|
||||||
|
|
||||||
data AA a where
|
instance HasChainRule ( AI Double ) 3 ( AI ( ℝ 2 ) ) where
|
||||||
Pt :: AAVal a -> AA a
|
|
||||||
Ival :: AAVal a -> AAVal a -> AA a
|
|
||||||
(:+:) :: AA Double -> AA Double -> AA Double
|
|
||||||
(:-:) :: AA Double -> AA Double -> AA Double
|
|
||||||
Negate :: AA Double -> AA Double
|
|
||||||
(:*:) :: AA Double -> AA Double -> AA Double
|
|
||||||
(:^:) :: AA Double -> Word -> AA Double
|
|
||||||
Recip :: AA Double -> AA Double
|
|
||||||
Cos :: AA Double -> AA Double
|
|
||||||
Sin :: AA Double -> AA Double
|
|
||||||
Pi :: AA Double
|
|
||||||
|
|
||||||
instance Show a => Show (AA a) where
|
konst x = D32 x o o o o o o o o o
|
||||||
showsPrec prec = \case
|
where o = T $ fromInteger (0 :: Integer)
|
||||||
Pt v -> showString "[" . showsPrec 0 v . showString "]"
|
value ( D32 { _D32_v = x } ) = x
|
||||||
Ival lo hi -> showString "[" . showsPrec 0 lo . showString "," . showsPrec 0 hi . showString "]"
|
linearD f x =
|
||||||
iv1 :+: iv2 -> showParen (prec > 6) $ showsPrec 6 iv1 . showString " + " . showsPrec 7 iv2
|
D32 (f x)
|
||||||
iv1 :-: iv2 -> showParen (prec > 6) $ showsPrec 6 iv1 . showString " - " . showsPrec 7 iv2
|
(T $ f $ Pt $ Val $ ℝ2 1 0)
|
||||||
iv1 :*: iv2 -> showParen (prec > 7) $ showsPrec 7 iv1 . showString " - " . showsPrec 8 iv2
|
(T $ f $ Pt $ Val $ ℝ2 0 1)
|
||||||
iv :^: n -> showParen (prec > 8) $ showsPrec 9 iv . showString " ^ " . showsPrec 8 n
|
o o o o o o o
|
||||||
Negate iv -> showParen (prec > 10) $ showString "negate " . showsPrec 11 iv
|
where o = origin
|
||||||
Recip iv -> showParen (prec > 10) $ showString "recip " . showsPrec 11 iv
|
|
||||||
Cos iv -> showParen (prec > 10) $ showString "cos " . showsPrec 11 iv
|
|
||||||
Sin iv -> showParen (prec > 10) $ showString "sin " . showsPrec 11 iv
|
|
||||||
Pi -> showString "pi"
|
|
||||||
|
|
||||||
infixl 6 :+:
|
chain :: forall w. Module ( AI Double ) ( T w ) => D3𝔸1 ( AI ( ℝ 2 ) ) -> D3𝔸2 w -> D3𝔸1 w
|
||||||
infixl 6 :-:
|
chain !df !dg =
|
||||||
infixl 7 :*:
|
let !o = origin @( AI Double ) @( T w )
|
||||||
infixr 8 :^:
|
!p = (^+^) @( AI Double ) @( T w )
|
||||||
|
!s = (^*) @( AI Double ) @( T w )
|
||||||
|
in $$( chainRule1NQ
|
||||||
|
[|| o ||] [|| p ||] [|| s ||]
|
||||||
|
[|| df ||] [|| dg ||] )
|
||||||
|
|
||||||
val :: Map String Double -> AAVal a -> a
|
instance HasChainRule ( AI Double ) 3 ( AI ( ℝ 3 ) ) where
|
||||||
val _ ( Val a ) = a
|
|
||||||
val vars ( Var v ) = vars Map.! v
|
|
||||||
|
|
||||||
eval :: Map String Double -> AA a -> 𝕀 a
|
konst x = D33 x o o o o o o o o o o o o o o o o o o o
|
||||||
eval vars = \ case
|
where o = T $ fromInteger (0 :: Integer)
|
||||||
Pt v -> let f = val vars v in 𝕀 f f
|
value ( D33 { _D33_v = x } ) = x
|
||||||
Ival lo hi -> 𝕀 (val vars lo) (val vars hi)
|
linearD f x =
|
||||||
iv1 :+: iv2 -> eval vars iv1 + eval vars iv2
|
D33 (f x)
|
||||||
iv1 :-: iv2 -> eval vars iv1 - eval vars iv2
|
(T $ f $ Pt $ Val $ ℝ3 1 0 0)
|
||||||
Negate iv -> negate $ eval vars iv
|
(T $ f $ Pt $ Val $ ℝ3 0 1 0)
|
||||||
iv1 :*: iv2 -> eval vars iv1 * eval vars iv2
|
(T $ f $ Pt $ Val $ ℝ3 0 0 1)
|
||||||
iv :^: n -> eval vars iv ^ n
|
o o o o o o o o o o o o o o o o
|
||||||
Recip iv -> recip $ eval vars iv
|
where o = origin
|
||||||
Cos iv -> cos $ eval vars iv
|
|
||||||
Sin iv -> sin $ eval vars iv
|
|
||||||
Pi -> pi
|
|
||||||
|
|
||||||
instance Prelude.Num ( AA Double ) where
|
chain :: forall w. Module ( AI Double ) ( T w ) => D3𝔸1 ( AI ( ℝ 3 ) ) -> D3𝔸3 w -> D3𝔸1 w
|
||||||
(+) = (:+:)
|
chain !df !dg =
|
||||||
(-) = (:-:)
|
let !o = origin @( AI Double ) @( T w )
|
||||||
negate = Negate
|
!p = (^+^) @( AI Double ) @( T w )
|
||||||
(*) = (:*:)
|
!s = (^*) @( AI Double ) @( T w )
|
||||||
abs = error "No abs for abstract intervals"
|
in $$( chainRule1NQ
|
||||||
signum = error "No signum for abstract intervals"
|
[|| o ||] [|| p ||] [|| s ||]
|
||||||
fromInteger = Pt . Val . fromInteger
|
[|| df ||] [|| dg ||] )
|
||||||
|
|
||||||
instance Prelude.Fractional ( AA Double ) where
|
instance HasChainRule ( AI Double ) 3 ( AI ( ℝ 4 ) ) where
|
||||||
recip = Recip
|
|
||||||
(/) = error "No division for abstract intervals"
|
|
||||||
fromRational = Pt . Val . fromRational
|
|
||||||
|
|
||||||
instance Ring ( AA Double ) where
|
konst x = D34 x o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o
|
||||||
(*) = (:*:)
|
where o = T $ fromInteger (0 :: Integer)
|
||||||
(^) = (:^:)
|
value ( D34 { _D34_v = x } ) = x
|
||||||
|
linearD f x =
|
||||||
|
D34 (f x)
|
||||||
|
(T $ f $ Pt $ Val $ ℝ4 1 0 0 0)
|
||||||
|
(T $ f $ Pt $ Val $ ℝ4 0 1 0 0)
|
||||||
|
(T $ f $ Pt $ Val $ ℝ4 0 0 1 0)
|
||||||
|
(T $ f $ Pt $ Val $ ℝ4 0 0 0 1)
|
||||||
|
o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o
|
||||||
|
where o = origin
|
||||||
|
|
||||||
deriving via ViaPrelude ( AA Double )
|
chain :: forall w. Module ( AI Double ) ( T w ) => D3𝔸1 ( AI ( ℝ 4 ) ) -> D3𝔸4 w -> D3𝔸1 w
|
||||||
instance AbelianGroup ( AA Double )
|
chain !df !dg =
|
||||||
deriving via ViaPrelude ( AA Double )
|
let !o = origin @( AI Double ) @( T w )
|
||||||
instance AbelianGroup ( T ( AA Double ) )
|
!p = (^+^) @( AI Double ) @( T w )
|
||||||
deriving via ViaPrelude ( AA Double )
|
!s = (^*) @( AI Double ) @( T w )
|
||||||
instance Field ( AA Double )
|
in $$( chainRule1NQ
|
||||||
|
[|| o ||] [|| p ||] [|| s ||]
|
||||||
|
[|| df ||] [|| dg ||] )
|
||||||
|
|
||||||
instance Transcendental ( AA Double ) where
|
--------------------------------------------------------------------------------
|
||||||
pi = Pi
|
-- Brushes (TODO copied from MetaBrush.Asset.Brushes)
|
||||||
cos = Cos
|
|
||||||
sin = Sin
|
κ :: Double
|
||||||
|
κ = 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 ) )
|
||||||
|
circleSpline p = sequenceA $
|
||||||
|
Spline { splineStart = p 1 0
|
||||||
|
, splineCurves = ClosedCurves crvs lastCrv }
|
||||||
|
where
|
||||||
|
crvs = Seq.fromList
|
||||||
|
[ Bezier3To ( p 1 κ ) ( p κ 1 ) ( NextPoint ( p 0 1 ) ) ()
|
||||||
|
, Bezier3To ( p -κ 1 ) ( p -1 κ ) ( NextPoint ( p -1 0 ) ) ()
|
||||||
|
, Bezier3To ( p -1 -κ ) ( p -κ -1 ) ( NextPoint ( p 0 -1 ) ) ()
|
||||||
|
]
|
||||||
|
lastCrv =
|
||||||
|
Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart ()
|
||||||
|
{-# INLINE circleSpline #-}
|
||||||
|
|
||||||
|
ellipseBrush :: forall {t} (i :: t) k irec
|
||||||
|
. ( irec ~ I i ( ℝ 3 )
|
||||||
|
, Module
|
||||||
|
( D k irec ( I i Double ) )
|
||||||
|
( D k irec ( I i ( ℝ 2 ) ) )
|
||||||
|
, Module ( I i Double ) ( T ( I i Double ) )
|
||||||
|
, HasChainRule ( I i Double ) k irec
|
||||||
|
, Representable ( I i Double ) irec
|
||||||
|
, Applicative ( D k irec )
|
||||||
|
, Transcendental ( D k irec ( I i Double ) )
|
||||||
|
)
|
||||||
|
=> ( forall a. a -> I i a )
|
||||||
|
-> ( Double -> I i Double -> I i Double )
|
||||||
|
-> C k irec ( Spline 'Closed () ( I i ( ℝ 2 ) ) )
|
||||||
|
ellipseBrush mkI scaleI =
|
||||||
|
D \ params ->
|
||||||
|
let a, b, phi :: D k irec ( I i Double )
|
||||||
|
a = runD ( var @_ @k ( Fin 1 ) ) params
|
||||||
|
b = runD ( var @_ @k ( Fin 2 ) ) params
|
||||||
|
phi = runD ( var @_ @k ( Fin 3 ) ) params
|
||||||
|
mkPt :: Double -> Double -> D k irec ( I i ( ℝ 2 ) )
|
||||||
|
mkPt x y
|
||||||
|
= let !a' = mul x a
|
||||||
|
!b' = mul y b
|
||||||
|
!c = cos phi
|
||||||
|
!s = sin phi
|
||||||
|
in ( a' * c - b' * s ) *^ e_x
|
||||||
|
^+^ ( a' * s + b' * c ) *^ e_y
|
||||||
|
in circleSpline @i @k @( ℝ 3 ) @( ℝ 2 ) mkPt
|
||||||
|
where
|
||||||
|
e_x, e_y :: D k irec ( I i ( ℝ 2 ) )
|
||||||
|
e_x = pure $ mkI $ ℝ2 1 0
|
||||||
|
e_y = pure $ mkI $ ℝ2 0 1
|
||||||
|
|
||||||
|
mul :: Double -> D k irec ( I i Double ) -> D k irec ( I i Double )
|
||||||
|
mul k = fmap ( scaleI k )
|
||||||
|
{-# INLINEABLE ellipseBrush #-}
|
||||||
|
|
|
||||||
465
src/cusps/Math/Interval/Abstract.hs
Normal file
465
src/cusps/Math/Interval/Abstract.hs
Normal file
|
|
@ -0,0 +1,465 @@
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
module Math.Interval.Abstract where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import Prelude hiding
|
||||||
|
( Num(..), Fractional(..), Floating(..), (^)
|
||||||
|
, unzip )
|
||||||
|
import qualified Prelude
|
||||||
|
( Num(..), Fractional(..) )
|
||||||
|
import Data.Coerce
|
||||||
|
( Coercible, coerce )
|
||||||
|
import Data.Foldable
|
||||||
|
( toList )
|
||||||
|
import Data.List
|
||||||
|
( intersperse )
|
||||||
|
import GHC.Show
|
||||||
|
( showCommaSpace )
|
||||||
|
|
||||||
|
-- acts
|
||||||
|
import Data.Act
|
||||||
|
( Act(..), Torsor(..) )
|
||||||
|
|
||||||
|
-- containers
|
||||||
|
import Data.Map
|
||||||
|
( Map )
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
( (!) )
|
||||||
|
|
||||||
|
-- groups
|
||||||
|
import Data.Group
|
||||||
|
( Group(..) )
|
||||||
|
|
||||||
|
-- MetaBrush
|
||||||
|
import Math.Algebra.Dual
|
||||||
|
import Math.Bezier.Stroke.EnvelopeEquation
|
||||||
|
( StrokeDatum(..) )
|
||||||
|
import Math.Differentiable
|
||||||
|
( I )
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
|
( ℝ(..), T(..)
|
||||||
|
, Vec(..), (!), unzip
|
||||||
|
, Fin(..), RepDim, Representable(..), RepresentableQ(..)
|
||||||
|
)
|
||||||
|
import Math.Module
|
||||||
|
( Module(..), Cross(..) )
|
||||||
|
import Math.Ring
|
||||||
|
( AbelianGroup(..), Ring(..), Field(..), Transcendental(..)
|
||||||
|
, ViaPrelude(..)
|
||||||
|
)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- EDSL for inspection
|
||||||
|
|
||||||
|
type instance D k (AI a) = D k (𝕀 a)
|
||||||
|
|
||||||
|
type instance I AI a = AI a
|
||||||
|
|
||||||
|
-- | A value: a constant, or a variable name.
|
||||||
|
data Value a where
|
||||||
|
Val :: a -> Value a
|
||||||
|
Var :: String -> Value Double
|
||||||
|
|
||||||
|
-- | A scalar or a vector.
|
||||||
|
data SV a where
|
||||||
|
Scalar :: SV Double
|
||||||
|
Vector :: IsVec v => SV v
|
||||||
|
|
||||||
|
instance Show a => Show ( Value a ) where
|
||||||
|
show (Val v) = show v
|
||||||
|
show (Var v) = v
|
||||||
|
|
||||||
|
-- | An abstract interval.
|
||||||
|
data AI a where
|
||||||
|
Pt :: Value a -> AI a
|
||||||
|
Ival :: Value a -> Value a -> AI a
|
||||||
|
(:+:) :: SV a -> AI a -> AI a -> AI a
|
||||||
|
(:-:) :: SV a -> AI a -> AI a -> AI a
|
||||||
|
Negate :: SV a -> AI a -> AI a
|
||||||
|
(:*:) :: AI Double -> AI Double -> AI Double
|
||||||
|
(:^:) :: AI Double -> Word -> AI Double
|
||||||
|
Recip :: AI Double -> AI Double
|
||||||
|
Scale :: IsVec v => AI Double -> AI v -> AI v
|
||||||
|
Cross :: AI ( ℝ 2 ) -> AI ( ℝ 2 ) -> AI Double
|
||||||
|
Cos :: AI Double -> AI Double
|
||||||
|
Sin :: AI Double -> AI Double
|
||||||
|
Pi :: AI Double
|
||||||
|
Coerce1 :: AI Double -> AI ( ℝ 1 )
|
||||||
|
Coerce2 :: AI ( ℝ 1 ) -> AI Double
|
||||||
|
Tabulate :: ( Eq ( ℝ n ), Show ( ℝ n ), Representable Double ( ℝ n ) ) => Vec n ( AI Double ) -> AI ( ℝ n )
|
||||||
|
Index :: ( Eq ( ℝ n ), Show ( ℝ n ), Representable Double ( ℝ n ) ) => AI ( ℝ n ) -> Fin n -> AI Double
|
||||||
|
|
||||||
|
instance ( Show a, Eq a ) => Show ( AI a ) where
|
||||||
|
showsPrec prec ai = case fst $ normalise ai of
|
||||||
|
Pt v -> showsPrec prec v
|
||||||
|
Ival lo hi -> showString "[" . showsPrec 0 lo . showCommaSpace . showsPrec 0 hi . showString "]"
|
||||||
|
(:+:) Scalar iv1 iv2 -> showParen (prec > 6) $ showsPrec 6 iv1 . showString " + " . showsPrec 7 iv2
|
||||||
|
(:+:) Vector iv1 iv2 -> showParen (prec > 6) $ showsPrec 6 iv1 . showString " + " . showsPrec 7 iv2
|
||||||
|
(:-:) Scalar iv1 iv2 -> showParen (prec > 6) $ showsPrec 6 iv1 . showString " - " . showsPrec 7 iv2
|
||||||
|
(:-:) Vector iv1 iv2 -> showParen (prec > 6) $ showsPrec 6 iv1 . showString " - " . showsPrec 7 iv2
|
||||||
|
iv1 :*: iv2 -> showParen (prec > 7) $ showsPrec 7 iv1 . showString " * " . showsPrec 8 iv2
|
||||||
|
Cross iv1 iv2 -> showParen (prec > 7) $ showsPrec 8 iv1 . showString " × " . showsPrec 8 iv2
|
||||||
|
iv :^: n -> showParen (prec > 8) $ showsPrec 9 iv . showString " ^ " . showsPrec 8 n
|
||||||
|
Scale k v -> showParen (prec > 9) $ showsPrec 10 k . showString " * " . showsPrec 10 v
|
||||||
|
Index iv ( Fin i ) -> showParen (prec > 9) $ showsPrec 9 iv . showString " ! " . showsPrec 10 i
|
||||||
|
Negate Scalar iv -> showParen (prec > 10) $ showString " -" . showsPrec 11 iv
|
||||||
|
Negate Vector iv -> showParen (prec > 10) $ showString " -" . showsPrec 11 iv
|
||||||
|
Recip iv -> showParen (prec > 10) $ showString " 1 / " . showsPrec 11 iv
|
||||||
|
Coerce1 iv -> showsPrec prec iv
|
||||||
|
Coerce2 iv -> showsPrec prec iv
|
||||||
|
Cos iv -> showParen (prec > 10) $ showString "cos " . showsPrec 11 iv
|
||||||
|
Sin iv -> showParen (prec > 10) $ showString "sin " . showsPrec 11 iv
|
||||||
|
Pi -> showString "pi"
|
||||||
|
Tabulate vs -> showString "(" . foldr (.) id ( intersperse showCommaSpace fields ) . showString ")"
|
||||||
|
where
|
||||||
|
fields :: [ ShowS ]
|
||||||
|
fields = [ showsPrec 0 v
|
||||||
|
| v <- toList vs
|
||||||
|
]
|
||||||
|
|
||||||
|
infixl 6 :+:
|
||||||
|
infixl 6 :-:
|
||||||
|
infixl 7 :*:
|
||||||
|
infixr 8 :^:
|
||||||
|
|
||||||
|
index_maybe :: ( Show ( ℝ n ), Representable Double ( ℝ n ) )
|
||||||
|
=> AI ( ℝ n ) -> Fin n -> Maybe ( AI Double )
|
||||||
|
index_maybe expr i = case expr of
|
||||||
|
Pt ( Val v )
|
||||||
|
-> Just $ Pt $ Val $ v `index` i
|
||||||
|
Ival ( Val lo ) ( Val hi )
|
||||||
|
-> Just $ Ival ( Val $ lo `index` i ) ( Val $ hi `index` i )
|
||||||
|
(:+:) Vector iv1 iv2
|
||||||
|
| Just v1 <- iv1 `index_maybe` i
|
||||||
|
, Just v2 <- iv2 `index_maybe` i
|
||||||
|
-> Just $ v1 + v2
|
||||||
|
(:-:) Vector iv1 iv2
|
||||||
|
| Just v1 <- iv1 `index_maybe` i
|
||||||
|
, Just v2 <- iv2 `index_maybe` i
|
||||||
|
-> Just $ v1 - v2
|
||||||
|
Negate Vector iv
|
||||||
|
| Just v <- iv `index_maybe` i
|
||||||
|
-> Just $ negate v
|
||||||
|
Scale k iv
|
||||||
|
| Just v <- iv `index_maybe` i
|
||||||
|
-> Just $ k * v
|
||||||
|
Tabulate v
|
||||||
|
-> Just $ v ! i
|
||||||
|
Coerce1 v
|
||||||
|
-> Just $ v
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
ival :: 𝕀 a -> AI a
|
||||||
|
ival ( 𝕀 lo hi ) = Ival ( Val lo ) ( Val hi )
|
||||||
|
|
||||||
|
normalise :: Eq a => AI a -> ( AI a, Maybe ( 𝕀 a ) )
|
||||||
|
normalise expr = case expr of
|
||||||
|
Pt ( Val v ) -> ( expr, Just $ 𝕀 v v )
|
||||||
|
Pt {} -> ( expr, Nothing )
|
||||||
|
Ival ( Val v1 ) ( Val v2 )
|
||||||
|
| v1 == v2
|
||||||
|
-> ( Pt ( Val v1 ), Just $ 𝕀 v1 v2 )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr, Just $ 𝕀 v1 v2 )
|
||||||
|
Ival {} -> ( expr, Nothing )
|
||||||
|
(:+:) sv iv1 iv2
|
||||||
|
| Scalar <- sv
|
||||||
|
, Just ( 𝕀 0 0 ) <- mv1
|
||||||
|
-> ( iv2', mv2 )
|
||||||
|
| Vector <- sv
|
||||||
|
, Just o <- mv1
|
||||||
|
, T o == origin
|
||||||
|
-> ( iv2', mv2 )
|
||||||
|
| Scalar <- sv
|
||||||
|
, Just ( 𝕀 0 0 ) <- mv2
|
||||||
|
-> ( iv1', mv1 )
|
||||||
|
| Vector <- sv
|
||||||
|
, Just o <- mv2
|
||||||
|
, T o == origin
|
||||||
|
-> ( iv1', mv1 )
|
||||||
|
| Just v1 <- mv1
|
||||||
|
, Just v2 <- mv2
|
||||||
|
-> let r = case sv of { Scalar -> v1 + v2; Vector -> unT $ T v1 ^+^ T v2 }
|
||||||
|
in ( ival r, Just $ r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = (:+:) sv iv1' iv2'
|
||||||
|
(iv1', mv1) = normalise iv1
|
||||||
|
(iv2', mv2) = normalise iv2
|
||||||
|
(:-:) sv iv1 iv2
|
||||||
|
| Scalar <- sv
|
||||||
|
, Just ( 𝕀 0 0 ) <- mv1
|
||||||
|
-> normalise $ Negate sv iv2
|
||||||
|
| Vector <- sv
|
||||||
|
, Just o <- mv1
|
||||||
|
, T o == origin
|
||||||
|
-> normalise $ Negate sv iv2
|
||||||
|
| Scalar <- sv
|
||||||
|
, Just ( 𝕀 0 0 ) <- mv2
|
||||||
|
-> ( iv1', mv1 )
|
||||||
|
| Vector <- sv
|
||||||
|
, Just o <- mv2
|
||||||
|
, T o == origin
|
||||||
|
-> ( iv1', mv1 )
|
||||||
|
| Just v1 <- mv1
|
||||||
|
, Just v2 <- mv2
|
||||||
|
-> let r = case sv of { Scalar -> v1 - v2; Vector -> unT $ T v1 ^-^ T v2 }
|
||||||
|
in ( ival r, Just $ r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = (:-:) sv iv1' iv2'
|
||||||
|
(iv1', mv1) = normalise iv1
|
||||||
|
(iv2', mv2) = normalise iv2
|
||||||
|
Negate sv iv
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = case sv of { Scalar -> unT $ negate $ T v; Vector -> unT $ origin ^-^ T v }
|
||||||
|
in ( ival r , Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Negate sv iv'
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
iv1 :*: iv2
|
||||||
|
| Just ( 𝕀 0 0 ) <- mv1
|
||||||
|
-> zero
|
||||||
|
| Just ( 𝕀 0 0 ) <- mv2
|
||||||
|
-> zero
|
||||||
|
| Just v1 <- mv1
|
||||||
|
, Just v2 <- mv2
|
||||||
|
-> let r = v1 + v2
|
||||||
|
in ( ival r, Just $ r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
zero = ( ival $ 𝕀 0 0, Just $ 𝕀 0 0 )
|
||||||
|
expr' = (:*:) iv1' iv2'
|
||||||
|
(iv1', mv1) = normalise iv1
|
||||||
|
(iv2', mv2) = normalise iv2
|
||||||
|
iv :^: n
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = v ^ n
|
||||||
|
in ( ival r , Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = iv' :^: n
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
Recip iv
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = recip v
|
||||||
|
in ( ival r , Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Recip iv'
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
Scale k iv
|
||||||
|
| Just ( 𝕀 0 0 ) <- mk
|
||||||
|
-> ( ival $ unT $ origin, Just $ unT origin )
|
||||||
|
| Just o <- mv
|
||||||
|
, T o == origin
|
||||||
|
-> ( ival $ unT $ origin, Just $ unT origin )
|
||||||
|
| Just ( 𝕀 1 1 ) <- mk
|
||||||
|
-> ( iv', mv )
|
||||||
|
| Just val_k <- mk
|
||||||
|
, Just val_v <- mv
|
||||||
|
-> let r = unT $ val_k *^ T val_v
|
||||||
|
in ( ival r, Just $ r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Scale k' iv'
|
||||||
|
(k' , mk) = normalise k
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
Cross iv1 iv2
|
||||||
|
| Just v1 <- mv1
|
||||||
|
, Just v2 <- mv2
|
||||||
|
-> let r = T v1 × T v2
|
||||||
|
in ( ival r, Just $ r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Cross iv1' iv2'
|
||||||
|
(iv1', mv1) = normalise iv1
|
||||||
|
(iv2', mv2) = normalise iv2
|
||||||
|
Cos iv
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = cos v
|
||||||
|
in ( ival r, Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Cos iv'
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
Sin iv
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = sin v
|
||||||
|
in ( ival r, Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Sin iv'
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
Pi -> ( Pi, Just pi )
|
||||||
|
Coerce1 iv
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = coerce v
|
||||||
|
in ( ival r, Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Coerce1 iv'
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
Coerce2 iv
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = coerce v
|
||||||
|
in ( ival r, Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Coerce2 iv'
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
Tabulate @n v
|
||||||
|
| Just xs <- sequence mxs
|
||||||
|
-> let r = tabulate ( xs ! )
|
||||||
|
in ( ival r, Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Tabulate v'
|
||||||
|
v' :: Vec n ( AI Double )
|
||||||
|
mxs :: Vec n ( Maybe ( 𝕀 Double ) )
|
||||||
|
(v', mxs) = unzip $ fmap normalise v
|
||||||
|
Index iv i
|
||||||
|
| Just r <- index_maybe iv' i
|
||||||
|
-> normalise r
|
||||||
|
| Just v <- mv
|
||||||
|
-> let r = v `index` i
|
||||||
|
in ( ival r, Just r )
|
||||||
|
| otherwise
|
||||||
|
-> ( expr', Nothing )
|
||||||
|
where
|
||||||
|
expr' = Index iv' i
|
||||||
|
(iv', mv) = normalise iv
|
||||||
|
|
||||||
|
val :: Map String Double -> Value a -> a
|
||||||
|
val _ ( Val a ) = a
|
||||||
|
val vars ( Var v ) = vars Map.! v
|
||||||
|
|
||||||
|
eval :: Map String Double -> AI a -> 𝕀 a
|
||||||
|
eval vars = \ case
|
||||||
|
Pt v -> let f = val vars v in 𝕀 f f
|
||||||
|
Ival lo hi -> 𝕀 (val vars lo) (val vars hi)
|
||||||
|
(:+:) Scalar iv1 iv2 -> eval vars iv1 + eval vars iv2
|
||||||
|
(:+:) Vector iv1 iv2 -> unT $ (^+^) ( T ( eval vars iv1 ) ) ( T ( eval vars iv2 ) )
|
||||||
|
(:-:) Scalar iv1 iv2 -> eval vars iv1 - eval vars iv2
|
||||||
|
(:-:) Vector iv1 iv2 -> unT $ (^-^) ( T ( eval vars iv1 ) ) ( T ( eval vars iv2 ) )
|
||||||
|
Negate Scalar iv -> unT $ negate $ T $ eval vars iv
|
||||||
|
Negate Vector iv -> unT $ invert $ T $ eval vars iv
|
||||||
|
iv1 :*: iv2 -> eval vars iv1 * eval vars iv2
|
||||||
|
iv :^: n -> eval vars iv ^ n
|
||||||
|
Recip iv -> recip $ eval vars iv
|
||||||
|
Scale k v -> unT $ eval vars k *^ T ( eval vars v )
|
||||||
|
Cross iv1 iv2 -> T ( eval vars iv1 ) × T ( eval vars iv2 )
|
||||||
|
Cos iv -> cos $ eval vars iv
|
||||||
|
Sin iv -> sin $ eval vars iv
|
||||||
|
Pi -> pi
|
||||||
|
Coerce1 a -> coerce $ eval vars a
|
||||||
|
Coerce2 a -> coerce $ eval vars a
|
||||||
|
Tabulate v -> let !w = fmap ( eval vars ) v
|
||||||
|
in tabulate ( w ! )
|
||||||
|
Index v i -> let !w = eval vars v
|
||||||
|
in index w i
|
||||||
|
|
||||||
|
instance Prelude.Num ( AI Double ) where
|
||||||
|
(+) = (:+:) Scalar
|
||||||
|
(-) = (:-:) Scalar
|
||||||
|
negate = Negate Scalar
|
||||||
|
(*) = (:*:)
|
||||||
|
abs = error "No abs for abstract intervals"
|
||||||
|
signum = error "No signum for abstract intervals"
|
||||||
|
fromInteger = Pt . Val . fromInteger
|
||||||
|
|
||||||
|
instance Prelude.Fractional ( AI Double ) where
|
||||||
|
recip = Recip
|
||||||
|
(/) = error "No division for abstract intervals"
|
||||||
|
fromRational = Pt . Val . fromRational
|
||||||
|
|
||||||
|
instance Ring ( AI Double ) where
|
||||||
|
(*) = (:*:)
|
||||||
|
(^) = (:^:)
|
||||||
|
|
||||||
|
deriving via ViaPrelude ( AI Double )
|
||||||
|
instance AbelianGroup ( AI Double )
|
||||||
|
deriving via ViaPrelude ( AI Double )
|
||||||
|
instance AbelianGroup ( T ( AI Double ) )
|
||||||
|
deriving via ViaPrelude ( AI Double )
|
||||||
|
instance Field ( AI Double )
|
||||||
|
|
||||||
|
instance Transcendental ( AI Double ) where
|
||||||
|
pi = Pi
|
||||||
|
cos = Cos
|
||||||
|
sin = Sin
|
||||||
|
|
||||||
|
class ( Eq v, Show v, Module ( 𝕀 Double ) ( T ( 𝕀 v ) ), Group ( T ( 𝕀 v ) ) )
|
||||||
|
=> IsVec v
|
||||||
|
instance ( Eq v, Show v, Module ( 𝕀 Double ) ( T ( 𝕀 v ) ), Group ( T ( 𝕀 v ) ) )
|
||||||
|
=> IsVec v
|
||||||
|
|
||||||
|
instance IsVec v => Module ( AI Double ) ( T ( AI v ) ) where
|
||||||
|
origin = T $ Pt $ Val $ inf $ unT ( origin :: T ( 𝕀 v ) )
|
||||||
|
(^+^) = coerce $ (:+:) Vector
|
||||||
|
(^-^) = coerce $ (:-:) Vector
|
||||||
|
(*^) = coerce Scale
|
||||||
|
instance Cross ( AI Double ) ( T ( AI ( ℝ 2 ) ) ) where
|
||||||
|
(×) = coerce Cross
|
||||||
|
|
||||||
|
instance IsVec v => Semigroup ( T ( AI v ) ) where
|
||||||
|
(<>) = (^+^)
|
||||||
|
instance IsVec v => Monoid ( T ( AI v ) ) where
|
||||||
|
mempty = origin
|
||||||
|
instance IsVec v => Group ( T ( AI v ) ) where
|
||||||
|
invert = coerce $ Negate Vector
|
||||||
|
|
||||||
|
instance IsVec v => Act ( T ( AI v ) ) ( AI v ) where
|
||||||
|
u • v = unT $ u ^+^ T v
|
||||||
|
instance IsVec v => Torsor ( T ( AI v ) ) ( AI v ) where
|
||||||
|
u --> v = T v ^-^ T u
|
||||||
|
|
||||||
|
deriving stock instance Show ( StrokeDatum 3 AI )
|
||||||
|
|
||||||
|
type instance RepDim ( AI u ) = RepDim u
|
||||||
|
|
||||||
|
instance Representable ( AI Double ) ( AI ( ℝ 1 ) ) where
|
||||||
|
tabulate f = Coerce1 ( f ( Fin 1 ) )
|
||||||
|
index x _ = Coerce2 x
|
||||||
|
instance Representable ( AI Double ) ( AI ( ℝ 2 ) ) where
|
||||||
|
tabulate f = Tabulate $ ( f ( Fin 1 ) ) `VS` ( f ( Fin 2 ) ) `VS` VZ
|
||||||
|
index x i = Index x i
|
||||||
|
instance Representable ( AI Double ) ( AI ( ℝ 3 ) ) where
|
||||||
|
tabulate f = Tabulate $ ( f ( Fin 1 ) ) `VS` ( f ( Fin 2 ) ) `VS` ( f ( Fin 3 ) ) `VS` VZ
|
||||||
|
index x i = Index x i
|
||||||
|
instance Representable ( AI Double ) ( AI ( ℝ 4 ) ) where
|
||||||
|
tabulate f = Tabulate $ ( f ( Fin 1 ) ) `VS` ( f ( Fin 2 ) ) `VS` ( f ( Fin 3 ) ) `VS` ( f ( Fin 4 ) ) `VS` VZ
|
||||||
|
index x i = Index x i
|
||||||
|
|
||||||
|
instance RepresentableQ ( AI Double ) ( AI ( ℝ 1 ) ) where
|
||||||
|
tabulateQ f = [|| Coerce1 $$( f ( Fin 1 ) ) ||]
|
||||||
|
indexQ x _ = [|| Coerce2 $$x ||]
|
||||||
|
instance RepresentableQ ( AI Double ) ( AI ( ℝ 2 ) ) where
|
||||||
|
tabulateQ f = [|| Tabulate $ $$( f ( Fin 1 ) ) `VS` $$( f ( Fin 2 ) ) `VS` VZ ||]
|
||||||
|
indexQ x ( Fin i ) = [|| Index $$x ( Fin i ) ||]
|
||||||
|
instance RepresentableQ ( AI Double ) ( AI ( ℝ 3 ) ) where
|
||||||
|
tabulateQ f = [|| Tabulate $ $$( f ( Fin 1 ) ) `VS` $$( f ( Fin 2 ) ) `VS` $$( f ( Fin 3 ) ) `VS` VZ ||]
|
||||||
|
indexQ x ( Fin i ) = [|| Index $$x ( Fin i ) ||]
|
||||||
|
instance RepresentableQ ( AI Double ) ( AI ( ℝ 4 ) ) where
|
||||||
|
tabulateQ f = [|| Tabulate $ $$( f ( Fin 1 ) ) `VS` $$( f ( Fin 2 ) ) `VS` $$( f ( Fin 3 ) ) `VS` $$( f ( Fin 4 ) ) `VS` VZ ||]
|
||||||
|
indexQ x ( Fin i ) = [|| Index $$x ( Fin i ) ||]
|
||||||
|
|
@ -15,6 +15,8 @@ module Math.Algebra.Dual
|
||||||
, uncurryD2, uncurryD3
|
, uncurryD2, uncurryD3
|
||||||
, linear, fun, var
|
, linear, fun, var
|
||||||
|
|
||||||
|
, chainRuleN1Q, chainRule1NQ
|
||||||
|
|
||||||
, D𝔸0(..)
|
, D𝔸0(..)
|
||||||
, D1𝔸1(..), D2𝔸1(..), D3𝔸1(..)
|
, D1𝔸1(..), D2𝔸1(..), D3𝔸1(..)
|
||||||
, D1𝔸2(..), D2𝔸2(..), D3𝔸2(..)
|
, D1𝔸2(..), D2𝔸2(..), D3𝔸2(..)
|
||||||
|
|
|
||||||
|
|
@ -534,12 +534,13 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
|
||||||
usedParams :: C 2 ( ℝ 1 ) usedParams
|
usedParams :: C 2 ( ℝ 1 ) usedParams
|
||||||
path :: C 2 ( ℝ 1 ) ( ℝ 2 )
|
path :: C 2 ( ℝ 1 ) ( ℝ 2 )
|
||||||
( path, usedParams )
|
( path, usedParams )
|
||||||
= pathAndUsedParams @2 @() id ptParams sp0 crv
|
= pathAndUsedParams @2 @() coerce id ptParams sp0 crv
|
||||||
|
|
||||||
curves :: ℝ 1 -- t
|
curves :: ℝ 1 -- t
|
||||||
-> Seq ( ℝ 1 {- s -} -> StrokeDatum 2 () )
|
-> Seq ( ℝ 1 {- s -} -> StrokeDatum 2 () )
|
||||||
curves =
|
curves =
|
||||||
brushStrokeData @2 @brushParams
|
brushStrokeData @2 @brushParams
|
||||||
|
coerce coerce
|
||||||
path
|
path
|
||||||
( chainRule @Double @2
|
( chainRule @Double @2
|
||||||
usedParams
|
usedParams
|
||||||
|
|
@ -550,6 +551,7 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
|
||||||
curvesI :: 𝕀ℝ 1 -- t
|
curvesI :: 𝕀ℝ 1 -- t
|
||||||
-> Seq ( 𝕀ℝ 1 {- s -} -> StrokeDatum 3 𝕀 )
|
-> Seq ( 𝕀ℝ 1 {- s -} -> StrokeDatum 3 𝕀 )
|
||||||
curvesI = brushStrokeData @3 @brushParams
|
curvesI = brushStrokeData @3 @brushParams
|
||||||
|
coerce coerce
|
||||||
pathI
|
pathI
|
||||||
( chainRule @( 𝕀 Double ) @3
|
( chainRule @( 𝕀 Double ) @3
|
||||||
usedParamsI
|
usedParamsI
|
||||||
|
|
@ -559,7 +561,7 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
|
||||||
|
|
||||||
usedParamsI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀 usedParams )
|
usedParamsI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀 usedParams )
|
||||||
pathI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 )
|
pathI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 )
|
||||||
( pathI, usedParamsI ) = pathAndUsedParams @3 @𝕀 singleton ptParams sp0 crv
|
( pathI, usedParamsI ) = pathAndUsedParams @3 @𝕀 coerce singleton ptParams sp0 crv
|
||||||
|
|
||||||
fwdBwd :: OutlineFn
|
fwdBwd :: OutlineFn
|
||||||
fwdBwd t
|
fwdBwd t
|
||||||
|
|
@ -601,31 +603,31 @@ pathAndUsedParams :: forall k i arr crvData ptData usedParams
|
||||||
, CurveOrder k
|
, CurveOrder k
|
||||||
, arr ~ C k
|
, arr ~ C k
|
||||||
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
||||||
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
|
||||||
, 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 usedParams ) )
|
, Module ( I i Double ) ( T ( I i usedParams ) )
|
||||||
, Torsor ( T ( I i usedParams ) ) ( I i usedParams )
|
, Torsor ( T ( I i usedParams ) ) ( I i usedParams )
|
||||||
)
|
)
|
||||||
=> ( forall a. a -> I i a )
|
=> ( I i ( ℝ 1 ) -> I i Double )
|
||||||
|
-> ( forall a. a -> I i a )
|
||||||
-> ( ptData -> usedParams )
|
-> ( ptData -> usedParams )
|
||||||
-> ptData
|
-> ptData
|
||||||
-> Curve Open crvData ptData
|
-> Curve Open crvData ptData
|
||||||
-> ( I i ( ℝ 1 ) `arr` I i ( ℝ 2 ), I i ( ℝ 1 ) `arr` I i usedParams )
|
-> ( I i ( ℝ 1 ) `arr` I i ( ℝ 2 ), I i ( ℝ 1 ) `arr` I i usedParams )
|
||||||
pathAndUsedParams toI ptParams sp0 crv =
|
pathAndUsedParams co toI ptParams 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 @k @i ( fmap ( toI . coords ) seg )
|
-> ( line @k @i co ( fmap ( toI . coords ) seg )
|
||||||
, line @k @i ( fmap ( toI . ptParams ) seg ) )
|
, line @k @i co ( fmap ( toI . 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 @k @i ( fmap ( toI . coords ) bez2 )
|
-> ( bezier2 @k @i co ( fmap ( toI . coords ) bez2 )
|
||||||
, bezier2 @k @i ( fmap ( toI . ptParams ) bez2 ) )
|
, bezier2 @k @i co ( fmap ( toI . 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 @k @i ( fmap ( toI . coords ) bez3 )
|
-> ( bezier3 @k @i co ( fmap ( toI . coords ) bez3 )
|
||||||
, bezier3 @k @i ( fmap ( toI . ptParams ) bez3 ) )
|
, bezier3 @k @i co ( fmap ( toI . ptParams ) bez3 ) )
|
||||||
|
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
-- Various utility functions
|
-- Various utility functions
|
||||||
|
|
@ -924,10 +926,11 @@ splineCurveFns :: forall k i
|
||||||
. ( CurveOrder k
|
. ( CurveOrder k
|
||||||
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
, 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 ) ) )
|
||||||
, Coercible ( I i ( ℝ 1 ) ) ( I i Double ) )
|
=> ( I i ( ℝ 1 ) -> I i Double )
|
||||||
=> Spline Closed () ( I i ( ℝ 2 ) ) -> Seq ( C k ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) ) )
|
-> Spline Closed () ( I i ( ℝ 2 ) )
|
||||||
splineCurveFns spls
|
-> Seq ( C k ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) ) )
|
||||||
|
splineCurveFns co spls
|
||||||
= runIdentity
|
= runIdentity
|
||||||
. bifoldSpline
|
. bifoldSpline
|
||||||
( \ pt crv -> Identity . Seq.singleton $ curveFn pt crv )
|
( \ pt crv -> Identity . Seq.singleton $ curveFn pt crv )
|
||||||
|
|
@ -940,11 +943,11 @@ splineCurveFns spls
|
||||||
-> ( C k ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) ) )
|
-> ( C k ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) ) )
|
||||||
curveFn p0 = \case
|
curveFn p0 = \case
|
||||||
LineTo { curveEnd = NextPoint p1 }
|
LineTo { curveEnd = NextPoint p1 }
|
||||||
-> line @k @i $ Segment p0 p1
|
-> line @k @i co $ Segment p0 p1
|
||||||
Bezier2To { controlPoint = p1, curveEnd = NextPoint p2 }
|
Bezier2To { controlPoint = p1, curveEnd = NextPoint p2 }
|
||||||
-> bezier2 @k @i $ Quadratic.Bezier p0 p1 p2
|
-> bezier2 @k @i co $ Quadratic.Bezier p0 p1 p2
|
||||||
Bezier3To { controlPoint1 = p1, controlPoint2 = p2, curveEnd = NextPoint p3 }
|
Bezier3To { controlPoint1 = p1, controlPoint2 = p2, curveEnd = NextPoint p3 }
|
||||||
-> bezier3 @k @i $ Cubic.Bezier p0 p1 p2 p3
|
-> bezier3 @k @i co $ 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.
|
||||||
|
|
@ -1081,17 +1084,19 @@ brushStrokeData :: forall k brushParams i arr
|
||||||
, D k ( I i ( ℝ 2 ) ) ~ D k ( ℝ 2 )
|
, D k ( I i ( ℝ 2 ) ) ~ D k ( ℝ 2 )
|
||||||
, Cross ( I i Double ) ( T ( I i ( ℝ 2 ) ) )
|
, Cross ( I i Double ) ( T ( I i ( ℝ 2 ) ) )
|
||||||
, Torsor ( T ( I i ( ℝ 2 ) ) ) ( I i ( ℝ 2 ) )
|
, Torsor ( T ( I i ( ℝ 2 ) ) ) ( I i ( ℝ 2 ) )
|
||||||
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
-- , Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
||||||
, Show brushParams
|
, Show brushParams
|
||||||
)
|
)
|
||||||
=> ( I i ( ℝ 1 ) `arr` I i ( ℝ 2 ) )
|
=> ( I i Double -> I i ( ℝ 1 ) )
|
||||||
|
-> ( I i ( ℝ 1 ) -> I i Double )
|
||||||
|
-> ( I i ( ℝ 1 ) `arr` I i ( ℝ 2 ) )
|
||||||
-- ^ path
|
-- ^ path
|
||||||
-> ( I i ( ℝ 1 ) `arr` I i brushParams )
|
-> ( I i ( ℝ 1 ) `arr` I i brushParams )
|
||||||
-- ^ brush parameters
|
-- ^ brush parameters
|
||||||
-> ( I i brushParams `arr` Spline Closed () ( I i ( ℝ 2 ) ) )
|
-> ( I i brushParams `arr` Spline Closed () ( I i ( ℝ 2 ) ) )
|
||||||
-- ^ brush from parameters
|
-- ^ brush from parameters
|
||||||
-> ( I i ( ℝ 1 ) -> Seq ( I i ( ℝ 1 ) -> StrokeDatum k i ) )
|
-> ( I i ( ℝ 1 ) -> Seq ( I i ( ℝ 1 ) -> StrokeDatum k i ) )
|
||||||
brushStrokeData path params brush =
|
brushStrokeData co1 co2 path params brush =
|
||||||
\ t ->
|
\ t ->
|
||||||
let
|
let
|
||||||
dpath_t :: D k ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) )
|
dpath_t :: D k ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) )
|
||||||
|
|
@ -1101,7 +1106,7 @@ brushStrokeData path params brush =
|
||||||
dbrush_params :: D k ( I i brushParams ) ( Spline Closed () ( I i ( ℝ 2 ) ) )
|
dbrush_params :: D k ( I i brushParams ) ( 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 brushParams ) ( I i ( ℝ 1 ) `arr` I i ( ℝ 2 ) ) )
|
splines :: Seq ( D k ( I i brushParams ) ( I i ( ℝ 1 ) `arr` I i ( ℝ 2 ) ) )
|
||||||
!splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns @k @i ) 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 ( I i ( ℝ 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.
|
||||||
|
|
@ -1115,7 +1120,7 @@ brushStrokeData path params brush =
|
||||||
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 = brushStroke @k dpath_t dbrush_t_s
|
dstroke = brushStroke @k dpath_t dbrush_t_s
|
||||||
( ee, 𝛿E𝛿sdcdt ) = envelopeEquation @k @i dstroke
|
( ee, 𝛿E𝛿sdcdt ) = envelopeEquation @k @i co1 dstroke
|
||||||
in -- trace
|
in -- trace
|
||||||
-- ( unlines
|
-- ( unlines
|
||||||
-- [ "envelopeEquation:"
|
-- [ "envelopeEquation:"
|
||||||
|
|
|
||||||
|
|
@ -79,25 +79,25 @@ class CurveOrder k where
|
||||||
line :: forall i b
|
line :: forall i b
|
||||||
. ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
|
. ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
|
||||||
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
||||||
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
|
||||||
)
|
)
|
||||||
=> Segment b -> C k ( I i ( ℝ 1 ) ) b
|
=> ( I i ( ℝ 1 ) -> I i Double )
|
||||||
|
-> Segment b -> C k ( I i ( ℝ 1 ) ) b
|
||||||
|
|
||||||
-- | A quadratic Bézier curve, as a differentiable function.
|
-- | A quadratic Bézier curve, as a differentiable function.
|
||||||
bezier2 :: forall i b
|
bezier2 :: forall i b
|
||||||
. ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
|
. ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
|
||||||
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
||||||
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
|
||||||
)
|
)
|
||||||
=> Quadratic.Bezier b -> C k ( I i ( ℝ 1 ) ) b
|
=> ( I i ( ℝ 1 ) -> I i Double )
|
||||||
|
-> Quadratic.Bezier b -> C k ( I i ( ℝ 1 ) ) b
|
||||||
|
|
||||||
-- | A cubic Bézier curve, as a differentiable function.
|
-- | A cubic Bézier curve, as a differentiable function.
|
||||||
bezier3 :: forall i b
|
bezier3 :: forall i b
|
||||||
. ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
|
. ( Module ( I i Double ) ( T b ), Torsor ( T b ) b
|
||||||
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
, D k ( I i ( ℝ 1 ) ) ~ D k ( ℝ 1 )
|
||||||
, Coercible ( I i ( ℝ 1 ) ) ( I i Double )
|
|
||||||
)
|
)
|
||||||
=> Cubic.Bezier b -> C k ( I i ( ℝ 1 ) ) b
|
=> ( I i ( ℝ 1 ) -> I i Double )
|
||||||
|
-> Cubic.Bezier b -> C k ( I i ( ℝ 1 ) ) b
|
||||||
|
|
||||||
uncurryD :: D k a ~ D k ( ℝ 1 )
|
uncurryD :: D k a ~ D k ( ℝ 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
|
||||||
|
|
@ -131,27 +131,27 @@ class CurveOrder k where
|
||||||
, D ( k - 1 ) ( I i ( ℝ 2 ) ) ~ D ( k - 1 ) ( ℝ 2 )
|
, D ( k - 1 ) ( I i ( ℝ 2 ) ) ~ D ( k - 1 ) ( ℝ 2 )
|
||||||
, D k ( I i ( ℝ 2 ) ) ~ D k ( ℝ 2 )
|
, D k ( I i ( ℝ 2 ) ) ~ D k ( ℝ 2 )
|
||||||
, Cross ( I i Double ) ( T ( I i ( ℝ 2 ) ) )
|
, Cross ( I i Double ) ( T ( I i ( ℝ 2 ) ) )
|
||||||
, Coercible ( I i Double ) ( I i ( ℝ 1 ) )
|
|
||||||
)
|
)
|
||||||
=> D k ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) )
|
=> ( I i Double -> I i ( ℝ 1 ) )
|
||||||
|
-> D k ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) )
|
||||||
-> ( D ( k - 1 ) ( I i ( ℝ 2 ) ) ( I i ( ℝ 1 ) )
|
-> ( D ( k - 1 ) ( I i ( ℝ 2 ) ) ( I i ( ℝ 1 ) )
|
||||||
, D ( k - 2 ) ( I i ( ℝ 2 ) ) ( T ( I i ( ℝ 2 ) ) ) )
|
, D ( k - 2 ) ( I i ( ℝ 2 ) ) ( T ( I i ( ℝ 2 ) ) ) )
|
||||||
|
|
||||||
instance CurveOrder 2 where
|
instance CurveOrder 2 where
|
||||||
line ( Segment a b :: Segment b ) =
|
line co ( Segment a b :: Segment b ) =
|
||||||
D \ ( coerce -> t ) ->
|
D \ ( co -> t ) ->
|
||||||
D21 ( lerp @( T b ) t a b )
|
D21 ( lerp @( T b ) t a b )
|
||||||
( a --> b )
|
( a --> b )
|
||||||
origin
|
origin
|
||||||
|
|
||||||
bezier2 ( bez :: Quadratic.Bezier b ) =
|
bezier2 co ( bez :: Quadratic.Bezier b ) =
|
||||||
D \ ( coerce -> t ) ->
|
D \ ( co -> t ) ->
|
||||||
D21 ( Quadratic.bezier @( T b ) bez t )
|
D21 ( Quadratic.bezier @( T b ) bez t )
|
||||||
( Quadratic.bezier' bez t )
|
( Quadratic.bezier' bez t )
|
||||||
( Quadratic.bezier'' bez )
|
( Quadratic.bezier'' bez )
|
||||||
|
|
||||||
bezier3 ( bez :: Cubic.Bezier b ) =
|
bezier3 co ( bez :: Cubic.Bezier b ) =
|
||||||
D \ ( coerce -> t ) ->
|
D \ ( co -> t ) ->
|
||||||
D21 ( Cubic.bezier @( T b ) bez t )
|
D21 ( Cubic.bezier @( T b ) bez t )
|
||||||
( Cubic.bezier' bez t )
|
( Cubic.bezier' bez t )
|
||||||
( Cubic.bezier'' bez t )
|
( Cubic.bezier'' bez t )
|
||||||
|
|
@ -171,12 +171,12 @@ instance CurveOrder 2 where
|
||||||
-- ∂²c/∂t∂s = ∂²b/∂t∂s
|
-- ∂²c/∂t∂s = ∂²b/∂t∂s
|
||||||
-- ∂²c/∂s² = ∂²b/∂s²
|
-- ∂²c/∂s² = ∂²b/∂s²
|
||||||
|
|
||||||
envelopeEquation ( D22 _ c_t c_s c_tt c_ts c_ss ) =
|
envelopeEquation co ( D22 _ c_t c_s c_tt c_ts c_ss ) =
|
||||||
let !ee = c_t × c_s
|
let !ee = c_t × c_s
|
||||||
!ee_t = c_tt × c_s + c_t × c_ts
|
!ee_t = c_tt × c_s + c_t × c_ts
|
||||||
!ee_s = c_ts × c_s + c_t × c_ss
|
!ee_s = c_ts × c_s + c_t × c_ss
|
||||||
!𝛿E𝛿sdcdt = ee_s *^ c_t ^-^ ee_t *^ c_s
|
!𝛿E𝛿sdcdt = ee_s *^ c_t ^-^ ee_t *^ c_s
|
||||||
in ( D12 ( coerce ee ) ( T $ coerce ee_t ) ( T $ coerce ee_s )
|
in ( D12 ( co ee ) ( T $ co ee_t ) ( T $ co ee_s )
|
||||||
, D0 𝛿E𝛿sdcdt )
|
, D0 𝛿E𝛿sdcdt )
|
||||||
-- Computation of total derivative dc/dt:
|
-- Computation of total derivative dc/dt:
|
||||||
--
|
--
|
||||||
|
|
@ -187,22 +187,22 @@ instance CurveOrder 2 where
|
||||||
|
|
||||||
instance CurveOrder 3 where
|
instance CurveOrder 3 where
|
||||||
|
|
||||||
line ( Segment a b :: Segment b ) =
|
line co ( Segment a b :: Segment b ) =
|
||||||
D \ ( coerce -> t ) ->
|
D \ ( co -> t ) ->
|
||||||
D31 ( lerp @( T b ) t a b )
|
D31 ( lerp @( T b ) t a b )
|
||||||
( a --> b )
|
( a --> b )
|
||||||
origin
|
origin
|
||||||
origin
|
origin
|
||||||
|
|
||||||
bezier2 ( bez :: Quadratic.Bezier b ) =
|
bezier2 co ( bez :: Quadratic.Bezier b ) =
|
||||||
D \ ( coerce -> t ) ->
|
D \ ( co -> t ) ->
|
||||||
D31 ( Quadratic.bezier @( T b ) bez t )
|
D31 ( Quadratic.bezier @( T b ) bez t )
|
||||||
( Quadratic.bezier' bez t )
|
( Quadratic.bezier' bez t )
|
||||||
( Quadratic.bezier'' bez )
|
( Quadratic.bezier'' bez )
|
||||||
origin
|
origin
|
||||||
|
|
||||||
bezier3 ( bez :: Cubic.Bezier b ) =
|
bezier3 co ( bez :: Cubic.Bezier b ) =
|
||||||
D \ ( coerce -> t ) ->
|
D \ ( co -> t ) ->
|
||||||
D31 ( Cubic.bezier @( T b ) bez t )
|
D31 ( Cubic.bezier @( T b ) bez t )
|
||||||
( Cubic.bezier' bez t )
|
( Cubic.bezier' bez t )
|
||||||
( Cubic.bezier'' bez t )
|
( Cubic.bezier'' bez t )
|
||||||
|
|
@ -219,7 +219,7 @@ instance CurveOrder 3 where
|
||||||
( p_tt ^+^ b_tt ) b_ts b_ss
|
( p_tt ^+^ b_tt ) b_ts b_ss
|
||||||
( p_ttt ^+^ b_ttt ) b_tts b_tss b_sss
|
( p_ttt ^+^ b_ttt ) b_tts b_tss b_sss
|
||||||
|
|
||||||
envelopeEquation
|
envelopeEquation co
|
||||||
( D32 _ c_t c_s
|
( D32 _ c_t c_s
|
||||||
c_tt c_ts c_ss
|
c_tt c_ts c_ss
|
||||||
c_ttt c_tts c_tss c_sss )
|
c_ttt c_tts c_tss c_sss )
|
||||||
|
|
@ -242,7 +242,7 @@ instance CurveOrder 3 where
|
||||||
!𝛿E𝛿sdcdt_s = ee_ss *^ c_t ^+^ ee_s *^ c_ts
|
!𝛿E𝛿sdcdt_s = ee_ss *^ c_t ^+^ ee_s *^ c_ts
|
||||||
^-^ ( ee_ts *^ c_s ^+^ ee_t *^ c_ss )
|
^-^ ( ee_ts *^ c_s ^+^ ee_t *^ c_ss )
|
||||||
in ( D22
|
in ( D22
|
||||||
( coerce ee )
|
( co ee )
|
||||||
( T $ coerce ee_t ) ( T $ coerce ee_s )
|
( T $ co ee_t ) ( T $ co ee_s )
|
||||||
( T $ coerce ee_tt) ( T $ coerce ee_ts ) ( T $ coerce ee_ss )
|
( T $ co ee_tt) ( T $ co ee_ts ) ( T $ co ee_ss )
|
||||||
, D12 𝛿E𝛿sdcdt ( T 𝛿E𝛿sdcdt_t ) ( T 𝛿E𝛿sdcdt_s ) )
|
, D12 𝛿E𝛿sdcdt ( T 𝛿E𝛿sdcdt_t ) ( T 𝛿E𝛿sdcdt_s ) )
|
||||||
|
|
|
||||||
|
|
@ -13,11 +13,12 @@ module Math.Linear
|
||||||
, Fin(..), MFin(..)
|
, Fin(..), MFin(..)
|
||||||
, RepDim, RepresentableQ(..)
|
, RepDim, RepresentableQ(..)
|
||||||
, Representable(..), injection, projection
|
, Representable(..), injection, projection
|
||||||
, Vec(..), (!), find, zipIndices
|
, Vec(..), (!), find, zipIndices, unzip
|
||||||
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Prelude hiding ( unzip )
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
( coerce )
|
( coerce )
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
|
|
@ -160,3 +161,9 @@ zipIndices = zipIndices_ 1
|
||||||
zipIndices_ :: forall i. Word -> Vec i a -> [ ( Fin n, a ) ]
|
zipIndices_ :: forall i. Word -> Vec i a -> [ ( Fin n, a ) ]
|
||||||
zipIndices_ _ VZ = []
|
zipIndices_ _ VZ = []
|
||||||
zipIndices_ i (a `VS` as) = ( Fin i, a ) : zipIndices_ ( i + 1 ) as
|
zipIndices_ i (a `VS` as) = ( Fin i, a ) : zipIndices_ ( i + 1 ) as
|
||||||
|
|
||||||
|
unzip :: Vec n ( a, b ) -> ( Vec n a, Vec n b )
|
||||||
|
unzip VZ = ( VZ, VZ )
|
||||||
|
unzip ( ( a, b ) `VS` ab ) =
|
||||||
|
case unzip ab of
|
||||||
|
( as, bs ) -> ( a `VS` as, b `VS` bs )
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue