handle brush corners

This commit is contained in:
sheaf 2024-11-02 10:57:04 +01:00
parent 7a82470db9
commit 197adec8d0
13 changed files with 852 additions and 552 deletions

View file

@ -1,12 +1,13 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Calligraphy.Brushes module Calligraphy.Brushes
( BrushFn, Brush(..) ( BrushFn, Brush(..), Corner(..)
, circleBrush , circleBrush
, ellipseBrush , ellipseBrush
, tearDropBrush , tearDropBrush
@ -21,19 +22,25 @@ import Data.Kind
import GHC.Exts import GHC.Exts
( Proxy#, proxy# ) ( Proxy#, proxy# )
import GHC.TypeNats import GHC.TypeNats
( Nat, type (<=) ) ( Nat )
-- acts
import Data.Act
( Torsor((-->)) )
-- containers -- containers
import Data.Sequence
( Seq )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( empty, fromList ) ( empty, fromList, singleton )
-- brush-strokes -- brush-strokes
import Math.Algebra.Dual import Math.Algebra.Dual
import Math.Bezier.Spline import Math.Bezier.Spline
import Math.Differentiable import Math.Differentiable
( I ) ( I, IVness(..), SingIVness (..) )
import Math.Interval import Math.Interval
( 𝕀, singleton, point ) ( 𝕀, singleton, point )
import Math.Linear import Math.Linear
import Math.Module import Math.Module
( Module((^+^), (*^)) ) ( Module((^+^), (*^)) )
@ -42,28 +49,43 @@ import Math.Ring
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | The shape of a brush (before applying any rotation). -- | The shape of a brush (before applying any rotation).
type BrushFn :: forall {kd}. kd -> Nat -> Nat -> Type type BrushFn :: IVness -> Nat -> Nat -> Type
type BrushFn i k nbBrushParams type BrushFn i k nbBrushParams
= C k ( I i nbBrushParams ) = C k ( I i nbBrushParams )
( Spline Closed () ( I i 2 ) ) ( Spline Closed () ( I i 2 ) )
-- | A corner of a brush.
type Corner :: Type -> Type
data Corner a
= Corner
{ cornerPoint :: a
, cornerStartTangent, cornerEndTangent :: !( T a )
}
deriving stock ( Eq, Show, Functor, Foldable, Traversable )
-- | A brush, described as a base shape + an optional rotation. -- | A brush, described as a base shape + an optional rotation.
data Brush nbBrushParams data Brush nbBrushParams
= Brush = Brush
{ -- | Base brush shape, before applying any rotation (if any). { -- | Base brush shape, before applying rotation (if any).
brushBaseShape :: BrushFn 2 nbBrushParams brushBaseShape :: BrushFn NonIV 2 nbBrushParams
-- | Base brush shape, before applying any rotation (if any). -- | Base brush shape, before applying rotation (if any).
, brushBaseShapeI :: BrushFn 𝕀 3 nbBrushParams , brushBaseShapeI :: BrushFn IsIV 3 nbBrushParams
-- | Brush corners, before applying rotation (if any).
, brushCorners :: Seq ( C 2 ( nbBrushParams ) ( Corner ( I NonIV 2 ) ) )
-- | Brush corners, before applying rotation (if any).
, brushCornersI :: Seq ( C 3 ( 𝕀 nbBrushParams ) ( Corner ( I IsIV 2 ) ) )
-- | Optional rotation angle function -- | Optional rotation angle function
-- (assumed to be a linear function). -- (assumed to be a linear function).
, mbRotation :: Maybe ( nbBrushParams -> Double ) , mbRotation :: Maybe ( nbBrushParams -> Double )
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Brushes -- Brushes
-- Some convenience type synonyms for brush types... a bit horrible -- Some convenience type synonyms for brush types... a bit horrible
type ParamsICt :: Nat -> k -> Nat -> Constraint type ParamsICt :: Nat -> IVness -> Nat -> Constraint
type ParamsICt k i nbParams = type ParamsICt k i nbParams =
( Module ( Module
( D k nbParams ( I i Double ) ) ( D k nbParams ( I i Double ) )
@ -79,8 +101,10 @@ type ParamsICt k i nbParams =
circleBrush :: Brush 1 circleBrush :: Brush 1
circleBrush = circleBrush =
Brush Brush
{ brushBaseShape = circleBrushFn @ @2 @1 proxy# id id { brushBaseShape = circleBrushFn @2 SNonIV
, brushBaseShapeI = circleBrushFn @𝕀 @3 @1 proxy# singleton point , brushBaseShapeI = circleBrushFn @3 SIsIV
, brushCorners = Seq.empty
, brushCornersI = Seq.empty
, mbRotation = Nothing , mbRotation = Nothing
} }
@ -88,8 +112,10 @@ circleBrush =
ellipseBrush :: Brush 3 ellipseBrush :: Brush 3
ellipseBrush = ellipseBrush =
Brush Brush
{ brushBaseShape = ellipseBrushFn @ @2 @3 proxy# id id { brushBaseShape = ellipseBrushFn @2 SNonIV
, brushBaseShapeI = ellipseBrushFn @𝕀 @3 @3 proxy# singleton point , brushBaseShapeI = ellipseBrushFn @3 SIsIV
, brushCorners = Seq.empty
, brushCornersI = Seq.empty
, mbRotation = Just ( `index` ( Fin 3 ) ) , mbRotation = Just ( `index` ( Fin 3 ) )
} }
@ -97,11 +123,24 @@ ellipseBrush =
tearDropBrush :: Brush 3 tearDropBrush :: Brush 3
tearDropBrush = tearDropBrush =
Brush Brush
{ brushBaseShape = tearDropBrushFn @ @2 @3 proxy# id id { brushBaseShape = tearDropBrushFn @2 SNonIV
, brushBaseShapeI = tearDropBrushFn @𝕀 @3 @3 proxy# singleton point , brushBaseShapeI = tearDropBrushFn @3 SIsIV
, brushCorners = Seq.singleton $ tearDropCorner @2 proxy# SNonIV
, brushCornersI = Seq.singleton $ tearDropCorner @3 proxy# SIsIV
, mbRotation = Just ( `index` ( Fin 3 ) ) , mbRotation = Just ( `index` ( Fin 3 ) )
} }
--------------------------------------------------------------------------------
type SplineFn k i nbParams
= SingIVness i
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
type CornerFn k i nbParams
= Proxy# k
-> SingIVness i
-> C k ( I i nbParams ) ( Corner ( I i 2 ) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Circle & ellipse -- Circle & ellipse
@ -128,15 +167,24 @@ circleSpline p = sequenceA $
Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart () Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart ()
{-# INLINE circleSpline #-} {-# INLINE circleSpline #-}
circleBrushFn :: forall {t} (i :: t) k nbParams mkI1 :: SingIVness i -> Double -> I i Double
. ( 1 <= nbParams mkI1 = \case
, ParamsICt k i nbParams SNonIV -> id
) SIsIV -> singleton
=> Proxy# i {-# INLINE mkI1 #-}
-> ( Double -> I i Double )
-> ( I 2 -> I i 2 ) mkI2 :: SingIVness i -> 2 -> I i 2
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) mkI2 = \case
circleBrushFn _ mkI1 mkI2 = SNonIV -> id
SIsIV -> point
{-# INLINE mkI2 #-}
circleBrushFn :: forall k i nbParams
. ( nbParams ~ 1
, ParamsICt k i nbParams
)
=> SplineFn k i nbParams
circleBrushFn ivness =
D \ params -> D \ params ->
let r :: D k nbParams ( I i Double ) let r :: D k nbParams ( I i Double )
r = runD ( var @_ @k $ Fin 1 ) params r = runD ( var @_ @k $ Fin 1 ) params
@ -147,22 +195,20 @@ circleBrushFn _ mkI1 mkI2 =
in circleSpline mkPt in circleSpline mkPt
where where
e_x, e_y :: D k nbParams ( I i 2 ) e_x, e_y :: D k nbParams ( I i 2 )
e_x = pure $ mkI2 $ 2 1 0 e_x = pure $ mkI2 ivness $ 2 1 0
e_y = pure $ mkI2 $ 2 0 1 e_y = pure $ mkI2 ivness $ 2 0 1
scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double ) scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
scaledBy d x = fmap ( mkI1 x * ) d scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# INLINEABLE circleBrushFn #-} {-# SPECIALISE circleBrushFn :: SplineFn 2 NonIV 1 #-}
{-# SPECIALISE circleBrushFn :: SplineFn 3 IsIV 1 #-}
ellipseBrushFn :: forall {t} (i :: t) k nbParams ellipseBrushFn :: forall k i nbParams
. ( 3 <= nbParams . ( nbParams ~ 3
, ParamsICt k i nbParams , ParamsICt k i nbParams
) )
=> Proxy# i => SplineFn k i nbParams
-> ( Double -> I i Double ) ellipseBrushFn ivness =
-> ( I 2 -> I i 2 )
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
ellipseBrushFn _ mkI1 mkI2 =
D \ params -> D \ params ->
let a, b :: D k nbParams ( I i Double ) let a, b :: D k nbParams ( I i Double )
a = runD ( var @_ @k $ Fin 1 ) params a = runD ( var @_ @k $ Fin 1 ) params
@ -175,12 +221,13 @@ ellipseBrushFn _ mkI1 mkI2 =
in circleSpline mkPt in circleSpline mkPt
where where
e_x, e_y :: D k nbParams ( I i 2 ) e_x, e_y :: D k nbParams ( I i 2 )
e_x = pure $ mkI2 $ 2 1 0 e_x = pure $ mkI2 ivness $ 2 1 0
e_y = pure $ mkI2 $ 2 0 1 e_y = pure $ mkI2 ivness $ 2 0 1
scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double ) scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
scaledBy d x = fmap ( mkI1 x * ) d scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# INLINEABLE ellipseBrushFn #-} {-# SPECIALISE ellipseBrushFn :: SplineFn 2 NonIV 3 #-}
{-# SPECIALISE ellipseBrushFn :: SplineFn 3 IsIV 3 #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Tear drop -- Tear drop
@ -202,15 +249,12 @@ tearHeight = 3 * sqrt 3 / 8
sqrt3_over_2 :: Double sqrt3_over_2 :: Double
sqrt3_over_2 = 0.5 * sqrt 3 sqrt3_over_2 = 0.5 * sqrt 3
tearDropBrushFn :: forall {t} (i :: t) k nbParams tearDropBrushFn :: forall k i nbParams
. ( 3 <= nbParams . ( nbParams ~ 3
, ParamsICt k i nbParams , ParamsICt k i nbParams
) )
=> Proxy# i => SplineFn k i nbParams
-> ( Double -> I i Double ) tearDropBrushFn ivness =
-> ( I 2 -> I i 2 )
-> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )
tearDropBrushFn _ mkI1 mkI2 =
D \ params -> D \ params ->
let w, h :: D k nbParams ( I i Double ) let w, h :: D k nbParams ( I i Double )
w = 2 * runD ( var @_ @k ( Fin 1 ) ) params w = 2 * runD ( var @_ @k ( Fin 1 ) ) params
@ -233,9 +277,41 @@ tearDropBrushFn _ mkI1 mkI2 =
BackToStart () } BackToStart () }
where where
e_x, e_y :: D k nbParams ( I i 2 ) e_x, e_y :: D k nbParams ( I i 2 )
e_x = pure $ mkI2 $ 2 1 0 e_x = pure $ mkI2 ivness $ 2 1 0
e_y = pure $ mkI2 $ 2 0 1 e_y = pure $ mkI2 ivness $ 2 0 1
scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double ) scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
scaledBy d x = fmap ( mkI1 x * ) d scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# INLINEABLE tearDropBrushFn #-} {-# SPECIALISE tearDropBrushFn :: SplineFn 2 NonIV 3 #-}
{-# SPECIALISE tearDropBrushFn :: SplineFn 3 IsIV 3 #-}
tearDropCorner :: forall k i nbParams. ( nbParams ~ 3, ParamsICt k i nbParams, Torsor ( T ( I i 2 ) ) ( I i 2 ) ) => CornerFn k i nbParams
tearDropCorner _ ivness =
D \ params ->
let w, h :: D k nbParams ( I i Double )
w = 2 * runD ( var @_ @k ( Fin 1 ) ) params
h = 2 * runD ( var @_ @k ( Fin 2 ) ) params
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
-- 3. rotate (done separately)
= let !x' = w `scaledBy` ( x / tearWidth )
!y' = h `scaledBy` ( ( y - tearCenter ) / tearHeight )
in x' *^ e_x ^+^ y' *^ e_y
!cornerPoint = mkPt 0 0
in sequenceA $
Corner
{ cornerPoint
, cornerStartTangent = T $ liftA2 ( \ x y -> unT $ x --> y ) ( mkPt -0.5 sqrt3_over_2 ) cornerPoint
, cornerEndTangent = T $ liftA2 ( \ x y -> unT $ x --> y ) cornerPoint ( mkPt 0.5 sqrt3_over_2 )
}
where
e_x, e_y :: D k nbParams ( I i 2 )
e_x = pure $ mkI2 ivness $ 2 1 0
e_y = pure $ mkI2 ivness $ 2 0 1
scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE tearDropCorner :: CornerFn 2 NonIV 3 #-}
{-# SPECIALISE tearDropCorner :: CornerFn 3 IsIV 3 #-}

View file

@ -9,12 +9,15 @@
module Math.Algebra.Dual module Math.Algebra.Dual
( C(..), D, Dim ( C(..), D, Dim
, Differential(..)
, HasChainRule(..), chainRule , HasChainRule(..), chainRule
, uncurryD2, uncurryD3 , uncurryD2, uncurryD3
, linear, fun, var , linear, fun, var
, chainRuleN1Q, chainRule1NQ , chainRuleN1Q, chainRule1NQ
, DiffModule(..)
, 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(..)
@ -30,7 +33,7 @@ import Prelude
import Data.Coerce import Data.Coerce
( coerce ) ( coerce )
import Data.Kind import Data.Kind
( Type ) ( Constraint, Type )
import GHC.TypeNats import GHC.TypeNats
( Nat ) ( Nat )
@ -94,18 +97,27 @@ instance ( Applicative ( D k ( Dim u ) ), Module r ( T v ) )
T ( D f ) ^-^ T ( D g ) = T $ D \ t -> liftA2 ( coerce $ (^-^) @r @( T v ) ) ( f t ) ( g t ) T ( D f ) ^-^ T ( D g ) = T $ D \ t -> liftA2 ( coerce $ (^-^) @r @( T v ) ) ( f t ) ( g t )
a *^ T ( D f ) = T $ D \ t -> fmap ( coerce $ (*^) @r @( T v ) a ) $ f t a *^ T ( D f ) = T $ D \ t -> fmap ( coerce $ (*^) @r @( T v ) a ) $ f t
newtype DiffModule k n v = DiffModule { getDiffModule :: D k n v }
instance ( Applicative ( D k n ), Module r ( T v ) )
=> Module r ( T ( DiffModule k n v ) ) where
origin = T $ DiffModule $ pure $ coerce $ origin @r @( T v )
T ( DiffModule f ) ^+^ T ( DiffModule g ) = T $ DiffModule $ liftA2 ( coerce $ (^+^) @r @( T v ) ) f g
T ( DiffModule f ) ^-^ T ( DiffModule g ) = T $ DiffModule $ liftA2 ( coerce $ (^-^) @r @( T v ) ) f g
a *^ T ( DiffModule f ) = T $ DiffModule $ fmap ( coerce $ (*^) @r @( T v ) a ) f
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- TODO: split up this class into the chain rule operation type Differential :: Nat -> Nat -> Constraint
-- and all the other operations. class Differential k n where
konst :: AbelianGroup w => w -> D k n w
value :: D k n w -> w
-- | @HasChainRule r k v@ means we have a chain rule -- | @HasChainRule r k v@ means we have a chain rule
-- with @D k v w@ in the middle, for any @r@-module @w@. -- with @D k v w@ in the middle, for any @r@-module @w@.
class HasChainRule r k v where class Differential k ( Dim v ) => HasChainRule r k v where
chain :: Module r ( T w ) chain :: Module r ( T w )
=> D k 1 v -> D k ( Dim v ) w -> D k 1 w => D k 1 v -> D k ( Dim v ) w -> D k 1 w
konst :: AbelianGroup w => w -> D k ( Dim v ) w
value :: D k ( Dim v ) w -> w
linearD :: Module r ( T w ) => ( v -> w ) -> v -> D k ( Dim v ) w linearD :: Module r ( T w ) => ( v -> w ) -> v -> D k ( Dim v ) w
linear :: forall k r v w linear :: forall k r v w
@ -122,27 +134,24 @@ chainRule ( D df ) ( D dg ) =
D \ x -> D \ x ->
case df x of case df x of
df_x -> df_x ->
chain @r @k @v df_x ( dg $ value @r @k @u df_x ) chain @r @k @v df_x ( dg $ value @k @( Dim u ) df_x )
uncurryD2 :: D 2 1 ( D 2 1 b ) -> D 2 2 b
uncurryD2 :: Dim a ~ 1 uncurryD2 ( D21 ( b_t0 ) ( T ( dbdt_t0 ) ) ( T ( d2bdt2_t0 ) ) ) =
=> D 2 1 ( C 2 a b ) -> a -> D 2 2 b let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_t0
uncurryD2 ( D21 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 = D21 dbdt_t0s0 d2bdtds_t0s0 _ = dbdt_t0
let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_t0 s0 D21 d2bdt2_t0s0 _ _ = d2bdt2_t0
D21 dbdt_t0s0 d2bdtds_t0s0 _ = dbdt_t0 s0
D21 d2bdt2_t0s0 _ _ = d2bdt2_t0 s0
in D22 in D22
b_t0s0 b_t0s0
( T dbdt_t0s0 ) dbds_t0s0 ( T dbdt_t0s0 ) dbds_t0s0
( T d2bdt2_t0s0 ) d2bdtds_t0s0 d2bds2_t0s0 ( T d2bdt2_t0s0 ) d2bdtds_t0s0 d2bds2_t0s0
uncurryD3 :: Dim a ~ 1 uncurryD3 :: D 3 1 ( D 3 1 b ) -> D 3 2 b
=> D 3 1 ( C 3 a b ) -> a -> D 3 2 b uncurryD3 ( D31 b_t0 ( T dbdt_t0 ) ( T d2bdt2_t0 ) ( T d3bdt3_t0 ) ) =
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
let D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 = b_t0 s0 D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ = dbdt_t0
D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ = dbdt_t0 s0 D31 d2bdt2_t0s0 d3bdt2ds_t0s0 _ _ = d2bdt2_t0
D31 d2bdt2_t0s0 d3bdt2ds_t0s0 _ _ = d2bdt2_t0 s0 D31 d3bdt3_t0s0 _ _ _ = d3bdt3_t0
D31 d3bdt3_t0s0 _ _ _ = d3bdt3_t0 s0
in D32 in D32
b_t0s0 b_t0s0
( T dbdt_t0s0 ) dbds_t0s0 ( T dbdt_t0s0 ) dbds_t0s0
@ -150,8 +159,8 @@ uncurryD3 ( D31 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ( T ( D d3b
( T d3bdt3_t0s0 ) d3bdt2ds_t0s0 d3bdtds2_t0s0 d3bds3_t0s0 ( T d3bdt3_t0s0 ) d3bdt2ds_t0s0 d3bdtds2_t0s0 d3bds3_t0s0
-- | Recover the underlying function, discarding all infinitesimal information. -- | Recover the underlying function, discarding all infinitesimal information.
fun :: forall r k v w. HasChainRule r k v => C k v w -> ( v -> w ) fun :: forall k v w. Differential k ( Dim v ) => C k v w -> ( v -> w )
fun ( D df ) = value @r @k @v . df fun ( D df ) = value @k @( Dim v ) . df
{-# INLINE fun #-} {-# INLINE fun #-}
-- | The differentiable germ of a coordinate variable. -- | The differentiable germ of a coordinate variable.
@ -216,7 +225,7 @@ instance ( Applicative ( D k ( Dim u ) )
negate ( ApAp2 !x ) = ApAp2 $ fmap ( negate @r ) x negate ( ApAp2 !x ) = ApAp2 $ fmap ( negate @r ) x
-- DO NOT USE PURE!! -- DO NOT USE PURE!!
fromInteger !i = ApAp2 $ konst @Double @k @u ( fromInteger @r i ) fromInteger !i = ApAp2 $ konst @k @( Dim u ) ( fromInteger @r i )
deriving newtype instance AbelianGroup r => AbelianGroup ( D𝔸0 r ) deriving newtype instance AbelianGroup r => AbelianGroup ( D𝔸0 r )
@ -498,7 +507,7 @@ deriving newtype instance Field r => Field ( D𝔸0 r )
--instance Field r => Field ( D1𝔸3 r ) where --instance Field r => Field ( D1𝔸3 r ) where
--instance Field r => Field ( D1𝔸4 r ) where --instance Field r => Field ( D1𝔸4 r ) where
instance Field r => Field ( D2𝔸1 r ) where instance Field r => Field ( D2𝔸1 r ) where
fromRational q = konst @Double @2 @( 1 ) ( fromRational q ) fromRational q = konst @2 @1 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -511,7 +520,7 @@ instance Field r => Field ( D2𝔸1 r ) where
{-# SPECIALISE instance Field ( D2𝔸1 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸1 Double ) #-}
{-# SPECIALISE instance Field ( D2𝔸1 𝕀 ) #-} {-# SPECIALISE instance Field ( D2𝔸1 𝕀 ) #-}
instance Field r => Field ( D2𝔸2 r ) where instance Field r => Field ( D2𝔸2 r ) where
fromRational q = konst @Double @2 @( 2 ) ( fromRational q ) fromRational q = konst @2 @2 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -524,7 +533,7 @@ instance Field r => Field ( D2𝔸2 r ) where
{-# SPECIALISE instance Field ( D2𝔸2 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸2 Double ) #-}
{-# SPECIALISE instance Field ( D2𝔸2 𝕀 ) #-} {-# SPECIALISE instance Field ( D2𝔸2 𝕀 ) #-}
instance Field r => Field ( D2𝔸3 r ) where instance Field r => Field ( D2𝔸3 r ) where
fromRational q = konst @Double @2 @( 3 ) ( fromRational q ) fromRational q = konst @2 @3 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -537,7 +546,7 @@ instance Field r => Field ( D2𝔸3 r ) where
{-# SPECIALISE instance Field ( D2𝔸3 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸3 Double ) #-}
{-# SPECIALISE instance Field ( D2𝔸3 𝕀 ) #-} {-# SPECIALISE instance Field ( D2𝔸3 𝕀 ) #-}
instance Field r => Field ( D2𝔸4 r ) where instance Field r => Field ( D2𝔸4 r ) where
fromRational q = konst @Double @2 @( 4 ) ( fromRational q ) fromRational q = konst @2 @4 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -550,7 +559,7 @@ instance Field r => Field ( D2𝔸4 r ) where
{-# SPECIALISE instance Field ( D2𝔸4 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸4 Double ) #-}
{-# SPECIALISE instance Field ( D2𝔸4 𝕀 ) #-} {-# SPECIALISE instance Field ( D2𝔸4 𝕀 ) #-}
instance Field r => Field ( D3𝔸1 r ) where instance Field r => Field ( D3𝔸1 r ) where
fromRational q = konst @Double @3 @( 1 ) ( fromRational q ) fromRational q = konst @3 @1 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -563,7 +572,7 @@ instance Field r => Field ( D3𝔸1 r ) where
{-# SPECIALISE instance Field ( D3𝔸1 Double ) #-} {-# SPECIALISE instance Field ( D3𝔸1 Double ) #-}
{-# SPECIALISE instance Field ( D3𝔸1 𝕀 ) #-} {-# SPECIALISE instance Field ( D3𝔸1 𝕀 ) #-}
instance Field r => Field ( D3𝔸2 r ) where instance Field r => Field ( D3𝔸2 r ) where
fromRational q = konst @Double @3 @( 2 ) ( fromRational q ) fromRational q = konst @3 @2 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -576,7 +585,7 @@ instance Field r => Field ( D3𝔸2 r ) where
{-# SPECIALISE instance Field ( D3𝔸2 Double ) #-} {-# SPECIALISE instance Field ( D3𝔸2 Double ) #-}
{-# SPECIALISE instance Field ( D3𝔸2 𝕀 ) #-} {-# SPECIALISE instance Field ( D3𝔸2 𝕀 ) #-}
instance Field r => Field ( D3𝔸3 r ) where instance Field r => Field ( D3𝔸3 r ) where
fromRational q = konst @Double @3 @( 3 ) ( fromRational q ) fromRational q = konst @3 @3 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -589,7 +598,7 @@ instance Field r => Field ( D3𝔸3 r ) where
{-# SPECIALISE instance Field ( D3𝔸3 Double ) #-} {-# SPECIALISE instance Field ( D3𝔸3 Double ) #-}
{-# SPECIALISE instance Field ( D3𝔸3 𝕀 ) #-} {-# SPECIALISE instance Field ( D3𝔸3 𝕀 ) #-}
instance Field r => Field ( D3𝔸4 r ) where instance Field r => Field ( D3𝔸4 r ) where
fromRational q = konst @Double @3 @( 4 ) ( fromRational q ) fromRational q = konst @3 @4 ( fromRational q )
recip df = recip df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -786,7 +795,7 @@ deriving newtype instance Transcendental r => Transcendental ( D𝔸0 r )
--instance Transcendental r => Transcendental ( D1𝔸3 r ) where --instance Transcendental r => Transcendental ( D1𝔸3 r ) where
--instance Transcendental r => Transcendental ( D1𝔸4 r ) where --instance Transcendental r => Transcendental ( D1𝔸4 r ) where
instance Transcendental r => Transcendental ( D2𝔸1 r ) where instance Transcendental r => Transcendental ( D2𝔸1 r ) where
pi = konst @Double @2 @( 1 ) pi pi = konst @2 @1 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -817,7 +826,7 @@ instance Transcendental r => Transcendental ( D2𝔸1 r ) where
{-# SPECIALISE instance Transcendental ( D2𝔸1 Double ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸1 Double ) #-}
{-# SPECIALISE instance Transcendental ( D2𝔸1 𝕀 ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸1 𝕀 ) #-}
instance Transcendental r => Transcendental ( D2𝔸2 r ) where instance Transcendental r => Transcendental ( D2𝔸2 r ) where
pi = konst @Double @2 @( 2 ) pi pi = konst @2 @2 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -848,7 +857,7 @@ instance Transcendental r => Transcendental ( D2𝔸2 r ) where
{-# SPECIALISE instance Transcendental ( D2𝔸2 Double ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸2 Double ) #-}
{-# SPECIALISE instance Transcendental ( D2𝔸2 𝕀 ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸2 𝕀 ) #-}
instance Transcendental r => Transcendental ( D2𝔸3 r ) where instance Transcendental r => Transcendental ( D2𝔸3 r ) where
pi = konst @Double @2 @( 3 ) pi pi = konst @2 @3 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -880,7 +889,7 @@ instance Transcendental r => Transcendental ( D2𝔸3 r ) where
{-# SPECIALISE instance Transcendental ( D2𝔸3 𝕀 ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸3 𝕀 ) #-}
instance Transcendental r => Transcendental ( D2𝔸4 r ) where instance Transcendental r => Transcendental ( D2𝔸4 r ) where
pi = konst @Double @2 @( 4 ) pi pi = konst @2 @4 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -912,7 +921,7 @@ instance Transcendental r => Transcendental ( D2𝔸4 r ) where
{-# SPECIALISE instance Transcendental ( D2𝔸4 𝕀 ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸4 𝕀 ) #-}
instance Transcendental r => Transcendental ( D3𝔸1 r ) where instance Transcendental r => Transcendental ( D3𝔸1 r ) where
pi = konst @Double @3 @( 1 ) pi pi = konst @3 @1 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -944,7 +953,7 @@ instance Transcendental r => Transcendental ( D3𝔸1 r ) where
{-# SPECIALISE instance Transcendental ( D3𝔸1 𝕀 ) #-} {-# SPECIALISE instance Transcendental ( D3𝔸1 𝕀 ) #-}
instance Transcendental r => Transcendental ( D3𝔸2 r ) where instance Transcendental r => Transcendental ( D3𝔸2 r ) where
pi = konst @Double @3 @( 2 ) pi pi = konst @3 @2 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -976,7 +985,7 @@ instance Transcendental r => Transcendental ( D3𝔸2 r ) where
{-# SPECIALISE instance Transcendental ( D3𝔸2 𝕀 ) #-} {-# SPECIALISE instance Transcendental ( D3𝔸2 𝕀 ) #-}
instance Transcendental r => Transcendental ( D3𝔸3 r ) where instance Transcendental r => Transcendental ( D3𝔸3 r ) where
pi = konst @Double @3 @( 3 ) pi pi = konst @3 @3 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -1008,7 +1017,7 @@ instance Transcendental r => Transcendental ( D3𝔸3 r ) where
{-# SPECIALISE instance Transcendental ( D3𝔸3 𝕀 ) #-} {-# SPECIALISE instance Transcendental ( D3𝔸3 𝕀 ) #-}
instance Transcendental r => Transcendental ( D3𝔸4 r ) where instance Transcendental r => Transcendental ( D3𝔸4 r ) where
pi = konst @Double @3 @( 4 ) pi pi = konst @3 @4 pi
sin df = sin df =
let let
fromInt = fromInteger @r fromInt = fromInteger @r
@ -1042,35 +1051,41 @@ instance Transcendental r => Transcendental ( D3𝔸4 r ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- HasChainRule instances. -- HasChainRule instances.
instance Differential 2 0 where
konst w = D0 w
value ( D0 v ) = v
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 2 ( 0 ) where instance HasChainRule Double 2 ( 0 ) where
konst w = D0 w
linearD f v = D0 ( f v ) linearD f v = D0 ( f v )
value ( D0 v ) = v
chain _ ( D0 gfx ) = D21 gfx origin origin chain _ ( D0 gfx ) = D21 gfx origin origin
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 3 ( 0 ) where instance Differential 3 0 where
konst w = D0 w konst w = D0 w
linearD f v = D0 ( f v )
value ( D0 v ) = v value ( D0 v ) = v
chain _ ( D0 gfx ) = D31 gfx origin origin origin
{-# INLINEABLE konst #-} {-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-}
{-# INLINEABLE value #-} {-# INLINEABLE value #-}
instance HasChainRule Double 3 ( 0 ) where
linearD f v = D0 ( f v )
chain _ ( D0 gfx ) = D31 gfx origin origin origin
{-# INLINEABLE linearD #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 2 ( 1 ) where instance Differential 2 1 where
konst :: forall w. AbelianGroup w => w -> D2𝔸1 w konst :: forall w. AbelianGroup w => w -> D2𝔸1 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 2 ( 1 ) where
linearD :: forall w. Module Double ( T w ) => ( 1 -> w ) -> 1 -> D2𝔸1 w linearD :: forall w. Module Double ( T w ) => ( 1 -> w ) -> 1 -> D2𝔸1 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1087,7 +1102,6 @@ instance HasChainRule Double 2 ( 1 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 1 ) -> D2𝔸1 w -> D2𝔸1 w chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 1 ) -> D2𝔸1 w -> D2𝔸1 w
chain !df !dg = chain !df !dg =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1096,20 +1110,28 @@ instance HasChainRule Double 2 ( 1 ) where
in $$( chainRule1NQ in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||] [|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] ) [|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 3 ( 1 ) where instance Differential 3 1 where
konst :: forall w. AbelianGroup w => w -> D3𝔸1 w konst :: forall w. AbelianGroup w => w -> D3𝔸1 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 3 ( 1 ) where
chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 1 ) -> D3𝔸1 w -> D3𝔸1 w
chain !df !dg =
let !o = origin @Double @( T w )
!p = (^+^) @Double @( T w )
!s = (^*) @Double @( T w )
in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] )
linearD :: forall w. Module Double ( T w ) => ( 1 -> w ) -> 1 -> D3𝔸1 w linearD :: forall w. Module Double ( T w ) => ( 1 -> w ) -> 1 -> D3𝔸1 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1126,29 +1148,19 @@ instance HasChainRule Double 3 ( 1 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 1 ) -> D3𝔸1 w -> D3𝔸1 w
chain !df !dg =
let !o = origin @Double @( T w )
!p = (^+^) @Double @( T w )
!s = (^*) @Double @( T w )
in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 2 ( 2 ) where instance Differential 2 2 where
konst :: forall w. AbelianGroup w => w -> D2𝔸2 w konst :: forall w. AbelianGroup w => w -> D2𝔸2 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 2 ( 2 ) where
linearD :: forall w. Module Double ( T w ) => ( 2 -> w ) -> 2 -> D2𝔸2 w linearD :: forall w. Module Double ( T w ) => ( 2 -> w ) -> 2 -> D2𝔸2 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1165,7 +1177,6 @@ instance HasChainRule Double 2 ( 2 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 2 ) -> D2𝔸2 w -> D2𝔸1 w chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 2 ) -> D2𝔸2 w -> D2𝔸1 w
chain !df !dg = chain !df !dg =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1174,20 +1185,19 @@ instance HasChainRule Double 2 ( 2 ) where
in $$( chainRule1NQ in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||] [|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] ) [|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 3 ( 2 ) where instance Differential 3 2 where
konst :: forall w. AbelianGroup w => w -> D3𝔸2 w konst :: forall w. AbelianGroup w => w -> D3𝔸2 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 3 ( 2 ) where
linearD :: forall w. Module Double ( T w ) => ( 2 -> w ) -> 2 -> D3𝔸2 w linearD :: forall w. Module Double ( T w ) => ( 2 -> w ) -> 2 -> D3𝔸2 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1204,7 +1214,6 @@ instance HasChainRule Double 3 ( 2 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 2 ) -> D3𝔸2 w -> D3𝔸1 w chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 2 ) -> D3𝔸2 w -> D3𝔸1 w
chain !df !dg = chain !df !dg =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1213,20 +1222,19 @@ instance HasChainRule Double 3 ( 2 ) where
in $$( chainRule1NQ in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||] [|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] ) [|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 2 ( 3 ) where instance Differential 2 3 where
konst :: forall w. AbelianGroup w => w -> D2𝔸3 w konst :: forall w. AbelianGroup w => w -> D2𝔸3 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 2 ( 3 ) where
linearD :: forall w. Module Double ( T w ) => ( 3 -> w ) -> 3 -> D2𝔸3 w linearD :: forall w. Module Double ( T w ) => ( 3 -> w ) -> 3 -> D2𝔸3 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1243,7 +1251,6 @@ instance HasChainRule Double 2 ( 3 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 3 ) -> D2𝔸3 w -> D2𝔸1 w chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 3 ) -> D2𝔸3 w -> D2𝔸1 w
chain !df !dg = chain !df !dg =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1252,20 +1259,19 @@ instance HasChainRule Double 2 ( 3 ) where
in $$( chainRule1NQ in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||] [|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] ) [|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 3 ( 3 ) where instance Differential 3 3 where
konst :: forall w. AbelianGroup w => w -> D3𝔸3 w konst :: forall w. AbelianGroup w => w -> D3𝔸3 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 3 ( 3 ) where
linearD :: forall w. Module Double ( T w ) => ( 3 -> w ) -> 3 -> D3𝔸3 w linearD :: forall w. Module Double ( T w ) => ( 3 -> w ) -> 3 -> D3𝔸3 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1282,7 +1288,6 @@ instance HasChainRule Double 3 ( 3 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 3 ) -> D3𝔸3 w -> D3𝔸1 w chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 3 ) -> D3𝔸3 w -> D3𝔸1 w
chain !df !dg = chain !df !dg =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1291,20 +1296,20 @@ instance HasChainRule Double 3 ( 3 ) where
in $$( chainRule1NQ in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||] [|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] ) [|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
{-# INLINEABLE linearD #-}
instance HasChainRule Double 2 ( 4 ) where instance Differential 2 4 where
konst :: forall w. AbelianGroup w => w -> D2𝔸4 w konst :: forall w. AbelianGroup w => w -> D2𝔸4 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 2 ( 4 ) where
linearD :: forall w. Module Double ( T w ) => ( 4 -> w ) -> 4 -> D2𝔸4 w linearD :: forall w. Module Double ( T w ) => ( 4 -> w ) -> 4 -> D2𝔸4 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1321,7 +1326,6 @@ instance HasChainRule Double 2 ( 4 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 4 ) -> D2𝔸4 w -> D2𝔸1 w chain :: forall w. Module Double ( T w ) => D2𝔸1 ( 4 ) -> D2𝔸4 w -> D2𝔸1 w
chain !df !dg = chain !df !dg =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1330,20 +1334,19 @@ instance HasChainRule Double 2 ( 4 ) where
in $$( chainRule1NQ in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||] [|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] ) [|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}
instance HasChainRule Double 3 ( 4 ) where instance Differential 3 4 where
konst :: forall w. AbelianGroup w => w -> D3𝔸4 w konst :: forall w. AbelianGroup w => w -> D3𝔸4 w
konst w = konst w =
let !o = fromInteger @w 0 let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial ) value df = $$( monIndexQ [|| df ||] zeroMonomial )
{-# INLINEABLE konst #-}
{-# INLINEABLE value #-}
instance HasChainRule Double 3 ( 4 ) where
linearD :: forall w. Module Double ( T w ) => ( 4 -> w ) -> 4 -> D3𝔸4 w linearD :: forall w. Module Double ( T w ) => ( 4 -> w ) -> 4 -> D3𝔸4 w
linearD f v = linearD f v =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1360,7 +1363,6 @@ instance HasChainRule Double 3 ( 4 ) where
| otherwise | otherwise
-> [|| unT o ||] -> [|| unT o ||]
) )
chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 4 ) -> D3𝔸4 w -> D3𝔸1 w chain :: forall w. Module Double ( T w ) => D3𝔸1 ( 4 ) -> D3𝔸4 w -> D3𝔸1 w
chain !df !dg = chain !df !dg =
let !o = origin @Double @( T w ) let !o = origin @Double @( T w )
@ -1369,7 +1371,5 @@ instance HasChainRule Double 3 ( 4 ) where
in $$( chainRule1NQ in $$( chainRule1NQ
[|| o ||] [|| p ||] [|| s ||] [|| o ||] [|| p ||] [|| s ||]
[|| df ||] [|| dg ||] ) [|| df ||] [|| dg ||] )
{-# INLINEABLE konst #-}
{-# INLINEABLE linearD #-} {-# INLINEABLE linearD #-}
{-# INLINEABLE value #-}
{-# INLINEABLE chain #-} {-# INLINEABLE chain #-}

View file

@ -312,6 +312,19 @@ instance MonomialBasisQ D1𝔸1 where
Mon ( Vec [ 1 ] ) -> [|| unT $ _D11_dx $$d ||] Mon ( Vec [ 1 ] ) -> [|| unT $ _D11_dx $$d ||]
_ -> [|| _D11_v $$d ||] _ -> [|| _D11_v $$d ||]
instance MonomialBasis D1𝔸1 where
monTabulate f =
let
_D11_v = f $ Mon ( Vec [ 0 ] )
_D11_dx = T $ f $ Mon ( Vec [ 1 ] )
in D11 { .. }
{-# INLINE monTabulate #-}
monIndex d = \ case
Mon ( Vec [ 1 ] ) -> unT $ _D11_dx d
_ -> _D11_v d
{-# INLINE monIndex #-}
type instance Deg D2𝔸1 = 2 type instance Deg D2𝔸1 = 2
type instance Vars D2𝔸1 = 1 type instance Vars D2𝔸1 = 1
instance MonomialBasisQ D2𝔸1 where instance MonomialBasisQ D2𝔸1 where

View file

@ -99,6 +99,8 @@ data FitPoint
{ fitPoint :: !( 2 ) { fitPoint :: !( 2 )
, fitTangent :: !( T ( 2 ) ) , fitTangent :: !( T ( 2 ) )
} }
| JoinPoint
{ joinPoint :: !( 2 ) }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData

View file

@ -1,4 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -51,9 +52,9 @@ import Data.List.NonEmpty
( NonEmpty ) ( NonEmpty )
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Maybe import Data.Maybe
( catMaybes, fromMaybe, isJust, listToMaybe, mapMaybe ) ( catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe )
import Data.Proxy import Data.Monoid
( Proxy(..) ) ( First(..) )
import Data.Semigroup import Data.Semigroup
( sconcat ) ( sconcat )
import GHC.Exts import GHC.Exts
@ -108,35 +109,26 @@ import Control.Monad.Trans.Writer.CPS
-- MetaBrush -- MetaBrush
import Calligraphy.Brushes import Calligraphy.Brushes
( Brush(..) ) ( Brush(..), Corner(..) )
import Math.Algebra.Dual import Math.Algebra.Dual
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitPoint, FitParameters, fitSpline ) ( FitPoint (..), FitParameters, fitSpline )
import Math.Bezier.Spline import Math.Bezier.Spline
( SplineType(..), SSplineType(..), SplineTypeI
, ssplineType, adjustSplineType, reverseSpline
, NextPoint(..), fromNextPoint
, KnownSplineType
( bifoldSpline, ibifoldSpline )
, Spline(..), SplinePts, Curves(..), Curve(..)
, openCurveStart, openCurveEnd, splitSplineAt, dropCurves
, showSplinePoints
)
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
import Math.Bezier.Stroke.EnvelopeEquation import Math.Bezier.Stroke.EnvelopeEquation
import Math.Differentiable import Math.Differentiable
( Differentiable, DiffInterp, I ) ( I, IVness(..), SingIVness (..)
, Differentiable, DiffInterp
)
import Math.Epsilon import Math.Epsilon
( epsilon ) ( epsilon )
import Math.Interval import Math.Interval
import Math.Linear import Math.Linear
import Math.Module import Math.Module
( Module(..), Inner((^.^)), Cross((×)), Interpolatable
, lerp, convexCombination, strictlyParallel
)
import Math.Ring import Math.Ring
( Transcendental ) ( Transcendental )
import qualified Math.Ring as Ring
import Math.Orientation import Math.Orientation
( Orientation(..), splineOrientation ( Orientation(..), splineOrientation
, between , between
@ -240,9 +232,10 @@ computeStrokeOutline ::
-- Differentiability. -- Differentiability.
, Interpolatable Double ( nbUsedParams ) , Interpolatable Double ( nbUsedParams )
, DiffInterp 2 nbBrushParams , DiffInterp 2 NonIV nbBrushParams
, DiffInterp 3 𝕀 nbBrushParams , DiffInterp 3 IsIV nbBrushParams
, HasChainRule Double 2 ( nbUsedParams ) , HasChainRule Double 2 ( nbUsedParams )
, HasChainRule 𝕀 2 ( 𝕀 nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀 nbUsedParams ) , HasChainRule 𝕀 3 ( 𝕀 nbUsedParams )
, HasChainRule Double 2 ( nbBrushParams ) , HasChainRule Double 2 ( nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀 nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀 nbBrushParams )
@ -254,13 +247,13 @@ computeStrokeOutline ::
-- Debugging. -- Debugging.
, Show ptData, Show crvData, Show ( nbBrushParams ) , Show ptData, Show crvData, Show ( nbBrushParams )
) )
=> RootSolvingAlgorithm => RootSolvingAlgorithm
-> Maybe ( RootIsolationOptions N 3 ) -> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 )
-> FitParameters -> FitParameters
-> ( ptData -> nbUsedParams ) -> ( ptData -> nbUsedParams )
-> ( nbUsedParams -> nbBrushParams ) -- ^ assumed to be linear and non-decreasing -> ( nbUsedParams -> nbBrushParams )
-- ^ assumed to be linear and non-decreasing
-> Brush nbBrushParams -> Brush nbBrushParams
-> Spline clo crvData ptData -> Spline clo crvData ptData
-> ST s -> ST s
@ -302,21 +295,29 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
etx, ety :: Double etx, ety :: Double
V2 etx ety = endTgt V2 etx ety = endTgt
startCap, endCap :: SplinePts Open mbStartCap, mbEndCap :: Maybe ( SplinePts Open )
startCap mbStartCap
| startTgtBwd `strictlyParallel` startTgtFwd
= Nothing
| isJust $ between CCW startTgtBwd startTgtFwd startTestTgt | isJust $ between CCW startTgtBwd startTgtFwd startTestTgt
= fmap ( T ( coords spt0 ) ) = Just
. fmap ( T ( coords spt0 ) )
$ joinWithBrush startBrush startTgtBwd startTgtFwd $ joinWithBrush startBrush startTgtBwd startTgtFwd
| otherwise | otherwise
= fmap ( T ( coords spt0 ) ) = Just
. fmap ( T ( coords spt0 ) )
. reverseSpline . reverseSpline
$ joinWithBrush startBrush startTgtFwd startTgtBwd $ joinWithBrush startBrush startTgtFwd startTgtBwd
endCap mbEndCap
| endTgtBwd `strictlyParallel` endTgtFwd
= Nothing
| isJust $ between CCW endTgtBwd endTgtFwd endTestTgt | isJust $ between CCW endTgtBwd endTgtFwd endTestTgt
= fmap ( T ( coords endPt ) ) = Just
. fmap ( T ( coords endPt ) )
$ joinWithBrush endBrush endTgtFwd endTgtBwd $ joinWithBrush endBrush endTgtFwd endTgtBwd
| otherwise | otherwise
= fmap ( T ( coords endPt ) ) = Just
. fmap ( T ( coords endPt ) )
. reverseSpline . reverseSpline
$ joinWithBrush endBrush endTgtBwd endTgtFwd $ joinWithBrush endBrush endTgtBwd endTgtFwd
@ -326,8 +327,14 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
cusps cusps
<- updateSpline ( startTgt, startTgtFwd, startTgtBwd ) <- updateSpline ( startTgt, startTgtFwd, startTgtBwd )
pure pure
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts ) ( Left ( adjustSplineType @Closed $ sconcat $ NE.fromList $ catMaybes [ mbStartCap, Just fwdPts, mbEndCap, Just bwdPts ] )
, fwdFits <> bwdFits , ( Seq.fromList $ fmap JoinPoint $ catMaybes
[ fmap splineEnd mbStartCap
, fmap splineStart mbEndCap
, fmap splineEnd mbEndCap
, fmap splineStart mbStartCap ]
)
<> fwdFits <> bwdFits
, cusps , cusps
) )
-- Closed brush path with at least one segment. -- Closed brush path with at least one segment.
@ -387,7 +394,7 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
brushShape pt = brushShape pt =
let Brush { brushBaseShape = shapeFn, mbRotation = mbRot } = brush let Brush { brushBaseShape = shapeFn, mbRotation = mbRot } = brush
brushParams = toBrushParams $ ptParams pt brushParams = toBrushParams $ ptParams pt
shape = fun @Double shapeFn brushParams shape = fun shapeFn brushParams
in case mbRot of in case mbRot of
Nothing -> shape Nothing -> shape
Just getθ -> Just getθ ->
@ -463,7 +470,10 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
-> WriterT OutlineData m () -> WriterT OutlineData m ()
tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) = tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) =
tell $ OutlineData tell $ OutlineData
( TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty ) ) ( TwoSided
( fwdJoin, Seq.fromList $ map JoinPoint [ splineStart fwdJoin, splineEnd fwdJoin ] )
( bwdJoin, Seq.fromList $ map JoinPoint [ splineStart bwdJoin, splineEnd bwdJoin ] )
)
[] []
where where
ptOffset :: T ( 2 ) ptOffset :: T ( 2 )
@ -524,9 +534,10 @@ outlineFunction
-- Differentiability. -- Differentiability.
, Interpolatable Double ( nbUsedParams ) , Interpolatable Double ( nbUsedParams )
, DiffInterp 2 nbBrushParams , DiffInterp 2 NonIV nbBrushParams
, DiffInterp 3 𝕀 nbBrushParams , DiffInterp 3 IsIV nbBrushParams
, HasChainRule Double 2 ( nbUsedParams ) , HasChainRule Double 2 ( nbUsedParams )
, HasChainRule 𝕀 2 ( 𝕀 nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀 nbUsedParams ) , HasChainRule 𝕀 3 ( 𝕀 nbUsedParams )
, HasChainRule Double 2 ( nbBrushParams ) , HasChainRule Double 2 ( nbBrushParams )
, HasChainRule 𝕀 3 ( 𝕀 nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀 nbBrushParams )
@ -542,7 +553,7 @@ outlineFunction
, Show ptData, Show crvData, Show ( nbBrushParams ) , Show ptData, Show crvData, Show ( nbBrushParams )
) )
=> RootSolvingAlgorithm => RootSolvingAlgorithm
-> Maybe ( RootIsolationOptions N 3 ) -> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 )
-> ( ptData -> nbUsedParams ) -> ( ptData -> nbUsedParams )
-> ( nbUsedParams -> nbBrushParams ) -- ^ assumed to be linear and non-decreasing -> ( nbUsedParams -> nbBrushParams ) -- ^ assumed to be linear and non-decreasing
-> Brush nbBrushParams -> Brush nbBrushParams
@ -550,37 +561,42 @@ outlineFunction
-> Curve Open crvData ptData -> Curve Open crvData ptData
-> OutlineInfo -> OutlineInfo
outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams
( Brush { brushBaseShape, brushBaseShapeI, mbRotation } ) = \ sp0 crv -> ( Brush { brushBaseShape, brushBaseShapeI
, brushCorners, brushCornersI
, mbRotation } ) = \ sp0 crv ->
let let
usedParams :: C 2 ( 1 ) ( nbUsedParams ) usedParams :: C 2 ( 1 ) ( nbUsedParams )
path :: C 2 ( 1 ) ( 2 ) path :: C 2 ( 1 ) ( 2 )
( path, usedParams ) ( path, usedParams )
= pathAndUsedParams @2 @ @nbUsedParams coerce id id ptParams sp0 crv = pathAndUsedParams @2 @NonIV @nbUsedParams coerce id id ptParams sp0 crv
curves :: 1 -- t curves :: 1 -- t
-> Seq ( 1 {- s -} -> StrokeDatum 2 ) -> ( Seq ( CornerStrokeDatum 2 NonIV )
, Seq ( 1 {- s -} -> StrokeDatum 2 NonIV ) )
curves = curves =
brushStrokeData @2 @nbBrushParams brushStrokeData @2 @nbBrushParams SNonIV
coerce coerce
path path
( fmap toBrushParams usedParams ) ( fmap toBrushParams usedParams )
brushBaseShape brushBaseShape
brushCorners
mbRotation mbRotation
curvesI :: 𝕀 1 -- t curvesI :: 𝕀 1 -- t
-> Seq ( 𝕀 1 {- s -} -> StrokeDatum 3 𝕀 ) -> ( Seq ( CornerStrokeDatum 3 IsIV )
, Seq ( 𝕀 1 {- s -} -> StrokeDatum 3 IsIV )
)
curvesI = curvesI =
brushStrokeData @3 @nbBrushParams brushStrokeData @3 @nbBrushParams SIsIV
coerce coerce
pathI pathI
( fmap ( nonDecreasing toBrushParams ) usedParamsI ) ( fmap ( nonDecreasing toBrushParams ) usedParamsI )
brushBaseShapeI brushBaseShapeI
brushCornersI
( fmap ( \ rot -> un𝕀1 . nonDecreasing ( 1 . rot ) ) mbRotation ) ( fmap ( \ rot -> un𝕀1 . nonDecreasing ( 1 . rot ) ) mbRotation )
usedParamsI :: C 3 ( 𝕀 1 ) ( 𝕀 nbUsedParams ) usedParamsI :: C 3 ( 𝕀 1 ) ( 𝕀 nbUsedParams )
pathI :: C 3 ( 𝕀 1 ) ( 𝕀 2 ) pathI :: C 3 ( 𝕀 1 ) ( 𝕀 2 )
( pathI, usedParamsI ) = pathAndUsedParams @3 @𝕀 @nbUsedParams coerce point point ptParams sp0 crv ( pathI, usedParamsI ) = pathAndUsedParams @3 @IsIV @nbUsedParams coerce point point ptParams sp0 crv
fwdBwd :: OutlineFn fwdBwd :: OutlineFn
fwdBwd t fwdBwd t
@ -604,12 +620,12 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams
in fmap ( unT . rotate cosθ sinθ . T ) in fmap ( unT . rotate cosθ sinθ . T )
in in
applyRot $ applyRot $
value @Double @2 @( nbBrushParams ) $ value @2 @nbBrushParams $
runD brushBaseShape brushParams runD brushBaseShape brushParams
( potentialCusps, definiteCusps ) = ( potentialCusps :: [Cusp], definiteCusps :: [Cusp] ) =
case mbCuspOptions of case mbCuspOptions of
Just cuspOptions Just ( cusp1Opts, cusp2Opts )
-- Don't try to compute cusps for a trivial curve -- Don't try to compute cusps for a trivial curve
-- (e.g. a line segment with identical start- and end-points), -- (e.g. a line segment with identical start- and end-points),
-- as the root isolation code chokes on this. -- as the root isolation code chokes on this.
@ -617,19 +633,28 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams
-- TODO: introduce a maximum time budget for the cusp computation, -- TODO: introduce a maximum time budget for the cusp computation,
-- and bail out if the computation exceeds the budget. -- and bail out if the computation exceeds the budget.
-- (Record such bailing out and warn the user if this happens often.) -- (Record such bailing out and warn the user if this happens often.)
, let ( cornerCusps, normalCusps ) = findCusps ( cusp1Opts, cusp2Opts ) curvesI
-> ->
foldMap foldMap
( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = potCusps } ) ) -> ( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = potCusps } ) ) ->
( map ( ( i , ) . fst ) potCusps, map ( i , ) defCusps ) ( map ( \ ( box, _ ) -> cornerCuspCoords ( fst . curves ) ( i, box ) ) potCusps
, map ( \ box -> cornerCuspCoords ( fst . curves ) ( i, box ) ) defCusps )
) )
( IntMap.toList $ findCusps cuspOptions curvesI ) ( IntMap.toList cornerCusps )
<>
foldMap
( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = potCusps } ) ) ->
( map ( \ ( box, _ ) -> cuspCoords ( snd . curves ) ( i, box ) ) potCusps
, map ( \ box -> cuspCoords ( snd . curves ) ( i, box ) ) defCusps )
)
( IntMap.toList normalCusps )
_ -> _ ->
( [], [] ) ( [], [] )
in OutlineInfo in OutlineInfo
{ outlineFn = fwdBwd { outlineFn = fwdBwd
, outlineDefiniteCusps = map ( cuspCoords curves ) definiteCusps , outlineDefiniteCusps = definiteCusps
, outlinePotentialCusps = map ( cuspCoords curves ) potentialCusps , outlinePotentialCusps = potentialCusps
} }
{-# INLINEABLE outlineFunction #-} {-# INLINEABLE outlineFunction #-}
@ -648,15 +673,15 @@ pathAndUsedParams :: forall k i (nbUsedParams :: Nat) arr crvData ptData
, Torsor ( T ( I i 2 ) ) ( I i 2 ) , Torsor ( T ( I i 2 ) ) ( I i 2 )
, Module ( I i Double ) ( T ( I i nbUsedParams ) ) , Module ( I i Double ) ( T ( I i nbUsedParams ) )
, Torsor ( T ( I i nbUsedParams ) ) ( I i nbUsedParams ) , Torsor ( T ( I i nbUsedParams ) ) ( I i nbUsedParams )
, Module Double ( T ( I nbUsedParams ) ) , Module Double ( T ( nbUsedParams ) )
, Torsor ( T ( ( I nbUsedParams ) ) ) ( I nbUsedParams ) , Torsor ( T ( ( nbUsedParams ) ) ) ( nbUsedParams )
, Representable Double ( nbUsedParams ) , Representable Double ( nbUsedParams )
, Representable 𝕀 ( 𝕀 nbUsedParams ) , Representable 𝕀 ( 𝕀 nbUsedParams )
) )
=> ( I i 1 -> I i Double ) => ( I i 1 -> I i Double )
-> ( I 2 -> I i 2 ) -> ( 2 -> I i 2 )
-> ( I nbUsedParams -> I i nbUsedParams ) -> ( nbUsedParams -> I i nbUsedParams )
-> ( ptData -> I nbUsedParams ) -> ( ptData -> nbUsedParams )
-> ptData -> ptData
-> Curve Open crvData ptData -> Curve Open crvData ptData
-> ( I i 1 `arr` I i 2, I i 1 `arr` I i nbUsedParams ) -> ( I i 1 `arr` I i 2, I i 1 `arr` I i nbUsedParams )
@ -1004,15 +1029,19 @@ instance Applicative ZipSeq where
liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys ) liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys )
{-# INLINE liftA2 #-} {-# INLINE liftA2 #-}
brushStrokeData :: forall {kd} (k :: Nat) (nbBrushParams :: Nat) (i :: kd) arr brushStrokeData :: forall (k :: Nat) (nbBrushParams :: Nat) (i :: IVness) arr
. ( arr ~ C k . ( arr ~ C k
, HasBézier k i, HasEnvelopeEquation k , HasBézier k i, HasEnvelopeEquation k
, Differentiable k i nbBrushParams , Differentiable k i nbBrushParams
, HasChainRule ( I i Double ) k ( I i 1 ) , HasChainRule ( I i Double ) k ( I i 1 )
, HasChainRule 𝕀 k ( 𝕀 nbBrushParams )
, Applicative ( D k 1 ) , Applicative ( D k 1 )
, Dim ( I i 1 ) ~ 1 , Dim ( I i 1 ) ~ 1
, Dim ( I i nbBrushParams ) ~ nbBrushParams , Dim ( I i nbBrushParams ) ~ nbBrushParams
, Traversable ( D k nbBrushParams ) , Traversable ( D k nbBrushParams )
, Traversable ( D k 1 )
, Module ( D k 1 𝕀 ) ( D k 1 ( 𝕀 2 ) )
, Transcendental ( D k 1 𝕀 )
, Transcendental ( I i Double ) , Transcendental ( I i Double )
, Module ( I i Double ) ( T ( I i 1 ) ) , Module ( I i Double ) ( T ( I i 1 ) )
@ -1020,88 +1049,161 @@ brushStrokeData :: forall {kd} (k :: Nat) (nbBrushParams :: Nat) (i :: kd) arr
, Torsor ( T ( I i 2 ) ) ( I i 2 ) , Torsor ( T ( I i 2 ) ) ( I i 2 )
, Show ( nbBrushParams ) , Show ( nbBrushParams )
, Show ( StrokeDatum k i ) , Show ( StrokeDatum k i )
, Show ( StrokeDatum k IsIV )
, Representable ( I i Double ) ( I i 2 ), RepDim ( I i 2 ) ~ 2 , Representable ( I i Double ) ( I i 2 ), RepDim ( I i 2 ) ~ 2
) )
=> ( I i Double -> I i 1 ) => SingIVness i
-> ( I i 1 -> I i Double )
-> ( I i 1 `arr` I i 2 ) -> ( I i 1 `arr` I i 2 )
-- ^ path -- ^ path
-> ( I i 1 `arr` I i nbBrushParams ) -> ( I i 1 `arr` I i nbBrushParams )
-- ^ brush parameters -- ^ brush parameters
-> ( I i nbBrushParams `arr` Spline Closed () ( I i 2 ) ) -> ( I i nbBrushParams `arr` Spline Closed () ( I i 2 ) )
-- ^ brush from parameters -- ^ brush from parameters
-> ( Seq ( I i nbBrushParams `arr` Corner ( I i 2 ) ) )
-- ^ brush corners from parameters
-> ( Maybe ( I i nbBrushParams -> I i Double ) ) -> ( Maybe ( I i nbBrushParams -> I i Double ) )
-- ^ rotation parameter -- ^ rotation parameter
-> ( I i 1 -> Seq ( I i 1 -> StrokeDatum k i ) ) -> ( I i 1 -> ( Seq ( CornerStrokeDatum k i ), Seq ( I i 1 -> StrokeDatum k i ) ) )
brushStrokeData co1 co2 path params brush mbBrushRotation = brushStrokeData ivness path params brush brushCorners mbBrushRotation =
\ t -> \ t ->
let let
dpath_t :: D k 1 ( I i 2 )
!dpath_t = runD path t
dparams_t :: D k 1 ( I i nbBrushParams )
!dparams_t = runD params t
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 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 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 co :: I i 1 -> I i Double
!co = case ivness of
SNonIV -> coerce
SIsIV -> coerce
dpath_t :: D k 1 ( I i 2 )
!dpath_t = runD path t
dparams_t :: D k 1 ( I i nbBrushParams )
!dparams_t = runD params t
brushParams :: I i nbBrushParams
!brushParams = value @k @1 dparams_t
dbrush_params :: D k nbBrushParams ( Spline Closed () ( I i 2 ) )
!dbrush_params = runD brush brushParams
splines :: Seq ( D k nbBrushParams ( I i 1 `arr` I i 2 ) )
!splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns @k @i co ) dbrush_params
dbrushes_t :: Seq ( I i 1 -> D k 2 ( I i 2 ) )
!dbrushes_t =
force $
fmap
( fmap ( uncurryD @k )
. ( \ db s -> fmap ( `runD` s ) db )
. chain @( I i Double ) @k dparams_t
-- This is the crucial use of the chain rule.
)
splines
in ( brushCorners <&> \ cornerFn ->
let !dcorner = runD cornerFn brushParams
!corner = value @k @nbBrushParams dcorner
!dcornerPt = chain @_ @k dparams_t $ fmap cornerPoint dcorner
in mkCornerStrokeDatum dpath_t dparams_t corner dcornerPt
, fmap ( mkStrokeDatum dpath_t dparams_t . ) dbrushes_t )
where where
mkStrokeDatum :: D k 1 ( I i 2 ) mkStrokeDatum :: D k 1 ( I i 2 )
-> D k 1 ( I i nbBrushParams ) -> D k 1 ( I i nbBrushParams )
-> ( I i 1 -> D k 2 ( I i 2 ) ) -> D k 2 ( I i 2 )
-> ( I i 1 -> StrokeDatum k i ) -> StrokeDatum k i
mkStrokeDatum dpath_t dparams_t dbrush_t s = mkStrokeDatum dpath_t dparams_t dbrush_t =
let dbrush_t_s = dbrush_t s let mbRotation = mbBrushRotation <&> \ getTheta -> fmap getTheta dparams_t
mbRotation = mbBrushRotation <&> \ getTheta -> fmap getTheta dparams_t in envelopeEquation @k ivness dpath_t dbrush_t mbRotation
in envelopeEquation @k @i Proxy co1 dpath_t dbrush_t_s mbRotation
{-# INLINEABLE brushStrokeData #-}
{- mkCornerStrokeDatum :: D k 1 ( I i 2 )
{-# SPECIALISE brushStrokeData -> D k 1 ( I i nbBrushParams )
:: ( 𝕀 -> ( 𝕀 1 ) ) -> Corner ( I i 2 )
-> ( 𝕀 1 -> 𝕀 ) -> D k 1 ( I i 2 )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) ) -> CornerStrokeDatum k i
-> ( C 3 ( 𝕀 1 ) ( 𝕀 1 ) ) mkCornerStrokeDatum dpath_t dparams_t corner dbrush_t =
-> ( C 3 ( 𝕀 1 ) ( Spline Closed () ( 𝕀 2 ) ) ) let mbRotation = mbBrushRotation <&> \ getTheta -> fmap getTheta dparams_t
-> ( Maybe ( 𝕀 1 -> 𝕀 ) ) in CornerStrokeDatum
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) ) { dpath = dpath_t
, dbrush = dbrush_t
, corner
, stroke = unT $
T ( value @k @1 dpath_t )
^+^ ( let b = T $ value @k @1 dbrush_t in case mbRotation of
Nothing -> b
Just -> let { θ = value @k @1 ; cosθ = Ring.cos θ; sinθ = Ring.sin θ } in rotate cosθ sinθ b
)
, mbRotation }
{-# SPECIALISE INLINE brushStrokeData
:: SingIVness NonIV
-> ( C 2 ( 1 ) ( 2 ) )
-> ( C 2 ( 1 ) ( 1 ) )
-> ( C 2 ( 1 ) ( Spline Closed () ( 2 ) ) )
-> ( Seq ( C 2 ( 1 ) ( Corner ( 2 ) ) ) )
-> ( Maybe ( 1 -> Double ) )
-> ( 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( 1 -> StrokeDatum 2 NonIV ) ) )
#-} #-}
{-# SPECIALISE brushStrokeData {-# SPECIALISE INLINE brushStrokeData
:: ( 𝕀 -> ( 𝕀 1 ) ) :: SingIVness NonIV
-> ( 𝕀 1 -> 𝕀 ) -> ( C 2 ( 1 ) ( 2 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) ) -> ( C 2 ( 1 ) ( 2 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) ) -> ( C 2 ( 2 ) ( Spline Closed () ( 2 ) ) )
-> ( C 3 ( 𝕀 2 ) ( Spline Closed () ( 𝕀 2 ) ) ) -> ( Seq ( C 2 ( 2 ) ( Corner ( 2 ) ) ) )
-> ( Maybe ( 𝕀 2 -> 𝕀) ) -> ( Maybe ( 2 -> Double ) )
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) ) -> ( 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( 1 -> StrokeDatum 2 NonIV ) ) )
#-} #-}
{-# SPECIALISE brushStrokeData {-# SPECIALISE INLINE brushStrokeData
:: ( 𝕀 -> ( 𝕀 1 ) ) :: SingIVness NonIV
-> ( 𝕀 1 -> 𝕀 ) -> ( C 2 ( 1 ) ( 2 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) ) -> ( C 2 ( 1 ) ( 3 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 3 ) ) -> ( C 2 ( 3 ) ( Spline Closed () ( 2 ) ) )
-> ( C 3 ( 𝕀 3 ) ( Spline Closed () ( 𝕀 2 ) ) ) -> ( Seq ( C 2 ( 3 ) ( Corner ( 2 ) ) ) )
-> ( Maybe ( 𝕀 3 -> 𝕀 ) ) -> ( Maybe ( 3 -> Double ) )
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) ) -> ( 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( 1 -> StrokeDatum 2 NonIV ) ) )
#-} #-}
{-# SPECIALISE brushStrokeData {-# SPECIALISE INLINE brushStrokeData
:: ( 𝕀 -> ( 𝕀 1 ) ) :: SingIVness NonIV
-> ( 𝕀 1 -> 𝕀 ) -> ( C 2 ( 1 ) ( 2 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) ) -> ( C 2 ( 1 ) ( 4 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 4 ) ) -> ( C 2 ( 4 ) ( Spline Closed () ( 2 ) ) )
-> ( C 3 ( 𝕀 4 ) ( Spline Closed () ( 𝕀 2 ) ) ) -> ( Seq ( C 2 ( 4 ) ( Corner ( 2 ) ) ) )
-> ( Maybe ( 𝕀 4 -> 𝕀 ) ) -> ( Maybe ( 4 -> Double ) )
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) ) -> ( 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( 1 -> StrokeDatum 2 NonIV ) ) )
#-} #-}
-} {-# SPECIALISE INLINE brushStrokeData
-- TODO: these specialisations fire in the benchmarking code because :: SingIVness IsIV
-- we instantiate brushParams with ( nbBrushParams ), but they won't fire -> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) )
-- in the main app code because we are using types such as "Record EllipseBrushFields". -> ( C 3 ( 𝕀 1 ) ( 𝕀 1 ) )
-> ( C 3 ( 𝕀 1 ) ( Spline Closed () ( 𝕀 2 ) ) )
-> ( Seq ( C 3 ( 𝕀 1 ) ( Corner ( 𝕀 2 ) ) ) )
-> ( Maybe ( 𝕀 1 -> 𝕀 ) )
-> ( 𝕀 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀 1 -> StrokeDatum 3 IsIV ) ) )
#-}
{-# SPECIALISE INLINE brushStrokeData
:: SingIVness IsIV
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) )
-> ( C 3 ( 𝕀 2 ) ( Spline Closed () ( 𝕀 2 ) ) )
-> ( Seq ( C 3 ( 𝕀 2 ) ( Corner ( 𝕀 2 ) ) ) )
-> ( Maybe ( 𝕀 2 -> 𝕀 ) )
-> ( 𝕀 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀 1 -> StrokeDatum 3 IsIV ) ) )
#-}
{-# SPECIALISE INLINE brushStrokeData
:: SingIVness IsIV
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 3 ) )
-> ( C 3 ( 𝕀 3 ) ( Spline Closed () ( 𝕀 2 ) ) )
-> ( Seq ( C 3 ( 𝕀 3 ) ( Corner ( 𝕀 2 ) ) ) )
-> ( Maybe ( 𝕀 3 -> 𝕀 ) )
-> ( 𝕀 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀 1 -> StrokeDatum 3 IsIV ) ) )
#-}
{-# SPECIALISE INLINE brushStrokeData
:: SingIVness IsIV
-> ( C 3 ( 𝕀 1 ) ( 𝕀 2 ) )
-> ( C 3 ( 𝕀 1 ) ( 𝕀 4 ) )
-> ( C 3 ( 𝕀 4 ) ( Spline Closed () ( 𝕀 2 ) ) )
-> ( Seq ( C 3 ( 𝕀 4 ) ( Corner ( 𝕀 2 ) ) ) )
-> ( Maybe ( 𝕀 4 -> 𝕀 ) )
-> ( 𝕀 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀 1 -> StrokeDatum 3 IsIV ) ) )
#-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Solving the envelolpe equation: root-finding. -- Solving the envelolpe equation: root-finding.
@ -1113,6 +1215,11 @@ data RootSolvingAlgorithm
-- | Use the modified Halley M2 method. -- | Use the modified Halley M2 method.
| HalleyM2 { maxIters :: Word, precision :: Int } | HalleyM2 { maxIters :: Word, precision :: Int }
data FwdBwd
= Fwd
| Bwd
deriving stock ( Eq, Show )
-- | 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 :: RootSolvingAlgorithm solveEnvelopeEquations :: RootSolvingAlgorithm
@ -1120,39 +1227,44 @@ solveEnvelopeEquations :: RootSolvingAlgorithm
-> 2 -> 2
-> T ( 2 ) -> T ( 2 )
-> ( Offset, Offset ) -> ( Offset, Offset )
-> Seq ( 1 -> StrokeDatum 2 ) -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( 1 -> StrokeDatum 2 NonIV ) )
-> ( ( 2, T ( 2 ) ), ( 2, T ( 2 ) ) ) -> ( ( 2, T ( 2 ) ), ( 2, T ( 2 ) ) )
solveEnvelopeEquations rootAlgo ( 1 _t ) path_t path'_t ( fwdOffset, bwdOffset ) strokeData solveEnvelopeEquations rootAlgo ( 1 _t ) path_t path'_t ( fwdOffset, bwdOffset ) ( corners, strokeData )
= ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) ) = ( fromMaybe fwdSol mbFwdCornerSol
, maybe ( bwdPt, -1 *^ bwdTgt ) ( \ ( pt, tgt ) -> ( pt, -1 *^ tgt ) ) mbBwdCornerSol
)
where where
fwdSol = findSolFrom "fwd" fwdOffset fwdSol = findSolFrom Fwd fwdOffset
( bwdPt, bwdTgt ) = findSolFrom "bwd" bwdOffset ( bwdPt, bwdTgt ) = findSolFrom Bwd bwdOffset
findSolFrom :: String -> Offset -> ( 2, T ( 2 ) ) mbFwdCornerSol = getFirst $ foldMap ( First . cornerSol Fwd ) corners
findSolFrom desc ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } ) mbBwdCornerSol = getFirst $ foldMap ( First . cornerSol Bwd ) corners
findSolFrom :: FwdBwd -> Offset -> ( 2, T ( 2 ) )
findSolFrom fwdOrBwd ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } )
= go ( fromIntegral i00 + fromMaybe 0.5 s00 ) = go ( fromIntegral i00 + fromMaybe 0.5 s00 )
where where
go :: Double -> ( 2, T ( 2 ) ) go :: Double -> ( 2, T ( 2 ) )
go is0 = go is0 =
case sol desc strokeData is0 of case sol fwdOrBwd strokeData is0 of
( goodSoln, pt, tgt ) ( goodSoln, pt, tgt )
| goodSoln | goodSoln
-> ( pt, tgt ) -> ( pt, tgt )
| otherwise | otherwise
-> ( off path_t, path'_t ) -> ( off path_t, path'_t )
sol :: String -> Seq ( 1 -> StrokeDatum 2 ) -> Double -> ( Bool, 2, T ( 2 ) ) sol :: FwdBwd -> Seq ( 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Bool, 2, T ( 2 ) )
sol desc f is0 = sol fwdOrBwd f is0 =
let ( solRes, _solSteps ) = runSolveMethod ( eqn f ) is0 let ( solRes, _solSteps ) = runSolveMethod ( eqn f ) is0
( good, is ) = ( good, is ) =
case solRes of case solRes of
Nothing -> ( False, is0 ) Nothing -> ( False, is0 )
Just is1 -> ( if desc == "fwd" Just is1 -> ( case fwdOrBwd of
then sgn >= 0 Fwd -> sgn >= 0
else sgn <= 0 Bwd -> sgn <= 0
, is1 , is1
) )
( sgn, ds, dcdt ) = finish f is ( sgn, ds, dcdt ) = finish f is
@ -1164,7 +1276,7 @@ solveEnvelopeEquations rootAlgo ( 1 _t ) path_t path'_t ( fwdOffset, bwdOffse
NewtonRaphson { maxIters, precision } -> NewtonRaphson { maxIters, precision } ->
newtonRaphson maxIters precision domain newtonRaphson maxIters precision domain
finish :: Seq ( 1 -> StrokeDatum 2 ) -> Double -> ( Double, 2, T ( 2 ) ) finish :: Seq ( 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Double, 2, T ( 2 ) )
finish fs is = finish fs is =
let (i, s) = fromDomain is in let (i, s) = fromDomain is in
case evalStrokeDatum fs is of -- TODO: a bit redundant to have to compute this again... case evalStrokeDatum fs is of -- TODO: a bit redundant to have to compute this again...
@ -1192,21 +1304,67 @@ solveEnvelopeEquations rootAlgo ( 1 _t ) path_t path'_t ( fwdOffset, bwdOffse
let cosθ = cos θ let cosθ = cos θ
sinθ = sin θ sinθ = sin θ
in rotate cosθ sinθ $ unrot_dcdt in rotate cosθ sinθ $ unrot_dcdt
-- TODO: reduce duplication with 'cornerSol'.
in ( T u ^.^ T v, stroke, dcdt ) in ( T u ^.^ T v, stroke, dcdt )
-- Compute the dot product of u and v (which are rotated versions of ∂c/∂t and ∂c/∂s). -- Compute the dot product of u and v (which are rotated versions of ∂c/∂t and ∂c/∂s).
-- The sign of this quantity determines which side of the envelope -- The sign of this quantity determines which side of the envelope
-- we are on. -- we are on.
evalStrokeDatum :: Seq ( 1 -> StrokeDatum 2 ) -> ( Double -> StrokeDatum 2 ) evalStrokeDatum :: Seq ( 1 -> StrokeDatum 2 NonIV ) -> ( Double -> StrokeDatum 2 NonIV )
evalStrokeDatum fs is = evalStrokeDatum fs is =
let (i, s) = fromDomain is let (i, s) = fromDomain is
in ( fs `Seq.index` i ) ( 1 $ max 1e-6 $ min (1 - 1e-6) $ s ) in ( fs `Seq.index` i ) ( 1 $ max 1e-6 $ min (1 - 1e-6) $ s )
eqn :: Seq ( 1 -> StrokeDatum 2 ) -> ( Double -> (# Double, Double #) ) eqn :: Seq ( 1 -> StrokeDatum 2 NonIV ) -> ( Double -> (# Double, Double #) )
eqn fs is = eqn fs is =
case evalStrokeDatum fs is of case evalStrokeDatum fs is of
StrokeDatum { ee = D12 ee _ ee_s } -> coerce (# ee, ee_s #) StrokeDatum { ee = D12 ee _ ee_s } -> coerce (# ee, ee_s #)
cornerSol :: FwdBwd -> CornerStrokeDatum 2 NonIV -> Maybe ( 2, T ( 2 ) )
cornerSol fwdOrBwd
cornerDatum@(
CornerStrokeDatum
{ dpath = _dp@( D21 p _ _ )
, dbrush = D21 b _b_t _b_tt
, mbRotation
, corner = Corner _ startTgt endTgt }
)
=
let D11 u _u_t = cornerStrokeDatum cornerDatum
flipWhenBwd =
case fwdOrBwd of
Fwd -> id
Bwd -> ( -1 *^ )
b_s = flipWhenBwd ( T u )
ori = CCW --case fwdOrBwd of { Fwd -> CCW ; Bwd -> CW }
res@( _pt, _tgt ) = case mbRotation of
Nothing -> ( unT $ T p ^+^ T b
, T u )
Just ( D21 θ _ _ ) ->
let cosθ = cos θ
sinθ = sin θ
in ( unT $ T p ^+^ rotate cosθ sinθ ( T b )
, rotate cosθ sinθ ( T u ) )
in
{-
trace (unlines
[ "cornerSol"
, "fwdOrBwd: " ++ show fwdOrBwd
, "ori: " ++ show ori
, "dp: " ++ show _dp
, "startTgt: " ++ show startTgt
, "endTgt: " ++ show endTgt
, "u: " ++ show u
, "b_s: " ++ show b_s
, "ok: " ++ show ( between ori startTgt endTgt b_s )
, "pt: " ++ show _pt
, "tgt: " ++ show _tgt
]) $
-}
if isNothing $ between ori startTgt endTgt b_s
then Nothing
else Just res
n :: Int n :: Int
n = Seq.length strokeData n = Seq.length strokeData
domain :: ( Double, Double ) domain :: ( Double, Double )
@ -1222,42 +1380,69 @@ solveEnvelopeEquations rootAlgo ( 1 _t ) path_t path'_t ( fwdOffset, bwdOffse
-- | Computes the brush stroke coordinates of a cusp from -- | Computes the brush stroke coordinates of a cusp from
-- the @(t,s)@ parameter values. -- the @(t,s)@ parameter values.
-- cuspCoords :: ( 1 -> Seq ( 1 -> StrokeDatum 2 NonIV ) )
-- TODO: use Newton's method starting at the midpoint of the box,
-- instead of just taking the midpoint of the box.
cuspCoords :: ( 1 -> Seq ( 1 -> StrokeDatum 2 ) )
-> ( Int, Box N ) -> ( Int, Box N )
-> Cusp -> Cusp
-- TODO: use Newton's method starting at the midpoint of the box,
-- instead of just taking the midpoint of the box.
cuspCoords eqs ( i, box ) cuspCoords eqs ( i, box )
| StrokeDatum | StrokeDatum
{ dpath, stroke } { dpath, stroke }
<- ( eqs ( 1 t_mid ) `Seq.index` i ) ( 1 s_mid ) <- ( eqs ( 1 t_mid ) `Seq.index` i ) ( 1 s_mid )
= Cusp = Cusp
{ cuspParameters = 2 t_mid s_mid { cuspParameters = 2 t_mid s_mid
, cuspPathCoords = coerce dpath , cuspPathCoords = dpath
, cuspStrokeCoords = coerce stroke , cuspStrokeCoords = stroke
} }
where where
𝕀 t_lo t_hi = box `index` Fin 1 t = box `index` Fin 1
𝕀 s_lo s_hi = box `index` Fin 2 s = box `index` Fin 2
t_mid = 0.5 * ( t_lo + t_hi ) t_mid = midpoint t
s_mid = 0.5 * ( s_lo + s_hi ) s_mid = midpoint s
cornerCuspCoords :: ( 1 -> Seq ( CornerStrokeDatum 2 NonIV ) )
-> ( Int, Box 1 )
-> Cusp
-- TODO: use Newton's method.
cornerCuspCoords eqs ( i, box )
| CornerStrokeDatum { dpath, stroke } <- eqs ( 1 t_mid ) `Seq.index` i
= Cusp
{ cuspParameters = 2 t_mid 0
, cuspPathCoords = dpath
, cuspStrokeCoords = stroke
}
where
t = box `index` Fin 1
t_mid = midpoint t
-- | Find cusps in the envelope for values of the parameters in -- | Find cusps in the envelope for values of the parameters in
-- \( 0 \leqslant t, s \leqslant 1 \), using interval arithmetic. -- \( 0 \leqslant t, s \leqslant 1 \), using interval arithmetic.
-- --
-- See 'isolateRootsIn' for details of the algorithms used. -- See 'isolateRootsIn' for details of the algorithms used.
findCusps findCusps
:: RootIsolationOptions N 3 :: ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 )
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) ) -> ( 𝕀 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀 1 -> StrokeDatum 3 IsIV ) ) )
-> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], DoneBoxes N ) -> ( IntMap ( [ ( Box 1, RootIsolationTree ( Box 1 ) ) ], DoneBoxes 1 )
findCusps opts boxStrokeData = , IntMap ( [ ( Box 2, RootIsolationTree ( Box 2 ) ) ], DoneBoxes 2 )
findCuspsIn opts boxStrokeData $ )
IntMap.fromList findCusps ( opts1, opts2 ) boxStrokeData =
[ ( i, [ 𝕀2 ( 𝕀 zero one ) ( 𝕀 zero one ) ] ) ( findCornerCuspsIn opts1 ( fst . boxStrokeData )
| i <- [ 0 .. length ( boxStrokeData ( 𝕀1 ( 𝕀 zero one ) ) ) - 1 ] ( IntMap.fromList
] [ ( i, [ 𝕀1 unit ] )
| i <- [ 0 .. length ( fst $ boxStrokeData ( 𝕀1 unit ) ) - 1 ]
]
)
, findCuspsIn opts2 ( snd . boxStrokeData )
( IntMap.fromList
[ ( i, [ 𝕀2 unit unit ] )
| i <- [ 0 .. length ( snd $ boxStrokeData ( 𝕀1 unit ) ) - 1 ]
]
)
)
where where
unit :: 𝕀
unit = 𝕀 zero one
{-# INLINE unit #-}
zero, one :: Double zero, one :: Double
zero = 1e-6 zero = 1e-6
one = 1 - zero one = 1 - zero
@ -1268,7 +1453,7 @@ findCusps opts boxStrokeData =
-- root isolation method. -- root isolation method.
findCuspsIn findCuspsIn
:: RootIsolationOptions N 3 :: RootIsolationOptions N 3
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) ) -> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 IsIV ) )
-> IntMap [ Box 2 ] -> IntMap [ Box 2 ]
-> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], DoneBoxes N ) -> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], DoneBoxes N )
findCuspsIn opts boxStrokeData initBoxes = findCuspsIn opts boxStrokeData initBoxes =
@ -1289,95 +1474,58 @@ findCuspsIn opts boxStrokeData initBoxes =
( T $ 𝕀3 ee_t f_t g_t ) ( T $ 𝕀3 ee_t f_t g_t )
( T $ 𝕀3 ee_s f_s g_s ) ( T $ 𝕀3 ee_s f_s g_s )
{- -- | Like 'findCuspsIn' but in the case that the envelope is traced out
findCuspsIn -- by a brush corner.
:: RootIsolationOptions N 3 findCornerCuspsIn
-> ( 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) ) :: RootIsolationOptions 1 2
-> IntMap [ Box 2 ] -> ( 𝕀 1 -> Seq ( CornerStrokeDatum 3 IsIV ) )
-> IntMap ( [ ( Box 3, RootIsolationTree ( Box 3 ) ) ], ( [ Box 3 ], [ Box 3 ] ) ) -> IntMap [ Box 1 ]
findCuspsIn opts boxStrokeData initBoxes = -> IntMap ( [ ( Box 1, RootIsolationTree ( Box 1 ) ) ], DoneBoxes 1 )
IntMap.mapWithKey ( \ i boxes -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) $ concatMap ( mkInitBox i ) boxes ) initBoxes findCornerCuspsIn opts boxStrokeData initBoxes =
IntMap.mapWithKey ( \ i -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) ) initBoxes
where where
mkInitBox :: Int -> Box 2 -> [ Box 3 ] eqnPiece i ( 𝕀1 t ) =
mkInitBox i ( 𝕀 ( 2 t_lo s_lo ) ( 2 t_hi s_hi ) ) = let CornerStrokeDatum
let t = 𝕀 ( 1 t_lo ) ( 1 t_hi ) { dpath =
s = 𝕀 ( 1 s_lo ) ( 1 s_hi ) D31 { _D31_dx = p'
StrokeDatum , _D31_dxdx = p''
{ du = }
D22 , dbrush =
{ _D22_v = 𝕀 ( 2 ux_lo uy_lo ) ( 2 ux_hi uy_hi )} D31 { _D31_v = b
, dv = , _D31_dx = b'
D22 , _D31_dxdx = b''
{ _D22_v = 𝕀 ( 2 vx_lo vy_lo ) ( 2 vx_hi vy_hi ) } }
, ee = , mbRotation
D22 } = ( boxStrokeData ( 𝕀1 t ) `Seq.index` i )
{ _D22_dx = T ( 𝕀 ( 1 ee_t_lo ) ( 1 ee_t_hi ) ) in case mbRotation of
, _D22_dy = T ( 𝕀 ( 1 ee_s_lo ) ( 1 ee_s_hi ) ) } Nothing ->
} = ( boxStrokeData t `Seq.index` i ) s D11 ( unT $ p' ^+^ b' )
-- λ = ∂E/∂t / ∂E/∂s ( p'' ^+^ b'' )
λ1 = 𝕀 ee_t_lo ee_t_hi 𝕀 ee_s_lo ee_s_hi Just ( D31 { _D31_v = θ, _D31_dx = T θ', _D31_dxdx = T θ'' } ) ->
-- λ = u / v let cosθ = Ring.cos θ
λ2 = 𝕀 ux_lo ux_hi 𝕀 vx_lo vx_hi sinθ = Ring.sin θ
λ3 = 𝕀 uy_lo uy_hi 𝕀 vy_lo vy_hi swap ( T ( 𝕀2 x y ) ) = T ( 𝕀2 -y x )
λ = [ 𝕀 ( recip -0 ) ( recip 0 ) ] rot = rotate cosθ sinθ
`intersectMany` λ1 rot' = rot . swap
`intersectMany` λ2 rot'' = rot . ( -1 *^ )
`intersectMany` λ3
in
let boxes = [ 𝕀 ( 3 t_lo s_lo λ_lo ) ( 3 t_hi s_hi λ_hi )
| 𝕀 λ_lo' λ_hi' <- λ
, let λ_lo = max λ_lo' ( min ( λ_hi' - 10 ) -100 )
λ_hi = min λ_hi' ( max ( λ_lo' + 10 ) 100 ) ]
in boxes
eqnPiece :: Int -> 𝕀 ( 3 ) -> D1𝔸3 ( 𝕀 ( 3 ) )
eqnPiece i ( 𝕀 ( 3 t_lo s_lo λ_lo ) ( 3 t_hi s_hi λ_hi ) ) =
let t = 𝕀 ( 1 t_lo ) ( 1 t_hi )
s = 𝕀 ( 1 s_lo ) ( 1 s_hi )
λ = 𝕀 λ_lo λ_hi
StrokeDatum in
{ du = -- TODO: I shouldn't have to do this by hand.
D22 { _D22_v = u --
, _D22_dx = T u_t , _D22_dy = T u_s } -- c(t) = p(t) + rot(θ(t)) b(t)
, dv = --
D22 { _D22_v = v -- abbreviate; let R = rot(θ(t)), R'=rot'(θ(t)), ...
, _D22_dx = T v_t , _D22_dy = T v_s } --
, ee = -- c = p + R b
D22 { _D22_dx = T ee_t, _D22_dy = T ee_s -- c' = p' + R b' + θ' R' b
, _D22_dxdx = T ee_tt, _D22_dxdy = T ee_ts, _D22_dydy = T ee_ss } -- c'' = p'' + R b'' + 2 θ' R' b' + θ'² R'' b + θ'' R' b
} = ( boxStrokeData t `Seq.index` i ) s --
D11 ( unT $ p' ^+^ rot b' ^+^ ( θ' *^ rot' ( T b ) ) )
( p'' ^+^ rot b''
^+^ ( 2 * θ' ) *^ rot' b'
^+^ ( θ' Ring.^ 2 ) *^ rot'' ( T b )
^+^ θ'' *^ rot' ( T b )
)
-- λ ∂E/∂s - ∂E/∂t = 0 -- TODO: instead of c'(t) and c''(t), it might be simpler
𝕀 ( 1 f1_lo ) ( 1 f1_hi ) = unT $ λ *^ T ee_s ^-^ T ee_t -- to compute g(t) = rot(-θ(t)) c'(t) and g'(t)?
𝕀 ( 1 f1_t_lo ) ( 1 f1_t_hi ) = unT $ λ *^ T ee_ts ^-^ T ee_tt
𝕀 ( 1 f1_s_lo ) ( 1 f1_s_hi ) = unT $ λ *^ T ee_ss ^-^ T ee_ts
𝕀 ( 1 f1_λ_lo ) ( 1 f1_λ_hi ) = ee_s
-- λ v - u = 0
𝕀 ( 2 f2_lo f3_lo ) ( 2 f2_hi f3_hi ) = unT $ λ *^ T v ^-^ T u
𝕀 ( 2 f2_t_lo f3_t_lo ) ( 2 f2_t_hi f3_t_hi ) = unT $ λ *^ T v_t ^-^ T u_t
𝕀 ( 2 f2_s_lo f3_s_lo ) ( 2 f2_s_hi f3_s_hi ) = unT $ λ *^ T v_s ^-^ T u_s
𝕀 ( 2 f2_λ_lo f3_λ_lo ) ( 2 f2_λ_hi f3_λ_hi ) = v
in D13 ( 𝕀 ( 3 f1_lo f2_lo f3_lo ) ( 3 f1_hi f2_hi f3_hi ) )
( T $ 𝕀 ( 3 f1_t_lo f2_t_lo f3_t_lo ) ( 3 f1_t_hi f2_t_hi f3_t_hi ) )
( T $ 𝕀 ( 3 f1_s_lo f2_s_lo f3_s_lo ) ( 3 f1_s_hi f2_s_hi f3_s_hi ) )
( T $ 𝕀 ( 3 f1_λ_lo f2_λ_lo f3_λ_lo ) ( 3 f1_λ_hi f2_λ_hi f3_λ_hi ) )
intersectMany :: [𝕀] -> [𝕀] -> [𝕀]
intersectMany _ [] = []
intersectMany is (j : js) = intersectOne is j ++ intersectMany is js
intersectOne :: [ 𝕀 ] -> 𝕀 -> [ 𝕀 ]
intersectOne is i = concatMap ( intersect i ) is
intersect :: 𝕀 -> 𝕀 -> [ 𝕀 ]
intersect ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 )
| lo > hi
= [ ]
| otherwise
= [ 𝕀 lo hi ]
where
lo = max lo1 lo2
hi = min hi1 hi2
-}

View file

@ -1,22 +1,25 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Math.Bezier.Stroke.EnvelopeEquation module Math.Bezier.Stroke.EnvelopeEquation
( StrokeDatum(..) ( StrokeDatum(..), CornerStrokeDatum(..)
, HasBézier(..) , HasBézier(..)
, HasEnvelopeEquation(..) , HasEnvelopeEquation(..)
, cornerStrokeDatum
) where ) where
-- base -- base
import Prelude hiding ( Num(..), (^), pi, sin, cos ) import Prelude hiding ( Num(..), (^), pi, sin, cos )
import Data.Coerce
( coerce )
import Data.Kind import Data.Kind
( Type, Constraint ) ( Type, Constraint )
import Data.List.NonEmpty import Data.List.NonEmpty
( NonEmpty(..) ) ( NonEmpty(..) )
import Data.Proxy
( Proxy(..) )
import GHC.TypeNats import GHC.TypeNats
( Nat, type (-) ) ( Nat, type (-) )
@ -25,11 +28,13 @@ import Data.Act
( Torsor ((-->)) ) ( Torsor ((-->)) )
-- brush-strokes -- brush-strokes
import Calligraphy.Brushes
( Corner )
import Math.Algebra.Dual import Math.Algebra.Dual
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
import Math.Differentiable import Math.Differentiable
( type I ) ( I, IVness(..), SingIVness (..) )
import Math.Interval import Math.Interval
import Math.Linear import Math.Linear
import Math.Module import Math.Module
@ -41,7 +46,7 @@ import Math.Ring
-- | 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, s) \), together with the value of the envelope equation at that -- \( (t, s) \), together with the value of the envelope equation at that
-- point. -- point.
type StrokeDatum :: Nat -> k -> Type type StrokeDatum :: Nat -> IVness -> Type
data StrokeDatum k i data StrokeDatum k i
= StrokeDatum = StrokeDatum
{ -- | Path \( p(t) \). { -- | Path \( p(t) \).
@ -62,7 +67,11 @@ data StrokeDatum k i
-- | Envelope function -- | Envelope function
-- --
-- \[ E(t_0,s_0) = \left ( \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} \right )_{(t_0,s_0)}. \] -- \[ \begin{align} E(t,s) &= \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} \\
-- &= \left ( R(-\theta(t)) \frac{\partial c}{\partial t} \right ) \times \left ( R(-\theta(t)) \frac{\partial c}{\partial s} \right ) \\
-- &= \left ( R(-\theta(t)) p'(t) + \theta'(t) S b(t,s) + \frac{\partial b}{\partial t} \right ) \times \frac{\partial b}{\partial s} \]
--
-- where \( S \) denotes the 2D swap function \( S(x,y) = (y,x) \).
, ee :: D ( k - 1 ) 2 ( I i 1 ) , ee :: D ( k - 1 ) 2 ( I i 1 )
-- \[ \frac{\partial E}{\partial s} \frac{\mathrm{d} c}{\mathrm{d} t}, \] -- \[ \frac{\partial E}{\partial s} \frac{\mathrm{d} c}{\mathrm{d} t}, \]
@ -73,12 +82,43 @@ data StrokeDatum k i
, 𝛿E𝛿sdcdt :: D ( k - 2 ) 2 ( T ( I i 2 ) ) , 𝛿E𝛿sdcdt :: D ( k - 2 ) 2 ( T ( I i 2 ) )
} }
deriving stock instance Show ( StrokeDatum 2 ) deriving stock instance
deriving stock instance Show ( StrokeDatum 3 𝕀 ) ( Show ( I i 2 )
, Show ( D k 1 ( I i Double ) )
, Show ( D k 1 ( I i 2 ) )
, Show ( D k 2 ( I i 2 ) )
, Show ( D ( k - 1 ) 2 ( I i 1 ) )
, Show ( D ( k - 1 ) 2 ( I i 2 ) )
, Show ( D ( k - 2 ) 2 ( T ( I i 2 ) ) )
)
=> Show ( StrokeDatum k i )
-- | A slimmed down version of 'StrokeDatum' for use at brush corners.
type CornerStrokeDatum :: Nat -> IVness -> Type
data CornerStrokeDatum k i
= CornerStrokeDatum
{ -- | Path \( p(t) \).
dpath :: D k 1 ( I i 2 )
-- | Brush shape \( b(t) \).
, dbrush :: D k 1 ( I i 2 )
-- | (Optional) rotation angle \( \theta(t) \).
, mbRotation :: Maybe ( D k 1 ( I i Double ) )
, corner :: Corner ( I i 2 )
, stroke :: I i 2
}
deriving stock instance
( Show ( I i Double )
, Show ( I i 2 )
, Show ( D k 1 ( I i Double ) )
, Show ( D k 1 ( I i 2 ) )
)
=> Show ( CornerStrokeDatum k i )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type HasBézier :: forall {t}. Nat -> t -> Constraint type HasBézier :: Nat -> IVness -> Constraint
class HasBézier k i where class HasBézier k i where
-- | Linear interpolation, as a differentiable function. -- | Linear interpolation, as a differentiable function.
@ -112,8 +152,7 @@ class HasBézier k i where
type HasEnvelopeEquation :: Nat -> Constraint type HasEnvelopeEquation :: Nat -> Constraint
class HasEnvelopeEquation k where class HasEnvelopeEquation k where
uncurryD :: Dim a ~ 1 uncurryD :: D k 1 ( D k 1 b ) -> D k 2 b
=> D k 1 ( C k a b ) -> a -> D k 2 b
-- | The envelope function -- | The envelope function
-- --
@ -135,14 +174,13 @@ class HasEnvelopeEquation k where
, Show ( StrokeDatum k i ) , Show ( StrokeDatum k i )
) )
=> Proxy i => SingIVness i
-> ( I i Double -> I i 1 )
-> D k 1 ( I i 2 ) -> D k 1 ( I i 2 )
-> D k 2 ( I i 2 ) -> D k 2 ( I i 2 )
-> Maybe ( D k 1 ( I i Double ) ) -> Maybe ( D k 1 ( I i Double ) )
-> StrokeDatum k i -> StrokeDatum k i
instance HasBézier 2 where instance HasBézier 2 NonIV where
line co ( Segment a b :: Segment b ) = line co ( Segment a b :: Segment b ) =
D \ ( co -> t ) -> D \ ( co -> t ) ->
D21 ( lerp @( T b ) t a b ) D21 ( lerp @( T b ) t a b )
@ -169,7 +207,7 @@ instance HasEnvelopeEquation 2 where
uncurryD = uncurryD2 uncurryD = uncurryD2
{-# INLINEABLE uncurryD #-} {-# INLINEABLE uncurryD #-}
envelopeEquation ( _ :: Proxy i ) co envelopeEquation ( ivness :: SingIVness i )
dp@( D21 ( T -> p ) p_t p_tt ) dp@( D21 ( T -> p ) p_t p_tt )
db@( D22 ( T -> b ) b_t b_s db@( D22 ( T -> b ) b_t b_s
b_tt b_ts b_ss ) b_tt b_ts b_ss )
@ -182,6 +220,10 @@ instance HasEnvelopeEquation 2 where
, du, dv, ee, 𝛿E𝛿sdcdt , du, dv, ee, 𝛿E𝛿sdcdt
} }
where where
co :: I i Double -> I i 1
co = case ivness of
SNonIV -> coerce
SIsIV -> coerce
(ee, 𝛿E𝛿sdcdt) = (ee, 𝛿E𝛿sdcdt) =
let let
D12 (T -> u) u_t u_s = du D12 (T -> u) u_t u_s = du
@ -250,7 +292,46 @@ instance HasEnvelopeEquation 2 where
) )
{-# INLINEABLE envelopeEquation #-} {-# INLINEABLE envelopeEquation #-}
instance HasBézier 3 where -- | Computes \( u \) and \( u_t \), where \( u \) is as in 'StrokeDatum'.
cornerStrokeDatum
:: CornerStrokeDatum 2 NonIV
-> D 1 1 ( 2 )
cornerStrokeDatum
CornerStrokeDatum
{ dpath = D21 _ p_t p_tt
, dbrush = D21 ( T -> b ) b_t b_tt
, mbRotation } =
case mbRotation of
Nothing -> D11 ( unT $ p_t ^+^ b_t ) ( p_tt ^+^ b_tt )
Just ( D21 θ ( T θ_t ) ( T θ_tt ) ) ->
let
rot, rot' :: T ( 2 ) -> T ( 2 )
cosθ = cos θ
sinθ = sin θ
rot = rotate cosθ -sinθ
rot' = rotate sinθ cosθ
swap :: T ( 2 ) -> T ( 2 )
swap ( T xy ) =
let x = xy `index` Fin 1
y = xy `index` Fin 2
in T $ tabulate \ case
Fin 1 -> -y
_ -> x
u, u_t :: T ( 2 )
u = rot p_t ^+^ θ_t *^ swap b ^+^ b_t
u_t = ( -θ_t *^ rot' p_t
^+^ rot p_tt
)
^+^
( θ_tt *^ swap b
^+^ θ_t *^ swap b_t
)
^+^ b_tt
in D11 ( unT u ) u_t
instance HasBézier 3 NonIV where
line co ( Segment a b :: Segment b ) = line co ( Segment a b :: Segment b ) =
D \ ( co -> t ) -> D \ ( co -> t ) ->
@ -281,7 +362,7 @@ instance HasEnvelopeEquation 3 where
uncurryD = uncurryD3 uncurryD = uncurryD3
{-# INLINEABLE uncurryD #-} {-# INLINEABLE uncurryD #-}
envelopeEquation ( _ :: Proxy i ) co envelopeEquation ( ivness :: SingIVness i )
dp@( D31 ( T -> p ) p_t p_tt p_ttt ) dp@( D31 ( T -> p ) p_t p_tt p_ttt )
db@( D32 ( T -> b ) b_t b_s db@( D32 ( T -> b ) b_t b_s
b_tt b_ts b_ss b_tt b_ts b_ss
@ -295,6 +376,10 @@ instance HasEnvelopeEquation 3 where
, du, dv, ee, 𝛿E𝛿sdcdt , du, dv, ee, 𝛿E𝛿sdcdt
} }
where where
co :: I i Double -> I i 1
co = case ivness of
SNonIV -> coerce
SIsIV -> coerce
(ee, 𝛿E𝛿sdcdt) = (ee, 𝛿E𝛿sdcdt) =
let let
D22 (T -> u) u_t u_s u_tt u_ts u_ss = du D22 (T -> u) u_t u_s u_tt u_ts u_ss = du
@ -400,7 +485,7 @@ instance HasEnvelopeEquation 3 where
) )
{-# INLINEABLE envelopeEquation #-} {-# INLINEABLE envelopeEquation #-}
instance HasBézier 3 𝕀 where instance HasBézier 3 IsIV where
line co ( Segment a b :: Segment b ) = line co ( Segment a b :: Segment b ) =
D \ ( co -> t ) -> D \ ( co -> t ) ->

View file

@ -2,7 +2,9 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Math.Differentiable module Math.Differentiable
( I, Differentiable, DiffInterp ) ( IVness(..), SingIVness(..)
, I, Differentiable, DiffInterp
)
where where
-- base -- base
@ -23,17 +25,24 @@ import Math.Ring
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data IVness
= NonIV
| IsIV
type SingIVness :: IVness -> Type
data SingIVness iv where
SNonIV :: SingIVness NonIV
SIsIV :: SingIVness IsIV
-- | Type family to parametrise over both pointwise and interval computations. -- | Type family to parametrise over both pointwise and interval computations.
-- type I :: forall l. IVness -> l -> Type
-- Use '' parameter for points, and '𝕀' parameter for intervals.
type I :: k -> l -> Type
type family I i t type family I i t
type instance I @(Nat -> Type) @Type Double = Double type instance I @Type NonIV Double = Double
type instance I @Type @Type 𝕀 Double = 𝕀 type instance I @Type IsIV Double = 𝕀
type instance I @(Nat -> Type) @Nat n = n type instance I @Nat NonIV n = n
type instance I @Type @Nat 𝕀 n = 𝕀 n type instance I @Nat IsIV n = 𝕀 n
type Differentiable :: Nat -> k -> Nat -> Constraint type Differentiable :: Nat -> IVness -> Nat -> Constraint
class class
( Module ( I i Double ) ( T ( I i u ) ) ( Module ( I i Double ) ( T ( I i u ) )
, HasChainRule ( I i Double ) k ( I i u ) , HasChainRule ( I i Double ) k ( I i u )
@ -47,7 +56,7 @@ instance
, Representable ( I i Double ) ( I i u ) , Representable ( I i Double ) ( I i u )
) => Differentiable k i u ) => Differentiable k i u
type DiffInterp :: Nat -> k -> Nat -> Constraint type DiffInterp :: Nat -> IVness -> Nat -> Constraint
class class
( Differentiable k i u ( Differentiable k i u
, Interpolatable ( I i Double ) ( I i u ) , Interpolatable ( I i Double ) ( I i u )

View file

@ -242,26 +242,15 @@ deriving via ( ViaModule 𝕀 ( 𝕀 n ) )
-- HasChainRule instances. -- HasChainRule instances.
instance HasChainRule 𝕀 2 ( 𝕀 0 ) where instance HasChainRule 𝕀 2 ( 𝕀 0 ) where
konst w = D0 w
linearD f v = D0 ( f v ) linearD f v = D0 ( f v )
value ( D0 v ) = v
chain _ ( D0 gfx ) = D21 gfx origin origin chain _ ( D0 gfx ) = D21 gfx origin origin
instance HasChainRule 𝕀 3 ( 𝕀 0 ) where instance HasChainRule 𝕀 3 ( 𝕀 0 ) where
konst w = D0 w
linearD f v = D0 ( f v ) linearD f v = D0 ( f v )
value ( D0 v ) = v
chain _ ( D0 gfx ) = D31 gfx origin origin origin chain _ ( D0 gfx ) = D31 gfx origin origin origin
instance HasChainRule 𝕀 2 ( 𝕀 1 ) where instance HasChainRule 𝕀 2 ( 𝕀 1 ) where
konst :: forall w. AbelianGroup w => w -> D2𝔸1 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 1 -> w ) -> 𝕀 1 -> D2𝔸1 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 1 -> w ) -> 𝕀 1 -> D2𝔸1 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )
@ -290,13 +279,6 @@ instance HasChainRule 𝕀 2 ( 𝕀 1 ) where
instance HasChainRule 𝕀 3 ( 𝕀 1 ) where instance HasChainRule 𝕀 3 ( 𝕀 1 ) where
konst :: forall w. AbelianGroup w => w -> D3𝔸1 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 1 -> w ) -> 𝕀 1 -> D3𝔸1 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 1 -> w ) -> 𝕀 1 -> D3𝔸1 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )
@ -325,13 +307,6 @@ instance HasChainRule 𝕀 3 ( 𝕀 1 ) where
instance HasChainRule 𝕀 2 ( 𝕀 2 ) where instance HasChainRule 𝕀 2 ( 𝕀 2 ) where
konst :: forall w. AbelianGroup w => w -> D2𝔸2 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 2 -> w ) -> 𝕀 2 -> D2𝔸2 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 2 -> w ) -> 𝕀 2 -> D2𝔸2 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )
@ -360,13 +335,6 @@ instance HasChainRule 𝕀 2 ( 𝕀 2 ) where
instance HasChainRule 𝕀 3 ( 𝕀 2 ) where instance HasChainRule 𝕀 3 ( 𝕀 2 ) where
konst :: forall w. AbelianGroup w => w -> D3𝔸2 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 2 -> w ) -> 𝕀 2 -> D3𝔸2 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 2 -> w ) -> 𝕀 2 -> D3𝔸2 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )
@ -395,13 +363,6 @@ instance HasChainRule 𝕀 3 ( 𝕀 2 ) where
instance HasChainRule 𝕀 2 ( 𝕀 3 ) where instance HasChainRule 𝕀 2 ( 𝕀 3 ) where
konst :: forall w. AbelianGroup w => w -> D2𝔸3 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 3 -> w ) -> 𝕀 3 -> D2𝔸3 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 3 -> w ) -> 𝕀 3 -> D2𝔸3 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )
@ -430,13 +391,6 @@ instance HasChainRule 𝕀 2 ( 𝕀 3 ) where
instance HasChainRule 𝕀 3 ( 𝕀 3 ) where instance HasChainRule 𝕀 3 ( 𝕀 3 ) where
konst :: forall w. AbelianGroup w => w -> D3𝔸3 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 3 -> w ) -> 𝕀 3 -> D3𝔸3 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 3 -> w ) -> 𝕀 3 -> D3𝔸3 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )
@ -465,13 +419,6 @@ instance HasChainRule 𝕀 3 ( 𝕀 3 ) where
instance HasChainRule 𝕀 2 ( 𝕀 4 ) where instance HasChainRule 𝕀 2 ( 𝕀 4 ) where
konst :: forall w. AbelianGroup w => w -> D2𝔸4 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 4 -> w ) -> 𝕀 4 -> D2𝔸4 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 4 -> w ) -> 𝕀 4 -> D2𝔸4 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )
@ -500,13 +447,6 @@ instance HasChainRule 𝕀 2 ( 𝕀 4 ) where
instance HasChainRule 𝕀 3 ( 𝕀 4 ) where instance HasChainRule 𝕀 3 ( 𝕀 4 ) where
konst :: forall w. AbelianGroup w => w -> D3𝔸4 w
konst w =
let !o = fromInteger @w 0
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
value df = $$( monIndexQ [|| df ||] zeroMonomial )
linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 4 -> w ) -> 𝕀 4 -> D3𝔸4 w linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀 4 -> w ) -> 𝕀 4 -> D3𝔸4 w
linearD f v = linearD f v =
let !o = origin @𝕀 @( T w ) let !o = origin @𝕀 @( T w )

View file

@ -232,7 +232,10 @@ runApplication application = do
NewtonRaphson NewtonRaphson
{ maxIters = 20, precision = 8 } { maxIters = 20, precision = 8 }
cuspFindingOptionsTVar <- STM.newTVarIO $ cuspFindingOptionsTVar <- STM.newTVarIO $
Just defaultRootIsolationOptions Just
( defaultRootIsolationOptions @1 @2
, defaultRootIsolationOptions @2 @3
)
-- Put all these stateful variables in a record for conciseness. -- Put all these stateful variables in a record for conciseness.
let let

View file

@ -115,19 +115,19 @@ data Variables
, selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) ) , selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( 2 ) ) ) , mousePosTVar :: !( STM.TVar ( Maybe ( 2 ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) )
, toolTVar :: !( STM.TVar Tool ) , toolTVar :: !( STM.TVar Tool )
, modeTVar :: !( STM.TVar Mode ) , modeTVar :: !( STM.TVar Mode )
, debugTVar :: !( STM.TVar Bool ) , debugTVar :: !( STM.TVar Bool )
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
, fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) ) , fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) )
, showGuidesTVar :: !( STM.TVar Bool ) , showGuidesTVar :: !( STM.TVar Bool )
, maxHistorySizeTVar :: !( STM.TVar Int ) , maxHistorySizeTVar :: !( STM.TVar Int )
, fitParametersTVar :: !( STM.TVar FitParameters ) , fitParametersTVar :: !( STM.TVar FitParameters )
, rootsAlgoTVar :: !( STM.TVar RootSolvingAlgorithm ) , rootsAlgoTVar :: !( STM.TVar RootSolvingAlgorithm )
, cuspFindingOptionsTVar :: !( STM.TVar ( Maybe ( RootIsolationOptions 2 3 ) ) ) , cuspFindingOptionsTVar :: !( STM.TVar ( Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) ) )
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -148,7 +148,9 @@ blankRender _ = pure ()
getDocumentRender getDocumentRender
:: Colours :: Colours
-> RootSolvingAlgorithm -> Maybe ( RootIsolationOptions 2 3 ) -> FitParameters -> RootSolvingAlgorithm
-> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 )
-> FitParameters
-> Mode -> Bool -> Mode -> Bool
-> Set Modifier -> Maybe ( 2 ) -> Maybe HoldAction -> Maybe PartialPath -> Set Modifier -> Maybe ( 2 ) -> Maybe HoldAction -> Maybe PartialPath
-> Document -> Document
@ -300,7 +302,7 @@ instance NFData StrokeRenderData where
-- - Otherwise, this consists of the underlying spline path only. -- - Otherwise, this consists of the underlying spline path only.
strokeRenderData strokeRenderData
:: RootSolvingAlgorithm :: RootSolvingAlgorithm
-> Maybe ( RootIsolationOptions 2 3 ) -> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 )
-> FitParameters -> FitParameters
-> Stroke -> Stroke
-> ST RealWorld StrokeRenderData -> ST RealWorld StrokeRenderData
@ -325,6 +327,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
-> do -> do
let embedUsedParams = inject2 $ MkR brush_defaults let embedUsedParams = inject2 $ MkR brush_defaults
-- Compute the outline using the brush function. -- Compute the outline using the brush function.
( outline, fitPts, cusps ) <- ( outline, fitPts, cusps ) <-
computeStrokeOutline @clo rootAlgo mbCuspOptions fitParams computeStrokeOutline @clo rootAlgo mbCuspOptions fitParams
@ -337,7 +340,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
, strokeBrushFunction = , strokeBrushFunction =
\ params -> \ params ->
let MkR brushParams = embedUsedParams $ toUsedParams params let MkR brushParams = embedUsedParams $ toUsedParams params
shape = fun @Double brushBaseShape brushParams shape = fun brushBaseShape brushParams
-- TODO: remove this logic which is duplicated -- TODO: remove this logic which is duplicated
-- from elsewhere. The type should make it -- from elsewhere. The type should make it
-- impossible to forget to apply the rotation. -- impossible to forget to apply the rotation.
@ -703,6 +706,17 @@ drawFitPoint _ ( Zoom { zoomFactor } ) ( FitPoint { fitPoint = 2 x y } ) = do
Cairo.fill Cairo.fill
Cairo.restore Cairo.restore
drawFitPoint _ ( Zoom { zoomFactor } ) ( JoinPoint { joinPoint = 2 x y } ) = lift do
-- Draw a little white circle.
Cairo.save
Cairo.translate x y
Cairo.arc 0 0 ( 3 / zoomFactor ) 0 ( 2 * pi )
Cairo.setSourceRGBA 255 255 255 0.9
Cairo.setLineWidth ( 1 / zoomFactor )
Cairo.stroke
Cairo.restore
drawFitPoint _ ( Zoom { zoomFactor } ) ( FitTangent { fitPoint = 2 x y, fitTangent = V2 tx ty } ) = do drawFitPoint _ ( Zoom { zoomFactor } ) ( FitTangent { fitPoint = 2 x y, fitTangent = V2 tx ty } ) = do
hue <- get hue <- get

View file

@ -44,10 +44,12 @@ import qualified Data.Text as Text
-- brush-strokes -- brush-strokes
import Calligraphy.Brushes import Calligraphy.Brushes
( Brush(..) ) ( Brush(..) )
import Math.Algebra.Dual
( HasChainRule )
import Math.Differentiable import Math.Differentiable
( DiffInterp ) ( DiffInterp, IVness(..) )
import Math.Interval import Math.Interval
( 𝕀 ) ( 𝕀, 𝕀 )
import Math.Linear import Math.Linear
-- MetaBrush -- MetaBrush
@ -78,13 +80,19 @@ type BrushFunction brushFields =
type NamedBrush :: [ Symbol ] -> Type type NamedBrush :: [ Symbol ] -> Type
data NamedBrush brushFields where data NamedBrush brushFields where
NamedBrush NamedBrush
:: forall brushFields :: forall brushFields nbBrushFields
. ( KnownSymbols brushFields . ( nbBrushFields ~ Length brushFields
, Representable Double ( ( Length brushFields ) ) , KnownSymbols brushFields
, DiffInterp 2 ( Length brushFields ) , Representable Double ( nbBrushFields )
, DiffInterp 3 𝕀 ( Length brushFields ) , DiffInterp 2 NonIV nbBrushFields
, Show ( ( Length brushFields ) ) , DiffInterp 3 IsIV nbBrushFields
, NFData ( ( Length brushFields ) )
-- TODO: clean up this constraint?
, HasChainRule 𝕀 2 ( 𝕀 nbBrushFields )
, Show ( nbBrushFields )
, NFData ( nbBrushFields )
) )
=> { brushName :: !Text => { brushName :: !Text
, brushFunction :: !( BrushFunction brushFields ) , brushFunction :: !( BrushFunction brushFields )
@ -122,8 +130,8 @@ class ( KnownSymbols pointFields, Typeable pointFields
, NFData ( Record pointFields ) , NFData ( Record pointFields )
, Representable Double ( ( Length pointFields ) ) , Representable Double ( ( Length pointFields ) )
, RepDim ( ( Length pointFields ) ) ~ Length pointFields , RepDim ( ( Length pointFields ) ) ~ Length pointFields
, DiffInterp 2 ( Length pointFields ) , DiffInterp 2 NonIV ( Length pointFields )
, DiffInterp 3 𝕀 ( Length pointFields ) , DiffInterp 3 IsIV ( Length pointFields )
) )
=> PointFields pointFields where { } => PointFields pointFields where { }
instance ( KnownSymbols pointFields, Typeable pointFields instance ( KnownSymbols pointFields, Typeable pointFields
@ -133,8 +141,8 @@ instance ( KnownSymbols pointFields, Typeable pointFields
, NFData ( Record pointFields ) , NFData ( Record pointFields )
, Representable Double ( ( Length pointFields ) ) , Representable Double ( ( Length pointFields ) )
, RepDim ( ( Length pointFields ) ) ~ Length pointFields , RepDim ( ( Length pointFields ) ) ~ Length pointFields
, DiffInterp 2 ( Length pointFields ) , DiffInterp 2 NonIV ( Length pointFields )
, DiffInterp 3 𝕀 ( Length pointFields ) , DiffInterp 3 IsIV ( Length pointFields )
) )
=> PointFields pointFields where { } => PointFields pointFields where { }

View file

@ -55,7 +55,6 @@ import qualified Data.Text as Text
-- MetaBrush -- MetaBrush
import Math.Differentiable import Math.Differentiable
import Math.Interval
import Math.Linear import Math.Linear
import Math.Module import Math.Module
( Module ) ( Module )
@ -146,8 +145,9 @@ intersect :: forall r1 r2 l1 l2
, Representable Double ( l2 ) , Representable Double ( l2 )
, Show ( l1 ) , Show ( l1 )
, Show ( l2 ) , Show ( l2 )
, Differentiable 2 l2 , Differentiable 2 NonIV l2
, Differentiable 3 𝕀 l2 , Differentiable 2 IsIV l2
, Differentiable 3 IsIV l2
) )
=> Intersection r1 r2 => Intersection r1 r2
intersect intersect
@ -178,8 +178,9 @@ data Intersection r1 r2 where
, KnownSymbols r1r2 , KnownSymbols r1r2
, Representable Double ( l12 ) , Representable Double ( l12 )
, Show ( l12 ) , Show ( l12 )
, Differentiable 2 l12 , Differentiable 2 NonIV l12
, Differentiable 3 𝕀 l12 , Differentiable 2 IsIV l12
, Differentiable 3 IsIV l12
) )
=> { project1 :: Record r1 -> Record r1r2 => { project1 :: Record r1 -> Record r1r2
-- ^ project out fields present in both rows -- ^ project out fields present in both rows
@ -204,8 +205,9 @@ doIntersection
=> ( forall r1r2 l12. => ( forall r1r2 l12.
( r1r2 ~ Intersect r1 r2 ( r1r2 ~ Intersect r1 r2
, KnownSymbols r1r2, l12 ~ Length r1r2 , KnownSymbols r1r2, l12 ~ Length r1r2
, Differentiable 2 l12 , Differentiable 2 NonIV l12
, Differentiable 3 𝕀 l12 , Differentiable 2 IsIV l12
, Differentiable 3 IsIV l12
, Representable Double ( l12 ) , Representable Double ( l12 )
, Show ( l12 ) , Show ( l12 )
) )
@ -304,17 +306,17 @@ type family Elem k ks where
data Union r1 r2 where data Union r1 r2 where
Union Union
:: forall r1r2_rocky r1 r2 l12_rocky :: forall r1r2 r1 r2 l12
. ( l12_rocky ~ Length r1r2_rocky . ( l12 ~ Length r1r2
, KnownSymbols r1r2_rocky , KnownSymbols r1r2
, Representable Double ( l12_rocky ) , Representable Double ( l12 )
, Show ( l12_rocky ) , Show ( l12 )
, NFData ( l12_rocky ) , NFData ( l12 )
, DiffInterp 2 l12_rocky , DiffInterp 2 NonIV l12
, DiffInterp 3 𝕀 l12_rocky , DiffInterp 3 IsIV l12
) )
=> { unionWith :: ( Double -> Double -> Double ) => { unionWith :: ( Double -> Double -> Double )
-> Record r1 -> Record r2 -> Record r1r2_rocky -> Record r1 -> Record r2 -> Record r1r2
-- ^ union of two records -- ^ union of two records
} -> Union r1 r2 } -> Union r1 r2
@ -327,8 +329,8 @@ union :: forall r1 r2 l1 l2
, Show ( l1 ) , Show ( l1 )
, Show ( l2 ) , Show ( l2 )
, NFData ( l2 ) , NFData ( l2 )
, DiffInterp 2 l2 , DiffInterp 2 NonIV l2
, DiffInterp 3 𝕀 l2 , DiffInterp 3 IsIV l2
) )
=> Union r1 r2 => Union r1 r2
union union
@ -380,8 +382,8 @@ doUnion
) )
=> ( forall r1r2 l12. => ( forall r1r2 l12.
( KnownSymbols r1r2, l12 ~ Length r1r2 ( KnownSymbols r1r2, l12 ~ Length r1r2
, DiffInterp 2 l12 , DiffInterp 2 NonIV l12
, DiffInterp 3 𝕀 l12 , DiffInterp 3 IsIV l12
, Representable Double ( l12 ) , Representable Double ( l12 )
, Show ( l12 ) , Show ( l12 )
, NFData ( l12 ) , NFData ( l12 )