mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
Further modularisation of root isolation code
The code is now generic over the dimension. There is a slight performance loss that I need to investigate; perhaps some things are not getting specialised? Maybe it is better to be more explicit about staging and splice in the functions with fixed dimensions.
This commit is contained in:
sheaf
parent
131753da82
commit
0160081e80
|
|
@ -199,8 +199,8 @@ data TestCase =
|
||||||
TestCase
|
TestCase
|
||||||
{ testName :: String
|
{ testName :: String
|
||||||
, testBrushStroke :: BrushStroke
|
, testBrushStroke :: BrushStroke
|
||||||
, testCuspOptions :: RootIsolationOptions
|
, testCuspOptions :: RootIsolationOptions 2 3
|
||||||
, testStartBoxes :: [ ( Int, Box ) ]
|
, testStartBoxes :: [ ( Int, Box 2 ) ]
|
||||||
}
|
}
|
||||||
|
|
||||||
brushStrokeFunctions
|
brushStrokeFunctions
|
||||||
|
|
@ -224,7 +224,7 @@ mkVal t i s = ( ℝ1 t, i, ℝ1 s )
|
||||||
mkI :: ( Double, Double ) -> 𝕀 Double
|
mkI :: ( Double, Double ) -> 𝕀 Double
|
||||||
mkI ( lo, hi ) = 𝕀 lo hi
|
mkI ( lo, hi ) = 𝕀 lo hi
|
||||||
|
|
||||||
mkBox :: ( Double, Double ) -> ( Double, Double ) -> Box
|
mkBox :: ( Double, Double ) -> ( Double, Double ) -> Box 2
|
||||||
mkBox ( t_min, t_max ) ( s_min, s_max ) =
|
mkBox ( t_min, t_max ) ( s_min, s_max ) =
|
||||||
( 𝕀 ( ℝ2 t_min s_min ) ( ℝ2 t_max s_max ) )
|
( 𝕀 ( ℝ2 t_min s_min ) ( ℝ2 t_max s_max ) )
|
||||||
|
|
||||||
|
|
@ -488,7 +488,7 @@ showD float = showFFloat (Just 6) float ""
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
ellipseTestCase :: RootIsolationOptions -> String -> ( Double, Double ) -> Double -> [ ( Int, Box ) ] -> TestCase
|
ellipseTestCase :: RootIsolationOptions 2 3 -> String -> ( Double, Double ) -> Double -> [ ( Int, Box 2 ) ] -> TestCase
|
||||||
ellipseTestCase opts str k0k1 rot startBoxes =
|
ellipseTestCase opts str k0k1 rot startBoxes =
|
||||||
TestCase
|
TestCase
|
||||||
{ testName = "ellipse (" ++ str ++ ")"
|
{ testName = "ellipse (" ++ str ++ ")"
|
||||||
|
|
@ -607,9 +607,11 @@ getStrokeFunctions brush sp0 crv =
|
||||||
brush @3 @𝕀 proxy# singleton )
|
brush @3 @𝕀 proxy# singleton )
|
||||||
{-# INLINEABLE getStrokeFunctions #-}
|
{-# INLINEABLE getStrokeFunctions #-}
|
||||||
|
|
||||||
defaultStartBoxes :: [ Int ] -> [ ( Int, Box ) ]
|
defaultStartBoxes :: [ Int ] -> [ ( Int, Box 2 ) ]
|
||||||
defaultStartBoxes is =
|
defaultStartBoxes is =
|
||||||
[ ( i, mkBox (zero, one) (zero, one) ) | i <- is ]
|
[ ( i, 𝕀 ( ℝ2 zero zero ) ( ℝ2 one one ) )
|
||||||
|
| i <- is
|
||||||
|
]
|
||||||
|
|
||||||
getR1 (ℝ1 u) = u
|
getR1 (ℝ1 u) = u
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1061,14 +1061,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -1100,14 +1100,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -1139,14 +1139,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -1178,14 +1178,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -1217,14 +1217,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -1256,14 +1256,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -1295,14 +1295,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -1334,14 +1334,14 @@ instance HasChainRule Double 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
|
||||||
|
|
@ -38,7 +38,8 @@ import Math.Linear
|
||||||
, zipIndices
|
, zipIndices
|
||||||
)
|
)
|
||||||
import Math.Monomial
|
import Math.Monomial
|
||||||
( Mon(..), MonomialBasis(..), Vars, Deg
|
( Mon(..), MonomialBasisQ(..), MonomialBasis(..)
|
||||||
|
, Vars, Deg
|
||||||
, mons, zeroMonomial, isZeroMonomial, totalDegree
|
, mons, zeroMonomial, isZeroMonomial, totalDegree
|
||||||
, multiSubsetSumFaà, multiSubsetsSum
|
, multiSubsetSumFaà, multiSubsetsSum
|
||||||
, partitionFaà, partitions
|
, partitionFaà, partitions
|
||||||
|
|
@ -203,8 +204,8 @@ data D3𝔸4 v =
|
||||||
-- (To be spliced in using Template Haskell.)
|
-- (To be spliced in using Template Haskell.)
|
||||||
chainRule1NQ :: forall dr1 dv v r w d
|
chainRule1NQ :: forall dr1 dv v r w d
|
||||||
. ( Ring r, RepresentableQ r v
|
. ( Ring r, RepresentableQ r v
|
||||||
, MonomialBasis dr1, Vars dr1 ~ 1
|
, MonomialBasisQ dr1, Vars dr1 ~ 1
|
||||||
, MonomialBasis dv , Vars dv ~ RepDim v
|
, MonomialBasisQ dv , Vars dv ~ RepDim v
|
||||||
, Deg dr1 ~ Deg dv
|
, Deg dr1 ~ Deg dv
|
||||||
, d ~ Vars dv, KnownNat d
|
, d ~ Vars dv, KnownNat d
|
||||||
)
|
)
|
||||||
|
|
@ -215,19 +216,19 @@ chainRule1NQ :: forall dr1 dv v r w d
|
||||||
-> CodeQ ( dv w )
|
-> CodeQ ( dv w )
|
||||||
-> CodeQ ( dr1 w )
|
-> CodeQ ( dr1 w )
|
||||||
chainRule1NQ zero_w sum_w scale_w df dg =
|
chainRule1NQ zero_w sum_w scale_w df dg =
|
||||||
monTabulate @dr1 \ ( Mon ( k `VS` _ ) ) ->
|
monTabulateQ @dr1 \ mon ->
|
||||||
case k of
|
case totalDegree mon of
|
||||||
-- Set the value of the composition separately,
|
-- Set the value of the composition separately,
|
||||||
-- as that isn't handled by the Faà di Bruno formula.
|
-- as that isn't handled by the Faà di Bruno formula.
|
||||||
0 -> monIndex @dv dg zeroMonomial
|
0 -> monIndexQ @dv dg zeroMonomial
|
||||||
_ ->
|
k ->
|
||||||
[|| unT $ $$( foldQ sum_w zero_w
|
[|| unT $ $$( foldQ sum_w zero_w
|
||||||
[ [|| $$scale_w ( T $$( monIndex @dv dg m_g ) )
|
[ [|| $$scale_w ( T $$( monIndexQ @dv dg m_g ) )
|
||||||
$$( foldQ [|| (Ring.+) ||] [|| Ring.fromInteger ( 0 :: Integer ) ||]
|
$$( foldQ [|| (Ring.+) ||] [|| Ring.fromInteger ( 0 :: Integer ) ||]
|
||||||
[ [|| Ring.fromInteger $$( liftTyped $ fromIntegral $ multiSubsetSumFaà k is ) Ring.*
|
[ [|| Ring.fromInteger $$( liftTyped $ fromIntegral $ multiSubsetSumFaà k is ) Ring.*
|
||||||
$$( foldQ [|| (Ring.*) ||] [|| Ring.fromInteger ( 1 :: Integer ) ||]
|
$$( foldQ [|| (Ring.*) ||] [|| Ring.fromInteger ( 1 :: Integer ) ||]
|
||||||
[ foldQ [|| (Ring.*) ||] [|| Ring.fromInteger ( 1 :: Integer ) ||]
|
[ foldQ [|| (Ring.*) ||] [|| Ring.fromInteger ( 1 :: Integer ) ||]
|
||||||
[ ( indexQ @r @v ( monIndex @dr1 df ( Mon $ f_deg `VS` VZ ) ) v_index )
|
[ ( indexQ @r @v ( monIndexQ @dr1 df ( Mon $ Vec [ f_deg ] ) ) v_index )
|
||||||
`powQ` pow
|
`powQ` pow
|
||||||
| ( f_deg, pow ) <- pows
|
| ( f_deg, pow ) <- pows
|
||||||
]
|
]
|
||||||
|
|
@ -248,8 +249,8 @@ chainRule1NQ zero_w sum_w scale_w df dg =
|
||||||
--
|
--
|
||||||
-- (To be spliced in using Template Haskell.)
|
-- (To be spliced in using Template Haskell.)
|
||||||
chainRuleN1Q :: forall du dr1 r
|
chainRuleN1Q :: forall du dr1 r
|
||||||
. ( MonomialBasis du
|
. ( MonomialBasisQ du
|
||||||
, MonomialBasis dr1, Vars dr1 ~ 1
|
, MonomialBasisQ dr1, Vars dr1 ~ 1
|
||||||
)
|
)
|
||||||
=> CodeQ ( Integer -> r ) -- ^ fromInteger (circumvent TH constraint issue)
|
=> CodeQ ( Integer -> r ) -- ^ fromInteger (circumvent TH constraint issue)
|
||||||
-> CodeQ ( r -> r -> r ) -- ^ (+) (circumvent TH constraint issue)
|
-> CodeQ ( r -> r -> r ) -- ^ (+) (circumvent TH constraint issue)
|
||||||
|
|
@ -259,19 +260,19 @@ chainRuleN1Q :: forall du dr1 r
|
||||||
-> CodeQ ( dr1 r )
|
-> CodeQ ( dr1 r )
|
||||||
-> CodeQ ( du r )
|
-> CodeQ ( du r )
|
||||||
chainRuleN1Q fromInt add times pow df dg =
|
chainRuleN1Q fromInt add times pow df dg =
|
||||||
monTabulate @du \ mon ->
|
monTabulateQ @du \ mon ->
|
||||||
if
|
if
|
||||||
| isZeroMonomial mon
|
| isZeroMonomial mon
|
||||||
-- Set the value of the composition separately,
|
-- Set the value of the composition separately,
|
||||||
-- as that isn't handled by the Faà di Bruno formula.
|
-- as that isn't handled by the Faà di Bruno formula.
|
||||||
-> monIndex @dr1 dg zeroMonomial
|
-> monIndexQ @dr1 dg zeroMonomial
|
||||||
| otherwise
|
| otherwise
|
||||||
-> foldQ add [|| $$fromInt ( 0 :: Integer ) ||]
|
-> foldQ add [|| $$fromInt ( 0 :: Integer ) ||]
|
||||||
[ [|| $$times $$( monIndex @dr1 dg ( Mon ( k `VS` VZ ) ) )
|
[ [|| $$times $$( monIndexQ @dr1 dg ( Mon ( Vec [ k ] ) ) )
|
||||||
$$( foldQ add [|| $$fromInt ( 0 :: Integer ) ||]
|
$$( foldQ add [|| $$fromInt ( 0 :: Integer ) ||]
|
||||||
[ [|| $$times ( $$fromInt $$( liftTyped $ fromIntegral $ partitionFaà mon is ) )
|
[ [|| $$times ( $$fromInt $$( liftTyped $ fromIntegral $ partitionFaà mon is ) )
|
||||||
$$( foldQ times [|| $$fromInt ( 1 :: Integer ) ||]
|
$$( foldQ times [|| $$fromInt ( 1 :: Integer ) ||]
|
||||||
[ [|| $$pow $$( monIndex @du df f_mon ) p ||]
|
[ [|| $$pow $$( monIndexQ @du df f_mon ) p ||]
|
||||||
| ( f_mon, p ) <- is
|
| ( f_mon, p ) <- is
|
||||||
]
|
]
|
||||||
) ||]
|
) ||]
|
||||||
|
|
@ -284,366 +285,395 @@ chainRuleN1Q fromInt add times pow df dg =
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- MonomialBasis instances follow (nothing else).
|
-- MonomialBasisQ instances follow (nothing else).
|
||||||
|
|
||||||
type instance Deg D𝔸0 = 0
|
type instance Deg D𝔸0 = 0
|
||||||
type instance Vars D𝔸0 = 0
|
type instance Vars D𝔸0 = 0
|
||||||
instance MonomialBasis D𝔸0 where
|
instance MonomialBasisQ D𝔸0 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D0_v = $$( f $ Mon VZ )
|
_D0_v = $$( f $ Mon ( Vec [ ] ) )
|
||||||
in D0 { .. }
|
in D0 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d _ = [|| _D0_v $$d ||]
|
monIndexQ d _ = [|| _D0_v $$d ||]
|
||||||
|
|
||||||
type instance Deg D1𝔸1 = 1
|
type instance Deg D1𝔸1 = 1
|
||||||
type instance Vars D1𝔸1 = 1
|
type instance Vars D1𝔸1 = 1
|
||||||
instance MonomialBasis D1𝔸1 where
|
instance MonomialBasisQ D1𝔸1 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D11_v = $$( f $ Mon ( 0 `VS` VZ ) )
|
_D11_v = $$( f $ Mon ( Vec [ 0 ] ) )
|
||||||
_D11_dx = T $$( f $ Mon ( 1 `VS` VZ ) )
|
_D11_dx = T $$( f $ Mon ( Vec [ 1 ] ) )
|
||||||
in D11 { .. }
|
in D11 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` VZ ) -> [|| unT $ _D11_dx $$d ||]
|
Mon ( Vec [ 1 ] ) -> [|| unT $ _D11_dx $$d ||]
|
||||||
_ -> [|| _D11_v $$d ||]
|
_ -> [|| _D11_v $$d ||]
|
||||||
|
|
||||||
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 MonomialBasis D2𝔸1 where
|
instance MonomialBasisQ D2𝔸1 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D21_v = $$( f $ Mon ( 0 `VS` VZ ) )
|
_D21_v = $$( f $ Mon ( Vec [ 0 ] ) )
|
||||||
_D21_dx = T $$( f $ Mon ( 1 `VS` VZ ) )
|
_D21_dx = T $$( f $ Mon ( Vec [ 1 ] ) )
|
||||||
_D21_dxdx = T $$( f $ Mon ( 2 `VS` VZ ) )
|
_D21_dxdx = T $$( f $ Mon ( Vec [ 2 ] ) )
|
||||||
in D21 { .. }
|
in D21 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` VZ ) -> [|| unT $ _D21_dx $$d ||]
|
Mon ( Vec [ 1 ] ) -> [|| unT $ _D21_dx $$d ||]
|
||||||
Mon ( 2 `VS` VZ ) -> [|| unT $ _D21_dxdx $$d ||]
|
Mon ( Vec [ 2 ] ) -> [|| unT $ _D21_dxdx $$d ||]
|
||||||
_ -> [|| _D21_v $$d ||]
|
_ -> [|| _D21_v $$d ||]
|
||||||
|
|
||||||
type instance Deg D3𝔸1 = 3
|
type instance Deg D3𝔸1 = 3
|
||||||
type instance Vars D3𝔸1 = 1
|
type instance Vars D3𝔸1 = 1
|
||||||
instance MonomialBasis D3𝔸1 where
|
instance MonomialBasisQ D3𝔸1 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D31_v = $$( f $ Mon ( 0 `VS` VZ ) )
|
_D31_v = $$( f $ Mon ( Vec [ 0 ] ) )
|
||||||
_D31_dx = T $$( f $ Mon ( 1 `VS` VZ ) )
|
_D31_dx = T $$( f $ Mon ( Vec [ 1 ] ) )
|
||||||
_D31_dxdx = T $$( f $ Mon ( 2 `VS` VZ ) )
|
_D31_dxdx = T $$( f $ Mon ( Vec [ 2 ] ) )
|
||||||
_D31_dxdxdx = T $$( f $ Mon ( 3 `VS` VZ ) )
|
_D31_dxdxdx = T $$( f $ Mon ( Vec [ 3 ] ) )
|
||||||
in D31 { .. }
|
in D31 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` VZ ) -> [|| unT $ _D31_dx $$d ||]
|
Mon ( Vec [ 1 ] ) -> [|| unT $ _D31_dx $$d ||]
|
||||||
Mon ( 2 `VS` VZ ) -> [|| unT $ _D31_dxdx $$d ||]
|
Mon ( Vec [ 2 ] ) -> [|| unT $ _D31_dxdx $$d ||]
|
||||||
Mon ( 3 `VS` VZ ) -> [|| unT $ _D31_dxdxdx $$d ||]
|
Mon ( Vec [ 3 ] ) -> [|| unT $ _D31_dxdxdx $$d ||]
|
||||||
_ -> [|| _D31_v $$d ||]
|
_ -> [|| _D31_v $$d ||]
|
||||||
|
|
||||||
type instance Deg D1𝔸2 = 1
|
type instance Deg D1𝔸2 = 1
|
||||||
type instance Vars D1𝔸2 = 2
|
type instance Vars D1𝔸2 = 2
|
||||||
instance MonomialBasis D1𝔸2 where
|
instance MonomialBasisQ D1𝔸2 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D12_v = $$( f $ Mon ( 0 `VS` 0 `VS` VZ ) )
|
_D12_v = $$( f $ Mon ( Vec [ 0, 0 ] ) )
|
||||||
_D12_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` VZ ) )
|
_D12_dx = T $$( f $ Mon ( Vec [ 1, 0 ] ) )
|
||||||
_D12_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` VZ ) )
|
_D12_dy = T $$( f $ Mon ( Vec [ 0, 1 ] ) )
|
||||||
in D12 { .. }
|
in D12 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D12_dx $$d ||]
|
Mon ( Vec [ 1, 0 ] ) -> [|| unT $ _D12_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D12_dy $$d ||]
|
Mon ( Vec [ 0, 1 ] ) -> [|| unT $ _D12_dy $$d ||]
|
||||||
_ -> [|| _D12_v $$d ||]
|
_ -> [|| _D12_v $$d ||]
|
||||||
|
|
||||||
|
|
||||||
|
instance MonomialBasis D1𝔸2 where
|
||||||
|
monTabulate f =
|
||||||
|
let
|
||||||
|
_D12_v = f $ Mon ( Vec [ 0, 0 ] )
|
||||||
|
_D12_dx = T $ f $ Mon ( Vec [ 1, 0 ] )
|
||||||
|
_D12_dy = T $ f $ Mon ( Vec [ 0, 1 ] )
|
||||||
|
in D12 { .. }
|
||||||
|
|
||||||
|
monIndex d = \ case
|
||||||
|
Mon ( Vec [ 1, 0 ] ) -> unT $ _D12_dx d
|
||||||
|
Mon ( Vec [ 0, 1 ] ) -> unT $ _D12_dy d
|
||||||
|
_ -> _D12_v d
|
||||||
|
|
||||||
type instance Deg D2𝔸2 = 2
|
type instance Deg D2𝔸2 = 2
|
||||||
type instance Vars D2𝔸2 = 2
|
type instance Vars D2𝔸2 = 2
|
||||||
instance MonomialBasis D2𝔸2 where
|
instance MonomialBasisQ D2𝔸2 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D22_v = $$( f $ Mon ( 0 `VS` 0 `VS` VZ ) )
|
_D22_v = $$( f $ Mon ( Vec [ 0, 0 ] ) )
|
||||||
_D22_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` VZ ) )
|
_D22_dx = T $$( f $ Mon ( Vec [ 1, 0 ] ) )
|
||||||
_D22_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` VZ ) )
|
_D22_dy = T $$( f $ Mon ( Vec [ 0, 1 ] ) )
|
||||||
_D22_dxdx = T $$( f $ Mon ( 2 `VS` 0 `VS` VZ ) )
|
_D22_dxdx = T $$( f $ Mon ( Vec [ 2, 0 ] ) )
|
||||||
_D22_dxdy = T $$( f $ Mon ( 1 `VS` 1 `VS` VZ ) )
|
_D22_dxdy = T $$( f $ Mon ( Vec [ 1, 1 ] ) )
|
||||||
_D22_dydy = T $$( f $ Mon ( 0 `VS` 2 `VS` VZ ) )
|
_D22_dydy = T $$( f $ Mon ( Vec [ 0, 2 ] ) )
|
||||||
in D22 { .. }
|
in D22 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D22_dx $$d ||]
|
Mon ( Vec [ 1, 0 ] ) -> [|| unT $ _D22_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D22_dy $$d ||]
|
Mon ( Vec [ 0, 1 ] ) -> [|| unT $ _D22_dy $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D22_dxdx $$d ||]
|
Mon ( Vec [ 2, 0 ] ) -> [|| unT $ _D22_dxdx $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D22_dxdy $$d ||]
|
Mon ( Vec [ 1, 1 ] ) -> [|| unT $ _D22_dxdy $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D22_dydy $$d ||]
|
Mon ( Vec [ 0, 2 ] ) -> [|| unT $ _D22_dydy $$d ||]
|
||||||
_ -> [|| _D22_v $$d ||]
|
_ -> [|| _D22_v $$d ||]
|
||||||
|
|
||||||
type instance Deg D3𝔸2 = 3
|
type instance Deg D3𝔸2 = 3
|
||||||
type instance Vars D3𝔸2 = 2
|
type instance Vars D3𝔸2 = 2
|
||||||
instance MonomialBasis D3𝔸2 where
|
instance MonomialBasisQ D3𝔸2 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D32_v = $$( f $ Mon ( 0 `VS` 0 `VS` VZ ) )
|
_D32_v = $$( f $ Mon ( Vec [ 0, 0 ] ) )
|
||||||
_D32_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` VZ ) )
|
_D32_dx = T $$( f $ Mon ( Vec [ 1, 0 ] ) )
|
||||||
_D32_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` VZ ) )
|
_D32_dy = T $$( f $ Mon ( Vec [ 0, 1 ] ) )
|
||||||
_D32_dxdx = T $$( f $ Mon ( 2 `VS` 0 `VS` VZ ) )
|
_D32_dxdx = T $$( f $ Mon ( Vec [ 2, 0 ] ) )
|
||||||
_D32_dxdy = T $$( f $ Mon ( 1 `VS` 1 `VS` VZ ) )
|
_D32_dxdy = T $$( f $ Mon ( Vec [ 1, 1 ] ) )
|
||||||
_D32_dydy = T $$( f $ Mon ( 0 `VS` 2 `VS` VZ ) )
|
_D32_dydy = T $$( f $ Mon ( Vec [ 0, 2 ] ) )
|
||||||
_D32_dxdxdx = T $$( f $ Mon ( 3 `VS` 0 `VS` VZ ) )
|
_D32_dxdxdx = T $$( f $ Mon ( Vec [ 3, 0 ] ) )
|
||||||
_D32_dxdxdy = T $$( f $ Mon ( 2 `VS` 1 `VS` VZ ) )
|
_D32_dxdxdy = T $$( f $ Mon ( Vec [ 2, 1 ] ) )
|
||||||
_D32_dxdydy = T $$( f $ Mon ( 1 `VS` 2 `VS` VZ ) )
|
_D32_dxdydy = T $$( f $ Mon ( Vec [ 1, 2 ] ) )
|
||||||
_D32_dydydy = T $$( f $ Mon ( 0 `VS` 3 `VS` VZ ) )
|
_D32_dydydy = T $$( f $ Mon ( Vec [ 0, 3 ] ) )
|
||||||
in D32 { .. } ||]
|
in D32 { .. } ||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D32_dx $$d ||]
|
Mon ( Vec [ 1, 0 ] ) -> [|| unT $ _D32_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D32_dy $$d ||]
|
Mon ( Vec [ 0, 1 ] ) -> [|| unT $ _D32_dy $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D32_dxdx $$d ||]
|
Mon ( Vec [ 2, 0 ] ) -> [|| unT $ _D32_dxdx $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D32_dxdy $$d ||]
|
Mon ( Vec [ 1, 1 ] ) -> [|| unT $ _D32_dxdy $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D32_dydy $$d ||]
|
Mon ( Vec [ 0, 2 ] ) -> [|| unT $ _D32_dydy $$d ||]
|
||||||
Mon ( 3 `VS` 0 `VS` VZ ) -> [|| unT $ _D32_dxdxdx $$d ||]
|
Mon ( Vec [ 3, 0 ] ) -> [|| unT $ _D32_dxdxdx $$d ||]
|
||||||
Mon ( 2 `VS` 1 `VS` VZ ) -> [|| unT $ _D32_dxdxdy $$d ||]
|
Mon ( Vec [ 2, 1 ] ) -> [|| unT $ _D32_dxdxdy $$d ||]
|
||||||
Mon ( 1 `VS` 2 `VS` VZ ) -> [|| unT $ _D32_dxdydy $$d ||]
|
Mon ( Vec [ 1, 2 ] ) -> [|| unT $ _D32_dxdydy $$d ||]
|
||||||
Mon ( 0 `VS` 3 `VS` VZ ) -> [|| unT $ _D32_dydydy $$d ||]
|
Mon ( Vec [ 0, 3 ] ) -> [|| unT $ _D32_dydydy $$d ||]
|
||||||
_ -> [|| _D32_v $$d ||]
|
_ -> [|| _D32_v $$d ||]
|
||||||
|
|
||||||
type instance Deg D1𝔸3 = 1
|
type instance Deg D1𝔸3 = 1
|
||||||
type instance Vars D1𝔸3 = 3
|
type instance Vars D1𝔸3 = 3
|
||||||
instance MonomialBasis D1𝔸3 where
|
instance MonomialBasisQ D1𝔸3 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
!_D13_v = $$( f ( Mon ( 0 `VS` 0 `VS` 0 `VS` VZ ) ) )
|
!_D13_v = $$( f ( Mon ( Vec [ 0, 0, 0 ] ) ) )
|
||||||
!_D13_dx = T $$( f ( Mon ( 1 `VS` 0 `VS` 0 `VS` VZ ) ) )
|
!_D13_dx = T $$( f ( Mon ( Vec [ 1, 0, 0 ] ) ) )
|
||||||
!_D13_dy = T $$( f ( Mon ( 0 `VS` 1 `VS` 0 `VS` VZ ) ) )
|
!_D13_dy = T $$( f ( Mon ( Vec [ 0, 1, 0 ] ) ) )
|
||||||
!_D13_dz = T $$( f ( Mon ( 0 `VS` 0 `VS` 1 `VS` VZ ) ) )
|
!_D13_dz = T $$( f ( Mon ( Vec [ 0, 0, 1 ] ) ) )
|
||||||
in D13 { .. }
|
in D13 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D13_dx $$d ||]
|
Mon ( Vec [ 1, 0, 0 ] ) -> [|| unT $ _D13_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D13_dy $$d ||]
|
Mon ( Vec [ 0, 1, 0 ] ) -> [|| unT $ _D13_dy $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D13_dz $$d ||]
|
Mon ( Vec [ 0, 0, 1 ] ) -> [|| unT $ _D13_dz $$d ||]
|
||||||
_ -> [|| _D13_v $$d ||]
|
_ -> [|| _D13_v $$d ||]
|
||||||
|
|
||||||
|
instance MonomialBasis D1𝔸3 where
|
||||||
|
monTabulate f =
|
||||||
|
let
|
||||||
|
!_D13_v = f ( Mon ( Vec [ 0, 0, 0 ] ) )
|
||||||
|
!_D13_dx = T $ f ( Mon ( Vec [ 1, 0, 0 ] ) )
|
||||||
|
!_D13_dy = T $ f ( Mon ( Vec [ 0, 1, 0 ] ) )
|
||||||
|
!_D13_dz = T $ f ( Mon ( Vec [ 0, 0, 1 ] ) )
|
||||||
|
in D13 { .. }
|
||||||
|
|
||||||
|
monIndex d = \ case
|
||||||
|
Mon ( Vec [ 1, 0, 0 ] ) -> unT $ _D13_dx d
|
||||||
|
Mon ( Vec [ 0, 1, 0 ] ) -> unT $ _D13_dy d
|
||||||
|
Mon ( Vec [ 0, 0, 1 ] ) -> unT $ _D13_dz d
|
||||||
|
_ -> _D13_v d
|
||||||
|
|
||||||
type instance Deg D2𝔸3 = 2
|
type instance Deg D2𝔸3 = 2
|
||||||
type instance Vars D2𝔸3 = 3
|
type instance Vars D2𝔸3 = 3
|
||||||
instance MonomialBasis D2𝔸3 where
|
instance MonomialBasisQ D2𝔸3 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D23_v = $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D23_v = $$( f $ Mon ( Vec [ 0, 0, 0 ] ) )
|
||||||
_D23_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D23_dx = T $$( f $ Mon ( Vec [ 1, 0, 0 ] ) )
|
||||||
_D23_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D23_dy = T $$( f $ Mon ( Vec [ 0, 1, 0 ] ) )
|
||||||
_D23_dz = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D23_dz = T $$( f $ Mon ( Vec [ 0, 0, 1 ] ) )
|
||||||
_D23_dxdx = T $$( f $ Mon ( 2 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D23_dxdx = T $$( f $ Mon ( Vec [ 2, 0, 0 ] ) )
|
||||||
_D23_dxdy = T $$( f $ Mon ( 1 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D23_dxdy = T $$( f $ Mon ( Vec [ 1, 1, 0 ] ) )
|
||||||
_D23_dydy = T $$( f $ Mon ( 0 `VS` 2 `VS` 0 `VS` VZ ) )
|
_D23_dydy = T $$( f $ Mon ( Vec [ 0, 2, 0 ] ) )
|
||||||
_D23_dxdz = T $$( f $ Mon ( 1 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D23_dxdz = T $$( f $ Mon ( Vec [ 1, 0, 1 ] ) )
|
||||||
_D23_dydz = T $$( f $ Mon ( 0 `VS` 1 `VS` 1 `VS` VZ ) )
|
_D23_dydz = T $$( f $ Mon ( Vec [ 0, 1, 1 ] ) )
|
||||||
_D23_dzdz = T $$( f $ Mon ( 0 `VS` 0 `VS` 2 `VS` VZ ) )
|
_D23_dzdz = T $$( f $ Mon ( Vec [ 0, 0, 2 ] ) )
|
||||||
in D23 { .. }
|
in D23 { .. }
|
||||||
||]
|
||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D23_dx $$d ||]
|
Mon ( Vec [ 1, 0, 0 ] ) -> [|| unT $ _D23_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D23_dy $$d ||]
|
Mon ( Vec [ 0, 1, 0 ] ) -> [|| unT $ _D23_dy $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D23_dz $$d ||]
|
Mon ( Vec [ 0, 0, 1 ] ) -> [|| unT $ _D23_dz $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D23_dxdx $$d ||]
|
Mon ( Vec [ 2, 0, 0 ] ) -> [|| unT $ _D23_dxdx $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D23_dxdy $$d ||]
|
Mon ( Vec [ 1, 1, 0 ] ) -> [|| unT $ _D23_dxdy $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D23_dydy $$d ||]
|
Mon ( Vec [ 0, 2, 0 ] ) -> [|| unT $ _D23_dydy $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D23_dxdz $$d ||]
|
Mon ( Vec [ 1, 0, 1 ] ) -> [|| unT $ _D23_dxdz $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D23_dydz $$d ||]
|
Mon ( Vec [ 0, 1, 1 ] ) -> [|| unT $ _D23_dydz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D23_dzdz $$d ||]
|
Mon ( Vec [ 0, 0, 2 ] ) -> [|| unT $ _D23_dzdz $$d ||]
|
||||||
_ -> [|| _D23_v $$d ||]
|
_ -> [|| _D23_v $$d ||]
|
||||||
|
|
||||||
|
|
||||||
type instance Deg D3𝔸3 = 3
|
type instance Deg D3𝔸3 = 3
|
||||||
type instance Vars D3𝔸3 = 3
|
type instance Vars D3𝔸3 = 3
|
||||||
instance MonomialBasis D3𝔸3 where
|
instance MonomialBasisQ D3𝔸3 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D33_v = $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D33_v = $$( f $ Mon ( Vec [ 0, 0, 0 ] ) )
|
||||||
_D33_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D33_dx = T $$( f $ Mon ( Vec [ 1, 0, 0 ] ) )
|
||||||
_D33_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D33_dy = T $$( f $ Mon ( Vec [ 0, 1, 0 ] ) )
|
||||||
_D33_dz = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D33_dz = T $$( f $ Mon ( Vec [ 0, 0, 1 ] ) )
|
||||||
_D33_dxdx = T $$( f $ Mon ( 2 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D33_dxdx = T $$( f $ Mon ( Vec [ 2, 0, 0 ] ) )
|
||||||
_D33_dxdy = T $$( f $ Mon ( 1 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D33_dxdy = T $$( f $ Mon ( Vec [ 1, 1, 0 ] ) )
|
||||||
_D33_dydy = T $$( f $ Mon ( 0 `VS` 2 `VS` 0 `VS` VZ ) )
|
_D33_dydy = T $$( f $ Mon ( Vec [ 0, 2, 0 ] ) )
|
||||||
_D33_dxdz = T $$( f $ Mon ( 1 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D33_dxdz = T $$( f $ Mon ( Vec [ 1, 0, 1 ] ) )
|
||||||
_D33_dydz = T $$( f $ Mon ( 0 `VS` 1 `VS` 1 `VS` VZ ) )
|
_D33_dydz = T $$( f $ Mon ( Vec [ 0, 1, 1 ] ) )
|
||||||
_D33_dzdz = T $$( f $ Mon ( 0 `VS` 0 `VS` 2 `VS` VZ ) )
|
_D33_dzdz = T $$( f $ Mon ( Vec [ 0, 0, 2 ] ) )
|
||||||
_D33_dxdxdx = T $$( f $ Mon ( 3 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D33_dxdxdx = T $$( f $ Mon ( Vec [ 3, 0, 0 ] ) )
|
||||||
_D33_dxdxdy = T $$( f $ Mon ( 2 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D33_dxdxdy = T $$( f $ Mon ( Vec [ 2, 1, 0 ] ) )
|
||||||
_D33_dxdydy = T $$( f $ Mon ( 1 `VS` 2 `VS` 0 `VS` VZ ) )
|
_D33_dxdydy = T $$( f $ Mon ( Vec [ 1, 2, 0 ] ) )
|
||||||
_D33_dydydy = T $$( f $ Mon ( 0 `VS` 3 `VS` 0 `VS` VZ ) )
|
_D33_dydydy = T $$( f $ Mon ( Vec [ 0, 3, 0 ] ) )
|
||||||
_D33_dxdxdz = T $$( f $ Mon ( 2 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D33_dxdxdz = T $$( f $ Mon ( Vec [ 2, 0, 1 ] ) )
|
||||||
_D33_dxdydz = T $$( f $ Mon ( 1 `VS` 1 `VS` 1 `VS` VZ ) )
|
_D33_dxdydz = T $$( f $ Mon ( Vec [ 1, 1, 1 ] ) )
|
||||||
_D33_dxdzdz = T $$( f $ Mon ( 1 `VS` 0 `VS` 2 `VS` VZ ) )
|
_D33_dxdzdz = T $$( f $ Mon ( Vec [ 1, 0, 2 ] ) )
|
||||||
_D33_dydydz = T $$( f $ Mon ( 0 `VS` 2 `VS` 1 `VS` VZ ) )
|
_D33_dydydz = T $$( f $ Mon ( Vec [ 0, 2, 1 ] ) )
|
||||||
_D33_dydzdz = T $$( f $ Mon ( 0 `VS` 1 `VS` 2 `VS` VZ ) )
|
_D33_dydzdz = T $$( f $ Mon ( Vec [ 0, 1, 2 ] ) )
|
||||||
_D33_dzdzdz = T $$( f $ Mon ( 0 `VS` 0 `VS` 3 `VS` VZ ) )
|
_D33_dzdzdz = T $$( f $ Mon ( Vec [ 0, 0, 3 ] ) )
|
||||||
in D33 { .. } ||]
|
in D33 { .. } ||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dx $$d ||]
|
Mon ( Vec [ 1, 0, 0 ] ) -> [|| unT $ _D33_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dy $$d ||]
|
Mon ( Vec [ 0, 1, 0 ] ) -> [|| unT $ _D33_dy $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D33_dz $$d ||]
|
Mon ( Vec [ 0, 0, 1 ] ) -> [|| unT $ _D33_dz $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dxdx $$d ||]
|
Mon ( Vec [ 2, 0, 0 ] ) -> [|| unT $ _D33_dxdx $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dxdy $$d ||]
|
Mon ( Vec [ 1, 1, 0 ] ) -> [|| unT $ _D33_dxdy $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dydy $$d ||]
|
Mon ( Vec [ 0, 2, 0 ] ) -> [|| unT $ _D33_dydy $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D33_dxdz $$d ||]
|
Mon ( Vec [ 1, 0, 1 ] ) -> [|| unT $ _D33_dxdz $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D33_dydz $$d ||]
|
Mon ( Vec [ 0, 1, 1 ] ) -> [|| unT $ _D33_dydz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D33_dzdz $$d ||]
|
Mon ( Vec [ 0, 0, 2 ] ) -> [|| unT $ _D33_dzdz $$d ||]
|
||||||
Mon ( 3 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dxdxdx $$d ||]
|
Mon ( Vec [ 3, 0, 0 ] ) -> [|| unT $ _D33_dxdxdx $$d ||]
|
||||||
Mon ( 2 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dxdxdy $$d ||]
|
Mon ( Vec [ 2, 1, 0 ] ) -> [|| unT $ _D33_dxdxdy $$d ||]
|
||||||
Mon ( 1 `VS` 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dxdydy $$d ||]
|
Mon ( Vec [ 1, 2, 0 ] ) -> [|| unT $ _D33_dxdydy $$d ||]
|
||||||
Mon ( 0 `VS` 3 `VS` 0 `VS` VZ ) -> [|| unT $ _D33_dydydy $$d ||]
|
Mon ( Vec [ 0, 3, 0 ] ) -> [|| unT $ _D33_dydydy $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D33_dxdxdz $$d ||]
|
Mon ( Vec [ 2, 0, 1 ] ) -> [|| unT $ _D33_dxdxdz $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D33_dxdydz $$d ||]
|
Mon ( Vec [ 1, 1, 1 ] ) -> [|| unT $ _D33_dxdydz $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D33_dxdzdz $$d ||]
|
Mon ( Vec [ 1, 0, 2 ] ) -> [|| unT $ _D33_dxdzdz $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` 1 `VS` VZ ) -> [|| unT $ _D33_dydydz $$d ||]
|
Mon ( Vec [ 0, 2, 1 ] ) -> [|| unT $ _D33_dydydz $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 2 `VS` VZ ) -> [|| unT $ _D33_dydzdz $$d ||]
|
Mon ( Vec [ 0, 1, 2 ] ) -> [|| unT $ _D33_dydzdz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 3 `VS` VZ ) -> [|| unT $ _D33_dzdzdz $$d ||]
|
Mon ( Vec [ 0, 0, 3 ] ) -> [|| unT $ _D33_dzdzdz $$d ||]
|
||||||
_ -> [|| _D33_v $$d ||]
|
_ -> [|| _D33_v $$d ||]
|
||||||
|
|
||||||
type instance Deg D1𝔸4 = 1
|
type instance Deg D1𝔸4 = 1
|
||||||
type instance Vars D1𝔸4 = 4
|
type instance Vars D1𝔸4 = 4
|
||||||
instance MonomialBasis D1𝔸4 where
|
instance MonomialBasisQ D1𝔸4 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D14_v = $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D14_v = $$( f $ Mon ( Vec [ 0, 0, 0, 0 ] ) )
|
||||||
_D14_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D14_dx = T $$( f $ Mon ( Vec [ 1, 0, 0, 0 ] ) )
|
||||||
_D14_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D14_dy = T $$( f $ Mon ( Vec [ 0, 1, 0, 0 ] ) )
|
||||||
_D14_dz = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D14_dz = T $$( f $ Mon ( Vec [ 0, 0, 1, 0 ] ) )
|
||||||
_D14_dw = T $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D14_dw = T $$( f $ Mon ( Vec [ 0, 0, 0, 1 ] ) )
|
||||||
in D14 { .. } ||]
|
in D14 { .. } ||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D14_dx $$d ||]
|
Mon ( Vec [ 1, 0, 0, 0 ] ) -> [|| unT $ _D14_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D14_dy $$d ||]
|
Mon ( Vec [ 0, 1, 0, 0 ] ) -> [|| unT $ _D14_dy $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D14_dz $$d ||]
|
Mon ( Vec [ 0, 0, 1, 0 ] ) -> [|| unT $ _D14_dz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D14_dw $$d ||]
|
Mon ( Vec [ 0, 0, 0, 1 ] ) -> [|| unT $ _D14_dw $$d ||]
|
||||||
_ -> [|| _D14_v $$d ||]
|
_ -> [|| _D14_v $$d ||]
|
||||||
|
|
||||||
type instance Deg D2𝔸4 = 2
|
type instance Deg D2𝔸4 = 2
|
||||||
type instance Vars D2𝔸4 = 4
|
type instance Vars D2𝔸4 = 4
|
||||||
instance MonomialBasis D2𝔸4 where
|
instance MonomialBasisQ D2𝔸4 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D24_v = $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D24_v = $$( f $ Mon ( Vec [ 0, 0, 0, 0 ] ) )
|
||||||
_D24_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D24_dx = T $$( f $ Mon ( Vec [ 1, 0, 0, 0 ] ) )
|
||||||
_D24_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D24_dy = T $$( f $ Mon ( Vec [ 0, 1, 0, 0 ] ) )
|
||||||
_D24_dz = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D24_dz = T $$( f $ Mon ( Vec [ 0, 0, 1, 0 ] ) )
|
||||||
_D24_dw = T $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D24_dw = T $$( f $ Mon ( Vec [ 0, 0, 0, 1 ] ) )
|
||||||
_D24_dxdx = T $$( f $ Mon ( 2 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D24_dxdx = T $$( f $ Mon ( Vec [ 2, 0, 0, 0 ] ) )
|
||||||
_D24_dxdy = T $$( f $ Mon ( 1 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D24_dxdy = T $$( f $ Mon ( Vec [ 1, 1, 0, 0 ] ) )
|
||||||
_D24_dydy = T $$( f $ Mon ( 0 `VS` 2 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D24_dydy = T $$( f $ Mon ( Vec [ 0, 2, 0, 0 ] ) )
|
||||||
_D24_dxdz = T $$( f $ Mon ( 1 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D24_dxdz = T $$( f $ Mon ( Vec [ 1, 0, 1, 0 ] ) )
|
||||||
_D24_dydz = T $$( f $ Mon ( 0 `VS` 1 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D24_dydz = T $$( f $ Mon ( Vec [ 0, 1, 1, 0 ] ) )
|
||||||
_D24_dzdz = T $$( f $ Mon ( 0 `VS` 0 `VS` 2 `VS` 0 `VS` VZ ) )
|
_D24_dzdz = T $$( f $ Mon ( Vec [ 0, 0, 2, 0 ] ) )
|
||||||
_D24_dxdw = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D24_dxdw = T $$( f $ Mon ( Vec [ 1, 0, 0, 1 ] ) )
|
||||||
_D24_dydw = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D24_dydw = T $$( f $ Mon ( Vec [ 0, 1, 0, 1 ] ) )
|
||||||
_D24_dzdw = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` 1 `VS` VZ ) )
|
_D24_dzdw = T $$( f $ Mon ( Vec [ 0, 0, 1, 1 ] ) )
|
||||||
_D24_dwdw = T $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 2 `VS` VZ ) )
|
_D24_dwdw = T $$( f $ Mon ( Vec [ 0, 0, 0, 2 ] ) )
|
||||||
in D24 { .. } ||]
|
in D24 { .. } ||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dx $$d ||]
|
Mon ( Vec [ 1, 0, 0, 0 ] ) -> [|| unT $ _D24_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dy $$d ||]
|
Mon ( Vec [ 0, 1, 0, 0 ] ) -> [|| unT $ _D24_dy $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dz $$d ||]
|
Mon ( Vec [ 0, 0, 1, 0 ] ) -> [|| unT $ _D24_dz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D24_dw $$d ||]
|
Mon ( Vec [ 0, 0, 0, 1 ] ) -> [|| unT $ _D24_dw $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dxdx $$d ||]
|
Mon ( Vec [ 2, 0, 0, 0 ] ) -> [|| unT $ _D24_dxdx $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dxdy $$d ||]
|
Mon ( Vec [ 1, 1, 0, 0 ] ) -> [|| unT $ _D24_dxdy $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dydy $$d ||]
|
Mon ( Vec [ 0, 2, 0, 0 ] ) -> [|| unT $ _D24_dydy $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dxdz $$d ||]
|
Mon ( Vec [ 1, 0, 1, 0 ] ) -> [|| unT $ _D24_dxdz $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dydz $$d ||]
|
Mon ( Vec [ 0, 1, 1, 0 ] ) -> [|| unT $ _D24_dydz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D24_dzdz $$d ||]
|
Mon ( Vec [ 0, 0, 2, 0 ] ) -> [|| unT $ _D24_dzdz $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D24_dxdw $$d ||]
|
Mon ( Vec [ 1, 0, 0, 1 ] ) -> [|| unT $ _D24_dxdw $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D24_dydw $$d ||]
|
Mon ( Vec [ 0, 1, 0, 1 ] ) -> [|| unT $ _D24_dydw $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D24_dzdw $$d ||]
|
Mon ( Vec [ 0, 0, 1, 1 ] ) -> [|| unT $ _D24_dzdw $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D24_dwdw $$d ||]
|
Mon ( Vec [ 0, 0, 0, 2 ] ) -> [|| unT $ _D24_dwdw $$d ||]
|
||||||
_ -> [|| _D24_v $$d ||]
|
_ -> [|| _D24_v $$d ||]
|
||||||
|
|
||||||
|
|
||||||
type instance Deg D3𝔸4 = 3
|
type instance Deg D3𝔸4 = 3
|
||||||
type instance Vars D3𝔸4 = 4
|
type instance Vars D3𝔸4 = 4
|
||||||
instance MonomialBasis D3𝔸4 where
|
instance MonomialBasisQ D3𝔸4 where
|
||||||
monTabulate f =
|
monTabulateQ f =
|
||||||
[|| let
|
[|| let
|
||||||
_D34_v = $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_v = $$( f $ Mon ( Vec [ 0, 0, 0, 0 ] ) )
|
||||||
_D34_dx = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dx = T $$( f $ Mon ( Vec [ 1, 0, 0, 0 ] ) )
|
||||||
_D34_dy = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dy = T $$( f $ Mon ( Vec [ 0, 1, 0, 0 ] ) )
|
||||||
_D34_dz = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D34_dz = T $$( f $ Mon ( Vec [ 0, 0, 1, 0 ] ) )
|
||||||
_D34_dw = T $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D34_dw = T $$( f $ Mon ( Vec [ 0, 0, 0, 1 ] ) )
|
||||||
_D34_dxdx = T $$( f $ Mon ( 2 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dxdx = T $$( f $ Mon ( Vec [ 2, 0, 0, 0 ] ) )
|
||||||
_D34_dxdy = T $$( f $ Mon ( 1 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dxdy = T $$( f $ Mon ( Vec [ 1, 1, 0, 0 ] ) )
|
||||||
_D34_dydy = T $$( f $ Mon ( 0 `VS` 2 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dydy = T $$( f $ Mon ( Vec [ 0, 2, 0, 0 ] ) )
|
||||||
_D34_dxdz = T $$( f $ Mon ( 1 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D34_dxdz = T $$( f $ Mon ( Vec [ 1, 0, 1, 0 ] ) )
|
||||||
_D34_dydz = T $$( f $ Mon ( 0 `VS` 1 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D34_dydz = T $$( f $ Mon ( Vec [ 0, 1, 1, 0 ] ) )
|
||||||
_D34_dzdz = T $$( f $ Mon ( 0 `VS` 0 `VS` 2 `VS` 0 `VS` VZ ) )
|
_D34_dzdz = T $$( f $ Mon ( Vec [ 0, 0, 2, 0 ] ) )
|
||||||
_D34_dxdw = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D34_dxdw = T $$( f $ Mon ( Vec [ 1, 0, 0, 1 ] ) )
|
||||||
_D34_dydw = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D34_dydw = T $$( f $ Mon ( Vec [ 0, 1, 0, 1 ] ) )
|
||||||
_D34_dzdw = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` 1 `VS` VZ ) )
|
_D34_dzdw = T $$( f $ Mon ( Vec [ 0, 0, 1, 1 ] ) )
|
||||||
_D34_dwdw = T $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 2 `VS` VZ ) )
|
_D34_dwdw = T $$( f $ Mon ( Vec [ 0, 0, 0, 2 ] ) )
|
||||||
_D34_dxdxdx = T $$( f $ Mon ( 3 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dxdxdx = T $$( f $ Mon ( Vec [ 3, 0, 0, 0 ] ) )
|
||||||
_D34_dxdxdy = T $$( f $ Mon ( 2 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dxdxdy = T $$( f $ Mon ( Vec [ 2, 1, 0, 0 ] ) )
|
||||||
_D34_dxdydy = T $$( f $ Mon ( 1 `VS` 2 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dxdydy = T $$( f $ Mon ( Vec [ 1, 2, 0, 0 ] ) )
|
||||||
_D34_dydydy = T $$( f $ Mon ( 0 `VS` 3 `VS` 0 `VS` 0 `VS` VZ ) )
|
_D34_dydydy = T $$( f $ Mon ( Vec [ 0, 3, 0, 0 ] ) )
|
||||||
_D34_dxdxdz = T $$( f $ Mon ( 2 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D34_dxdxdz = T $$( f $ Mon ( Vec [ 2, 0, 1, 0 ] ) )
|
||||||
_D34_dxdydz = T $$( f $ Mon ( 1 `VS` 1 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D34_dxdydz = T $$( f $ Mon ( Vec [ 1, 1, 1, 0 ] ) )
|
||||||
_D34_dxdzdz = T $$( f $ Mon ( 1 `VS` 0 `VS` 2 `VS` 0 `VS` VZ ) )
|
_D34_dxdzdz = T $$( f $ Mon ( Vec [ 1, 0, 2, 0 ] ) )
|
||||||
_D34_dydydz = T $$( f $ Mon ( 0 `VS` 2 `VS` 1 `VS` 0 `VS` VZ ) )
|
_D34_dydydz = T $$( f $ Mon ( Vec [ 0, 2, 1, 0 ] ) )
|
||||||
_D34_dydzdz = T $$( f $ Mon ( 0 `VS` 1 `VS` 2 `VS` 0 `VS` VZ ) )
|
_D34_dydzdz = T $$( f $ Mon ( Vec [ 0, 1, 2, 0 ] ) )
|
||||||
_D34_dzdzdz = T $$( f $ Mon ( 0 `VS` 0 `VS` 3 `VS` 0 `VS` VZ ) )
|
_D34_dzdzdz = T $$( f $ Mon ( Vec [ 0, 0, 3, 0 ] ) )
|
||||||
_D34_dxdxdw = T $$( f $ Mon ( 2 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D34_dxdxdw = T $$( f $ Mon ( Vec [ 2, 0, 0, 1 ] ) )
|
||||||
_D34_dxdydw = T $$( f $ Mon ( 1 `VS` 1 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D34_dxdydw = T $$( f $ Mon ( Vec [ 1, 1, 0, 1 ] ) )
|
||||||
_D34_dydydw = T $$( f $ Mon ( 0 `VS` 2 `VS` 0 `VS` 1 `VS` VZ ) )
|
_D34_dydydw = T $$( f $ Mon ( Vec [ 0, 2, 0, 1 ] ) )
|
||||||
_D34_dxdzdw = T $$( f $ Mon ( 1 `VS` 0 `VS` 1 `VS` 1 `VS` VZ ) )
|
_D34_dxdzdw = T $$( f $ Mon ( Vec [ 1, 0, 1, 1 ] ) )
|
||||||
_D34_dydzdw = T $$( f $ Mon ( 0 `VS` 1 `VS` 1 `VS` 1 `VS` VZ ) )
|
_D34_dydzdw = T $$( f $ Mon ( Vec [ 0, 1, 1, 1 ] ) )
|
||||||
_D34_dzdzdw = T $$( f $ Mon ( 0 `VS` 0 `VS` 2 `VS` 1 `VS` VZ ) )
|
_D34_dzdzdw = T $$( f $ Mon ( Vec [ 0, 0, 2, 1 ] ) )
|
||||||
_D34_dxdwdw = T $$( f $ Mon ( 1 `VS` 0 `VS` 0 `VS` 2 `VS` VZ ) )
|
_D34_dxdwdw = T $$( f $ Mon ( Vec [ 1, 0, 0, 2 ] ) )
|
||||||
_D34_dydwdw = T $$( f $ Mon ( 0 `VS` 1 `VS` 0 `VS` 2 `VS` VZ ) )
|
_D34_dydwdw = T $$( f $ Mon ( Vec [ 0, 1, 0, 2 ] ) )
|
||||||
_D34_dzdwdw = T $$( f $ Mon ( 0 `VS` 0 `VS` 1 `VS` 2 `VS` VZ ) )
|
_D34_dzdwdw = T $$( f $ Mon ( Vec [ 0, 0, 1, 2 ] ) )
|
||||||
_D34_dwdwdw = T $$( f $ Mon ( 0 `VS` 0 `VS` 0 `VS` 3 `VS` VZ ) )
|
_D34_dwdwdw = T $$( f $ Mon ( Vec [ 0, 0, 0, 3 ] ) )
|
||||||
in D34 { .. } ||]
|
in D34 { .. } ||]
|
||||||
|
|
||||||
monIndex d = \ case
|
monIndexQ d = \ case
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dx $$d ||]
|
Mon ( Vec [ 1, 0, 0, 0 ] ) -> [|| unT $ _D34_dx $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dy $$d ||]
|
Mon ( Vec [ 0, 1, 0, 0 ] ) -> [|| unT $ _D34_dy $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dz $$d ||]
|
Mon ( Vec [ 0, 0, 1, 0 ] ) -> [|| unT $ _D34_dz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dw $$d ||]
|
Mon ( Vec [ 0, 0, 0, 1 ] ) -> [|| unT $ _D34_dw $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdx $$d ||]
|
Mon ( Vec [ 2, 0, 0, 0 ] ) -> [|| unT $ _D34_dxdx $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdy $$d ||]
|
Mon ( Vec [ 1, 1, 0, 0 ] ) -> [|| unT $ _D34_dxdy $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dydy $$d ||]
|
Mon ( Vec [ 0, 2, 0, 0 ] ) -> [|| unT $ _D34_dydy $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdz $$d ||]
|
Mon ( Vec [ 1, 0, 1, 0 ] ) -> [|| unT $ _D34_dxdz $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dydz $$d ||]
|
Mon ( Vec [ 0, 1, 1, 0 ] ) -> [|| unT $ _D34_dydz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dzdz $$d ||]
|
Mon ( Vec [ 0, 0, 2, 0 ] ) -> [|| unT $ _D34_dzdz $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dxdw $$d ||]
|
Mon ( Vec [ 1, 0, 0, 1 ] ) -> [|| unT $ _D34_dxdw $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dydw $$d ||]
|
Mon ( Vec [ 0, 1, 0, 1 ] ) -> [|| unT $ _D34_dydw $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dzdw $$d ||]
|
Mon ( Vec [ 0, 0, 1, 1 ] ) -> [|| unT $ _D34_dzdw $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D34_dwdw $$d ||]
|
Mon ( Vec [ 0, 0, 0, 2 ] ) -> [|| unT $ _D34_dwdw $$d ||]
|
||||||
Mon ( 3 `VS` 0 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdxdx $$d ||]
|
Mon ( Vec [ 3, 0, 0, 0 ] ) -> [|| unT $ _D34_dxdxdx $$d ||]
|
||||||
Mon ( 2 `VS` 1 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdxdy $$d ||]
|
Mon ( Vec [ 2, 1, 0, 0 ] ) -> [|| unT $ _D34_dxdxdy $$d ||]
|
||||||
Mon ( 1 `VS` 2 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdydy $$d ||]
|
Mon ( Vec [ 1, 2, 0, 0 ] ) -> [|| unT $ _D34_dxdydy $$d ||]
|
||||||
Mon ( 0 `VS` 3 `VS` 0 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dydydy $$d ||]
|
Mon ( Vec [ 0, 3, 0, 0 ] ) -> [|| unT $ _D34_dydydy $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdxdz $$d ||]
|
Mon ( Vec [ 2, 0, 1, 0 ] ) -> [|| unT $ _D34_dxdxdz $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdydz $$d ||]
|
Mon ( Vec [ 1, 1, 1, 0 ] ) -> [|| unT $ _D34_dxdydz $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dxdzdz $$d ||]
|
Mon ( Vec [ 1, 0, 2, 0 ] ) -> [|| unT $ _D34_dxdzdz $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` 1 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dydydz $$d ||]
|
Mon ( Vec [ 0, 2, 1, 0 ] ) -> [|| unT $ _D34_dydydz $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 2 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dydzdz $$d ||]
|
Mon ( Vec [ 0, 1, 2, 0 ] ) -> [|| unT $ _D34_dydzdz $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 3 `VS` 0 `VS` VZ ) -> [|| unT $ _D34_dzdzdz $$d ||]
|
Mon ( Vec [ 0, 0, 3, 0 ] ) -> [|| unT $ _D34_dzdzdz $$d ||]
|
||||||
Mon ( 2 `VS` 0 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dxdxdw $$d ||]
|
Mon ( Vec [ 2, 0, 0, 1 ] ) -> [|| unT $ _D34_dxdxdw $$d ||]
|
||||||
Mon ( 1 `VS` 1 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dxdydw $$d ||]
|
Mon ( Vec [ 1, 1, 0, 1 ] ) -> [|| unT $ _D34_dxdydw $$d ||]
|
||||||
Mon ( 0 `VS` 2 `VS` 0 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dydydw $$d ||]
|
Mon ( Vec [ 0, 2, 0, 1 ] ) -> [|| unT $ _D34_dydydw $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dxdzdw $$d ||]
|
Mon ( Vec [ 1, 0, 1, 1 ] ) -> [|| unT $ _D34_dxdzdw $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 1 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dydzdw $$d ||]
|
Mon ( Vec [ 0, 1, 1, 1 ] ) -> [|| unT $ _D34_dydzdw $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 2 `VS` 1 `VS` VZ ) -> [|| unT $ _D34_dzdzdw $$d ||]
|
Mon ( Vec [ 0, 0, 2, 1 ] ) -> [|| unT $ _D34_dzdzdw $$d ||]
|
||||||
Mon ( 1 `VS` 0 `VS` 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D34_dxdwdw $$d ||]
|
Mon ( Vec [ 1, 0, 0, 2 ] ) -> [|| unT $ _D34_dxdwdw $$d ||]
|
||||||
Mon ( 0 `VS` 1 `VS` 0 `VS` 2 `VS` VZ ) -> [|| unT $ _D34_dydwdw $$d ||]
|
Mon ( Vec [ 0, 1, 0, 2 ] ) -> [|| unT $ _D34_dydwdw $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 1 `VS` 2 `VS` VZ ) -> [|| unT $ _D34_dzdwdw $$d ||]
|
Mon ( Vec [ 0, 0, 1, 2 ] ) -> [|| unT $ _D34_dzdwdw $$d ||]
|
||||||
Mon ( 0 `VS` 0 `VS` 0 `VS` 3 `VS` VZ ) -> [|| unT $ _D34_dwdwdw $$d ||]
|
Mon ( Vec [ 0, 0, 0, 3 ] ) -> [|| unT $ _D34_dwdwdw $$d ||]
|
||||||
_ -> [|| _D34_v $$d ||]
|
_ -> [|| _D34_v $$d ||]
|
||||||
|
|
|
||||||
|
|
@ -243,7 +243,7 @@ computeStrokeOutline ::
|
||||||
|
|
||||||
)
|
)
|
||||||
=> RootSolvingAlgorithm
|
=> RootSolvingAlgorithm
|
||||||
-> Maybe RootIsolationOptions
|
-> Maybe ( RootIsolationOptions 2 3 )
|
||||||
-> FitParameters
|
-> FitParameters
|
||||||
-> ( ptData -> usedParams )
|
-> ( ptData -> usedParams )
|
||||||
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
|
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
|
||||||
|
|
@ -522,7 +522,7 @@ outlineFunction
|
||||||
, Show ptData, Show brushParams
|
, Show ptData, Show brushParams
|
||||||
)
|
)
|
||||||
=> RootSolvingAlgorithm
|
=> RootSolvingAlgorithm
|
||||||
-> Maybe RootIsolationOptions
|
-> Maybe ( RootIsolationOptions 2 3 )
|
||||||
-> ( ptData -> usedParams )
|
-> ( ptData -> usedParams )
|
||||||
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
|
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
|
||||||
-> ( forall {t} k (i :: t)
|
-> ( forall {t} k (i :: t)
|
||||||
|
|
@ -1147,7 +1147,7 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
|
||||||
-- TODO: use Newton's method starting at the midpoint of the box,
|
-- TODO: use Newton's method starting at the midpoint of the box,
|
||||||
-- instead of just taking the midpoint of the box.
|
-- instead of just taking the midpoint of the box.
|
||||||
cuspCoords :: ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () ) )
|
cuspCoords :: ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () ) )
|
||||||
-> ( Int, Box )
|
-> ( Int, Box 2 )
|
||||||
-> Cusp
|
-> Cusp
|
||||||
cuspCoords eqs ( i, 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
cuspCoords eqs ( i, 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
||||||
| StrokeDatum
|
| StrokeDatum
|
||||||
|
|
@ -1168,13 +1168,13 @@ cuspCoords eqs ( i, 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
||||||
--
|
--
|
||||||
-- See 'isolateRootsIn' for details of the algorithms used.
|
-- See 'isolateRootsIn' for details of the algorithms used.
|
||||||
findCusps
|
findCusps
|
||||||
:: RootIsolationOptions
|
:: RootIsolationOptions 2 3
|
||||||
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
||||||
-> IntMap ( [ ( Box, RootIsolationTree Box ) ], ( [ Box ], [ Box ] ) )
|
-> IntMap ( [ ( Box 2, RootIsolationTree ( Box 2 ) ) ], ( [ Box 2 ], [ Box 2 ] ) )
|
||||||
findCusps opts boxStrokeData =
|
findCusps opts boxStrokeData =
|
||||||
findCuspsIn opts boxStrokeData $
|
findCuspsIn opts boxStrokeData $
|
||||||
IntMap.fromList
|
IntMap.fromList
|
||||||
[ ( i, [ 𝕀 ( ℝ2 zero zero ) ( ℝ2 one one ) ] )
|
[ ( i, [ 𝕀 ( ℝ2 zero zero ) ( ℝ2 one one ) ] ) --[ 𝕀 ( ℝ3 zero zero -1e6 ) ( ℝ3 one one 1e6 ) ] )
|
||||||
| i <- [ 0 .. length ( boxStrokeData ( 𝕀 ( ℝ1 zero ) ( ℝ1 one ) ) ) - 1 ]
|
| i <- [ 0 .. length ( boxStrokeData ( 𝕀 ( ℝ1 zero ) ( ℝ1 one ) ) ) - 1 ]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
|
|
@ -1187,10 +1187,10 @@ findCusps opts boxStrokeData =
|
||||||
-- | Like 'findCusps', but parametrised over the initial boxes for the
|
-- | Like 'findCusps', but parametrised over the initial boxes for the
|
||||||
-- root isolation method.
|
-- root isolation method.
|
||||||
findCuspsIn
|
findCuspsIn
|
||||||
:: RootIsolationOptions
|
:: RootIsolationOptions 2 3
|
||||||
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
||||||
-> IntMap [ Box ]
|
-> IntMap [ Box 2 ]
|
||||||
-> IntMap ( [ ( Box, RootIsolationTree Box ) ], ( [ Box ], [ Box ] ) )
|
-> IntMap ( [ ( Box 2, RootIsolationTree ( Box 2 ) ) ], ( [ Box 2 ], [ Box 2 ] ) )
|
||||||
findCuspsIn opts boxStrokeData initBoxes =
|
findCuspsIn opts boxStrokeData initBoxes =
|
||||||
IntMap.mapWithKey ( \ i -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) ) initBoxes
|
IntMap.mapWithKey ( \ i -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) ) initBoxes
|
||||||
where
|
where
|
||||||
|
|
@ -1211,3 +1211,47 @@ findCuspsIn opts boxStrokeData initBoxes =
|
||||||
in D12 ( 𝕀 ( ℝ3 ee_lo f_lo g_lo ) ( ℝ3 ee_hi f_hi g_hi ) )
|
in D12 ( 𝕀 ( ℝ3 ee_lo f_lo g_lo ) ( ℝ3 ee_hi f_hi g_hi ) )
|
||||||
( T $ 𝕀 ( ℝ3 ee_t_lo f_t_lo g_t_lo ) ( ℝ3 ee_t_hi f_t_hi g_t_hi ) )
|
( T $ 𝕀 ( ℝ3 ee_t_lo f_t_lo g_t_lo ) ( ℝ3 ee_t_hi f_t_hi g_t_hi ) )
|
||||||
( T $ 𝕀 ( ℝ3 ee_s_lo f_s_lo g_s_lo ) ( ℝ3 ee_s_hi f_s_hi g_s_hi ) )
|
( T $ 𝕀 ( ℝ3 ee_s_lo f_s_lo g_s_lo ) ( ℝ3 ee_s_hi f_s_hi g_s_hi ) )
|
||||||
|
|
||||||
|
{-
|
||||||
|
findCuspsIn
|
||||||
|
:: RootIsolationOptions 3 3
|
||||||
|
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
||||||
|
-> IntMap [ Box 3 ]
|
||||||
|
-> IntMap ( [ ( Box 3, RootIsolationTree ( Box 3 ) ) ], ( [ Box 3 ], [ Box 3 ] ) )
|
||||||
|
findCuspsIn opts boxStrokeData initBoxes =
|
||||||
|
IntMap.mapWithKey ( \ i -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) ) initBoxes
|
||||||
|
where
|
||||||
|
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
|
||||||
|
{ dstroke =
|
||||||
|
D32 { _D32_dx = T c_t, _D32_dy = T c_s
|
||||||
|
, _D32_dxdx = T c_tt, _D32_dxdy = T c_ts, _D32_dydy = T c_ss }
|
||||||
|
, ee =
|
||||||
|
D22 { _D22_dx = T ee_t, _D22_dy = T ee_s
|
||||||
|
, _D22_dxdx = T ee_tt, _D22_dxdy = T ee_ts, _D22_dydy = T ee_ss }
|
||||||
|
} = ( boxStrokeData t `Seq.index` i ) s
|
||||||
|
|
||||||
|
-- λ ∂E/∂s - ∂E/∂t = 0
|
||||||
|
𝕀 ( ℝ1 f1_lo ) ( ℝ1 f1_hi ) = unT $ λ *^ T ee_s ^-^ T ee_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
|
||||||
|
|
||||||
|
-- λ ∂c/∂s - ∂c/∂t = 0
|
||||||
|
𝕀 ( ℝ2 f2_lo f3_lo ) ( ℝ2 f2_hi f3_hi ) = unT $ λ *^ T c_s ^-^ T c_t
|
||||||
|
𝕀 ( ℝ2 f2_t_lo f3_t_lo ) ( ℝ2 f2_t_hi f3_t_hi ) = unT $ λ *^ T c_ts ^-^ T c_tt
|
||||||
|
𝕀 ( ℝ2 f2_s_lo f3_s_lo ) ( ℝ2 f2_s_hi f3_s_hi ) = unT $ λ *^ T c_ss ^-^ T c_ts
|
||||||
|
𝕀 ( ℝ2 f2_λ_lo f3_λ_lo ) ( ℝ2 f2_λ_hi f3_λ_hi ) = c_s
|
||||||
|
|
||||||
|
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 ) )
|
||||||
|
|
||||||
|
|
||||||
|
-}
|
||||||
|
|
@ -179,14 +179,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -214,14 +214,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -249,14 +249,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -284,14 +284,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -319,14 +319,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -354,14 +354,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -389,14 +389,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
@ -424,14 +424,14 @@ instance HasChainRule ( 𝕀 Double ) 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 $$( monTabulate \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] )
|
||||||
|
|
||||||
value df = $$( monIndex [|| df ||] zeroMonomial )
|
value df = $$( monIndexQ [|| df ||] zeroMonomial )
|
||||||
|
|
||||||
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 )
|
||||||
in $$( monTabulate \ mon ->
|
in $$( monTabulateQ \ mon ->
|
||||||
if | isZeroMonomial mon
|
if | isZeroMonomial mon
|
||||||
-> [|| f v ||]
|
-> [|| f v ||]
|
||||||
| Just i <- isLinear mon
|
| Just i <- isLinear mon
|
||||||
|
|
|
||||||
|
|
@ -10,25 +10,29 @@ module Math.Linear
|
||||||
|
|
||||||
-- * Points and vectors (second version)
|
-- * Points and vectors (second version)
|
||||||
, ℝ(..), T(.., V2, V3, V4)
|
, ℝ(..), T(.., V2, V3, V4)
|
||||||
, Fin(..), MFin(..)
|
, Fin(..), MFin(..), universe, coordinates
|
||||||
, RepDim, RepresentableQ(..)
|
, RepDim, RepresentableQ(..)
|
||||||
, Representable(..), set, injection, projection
|
, Representable(..), set, injection, projection
|
||||||
, Vec(..), (!), find, zipIndices, unzip
|
, Vec(..), (!), find, zipIndices
|
||||||
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Prelude hiding ( unzip )
|
import Prelude hiding ( unzip )
|
||||||
|
import Control.Applicative
|
||||||
|
( ZipList(..) )
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
( coerce )
|
( coerce )
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
( Type )
|
( Type )
|
||||||
|
import GHC.Exts
|
||||||
|
( proxy# )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic, Generic1, Generically(..), Generically1(..) )
|
( Generic, Generic1, Generically(..), Generically1(..) )
|
||||||
|
import GHC.Stack
|
||||||
|
( HasCallStack )
|
||||||
import GHC.TypeNats
|
import GHC.TypeNats
|
||||||
( Nat, type (+) )
|
( Nat, KnownNat, natVal' )
|
||||||
import Unsafe.Coerce
|
|
||||||
( unsafeCoerce )
|
|
||||||
|
|
||||||
-- acts
|
-- acts
|
||||||
import Data.Act
|
import Data.Act
|
||||||
|
|
@ -114,53 +118,36 @@ pattern V4 x y z w = T ( ℝ4 x y z w )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
infixr 5 `VS`
|
|
||||||
type Vec :: Nat -> Type -> Type
|
type Vec :: Nat -> Type -> Type
|
||||||
data Vec n a where
|
newtype Vec n a = Vec { vecList :: [ a ] }
|
||||||
VZ :: Vec 0 a
|
deriving newtype ( Show, Eq, Ord, Functor, Foldable )
|
||||||
VS :: forall n a. a -> Vec n a -> Vec ( 1 + n ) a
|
deriving Applicative via ZipList
|
||||||
-- can't be strict, otherwise we can't conveniently
|
|
||||||
-- unsafeCoerce from lists
|
|
||||||
|
|
||||||
--deriving stock instance Show a => Show ( Vec n a )
|
universe :: forall n. KnownNat n => Vec n ( Fin n )
|
||||||
instance Show a => Show ( Vec n a ) where
|
universe = Vec [ Fin i | i <- [ 1 .. fromIntegral ( natVal' @n proxy# ) ] ]
|
||||||
showsPrec p v = showsPrec p ( unsafeCoerce v :: [ a ] )
|
|
||||||
|
|
||||||
deriving stock instance Functor ( Vec n )
|
coordinates :: forall r u. ( Representable r u ) => u -> Vec ( RepDim u ) r
|
||||||
deriving stock instance Foldable ( Vec n )
|
coordinates u = fmap ( index u ) $ universe @( RepDim u )
|
||||||
deriving stock instance Traversable ( Vec n )
|
{-# INLINEABLE coordinates #-}
|
||||||
|
|
||||||
instance Eq a => Eq ( Vec n a ) where
|
|
||||||
(==) = unsafeCoerce $ (==) @[a]
|
|
||||||
|
|
||||||
instance Ord a => Ord ( Vec n a ) where
|
|
||||||
compare = unsafeCoerce $ compare @[a]
|
|
||||||
(<=) = unsafeCoerce $ (<=) @[a]
|
|
||||||
|
|
||||||
infixl 9 !
|
infixl 9 !
|
||||||
(!) :: forall l a. Vec l a -> Fin l -> a
|
(!) :: forall l a. HasCallStack => Vec l a -> Fin l -> a
|
||||||
v ! Fin i = ( unsafeCoerce v :: [ a ] ) !! fromIntegral i
|
( Vec l ) ! Fin i = l !! ( fromIntegral i - 1 )
|
||||||
|
|
||||||
find :: forall l a. ( a -> Bool ) -> Vec l a -> MFin l
|
find :: forall l a. ( a -> Bool ) -> Vec l a -> MFin l
|
||||||
find f v = MFin ( find_ 1 v )
|
find f ( Vec v ) = MFin ( find_ 1 v )
|
||||||
where
|
where
|
||||||
find_ :: Word -> Vec n a -> Word
|
find_ :: Word -> [ a ] -> Word
|
||||||
find_ j ( VS a as )
|
find_ j ( a : as )
|
||||||
| f a
|
| f a
|
||||||
= j
|
= j
|
||||||
| otherwise
|
| otherwise
|
||||||
= find_ ( j + 1 ) as
|
= find_ ( j + 1 ) as
|
||||||
find_ _ VZ = 0
|
find_ _ [] = 0
|
||||||
|
|
||||||
zipIndices :: forall n a. Vec n a -> [ ( Fin n, a ) ]
|
zipIndices :: forall n a. Vec n a -> [ ( Fin n, a ) ]
|
||||||
zipIndices = zipIndices_ 1
|
zipIndices ( Vec v ) = zipIndices_ 1 v
|
||||||
where
|
where
|
||||||
zipIndices_ :: forall i. Word -> Vec i a -> [ ( Fin n, a ) ]
|
zipIndices_ :: Word -> [ a ] -> [ ( Fin n, a ) ]
|
||||||
zipIndices_ _ VZ = []
|
zipIndices_ _ [] = []
|
||||||
zipIndices_ i (a `VS` as) = ( Fin i, a ) : zipIndices_ ( i + 1 ) as
|
zipIndices_ i (a : as) = ( Fin i, a ) : zipIndices_ ( i + 1 ) as
|
||||||
|
|
||||||
unzip :: Vec n ( a, b ) -> ( Vec n a, Vec n b )
|
|
||||||
unzip VZ = ( VZ, VZ )
|
|
||||||
unzip ( ( a, b ) `VS` ab ) =
|
|
||||||
case unzip ab of
|
|
||||||
( as, bs ) -> ( a `VS` as, b `VS` bs )
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
module Math.Linear.Internal
|
module Math.Linear.Internal
|
||||||
|
|
@ -22,7 +23,7 @@ import GHC.Generics
|
||||||
import GHC.Show
|
import GHC.Show
|
||||||
( showSpace )
|
( showSpace )
|
||||||
import GHC.TypeNats
|
import GHC.TypeNats
|
||||||
( Nat )
|
( Nat, KnownNat )
|
||||||
|
|
||||||
-- template-haskell
|
-- template-haskell
|
||||||
import Language.Haskell.TH
|
import Language.Haskell.TH
|
||||||
|
|
@ -94,7 +95,7 @@ instance Show ( ℝ 4 ) where
|
||||||
-- | 1, ..., n
|
-- | 1, ..., n
|
||||||
type Fin :: Nat -> Type
|
type Fin :: Nat -> Type
|
||||||
newtype Fin n = Fin Word
|
newtype Fin n = Fin Word
|
||||||
deriving stock Eq
|
deriving stock ( Eq, Ord, Show )
|
||||||
|
|
||||||
-- | 0, ..., n
|
-- | 0, ..., n
|
||||||
type MFin :: Nat -> Type
|
type MFin :: Nat -> Type
|
||||||
|
|
@ -109,16 +110,16 @@ class RepresentableQ r v | v -> r where
|
||||||
indexQ :: CodeQ v -> Fin ( RepDim v ) -> CodeQ r
|
indexQ :: CodeQ v -> Fin ( RepDim v ) -> CodeQ r
|
||||||
|
|
||||||
type Representable :: Type -> Type -> Constraint
|
type Representable :: Type -> Type -> Constraint
|
||||||
class Representable r v | v -> r where
|
class KnownNat ( RepDim v ) => Representable r v | v -> r where
|
||||||
tabulate :: ( Fin ( RepDim v ) -> r ) -> v
|
tabulate :: ( Fin ( RepDim v ) -> r ) -> v
|
||||||
index :: v -> Fin ( RepDim v ) -> r
|
index :: v -> Fin ( RepDim v ) -> r
|
||||||
|
|
||||||
{-# INLINEABLE set #-}
|
|
||||||
set :: Representable r v => Fin ( RepDim v ) -> r -> v -> v
|
set :: Representable r v => Fin ( RepDim v ) -> r -> v -> v
|
||||||
set i r u = tabulate \ j ->
|
set i r u = tabulate \ j ->
|
||||||
if i == j
|
if i == j
|
||||||
then r
|
then r
|
||||||
else index u j
|
else index u j
|
||||||
|
{-# INLINEABLE set #-}
|
||||||
|
|
||||||
projection :: ( Representable r u, Representable r v )
|
projection :: ( Representable r u, Representable r v )
|
||||||
=> ( Fin ( RepDim v ) -> Fin ( RepDim u ) )
|
=> ( Fin ( RepDim v ) -> Fin ( RepDim u ) )
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@
|
||||||
|
|
||||||
module Math.Monomial
|
module Math.Monomial
|
||||||
( Mon(..)
|
( Mon(..)
|
||||||
, MonomialBasis(..), Deg, Vars
|
, MonomialBasis(..), MonomialBasisQ(..), Deg, Vars
|
||||||
, zeroMonomial, isZeroMonomial
|
, zeroMonomial, isZeroMonomial
|
||||||
, totalDegree, isLinear
|
, totalDegree, isLinear, linearMonomial
|
||||||
|
|
||||||
, split, mons
|
, split, mons
|
||||||
|
|
||||||
|
|
@ -57,40 +57,44 @@ type family Vars f
|
||||||
zeroMonomial :: forall k n. KnownNat n => Mon k n
|
zeroMonomial :: forall k n. KnownNat n => Mon k n
|
||||||
zeroMonomial = Mon $ unsafeCoerce @[ Word ] @( Vec n Word )
|
zeroMonomial = Mon $ unsafeCoerce @[ Word ] @( Vec n Word )
|
||||||
$ replicate ( fromIntegral $ word @n ) 0
|
$ replicate ( fromIntegral $ word @n ) 0
|
||||||
|
{-# INLINEABLE zeroMonomial #-}
|
||||||
|
|
||||||
isZeroMonomial :: Mon k n -> Bool
|
isZeroMonomial :: Mon k n -> Bool
|
||||||
isZeroMonomial ( Mon VZ ) = True
|
isZeroMonomial ( Mon ( Vec pows ) ) = all ( == 0 ) pows
|
||||||
isZeroMonomial ( Mon ( i `VS` is ) )
|
|
||||||
| i == 0
|
|
||||||
= isZeroMonomial ( Mon is )
|
|
||||||
| otherwise
|
|
||||||
= False
|
|
||||||
|
|
||||||
totalDegree :: Mon k n -> Word
|
totalDegree :: Mon k n -> Word
|
||||||
totalDegree ( Mon VZ ) = 0
|
totalDegree ( Mon ( Vec pows ) ) = sum pows
|
||||||
totalDegree ( Mon ( i `VS` is ) ) = i + totalDegree ( Mon is )
|
|
||||||
|
linearMonomial :: forall k n. ( KnownNat n, 1 <= k ) => Fin n -> Mon k n
|
||||||
|
linearMonomial ( Fin i' ) =
|
||||||
|
Mon $ unsafeCoerce @[ Word ] @( Vec n Word )
|
||||||
|
$ replicate ( i - 1 ) 0 ++ [ 1 ] ++ replicate ( n - i ) 0
|
||||||
|
where
|
||||||
|
n, i :: Int
|
||||||
|
n = fromIntegral $ word @n
|
||||||
|
i = fromIntegral i'
|
||||||
|
{-# INLINEABLE linearMonomial #-}
|
||||||
|
|
||||||
isLinear :: Mon k n -> Maybe ( Fin n )
|
isLinear :: Mon k n -> Maybe ( Fin n )
|
||||||
isLinear = fmap Fin . go 1
|
isLinear ( Mon ( Vec pows ) ) = fmap Fin $ go 1 pows
|
||||||
where
|
where
|
||||||
go :: forall k' n'. Word -> Mon k' n' -> Maybe Word
|
go :: Word -> [ Word ] -> Maybe Word
|
||||||
go _ ( Mon VZ )
|
go _ [] = Nothing
|
||||||
= Nothing
|
go j ( i : is )
|
||||||
go j ( Mon ( i `VS` is ) )
|
|
||||||
| i == 0
|
| i == 0
|
||||||
= go ( j + 1 ) ( Mon is )
|
= go ( j + 1 ) is
|
||||||
| i == 1 && isZeroMonomial ( Mon is )
|
| i == 1 && all ( == 0 ) is
|
||||||
= Just j
|
= Just j
|
||||||
| otherwise
|
| otherwise
|
||||||
= Nothing
|
= Nothing
|
||||||
|
|
||||||
-- | Comultiplication of monomials.
|
-- | Co-multiplication of monomials.
|
||||||
split :: Mon k n -> [ ( Mon k n, Mon k n ) ]
|
split :: Mon k n -> [ ( Mon k n, Mon k n ) ]
|
||||||
split ( Mon VZ ) = [ ( Mon VZ, Mon VZ ) ]
|
split ( Mon ( Vec [] ) ) = [ ( Mon ( Vec [] ), Mon ( Vec [] ) ) ]
|
||||||
split ( Mon ( d `VS` ds ) ) =
|
split ( Mon ( Vec ( d : ds ) ) ) =
|
||||||
[ ( Mon ( i `VS` as ), Mon ( ( d - i ) `VS` bs ) )
|
[ ( Mon ( Vec ( i : as ) ), Mon ( Vec ( ( ( d - i ) : bs ) ) ) )
|
||||||
| i <- [ 0 .. d ]
|
| i <- [ 0 .. d ]
|
||||||
, ( Mon as, Mon bs ) <- ( split ( Mon ds ) )
|
, ( Mon ( Vec as ), Mon ( Vec bs ) ) <- ( split ( Mon ( Vec ds ) ) )
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | All monomials of degree less than or equal to @k@ in @n@ variables,
|
-- | All monomials of degree less than or equal to @k@ in @n@ variables,
|
||||||
|
|
@ -105,12 +109,12 @@ mons' 0 n = [ replicate ( fromIntegral n ) 0 ]
|
||||||
mons' k n = [ i : is | i <- reverse [ 0 .. k ], is <- mons' ( k - i ) ( n - 1 ) ]
|
mons' k n = [ i : is | i <- reverse [ 0 .. k ], is <- mons' ( k - i ) ( n - 1 ) ]
|
||||||
|
|
||||||
subs :: Mon k n -> [ ( Mon k n, Word ) ]
|
subs :: Mon k n -> [ ( Mon k n, Word ) ]
|
||||||
subs ( Mon VZ ) = [ ( Mon VZ, maxBound ) ]
|
subs ( Mon ( Vec []) ) = [ ( Mon ( Vec [] ), maxBound ) ]
|
||||||
subs ( Mon ( i `VS` is ) )
|
subs ( Mon ( Vec ( i : is ) ) )
|
||||||
= [ ( Mon ( j `VS` js )
|
= [ ( Mon ( Vec ( j : js ) )
|
||||||
, if j == 0 then mult else min ( i `quot` j ) mult )
|
, if j == 0 then mult else min ( i `quot` j ) mult )
|
||||||
| j <- [ 0 .. i ]
|
| j <- [ 0 .. i ]
|
||||||
, ( Mon js, mult ) <- subs ( Mon is )
|
, ( Mon ( Vec js ), mult ) <- subs ( Mon ( Vec is ) )
|
||||||
]
|
]
|
||||||
|
|
||||||
word :: forall n. KnownNat n => Word
|
word :: forall n. KnownNat n => Word
|
||||||
|
|
@ -121,8 +125,8 @@ factorial :: Word -> Word
|
||||||
factorial i = product [ 1 .. i ]
|
factorial i = product [ 1 .. i ]
|
||||||
|
|
||||||
vecFactorial :: Vec n Word -> Word
|
vecFactorial :: Vec n Word -> Word
|
||||||
vecFactorial VZ = 1
|
vecFactorial ( Vec [] ) = 1
|
||||||
vecFactorial ( i `VS` is ) = factorial i * vecFactorial is
|
vecFactorial ( Vec ( i : is ) ) = factorial i * vecFactorial ( Vec is )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Computations for the chain rule R^1 -> R^n -> R^m
|
-- Computations for the chain rule R^1 -> R^n -> R^m
|
||||||
|
|
@ -160,13 +164,13 @@ multiSubsetsSum :: forall n
|
||||||
multiSubsetsSum is = goMSS
|
multiSubsetsSum is = goMSS
|
||||||
where
|
where
|
||||||
goMSS :: forall i. Word -> Vec i Word -> [ Vec i [ ( Word, Word ) ] ]
|
goMSS :: forall i. Word -> Vec i Word -> [ Vec i [ ( Word, Word ) ] ]
|
||||||
goMSS 0 VZ = [ VZ ]
|
goMSS 0 ( Vec [] ) = [ Vec [] ]
|
||||||
goMSS _ VZ = [ ]
|
goMSS _ ( Vec [] ) = [ ]
|
||||||
goMSS s (n `VS` ns) =
|
goMSS s ( Vec ( n : ns ) ) =
|
||||||
[ multi `VS` rest
|
[ Vec ( multi : rest )
|
||||||
| s_i <- [ n * i_min .. s ]
|
| s_i <- [ n * i_min .. s ]
|
||||||
, multi <- multiSubsetSum n s_i is
|
, multi <- multiSubsetSum n s_i is
|
||||||
, rest <- goMSS ( s - s_i ) ns ]
|
, Vec rest <- goMSS ( s - s_i ) ( Vec ns ) ]
|
||||||
i_min = case is of
|
i_min = case is of
|
||||||
[] -> 0
|
[] -> 0
|
||||||
_ -> max 0 $ minimum is
|
_ -> max 0 $ minimum is
|
||||||
|
|
@ -224,19 +228,27 @@ subPart' m = zipWith ( \ i j -> i - m * j )
|
||||||
-- monomials in @Vars u@ variables, of degree up to (and including) @Deg u@.
|
-- monomials in @Vars u@ variables, of degree up to (and including) @Deg u@.
|
||||||
type MonomialBasis :: ( Type -> Type ) -> Constraint
|
type MonomialBasis :: ( Type -> Type ) -> Constraint
|
||||||
class MonomialBasis f where
|
class MonomialBasis f where
|
||||||
monTabulate :: ( ( Mon ( Deg f ) ( Vars f ) ) -> CodeQ u ) -> CodeQ ( f u )
|
monTabulate :: ( ( Mon ( Deg f ) ( Vars f ) ) -> u ) -> f u
|
||||||
monIndex :: CodeQ ( f u ) -> Mon ( Deg f ) ( Vars f ) -> CodeQ u
|
monIndex :: f u -> Mon ( Deg f ) ( Vars f ) -> u
|
||||||
|
|
||||||
|
-- | @'MonomialBasisQ' f@ exhibits @f u@ as a free @r@-module with basis the
|
||||||
|
-- monomials in @Vars u@ variables, of degree up to (and including) @Deg u@,
|
||||||
|
-- at compile-time (to be spliced in using TemplateHaskell).
|
||||||
|
type MonomialBasisQ :: ( Type -> Type ) -> Constraint
|
||||||
|
class MonomialBasisQ f where
|
||||||
|
monTabulateQ :: ( ( Mon ( Deg f ) ( Vars f ) ) -> CodeQ u ) -> CodeQ ( f u )
|
||||||
|
monIndexQ :: CodeQ ( f u ) -> Mon ( Deg f ) ( Vars f ) -> CodeQ u
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
prodRuleQ :: forall f r. MonomialBasis f
|
prodRuleQ :: forall f r. MonomialBasisQ f
|
||||||
=> CodeQ r -> CodeQ ( r -> r -> r ) -> CodeQ ( r -> r -> r )
|
=> CodeQ r -> CodeQ ( r -> r -> r ) -> CodeQ ( r -> r -> r )
|
||||||
-- Ring r constraint (circumvent TH constraint problem)
|
-- Ring r constraint (circumvent TH constraint problem)
|
||||||
-> CodeQ ( f r ) -> CodeQ ( f r ) -> CodeQ ( f r )
|
-> CodeQ ( f r ) -> CodeQ ( f r ) -> CodeQ ( f r )
|
||||||
prodRuleQ zero plus times df1 df2 =
|
prodRuleQ zero plus times df1 df2 =
|
||||||
monTabulate @f \ mon ->
|
monTabulateQ @f \ mon ->
|
||||||
[|| $$( foldQ plus zero
|
[|| $$( foldQ plus zero
|
||||||
[ [|| $$times $$( monIndex @f df1 m1 ) $$( monIndex @f df2 m2 ) ||]
|
[ [|| $$times $$( monIndexQ @f df1 m1 ) $$( monIndexQ @f df2 m2 ) ||]
|
||||||
| (m1, m2) <- split mon
|
| (m1, m2) <- split mon
|
||||||
] )
|
] )
|
||||||
||]
|
||]
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Math.Root.Isolation
|
module Math.Root.Isolation
|
||||||
( -- * Root isolation using interval arithmetic
|
( -- * Root isolation using interval arithmetic
|
||||||
Box, BoxHistory
|
Box, BoxHistory
|
||||||
|
|
@ -22,7 +24,6 @@ module Math.Root.Isolation
|
||||||
-- ** Trees recording search space of root isolation algorithms
|
-- ** Trees recording search space of root isolation algorithms
|
||||||
, RootIsolationTree(..), showRootIsolationTree
|
, RootIsolationTree(..), showRootIsolationTree
|
||||||
, RootIsolationStep(..)
|
, RootIsolationStep(..)
|
||||||
, RootIsolationLeaf(..)
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -33,19 +34,35 @@ import Control.Monad
|
||||||
( when )
|
( when )
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
( Bifunctor(bimap) )
|
( Bifunctor(bimap) )
|
||||||
|
import Data.Coerce
|
||||||
|
( coerce )
|
||||||
|
import Data.Kind
|
||||||
|
( Type )
|
||||||
|
import Data.Foldable
|
||||||
|
( toList )
|
||||||
import Data.List
|
import Data.List
|
||||||
( nub, partition)
|
( nub, partition, sort )
|
||||||
import Data.List.NonEmpty
|
import Data.List.NonEmpty
|
||||||
( NonEmpty )
|
( NonEmpty )
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
( NonEmpty(..), last )
|
( NonEmpty(..), last, singleton )
|
||||||
|
import Data.Semigroup
|
||||||
|
( Arg(..), Dual(..) )
|
||||||
import Numeric
|
import Numeric
|
||||||
( showFFloat )
|
( showFFloat )
|
||||||
|
import GHC.TypeNats
|
||||||
|
( Nat, KnownNat )
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import Data.Tree
|
import Data.Tree
|
||||||
( Tree(..) )
|
( Tree(..) )
|
||||||
|
|
||||||
|
-- eigen
|
||||||
|
import qualified Eigen.Matrix as Eigen
|
||||||
|
( Matrix
|
||||||
|
, determinant, generate, inverse, unsafeCoeff
|
||||||
|
)
|
||||||
|
|
||||||
-- transformers
|
-- transformers
|
||||||
import Control.Monad.Trans.State.Strict as State
|
import Control.Monad.Trans.State.Strict as State
|
||||||
( State, evalState, get, put )
|
( State, evalState, get, put )
|
||||||
|
|
@ -54,7 +71,7 @@ import Control.Monad.Trans.Writer.CPS
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Algebra.Dual
|
import Math.Algebra.Dual
|
||||||
( D, D1𝔸2(..) )
|
( D )
|
||||||
import Math.Epsilon
|
import Math.Epsilon
|
||||||
( nearZero )
|
( nearZero )
|
||||||
import Math.Float.Utils
|
import Math.Float.Utils
|
||||||
|
|
@ -63,6 +80,10 @@ import Math.Interval
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( Module(..) )
|
( Module(..) )
|
||||||
|
import Math.Monomial
|
||||||
|
( MonomialBasis(..), Deg, Vars
|
||||||
|
, linearMonomial, zeroMonomial
|
||||||
|
)
|
||||||
import qualified Math.Ring as Ring
|
import qualified Math.Ring as Ring
|
||||||
|
|
||||||
--import Debug.Utils
|
--import Debug.Utils
|
||||||
|
|
@ -71,19 +92,19 @@ import qualified Math.Ring as Ring
|
||||||
|
|
||||||
-- | A tree recording the steps taken when doing cusp finding.
|
-- | A tree recording the steps taken when doing cusp finding.
|
||||||
data RootIsolationTree d
|
data RootIsolationTree d
|
||||||
= RootIsolationLeaf (RootIsolationLeaf d)
|
= RootIsolationLeaf String d
|
||||||
| RootIsolationStep RootIsolationStep [(d, RootIsolationTree d)]
|
| RootIsolationStep RootIsolationStep [(d, RootIsolationTree d)]
|
||||||
|
|
||||||
-- | A description of a step taken in cusp-finding.
|
-- | A description of a step taken in cusp-finding.
|
||||||
data RootIsolationStep
|
data RootIsolationStep
|
||||||
= GaussSeidelStep
|
= GaussSeidelStep
|
||||||
| BisectionStep (String, Double)
|
| BisectionStep String Double
|
||||||
| Box1Step
|
| Box1Step
|
||||||
| Box2Step
|
| Box2Step
|
||||||
|
|
||||||
instance Show RootIsolationStep where
|
instance Show RootIsolationStep where
|
||||||
showsPrec _ GaussSeidelStep = showString "GS"
|
showsPrec _ GaussSeidelStep = showString "GS"
|
||||||
showsPrec _ ( BisectionStep (coord, w) )
|
showsPrec _ ( BisectionStep coord w )
|
||||||
= showString "bis "
|
= showString "bis "
|
||||||
. showParen True
|
. showParen True
|
||||||
( showString coord
|
( showString coord
|
||||||
|
|
@ -93,56 +114,81 @@ instance Show RootIsolationStep where
|
||||||
showsPrec _ Box1Step = showString "box(1)"
|
showsPrec _ Box1Step = showString "box(1)"
|
||||||
showsPrec _ Box2Step = showString "box(2)"
|
showsPrec _ Box2Step = showString "box(2)"
|
||||||
|
|
||||||
data RootIsolationLeaf d
|
showRootIsolationTree
|
||||||
= TooSmall d
|
:: ( Representable Double ( ℝ n ), Show ( Box n ) )
|
||||||
deriving stock Show
|
=> Box n -> RootIsolationTree ( Box n ) -> Tree String
|
||||||
|
showRootIsolationTree cand (RootIsolationLeaf why l) = Node (show cand ++ " " ++ showArea (boxArea cand) ++ " " ++ why ++ " " ++ show l) []
|
||||||
showRootIsolationTree :: Box -> RootIsolationTree Box -> Tree String
|
|
||||||
showRootIsolationTree cand (RootIsolationLeaf l) = Node (show cand ++ " " ++ showArea (boxArea cand) ++ " " ++ show l) []
|
|
||||||
showRootIsolationTree cand (RootIsolationStep s ts)
|
showRootIsolationTree cand (RootIsolationStep s ts)
|
||||||
= Node (show cand ++ " abc " ++ showArea (boxArea cand) ++ " " ++ show s) $ map (\ (c,t) -> showRootIsolationTree c t) ts
|
= Node (show cand ++ " abc " ++ showArea (boxArea cand) ++ " " ++ show s) $ map (\ (c,t) -> showRootIsolationTree c t) ts
|
||||||
|
|
||||||
boxArea :: Box -> Double
|
boxArea :: Representable Double ( ℝ n ) => Box n -> Double
|
||||||
boxArea ( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
boxArea ( 𝕀 lo hi ) =
|
||||||
= abs ( t_hi - t_lo ) * abs ( s_hi - s_lo )
|
product ( ( \ l h -> abs ( h - l ) ) <$> coordinates lo <*> coordinates hi )
|
||||||
|
|
||||||
showArea :: Double -> String
|
showArea :: Double -> String
|
||||||
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
|
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
|
||||||
|
|
||||||
type Box = 𝕀ℝ 2
|
type Box n = 𝕀ℝ n
|
||||||
type BoxHistory = [ NE.NonEmpty ( RootIsolationStep, Box ) ]
|
type BoxHistory n = [ NE.NonEmpty ( RootIsolationStep, Box n ) ]
|
||||||
|
type BoxCt n d = ( n ~ 2, d ~ 3 )
|
||||||
|
{-
|
||||||
|
( Show ( 𝕀ℝ n ), Show ( ℝ n )
|
||||||
|
, Eq ( ℝ n )
|
||||||
|
, Representable Double ( ℝ n )
|
||||||
|
, MonomialBasis ( D 1 ( ℝ n ) )
|
||||||
|
, Deg ( D 1 ( ℝ n ) ) ~ 1
|
||||||
|
, Vars ( D 1 ( ℝ n ) ) ~ n
|
||||||
|
, Module ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
||||||
|
, Applicative ( Vec n )
|
||||||
|
|
||||||
|
, Ord ( ℝ d )
|
||||||
|
, Module Double ( T ( ℝ d ) )
|
||||||
|
, Representable Double ( ℝ d )
|
||||||
|
)
|
||||||
|
-}
|
||||||
|
|
||||||
-- | Options for the root isolation methods in 'findCusps' and 'isolateRootsIn'.
|
-- | Options for the root isolation methods in 'findCusps' and 'isolateRootsIn'.
|
||||||
data RootIsolationOptions
|
type RootIsolationOptions :: Nat -> Nat -> Type
|
||||||
|
data RootIsolationOptions n d
|
||||||
= RootIsolationOptions
|
= RootIsolationOptions
|
||||||
{ -- | Minimum width of a box.
|
{ -- | Minimum width of a box.
|
||||||
minWidth :: !Double
|
minWidth :: !Double
|
||||||
-- | Given a box and its history, return a round of cusp-finding strategies
|
-- | Given a box and its history, return a round of cusp-finding strategies
|
||||||
-- to run, in sequence, on this box.
|
-- to run, in sequence, on this box.
|
||||||
, cuspFindingAlgorithms :: !( Box -> BoxHistory -> NonEmpty RootIsolationAlgorithm )
|
--
|
||||||
|
-- Returning an empty list means: give up on this box.
|
||||||
|
, cuspFindingAlgorithms :: !( Box n -> BoxHistory n -> Either String ( NE.NonEmpty ( RootIsolationAlgorithm n d ) ) )
|
||||||
}
|
}
|
||||||
|
|
||||||
data RootIsolationAlgorithm
|
type RootIsolationAlgorithm :: Nat -> Nat -> Type
|
||||||
|
data RootIsolationAlgorithm n d
|
||||||
-- | Bisection step.
|
-- | Bisection step.
|
||||||
= Bisection !BisectionOptions
|
= Bisection !( BisectionOptions n d )
|
||||||
-- | Gauss–Seidel step with the given preconditioning method.
|
-- | Gauss–Seidel step with the given preconditioning method.
|
||||||
| GaussSeidel !GaussSeidelOptions
|
| GaussSeidel !( GaussSeidelOptions n d )
|
||||||
-- | @box(1)@-consistency.
|
-- | @box(1)@-consistency.
|
||||||
| Box1 !Box1Options
|
| Box1 !Box1Options
|
||||||
-- | @box(2)@-consistency.
|
-- | @box(2)@-consistency.
|
||||||
| Box2 !Box2Options
|
| Box2 !Box2Options
|
||||||
|
|
||||||
-- | Options for the bisection method.
|
-- | Options for the bisection method.
|
||||||
data BisectionOptions =
|
type BisectionOptions :: Nat -> Nat -> Type
|
||||||
|
data BisectionOptions n d =
|
||||||
BisectionOptions
|
BisectionOptions
|
||||||
{ canHaveSols :: !( ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) ) -> Box -> Bool )
|
{ canHaveSols :: !( ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> Box n -> Bool )
|
||||||
, fallbackBisectionDim :: !( [ ( RootIsolationStep, Box ) ] -> BoxHistory -> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) ) -> ( Int, String ) )
|
, fallbackBisectionDim :: !( [ ( RootIsolationStep, Box n ) ] -> BoxHistory n -> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) ) -> ( Fin n, String ) )
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Options for the interval Gauss–Seidel method.
|
-- | Options for the interval Gauss–Seidel method.
|
||||||
data GaussSeidelOptions =
|
type GaussSeidelOptions :: Nat -> Nat -> Type
|
||||||
|
data GaussSeidelOptions n d =
|
||||||
GaussSeidelOptions
|
GaussSeidelOptions
|
||||||
{ gsPreconditioner :: !Preconditioner }
|
{ -- | Which preconditioner to user?
|
||||||
|
gsPreconditioner :: !Preconditioner
|
||||||
|
-- | Function that projects over the equations we will consider
|
||||||
|
-- (the identity for a well-determined problem, or a project for
|
||||||
|
-- an overdetermined system).
|
||||||
|
, gsDims :: ( 𝕀ℝ d -> 𝕀ℝ n ) }
|
||||||
|
|
||||||
-- | Options for the @box(1)@-consistency method.
|
-- | Options for the @box(1)@-consistency method.
|
||||||
data Box1Options =
|
data Box1Options =
|
||||||
|
|
@ -156,7 +202,7 @@ data Box2Options =
|
||||||
, box2LambdaMin :: !Double
|
, box2LambdaMin :: !Double
|
||||||
}
|
}
|
||||||
|
|
||||||
defaultRootIsolationOptions :: RootIsolationOptions
|
defaultRootIsolationOptions :: RootIsolationOptions 2 3
|
||||||
defaultRootIsolationOptions =
|
defaultRootIsolationOptions =
|
||||||
RootIsolationOptions
|
RootIsolationOptions
|
||||||
{ minWidth
|
{ minWidth
|
||||||
|
|
@ -166,68 +212,119 @@ defaultRootIsolationOptions =
|
||||||
minWidth = 1e-5
|
minWidth = 1e-5
|
||||||
narrowAbs = 5e-3
|
narrowAbs = 5e-3
|
||||||
|
|
||||||
defaultRootIsolationAlgorithms :: Double -> Double -> Box -> BoxHistory -> NonEmpty RootIsolationAlgorithm
|
defaultRootIsolationAlgorithms
|
||||||
defaultRootIsolationAlgorithms minWidth narrowAbs box history =
|
:: forall n d
|
||||||
case history of
|
. BoxCt n d
|
||||||
|
=> Double -> Double -> Box n -> BoxHistory n -> Either String ( NE.NonEmpty ( RootIsolationAlgorithm n d ) )
|
||||||
|
defaultRootIsolationAlgorithms minWidth narrowAbs box history
|
||||||
|
-- All the box widths are lower than the minimum width: give up.
|
||||||
|
| and $ ( \ cd -> width cd <= minWidth ) <$> coordinates box
|
||||||
|
= Left $ "sizes <= " ++ show minWidth
|
||||||
|
-- Give up after depth 50
|
||||||
|
-- | length history >= 50
|
||||||
|
-- = Left "depth >= 50"
|
||||||
|
| otherwise
|
||||||
|
= Right $ case history of
|
||||||
lastRoundBoxes : _
|
lastRoundBoxes : _
|
||||||
-- If, in the last round of strategies, we didn't try bisection...
|
-- If, in the last round of strategies, we didn't try bisection...
|
||||||
| any ( \case { BisectionStep {} -> False; _ -> True } . fst ) lastRoundBoxes
|
| any ( \case { BisectionStep {} -> False; _ -> True } . fst ) lastRoundBoxes
|
||||||
, (_, lastRoundFirstBox ) <- NE.last lastRoundBoxes
|
, ( _step, lastRoundFirstBox ) <- NE.last lastRoundBoxes
|
||||||
-- ...and the last round didn't sufficiently reduce the size of the box...
|
-- ...and the last round didn't sufficiently reduce the size of the box...
|
||||||
, not $ box `sufficientlySmallerThan` lastRoundFirstBox
|
, not $ box `sufficientlySmallerThan` lastRoundFirstBox
|
||||||
-- ...then try bisecting the box.
|
-- ...then try bisecting the box.
|
||||||
-> Bisection ( defaultBisectionOptions minWidth narrowAbs box ) NE.:| []
|
-> NE.singleton $ Bisection ( defaultBisectionOptions minWidth narrowAbs box )
|
||||||
|
|
||||||
-- Otherwise, do a normal round.
|
-- Otherwise, do a normal round.
|
||||||
-- Currently: we try an interval Gauss–Seidel step followed by box(1)-consistency.
|
-- Currently: we try an interval Gauss–Seidel step followed by box(1)-consistency.
|
||||||
_ -> GaussSeidel defaultGaussSeidelOptions
|
_ -> GaussSeidel defaultGaussSeidelOptions
|
||||||
NE.:| [ Box1 ( Box1Options { box1EpsEq = narrowAbs } ) ]
|
NE.:| [ Box1 ( Box1Options { box1EpsEq = narrowAbs } ) ]
|
||||||
where
|
where
|
||||||
sufficientlySmallerThan :: Box -> Box -> Bool
|
-- Did we reduce the box width by at least "narrowAbs" in at least one of the dimensions?
|
||||||
sufficientlySmallerThan
|
sufficientlySmallerThan :: Box n -> Box n -> Bool
|
||||||
( 𝕀 ( ℝ2 t1_lo s1_lo ) ( ℝ2 t1_hi s1_hi ) )
|
b1 `sufficientlySmallerThan` b2 =
|
||||||
( 𝕀 ( ℝ2 t2_lo s2_lo ) ( ℝ2 t2_hi s2_hi ) ) =
|
or $
|
||||||
( ( t1_hi - t1_lo ) - ( t2_hi - t2_lo ) > narrowAbs )
|
( \ cd1 cd2 -> width cd2 - width cd1 > narrowAbs )
|
||||||
||
|
<$> coordinates b1
|
||||||
( ( s1_hi - s1_lo ) - ( s2_hi - s2_lo ) > narrowAbs )
|
<*> coordinates b2
|
||||||
|
{-# INLINEABLE defaultRootIsolationAlgorithms #-}
|
||||||
|
|
||||||
defaultGaussSeidelOptions :: GaussSeidelOptions
|
defaultGaussSeidelOptions :: GaussSeidelOptions 2 3
|
||||||
defaultGaussSeidelOptions = GaussSeidelOptions { gsPreconditioner = InverseMidJacobian }
|
defaultGaussSeidelOptions =
|
||||||
|
GaussSeidelOptions
|
||||||
|
{ gsPreconditioner = InverseMidJacobian
|
||||||
|
, gsDims = --id
|
||||||
|
\ ( 𝕀 ( ℝ3 _a_lo b_lo c_lo ) ( ℝ3 _a_hi b_hi c_hi ) )
|
||||||
|
-> 𝕀 ( ℝ2 b_lo c_lo ) ( ℝ2 b_hi c_hi )
|
||||||
|
}
|
||||||
|
|
||||||
defaultBisectionOptions :: Double -> Double -> Box -> BisectionOptions
|
|
||||||
defaultBisectionOptions
|
defaultBisectionOptions
|
||||||
_minWidth
|
:: forall n d
|
||||||
_narrowAbs
|
. BoxCt n d
|
||||||
box@( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
=> Double -> Double
|
||||||
= BisectionOptions
|
-> Box n -> BisectionOptions n d
|
||||||
|
defaultBisectionOptions _minWidth _narrowAbs box =
|
||||||
|
BisectionOptions
|
||||||
{ canHaveSols =
|
{ canHaveSols =
|
||||||
\ eqs box' ->
|
\ eqs box' ->
|
||||||
-- box(0)-consistency
|
-- box(0)-consistency
|
||||||
let D12 iRange _ _ = eqs box'
|
let iRange' :: Box d
|
||||||
in ℝ3 0 0 0 `inside` iRange
|
iRange' = ( `monIndex` zeroMonomial ) $ eqs box'
|
||||||
|
in unT ( origin @Double ) `inside` iRange'
|
||||||
|
|
||||||
-- box(1)-consistency
|
-- box(1)-consistency
|
||||||
--not $ null $ makeBox1Consistent eqs _minWidth _narrowAbs box'
|
--not $ null $ makeBox1Consistent eqs _minWidth _narrowAbs box'
|
||||||
|
|
||||||
-- box(2)-consistency
|
-- box(2)-consistency
|
||||||
--let box'' = makeBox2Consistent eqs _minWidth _narrowAbs 0.2 box'
|
--let box'' = makeBox2Consistent eqs _minWidth _narrowAbs 0.2 box'
|
||||||
-- D12 iRange'' = eqs box''
|
-- iRange'' :: Box d
|
||||||
--in ℝ3 0 0 0 `inside` iRange''
|
-- iRange'' = value @Double @1 @( Box n ) $ eqs box''
|
||||||
|
--in origin @Double `inside` iRange''
|
||||||
, fallbackBisectionDim =
|
, fallbackBisectionDim =
|
||||||
\ _roundHist _prevRoundsHist eqs ->
|
\ _roundHist _prevRoundsHist eqs ->
|
||||||
let D12 _ ( T f_t ) ( T f_s ) = eqs box
|
let df = eqs box
|
||||||
wd_t = t_hi - t_lo
|
datPerCoord =
|
||||||
wd_s = s_hi - s_lo
|
[ CoordBisectionData
|
||||||
tJWidth = wd_t * normVI3 f_t
|
{ coordIndex = i
|
||||||
sJWidth = wd_s * normVI3 f_s
|
, coordInterval = box `index` i
|
||||||
in if tJWidth >= sJWidth
|
, coordJacobianColumn = df `monIndex` ( linearMonomial i )
|
||||||
-- bisect along dimension that maximises width(x_j) * || J_j || ...
|
|
||||||
-- ... but don't allow thin boxes
|
|
||||||
|| ( wd_t >= 10 * wd_s )
|
|
||||||
&& not ( wd_s >= 10 * wd_t )
|
|
||||||
then (0, "")
|
|
||||||
else (1, "")
|
|
||||||
}
|
}
|
||||||
|
| i <- toList $ universe @n ]
|
||||||
|
|
||||||
|
-- First, check if the largest dimension is over 10 times larger
|
||||||
|
-- than the smallest dimension; if so bisect along that coordinate.
|
||||||
|
in case sortOnArg ( width . coordInterval ) datPerCoord of
|
||||||
|
[] -> error "dimension 0"
|
||||||
|
[Arg _ d] -> (coordIndex d, "")
|
||||||
|
Arg w0 _ : ds ->
|
||||||
|
let Arg w1 d1 = last ds
|
||||||
|
in if w1 >= 10 * w0
|
||||||
|
then ( coordIndex d1, "tooWide")
|
||||||
|
-- Otherwise, pick the dimension with the largest spread = width * Jacobian column norm
|
||||||
|
else case sortOnArg ( Dual . spread ) datPerCoord of
|
||||||
|
[] -> error "dimension 0"
|
||||||
|
Arg _ d : _ ->
|
||||||
|
(coordIndex d, "spread")
|
||||||
|
}
|
||||||
|
{-# INLINEABLE defaultBisectionOptions #-}
|
||||||
|
|
||||||
|
sortOnArg :: Ord b => (a -> b) -> [a] -> [Arg b a]
|
||||||
|
sortOnArg f = sort . map ( \ a -> Arg ( f a ) a )
|
||||||
|
{-# INLINEABLE sortOnArg #-}
|
||||||
|
|
||||||
|
type CoordBisectionData :: Nat -> Nat -> Type
|
||||||
|
data CoordBisectionData n d =
|
||||||
|
CoordBisectionData
|
||||||
|
{ coordIndex :: !( Fin n )
|
||||||
|
, coordInterval :: !( 𝕀 Double )
|
||||||
|
, coordJacobianColumn :: !( 𝕀ℝ d )
|
||||||
|
}
|
||||||
|
deriving stock instance Show ( ℝ d )
|
||||||
|
=> Show ( CoordBisectionData n d )
|
||||||
|
|
||||||
|
spread :: ( BoxCt n d, Representable Double ( ℝ d ) )
|
||||||
|
=> CoordBisectionData n d -> Double
|
||||||
|
spread ( CoordBisectionData { coordInterval = cd, coordJacobianColumn = j_cd } )
|
||||||
|
= width cd * normVI j_cd
|
||||||
|
{-# INLINEABLE spread #-}
|
||||||
|
|
||||||
-- | Use the following algorithms using interval arithmetic in order
|
-- | Use the following algorithms using interval arithmetic in order
|
||||||
-- to isolate roots:
|
-- to isolate roots:
|
||||||
|
|
@ -243,10 +340,12 @@ defaultBisectionOptions
|
||||||
-- will converge starting from anywhere inside the box), and @dunno@ are small
|
-- will converge starting from anywhere inside the box), and @dunno@ are small
|
||||||
-- boxes which might or might not contain solutions.
|
-- boxes which might or might not contain solutions.
|
||||||
isolateRootsIn
|
isolateRootsIn
|
||||||
:: RootIsolationOptions
|
:: forall n d
|
||||||
-> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) )
|
. BoxCt n d
|
||||||
-> Box
|
=> RootIsolationOptions n d
|
||||||
-> ( [ ( Box, RootIsolationTree Box ) ], ( [ Box ], [ Box ] ) )
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
|
-> Box n
|
||||||
|
-> ( [ ( Box n, RootIsolationTree ( Box n ) ) ], ( [ Box n ], [ Box n ] ) )
|
||||||
isolateRootsIn
|
isolateRootsIn
|
||||||
( RootIsolationOptions
|
( RootIsolationOptions
|
||||||
{ minWidth
|
{ minWidth
|
||||||
|
|
@ -257,40 +356,41 @@ isolateRootsIn
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
go :: BoxHistory
|
go :: BoxHistory n
|
||||||
-> Box -- box to work on
|
-> Box n -- box to work on
|
||||||
-> Writer ( [ Box ], [ Box ] )
|
-> Writer ( [ Box n ], [ Box n ] )
|
||||||
[ RootIsolationTree Box ]
|
[ RootIsolationTree ( Box n ) ]
|
||||||
go history
|
go history cand
|
||||||
cand@( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
| -- Check the range of the equations contains zero.
|
||||||
| -- Check the envelope equation interval contains zero.
|
not $ ( unT ( origin @Double ) `inside` iRange )
|
||||||
not $ ( ℝ3 0 0 0 `inside` iRange )
|
|
||||||
-- Box doesn't contain a solution: discard it.
|
-- Box doesn't contain a solution: discard it.
|
||||||
= return []
|
= return []
|
||||||
-- Box is small: stop processing it.
|
|
||||||
| t_hi - t_lo < minWidth && s_hi - s_lo < minWidth
|
|
||||||
= do let res = TooSmall cand
|
|
||||||
tell ( [ cand ], [] )
|
|
||||||
return [ RootIsolationLeaf res ]
|
|
||||||
| otherwise
|
| otherwise
|
||||||
= doStrategies history ( cuspFindingAlgorithms cand history ) cand
|
= case cuspFindingAlgorithms cand history of
|
||||||
|
Right strats -> doStrategies history strats cand
|
||||||
|
Left whyStop -> do
|
||||||
|
-- We are giving up on this box (e.g. because it is too small,
|
||||||
|
-- or we have reached an iteration depth).
|
||||||
|
tell ( [ cand ], [] )
|
||||||
|
return [ RootIsolationLeaf whyStop cand ]
|
||||||
where
|
where
|
||||||
D12 iRange _ _ = eqs $ 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi )
|
iRange :: Box d
|
||||||
|
iRange = ( `monIndex` zeroMonomial ) $ eqs cand
|
||||||
|
|
||||||
-- Run a round of cusp finding strategies, then recur.
|
-- Run a round of cusp finding strategies, then recur.
|
||||||
doStrategies
|
doStrategies
|
||||||
:: BoxHistory
|
:: BoxHistory n
|
||||||
-> NonEmpty RootIsolationAlgorithm
|
-> NonEmpty ( RootIsolationAlgorithm n d )
|
||||||
-> Box
|
-> Box n
|
||||||
-> Writer ( [ Box ], [ Box ] )
|
-> Writer ( [ Box n ], [ Box n ] )
|
||||||
[ RootIsolationTree Box ]
|
[ RootIsolationTree ( Box n ) ]
|
||||||
doStrategies prevRoundsHist = do_strats []
|
doStrategies prevRoundsHist = do_strats []
|
||||||
where
|
where
|
||||||
do_strats :: [ ( RootIsolationStep, Box ) ]
|
do_strats :: [ ( RootIsolationStep, Box n ) ]
|
||||||
-> NE.NonEmpty RootIsolationAlgorithm
|
-> NE.NonEmpty ( RootIsolationAlgorithm n d )
|
||||||
-> Box
|
-> Box n
|
||||||
-> Writer ( [ Box ], [ Box ] )
|
-> Writer ( [ Box n ], [ Box n ] )
|
||||||
[ RootIsolationTree Box ]
|
[ RootIsolationTree ( Box n )]
|
||||||
do_strats thisRoundHist ( algo NE.:| algos ) box = do
|
do_strats thisRoundHist ( algo NE.:| algos ) box = do
|
||||||
-- Run one strategy in the round.
|
-- Run one strategy in the round.
|
||||||
( step, boxes ) <- doStrategy thisRoundHist prevRoundsHist eqs minWidth algo box
|
( step, boxes ) <- doStrategy thisRoundHist prevRoundsHist eqs minWidth algo box
|
||||||
|
|
@ -307,116 +407,137 @@ isolateRootsIn
|
||||||
in recur step ( go history ) boxes
|
in recur step ( go history ) boxes
|
||||||
|
|
||||||
recur :: RootIsolationStep
|
recur :: RootIsolationStep
|
||||||
-> ( Box -> Writer ( [ Box ], [ Box ] ) [ RootIsolationTree Box ] )
|
-> ( Box n -> Writer ( [ Box n ], [ Box n ] ) [ RootIsolationTree ( Box n ) ] )
|
||||||
-> [ Box ]
|
-> [ Box n ]
|
||||||
-> Writer ( [Box], [Box] ) [ RootIsolationTree Box ]
|
-> Writer ( [ Box n ], [ Box n ] ) [ RootIsolationTree ( Box n ) ]
|
||||||
recur step r cands = do
|
recur step r cands = do
|
||||||
rest <- traverse ( \ c -> do { trees <- r c; return [ (c, tree) | tree <- trees ] } ) cands
|
rest <- traverse ( \ c -> do { trees <- r c; return [ (c, tree) | tree <- trees ] } ) cands
|
||||||
return [ RootIsolationStep step $ concat rest ]
|
return [ RootIsolationStep step $ concat rest ]
|
||||||
|
{-# INLINEABLE isolateRootsIn #-}
|
||||||
|
|
||||||
-- | Execute a cusp-finding strategy, replacing the input box with
|
-- | Execute a cusp-finding strategy, replacing the input box with
|
||||||
-- (hopefully smaller) output boxes.
|
-- (hopefully smaller) output boxes.
|
||||||
doStrategy :: [ ( RootIsolationStep, Box ) ]
|
doStrategy
|
||||||
-> BoxHistory
|
:: BoxCt n d
|
||||||
-> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) )
|
=> [ ( RootIsolationStep, Box n ) ]
|
||||||
|
-> BoxHistory n
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
-> Double
|
-> Double
|
||||||
-> RootIsolationAlgorithm
|
-> RootIsolationAlgorithm n d
|
||||||
-> Box
|
-> Box n
|
||||||
-> Writer ( [ Box ], [ Box ] )
|
-> Writer ( [ Box n ], [ Box n ] )
|
||||||
( RootIsolationStep, [ Box ] )
|
( RootIsolationStep, [ Box n ] )
|
||||||
doStrategy roundHistory previousRoundsHistory eqs minWidth algo box =
|
doStrategy roundHistory previousRoundsHistory eqs minWidth algo box =
|
||||||
case algo of
|
case algo of
|
||||||
GaussSeidel ( GaussSeidelOptions { gsPreconditioner } ) -> do
|
GaussSeidel gsOptions -> do
|
||||||
boxes <- intervalGaussSeidel eqs gsPreconditioner box
|
boxes <- intervalGaussSeidel gsOptions eqs box
|
||||||
return ( GaussSeidelStep, boxes )
|
return ( GaussSeidelStep, boxes )
|
||||||
Box1 ( Box1Options { box1EpsEq } ) ->
|
Box1 ( Box1Options { box1EpsEq } ) ->
|
||||||
return ( Box1Step, makeBox1Consistent eqs minWidth box1EpsEq box )
|
return ( Box1Step, makeBox1Consistent eqs minWidth box1EpsEq box )
|
||||||
Box2 ( Box2Options { box2LambdaMin, box2EpsEq } ) ->
|
Box2 ( Box2Options { box2LambdaMin, box2EpsEq } ) ->
|
||||||
return ( Box2Step, [ makeBox2Consistent eqs minWidth box2EpsEq box2LambdaMin box ] )
|
return ( Box2Step, [ makeBox2Consistent eqs minWidth box2EpsEq box2LambdaMin box ] )
|
||||||
Bisection ( BisectionOptions { canHaveSols, fallbackBisectionDim } ) -> do
|
Bisection ( BisectionOptions { canHaveSols, fallbackBisectionDim } ) -> do
|
||||||
let ( boxes, whatBis ) = bisect ( canHaveSols eqs ) ( fallbackBisectionDim roundHistory previousRoundsHistory eqs ) box
|
let ( boxes, ( whatBis, mid ) ) = bisect ( canHaveSols eqs ) ( fallbackBisectionDim roundHistory previousRoundsHistory eqs ) box
|
||||||
return ( BisectionStep whatBis, boxes )
|
return ( BisectionStep whatBis mid, boxes )
|
||||||
|
{-# INLINEABLE doStrategy #-}
|
||||||
|
|
||||||
-- | Bisect the given box.
|
-- | Bisect the given box.
|
||||||
--
|
--
|
||||||
-- (The difficult part lies in determining along which dimension to bisect.)
|
-- (The difficult part lies in determining along which dimension to bisect.)
|
||||||
bisect :: ( Box -> Bool )
|
bisect
|
||||||
|
:: forall n
|
||||||
|
. ( KnownNat n, Representable Double ( ℝ n ) )
|
||||||
|
=> ( Box n -> Bool )
|
||||||
-- ^ how to check whether a box contains solutions
|
-- ^ how to check whether a box contains solutions
|
||||||
-> ( Int, String )
|
-> ( Fin n, String )
|
||||||
-- ^ fall-back choice of dimension (and "why" we chose it)
|
-- ^ fallback choice of dimension (and "why" we chose it)
|
||||||
-> Box
|
-> Box n
|
||||||
-> ( [ Box ], ( String, Double ) )
|
-> ( [ Box n ], ( String, Double ) )
|
||||||
bisect canHaveSols ( dim, why )
|
bisect canHaveSols ( fallbackDim, why ) box =
|
||||||
( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
|
||||||
-- We try to bisect along a dimension which eliminates zeros from one of the
|
-- We try to bisect along a dimension which eliminates zeros from one of the
|
||||||
-- sub-regions.
|
-- sub-regions.
|
||||||
--
|
--
|
||||||
-- If this fails, we fall-back to the provided dimension choice.
|
-- If this fails, we fall back to the provided dimension choice.
|
||||||
= let t_mid = 0.5 * ( t_lo + t_hi )
|
case findFewestSols solsList of
|
||||||
s_mid = 0.5 * ( s_lo + s_hi )
|
Just ( Arg _nbSols ( i, mid, oks ) ) ->
|
||||||
l = 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_mid s_hi )
|
( oks, ("cd = " ++ show i, mid ) )
|
||||||
r = 𝕀 ( ℝ2 t_mid s_lo ) ( ℝ2 t_hi s_hi )
|
Nothing ->
|
||||||
d = 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_mid )
|
case bisectInCoord box fallbackDim of
|
||||||
u = 𝕀 ( ℝ2 t_lo s_mid ) ( ℝ2 t_hi s_hi )
|
( mid, (lo, hi) ) ->
|
||||||
l_skip = not $ canHaveSols l
|
( [ lo, hi ], ( why, mid ) )
|
||||||
r_skip = not $ canHaveSols r
|
where
|
||||||
d_skip = not $ canHaveSols d
|
solsList =
|
||||||
u_skip = not $ canHaveSols u
|
[ Arg ( fromIntegral $ length oks ) ( i, mid, oks )
|
||||||
|
| i <- toList $ universe @n
|
||||||
|
, let (mid, (lo, hi)) = bisectInCoord box i
|
||||||
|
lo_ok = canHaveSols lo
|
||||||
|
hi_ok = canHaveSols hi
|
||||||
|
oks = [ lo | lo_ok ] ++ [ hi | hi_ok ]
|
||||||
|
]
|
||||||
|
{-# INLINEABLE bisect #-}
|
||||||
|
|
||||||
( bisGuesses, whatBis )
|
-- | Find any element with the least argument.
|
||||||
| l_skip && r_skip
|
--
|
||||||
= ( [], ( "lr", t_mid ) )
|
-- NB: this function shortcuts as soon as it finds an element with argument 0.
|
||||||
| d_skip && u_skip
|
findFewestSols :: forall a. [ Arg Word a ] -> Maybe ( Arg Word a )
|
||||||
= ( [], ( "du", s_mid ) )
|
findFewestSols [] = Nothing
|
||||||
| l_skip
|
findFewestSols ( arg@( Arg nbSols _ ) : args )
|
||||||
= ( [ r ], ( "r", t_mid ) )
|
| nbSols == 0
|
||||||
| r_skip
|
= Just arg
|
||||||
= ( [ l ], ( "l", t_mid ) )
|
|
||||||
| d_skip
|
|
||||||
= ( [ u ], ( "u", s_mid ) )
|
|
||||||
| u_skip
|
|
||||||
= ( [ d ], ( "d", s_mid ) )
|
|
||||||
| otherwise
|
| otherwise
|
||||||
= let why' = case why of
|
= Just $ go arg args
|
||||||
"" -> ""
|
where
|
||||||
_ -> " (" ++ why ++ ")"
|
go :: Arg Word a -> [ Arg Word a ] -> Arg Word a
|
||||||
in case dim of
|
go bestSoFar [] = bestSoFar
|
||||||
0 -> ( [ l, r ], ( "t" ++ why', t_mid ) )
|
go bestSoFar@( Arg bestNbSolsSoFar _ ) ( arg'@( Arg nbSols' _ ) : args' )
|
||||||
1 -> ( [ d, u ], ( "s" ++ why', s_mid ) )
|
| nbSols' == 0
|
||||||
_ -> error "bisect: fall-back bisection dimension should be either 0 or 1"
|
= arg'
|
||||||
in ( bisGuesses, whatBis )
|
| nbSols' < bestNbSolsSoFar
|
||||||
|
= go arg' args'
|
||||||
|
| otherwise
|
||||||
|
= go bestSoFar args'
|
||||||
|
|
||||||
|
bisectInCoord
|
||||||
|
:: Representable Double ( ℝ n )
|
||||||
|
=> Box n -> Fin n -> ( Double, ( Box n, Box n ) )
|
||||||
|
bisectInCoord box i =
|
||||||
|
let 𝕀 z_lo z_hi = box `index` i
|
||||||
|
z_mid = 0.5 * ( z_lo + z_hi )
|
||||||
|
in ( z_mid
|
||||||
|
, ( set i ( 𝕀 z_lo z_mid ) box
|
||||||
|
, set i ( 𝕀 z_mid z_hi ) box ) )
|
||||||
|
{-# INLINEABLE bisectInCoord #-}
|
||||||
|
|
||||||
-- | Interval Newton method with Gauss–Seidel step.
|
-- | Interval Newton method with Gauss–Seidel step.
|
||||||
intervalGaussSeidel
|
intervalGaussSeidel
|
||||||
:: ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) )
|
:: forall n d
|
||||||
|
. BoxCt n d
|
||||||
|
=> GaussSeidelOptions n d
|
||||||
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
-- ^ equations
|
-- ^ equations
|
||||||
-> Preconditioner
|
-> 𝕀ℝ n
|
||||||
-- ^ preconditioner to use for the Gauss–Seidel step
|
-- ^ box
|
||||||
-> 𝕀ℝ 2
|
-> Writer ( [ 𝕀ℝ n ], [ 𝕀ℝ n ] ) [ 𝕀ℝ n ]
|
||||||
-> Writer ( [ 𝕀ℝ 2 ], [ 𝕀ℝ 2 ] ) [ 𝕀ℝ 2 ]
|
|
||||||
intervalGaussSeidel
|
intervalGaussSeidel
|
||||||
|
( GaussSeidelOptions { gsPreconditioner = precondMeth, gsDims = projectDims } )
|
||||||
eqs
|
eqs
|
||||||
precondMethod
|
box
|
||||||
ts@( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) )
|
| let boxMid = singleton $ midpoint box
|
||||||
| D12 _f ( T ee_f_t ) ( T ee_f_s )
|
df = eqs box
|
||||||
<- eqs ts
|
f' :: Vec n ( 𝕀ℝ n )
|
||||||
, let f_t = take2 ee_f_t
|
f' = fmap ( \ i -> projectDims $ df `monIndex` linearMonomial i ) ( universe @n )
|
||||||
f_s = take2 ee_f_s
|
f_mid = projectDims $ eqs boxMid `monIndex` zeroMonomial
|
||||||
, D12 ee_f_mid ( T _ee_f_t_mid ) ( T _ee_f_s_mid )
|
|
||||||
<- eqs ts_mid
|
|
||||||
, let f_mid = take2 ee_f_mid
|
|
||||||
|
|
||||||
= let -- Interval Newton method: take one Gauss–Seidel step
|
= let -- Interval Newton method: take one Gauss–Seidel step
|
||||||
-- for the equation f'(x) v = - f(x_mid),
|
-- for the system of equations f'(x) ( x - x_mid ) = - f(x_mid).
|
||||||
-- where f = 𝛿E/𝛿s * dc/dt
|
( a, b ) = precondition precondMeth
|
||||||
( a, b ) = precondition precondMethod
|
( fmap midpoint f' )
|
||||||
( midI f_t, midI f_s )
|
f' ( negateBox $ singleton $ midpoint $ f_mid )
|
||||||
( f_t, f_s ) ( neg f_mid )
|
|
||||||
|
|
||||||
-- NB: we have to re-center around zero to take a Gauss–Seidel step.
|
-- NB: we have to change coordinates, putting the midpoint of the box
|
||||||
gsGuesses = map ( first ( \ ts' -> unT $ T ts' ^+^ T ts_mid ) )
|
-- at the origin, in order to take a Gauss–Seidel step.
|
||||||
$ gaussSeidelStep a b ( unT $ T ts ^-^ T ts_mid )
|
gsGuesses = map ( first ( \ box' -> unT $ box' ^+^ T boxMid ) )
|
||||||
|
$ gaussSeidelStep a b ( T box ^-^ T boxMid )
|
||||||
in
|
in
|
||||||
-- If the Gauss–Seidel step was a contraction, then the box
|
-- If the Gauss–Seidel step was a contraction, then the box
|
||||||
-- contains a unique solution (by the Banach fixed point theorem).
|
-- contains a unique solution (by the Banach fixed point theorem).
|
||||||
|
|
@ -428,54 +549,55 @@ intervalGaussSeidel
|
||||||
in do tell ( [], done )
|
in do tell ( [], done )
|
||||||
return todo
|
return todo
|
||||||
where
|
where
|
||||||
t_mid = 0.5 * ( t_lo + t_hi )
|
{-# INLINEABLE intervalGaussSeidel #-}
|
||||||
s_mid = 0.5 * ( s_lo + s_hi )
|
|
||||||
ts_mid = singleton ( ℝ2 t_mid s_mid )
|
|
||||||
neg ( 𝕀 ( ℝ2 x_lo y_lo ) ( ℝ2 x_hi y_hi ) )
|
|
||||||
= let !( 𝕀 x'_lo x'_hi ) = negate $ 𝕀 x_lo x_hi
|
|
||||||
!( 𝕀 y'_lo y'_hi ) = negate $ 𝕀 y_lo y_hi
|
|
||||||
in 𝕀 ( ℝ2 x'_lo y'_lo ) ( ℝ2 x'_hi y'_hi )
|
|
||||||
take2 :: 𝕀ℝ 3 -> 𝕀ℝ 2
|
|
||||||
take2 ( 𝕀 ( ℝ3 _a_lo b_lo c_lo ) ( ℝ3 _a_hi b_hi c_hi ) )
|
|
||||||
= 𝕀 ( ℝ2 b_lo c_lo ) ( ℝ2 b_hi c_hi )
|
|
||||||
-- TODO: always using the last 2 coordinates, instead of any
|
|
||||||
-- pair of two coordinates.
|
|
||||||
|
|
||||||
-- Take one interval Gauss–Seidel step for the equation \( A X = B \),
|
-- | The midpoint of a box.
|
||||||
-- refining the initial guess box for \( X \) into up to four (disjoint) new boxes.
|
midpoint :: Representable Double ( ℝ n ) => 𝕀ℝ n -> ℝ n
|
||||||
|
midpoint box =
|
||||||
|
tabulate $ \ i ->
|
||||||
|
let 𝕀 z_lo z_hi = index box i
|
||||||
|
z_mid = 0.5 * ( z_lo + z_hi )
|
||||||
|
in z_mid
|
||||||
|
{-# INLINEABLE midpoint #-}
|
||||||
|
|
||||||
|
-- | Negate a box.
|
||||||
|
negateBox :: Representable Double ( ℝ n ) => 𝕀ℝ n -> 𝕀ℝ n
|
||||||
|
negateBox v = tabulate $ \ i -> negate ( index v i )
|
||||||
|
{-# INLINEABLE negateBox #-}
|
||||||
|
|
||||||
|
-- | Take one interval Gauss–Seidel step for the equation \( A X = B \),
|
||||||
|
-- refining the initial guess box for \( X \) into up to \( 2^n \) (disjoint) new boxes.
|
||||||
--
|
--
|
||||||
-- The boolean indicates whether the Gauss–Seidel step was a contraction.
|
-- The boolean indicates whether the Gauss–Seidel step was a contraction.
|
||||||
gaussSeidelStep :: ( 𝕀ℝ 2, 𝕀ℝ 2 ) -- ^ columns of \( A \)
|
|
||||||
-> 𝕀ℝ 2 -- ^ \( B \)
|
|
||||||
-> 𝕀ℝ 2 -- ^ initial box \( X \)
|
|
||||||
-> [ ( 𝕀ℝ 2, Bool ) ]
|
|
||||||
gaussSeidelStep
|
gaussSeidelStep
|
||||||
( 𝕀 ( ℝ2 a11_lo a21_lo ) ( ℝ2 a11_hi a21_hi )
|
:: forall n
|
||||||
, 𝕀 ( ℝ2 a12_lo a22_lo ) ( ℝ2 a12_hi a22_hi ) )
|
. ( Representable Double ( ℝ n ), Eq ( ℝ n ) )
|
||||||
( 𝕀 ( ℝ2 b1_lo b2_lo ) ( ℝ2 b1_hi b2_hi ) )
|
=> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
( 𝕀 ( ℝ2 x1_lo x2_lo ) ( ℝ2 x1_hi x2_hi ) )
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
= let !a11 = 𝕀 a11_lo a11_hi
|
-> T ( 𝕀ℝ n ) -- ^ initial box \( X \)
|
||||||
!a12 = 𝕀 a12_lo a12_hi
|
-> [ ( T ( 𝕀ℝ n ), Bool ) ]
|
||||||
!a21 = 𝕀 a21_lo a21_hi
|
gaussSeidelStep as b ( T x0 ) = coerce $ nub $
|
||||||
!a22 = 𝕀 a22_lo a22_hi
|
forEachDim @n ( x0, True ) $ \ i ( x, contraction ) -> do
|
||||||
!b1 = 𝕀 b1_lo b1_hi
|
-- x_i' = ( b_i - sum { j /= i } a_ij * x_j ) / a_ii
|
||||||
!b2 = 𝕀 b2_lo b2_hi
|
x_i'0 <- ( b `index` i - sum [ ( as ! j ) `index` i * x `index` j | j <- toList ( universe @n ), j /= i ] )
|
||||||
!x1 = 𝕀 x1_lo x1_hi
|
`extendedDivide` ( ( as ! i ) `index` i )
|
||||||
!x2 = 𝕀 x2_lo x2_hi
|
( x_i', sub_i ) <- x_i'0 `intersect` ( x `index` i )
|
||||||
in nub $ do
|
return $ ( set i x_i' x, sub_i && contraction )
|
||||||
|
|
||||||
-- x1' = ( ( b1 - a12 * x2 ) / a11 ) ∩ x1
|
|
||||||
x1'_0 <- ( b1 - a12 * x2 ) `extendedDivide` a11
|
|
||||||
( x1'@( 𝕀 x1'_lo x1'_hi ), sub_x1 ) <- x1'_0 `intersect` x1
|
|
||||||
-- x2' = ( ( b2 - a21 * x1' ) / a22 ) ∩ x2
|
|
||||||
x2'_0 <- ( b2 - a21 * x1' ) `extendedDivide` a22
|
|
||||||
( 𝕀 x2'_lo x2'_hi, sub_x2 ) <- x2'_0 `intersect` x2
|
|
||||||
|
|
||||||
return ( ( 𝕀 ( ℝ2 x1'_lo x2'_lo) ( ℝ2 x1'_hi x2'_hi ) )
|
|
||||||
, sub_x1 && sub_x2 )
|
|
||||||
-- TODO: try implementing the complete interval union Gauss–Seidel algorithm.
|
-- TODO: try implementing the complete interval union Gauss–Seidel algorithm.
|
||||||
-- See "Algorithm 2" in
|
-- See "Algorithm 2" in
|
||||||
-- "Using interval unions to solve linear systems of equations with uncertainties"
|
-- "Using interval unions to solve linear systems of equations with uncertainties"
|
||||||
|
{-# INLINEABLE gaussSeidelStep #-}
|
||||||
|
|
||||||
|
-- | Run an effectful computation several times in sequence, piping its output
|
||||||
|
-- into the next input, once for each coordinate dimension.
|
||||||
|
forEachDim :: forall n a m. ( KnownNat n, Monad m ) => a -> ( Fin n -> a -> m a ) -> m a
|
||||||
|
forEachDim a0 f = go ( toList $ universe @n ) a0
|
||||||
|
where
|
||||||
|
go [] a = return a
|
||||||
|
go ( i : is ) a = do
|
||||||
|
a' <- f i a
|
||||||
|
go is a'
|
||||||
|
{-# INLINEABLE forEachDim #-}
|
||||||
|
|
||||||
-- | Compute the intersection of two intervals.
|
-- | Compute the intersection of two intervals.
|
||||||
--
|
--
|
||||||
|
|
@ -503,9 +625,10 @@ data Preconditioner
|
||||||
-- See also
|
-- See also
|
||||||
-- "Presentation of a highly tuned multithreaded interval solver for underdetermined and well-determined nonlinear systems"
|
-- "Presentation of a highly tuned multithreaded interval solver for underdetermined and well-determined nonlinear systems"
|
||||||
makeBox1Consistent
|
makeBox1Consistent
|
||||||
:: ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) )
|
:: BoxCt n d
|
||||||
|
=> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
-> Double -> Double
|
-> Double -> Double
|
||||||
-> Box -> [ Box ]
|
-> Box n -> [ Box n ]
|
||||||
makeBox1Consistent eqs minWidth epsEq x =
|
makeBox1Consistent eqs minWidth epsEq x =
|
||||||
( `State.evalState` False ) $
|
( `State.evalState` False ) $
|
||||||
pipeFunctionsWhileTrue ( allNarrowingOperators epsEq minWidth eqs ) x
|
pipeFunctionsWhileTrue ( allNarrowingOperators epsEq minWidth eqs ) x
|
||||||
|
|
@ -513,24 +636,26 @@ makeBox1Consistent eqs minWidth epsEq x =
|
||||||
-- | An implementation of "bound-consistency" from the paper
|
-- | An implementation of "bound-consistency" from the paper
|
||||||
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
|
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
|
||||||
makeBox2Consistent
|
makeBox2Consistent
|
||||||
:: ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) )
|
:: forall n d
|
||||||
|
. BoxCt n d
|
||||||
|
=> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
-> Double -> Double -> Double
|
-> Double -> Double -> Double
|
||||||
-> Box -> Box
|
-> Box n -> Box n
|
||||||
makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False ) $ doLoop 0.25 x0
|
makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False ) $ doLoop 0.25 x0
|
||||||
where
|
where
|
||||||
doLoop :: Double -> Box -> State Bool Box
|
doLoop :: Double -> Box n -> State Bool ( Box n )
|
||||||
doLoop lambda x = do
|
doLoop lambda x = do
|
||||||
x' <- boundConsistency get_t set_t lambda x
|
x'' <- forEachDim @n x $ \ i ->
|
||||||
x'' <- boundConsistency get_s set_s lambda x'
|
boundConsistency ( `index` i ) ( set i ) lambda
|
||||||
modified <- State.get
|
modified <- State.get
|
||||||
let lambda' = if modified then lambda else 0.5 * lambda
|
let lambda' = if modified then lambda else 0.5 * lambda
|
||||||
if lambda' < lambdaMin
|
if lambda' < lambdaMin
|
||||||
then return x''
|
then return x''
|
||||||
else do { State.put False ; doLoop lambda' x'' }
|
else do { State.put False ; doLoop lambda' x'' }
|
||||||
|
|
||||||
boundConsistency :: ( Box -> 𝕀 Double )
|
boundConsistency :: ( Box n -> 𝕀 Double )
|
||||||
-> ( 𝕀 Double -> Box -> Box )
|
-> ( 𝕀 Double -> Box n -> Box n )
|
||||||
-> Double -> Box -> State Bool Box
|
-> Double -> Box n -> State Bool ( Box n )
|
||||||
boundConsistency getter setter lambda box = do
|
boundConsistency getter setter lambda box = do
|
||||||
let x@( 𝕀 x_inf x_sup ) = getter box
|
let x@( 𝕀 x_inf x_sup ) = getter box
|
||||||
c1 = ( 1 - lambda ) * x_inf + lambda * x_sup
|
c1 = ( 1 - lambda ) * x_inf + lambda * x_sup
|
||||||
|
|
@ -548,62 +673,63 @@ makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False )
|
||||||
State.put True
|
State.put True
|
||||||
return $ setter x' box
|
return $ setter x' box
|
||||||
|
|
||||||
precondition :: Preconditioner
|
-- | Pre-condition the system \( AX = B \).
|
||||||
-> ( 𝕀ℝ 2, 𝕀ℝ 2 )
|
precondition
|
||||||
-> ( 𝕀ℝ 2, 𝕀ℝ 2 )
|
:: forall n
|
||||||
-> 𝕀ℝ 2
|
. ( KnownNat n, Representable Double ( ℝ n ) )
|
||||||
-> ( ( 𝕀ℝ 2, 𝕀ℝ 2 ), 𝕀ℝ 2 )
|
=> Preconditioner -- ^ pre-conditioning method to use
|
||||||
precondition meth jac_mid a@( a1, a2 ) b =
|
-> Vec n ( ℝ n ) -- ^ entry-wise midpoint matrix of the interval Jacobian matrix
|
||||||
|
-> Vec n ( 𝕀ℝ n ) -- ^ columns of \( A \)
|
||||||
|
-> 𝕀ℝ n -- ^ \( B \)
|
||||||
|
-> ( Vec n ( 𝕀ℝ n ), 𝕀ℝ n )
|
||||||
|
precondition meth jac_mid as b =
|
||||||
case meth of
|
case meth of
|
||||||
NoPreconditioning
|
NoPreconditioning
|
||||||
-> ( a, b )
|
-> ( as, b )
|
||||||
InverseMidJacobian
|
InverseMidJacobian
|
||||||
| ( 𝕀 ( ℝ2 a11_lo a21_lo ) ( ℝ2 a11_hi a21_hi )
|
| let mat = toEigen jac_mid
|
||||||
, 𝕀 ( ℝ2 a12_lo a22_lo ) ( ℝ2 a12_hi a22_hi ) ) <- jac_mid
|
det = Eigen.determinant mat
|
||||||
, let !a11 = 0.5 * ( a11_lo + a11_hi )
|
, not $ nearZero det
|
||||||
!a12 = 0.5 * ( a12_lo + a12_hi )
|
, let precond = Eigen.inverse mat
|
||||||
!a21 = 0.5 * ( a21_lo + a21_hi )
|
doPrecond = matMulVec ( fromEigen precond )
|
||||||
!a22 = 0.5 * ( a22_lo + a22_hi )
|
-> ( fmap doPrecond as, doPrecond b )
|
||||||
!d = a11 * a22 - a12 * a21
|
|
||||||
, not ( nearZero d )
|
|
||||||
, let !precond = ( ℝ2 a22 -a12, ℝ2 -a21 a11 )
|
|
||||||
!inv = recip d
|
|
||||||
f x = scale inv $ matMulVec precond x
|
|
||||||
-> ( ( f a1, f a2 ), f b )
|
|
||||||
| otherwise
|
| otherwise
|
||||||
-> ( a, b )
|
-> ( as, b )
|
||||||
|
|
||||||
scale :: Double -> 𝕀ℝ 2 -> 𝕀ℝ 2
|
|
||||||
scale s ( 𝕀 ( ℝ2 a1_lo a2_lo ) ( ℝ2 a1_hi a2_hi ) )
|
|
||||||
= 𝕀 ( ℝ2 b1_lo b2_lo ) ( ℝ2 b1_hi b2_hi )
|
|
||||||
where
|
where
|
||||||
𝕀 b1_lo b1_hi = scaleInterval s ( 𝕀 a1_lo a1_hi )
|
toEigen :: Vec n ( ℝ n ) -> Eigen.Matrix n n Double
|
||||||
𝕀 b2_lo b2_hi = scaleInterval s ( 𝕀 a2_lo a2_hi )
|
toEigen cols =
|
||||||
|
Eigen.generate $ \ r c ->
|
||||||
|
( cols ! Fin ( fromIntegral c + 1 ) ) `index` ( Fin ( fromIntegral r + 1 ) )
|
||||||
|
|
||||||
matMulVec :: ( ℝ 2, ℝ 2 ) -> 𝕀ℝ 2 -> 𝕀ℝ 2
|
fromEigen :: Eigen.Matrix n n Double -> Vec n ( ℝ n )
|
||||||
matMulVec ( ℝ2 a11 a21, ℝ2 a12 a22 ) ( 𝕀 ( ℝ2 u_lo v_lo ) ( ℝ2 u_hi v_hi ) )
|
fromEigen mat =
|
||||||
= 𝕀 ( ℝ2 u'_lo v'_lo ) ( ℝ2 u'_hi v'_hi )
|
fmap
|
||||||
|
( \ ( Fin c ) ->
|
||||||
|
tabulate $ \ ( Fin r ) ->
|
||||||
|
Eigen.unsafeCoeff ( fromIntegral r - 1 ) ( fromIntegral c - 1 ) mat
|
||||||
|
)
|
||||||
|
( universe @n )
|
||||||
|
|
||||||
|
-- | Matrix multiplication \( A v \).
|
||||||
|
matMulVec
|
||||||
|
:: forall n m
|
||||||
|
. ( Representable Double ( ℝ n ), Representable Double ( ℝ m ) )
|
||||||
|
=> Vec m ( ℝ n ) -- ^ columns of the matrix \( A )
|
||||||
|
-> 𝕀ℝ m -- ^ vector \( v \)
|
||||||
|
-> 𝕀ℝ n
|
||||||
|
matMulVec as v = tabulate $ \ r ->
|
||||||
|
sum [ scaleInterval ( ( as ! c ) `index` r ) ( index v c )
|
||||||
|
| c <- toList ( universe @m )
|
||||||
|
]
|
||||||
|
{-# INLINEABLE matMulVec #-}
|
||||||
|
|
||||||
|
normVI :: ( Applicative ( Vec d ), Representable Double ( ℝ d ) ) => 𝕀ℝ d -> Double
|
||||||
|
normVI ( 𝕀 los his ) =
|
||||||
|
sqrt $ sum ( nm1 <$> coordinates los <*> coordinates his )
|
||||||
where
|
where
|
||||||
u = 𝕀 u_lo u_hi
|
nm1 :: Double -> Double -> Double
|
||||||
v = 𝕀 v_lo v_hi
|
nm1 lo hi = max ( abs lo ) ( abs hi ) Ring.^ 2
|
||||||
𝕀 u'_lo u'_hi = scaleInterval a11 u + scaleInterval a12 v
|
{-# INLINEABLE normVI #-}
|
||||||
𝕀 v'_lo v'_hi = scaleInterval a21 u + scaleInterval a22 v
|
|
||||||
|
|
||||||
midI :: 𝕀ℝ 2 -> 𝕀ℝ 2
|
|
||||||
midI ( 𝕀 ( ℝ2 x_lo y_lo ) ( ℝ2 x_hi y_hi ) ) =
|
|
||||||
singleton $ ℝ2 ( 0.5 * ( x_lo + x_hi ) ) ( 0.5 * ( y_lo + y_hi ) )
|
|
||||||
--width :: 𝕀ℝ 1 -> Double
|
|
||||||
--width ( 𝕀 ( ℝ1 lo ) ( ℝ1 hi ) ) = hi - lo
|
|
||||||
--normI :: 𝕀ℝ 1 -> Double
|
|
||||||
--normI ( 𝕀 ( ℝ1 lo ) ( ℝ1 hi ) ) = sqrt $ sup $ ( 𝕀 lo hi ) Ring.^ 2
|
|
||||||
--normVI :: 𝕀ℝ 2 -> Double
|
|
||||||
--normVI ( 𝕀 ( ℝ2 x_lo y_lo ) ( ℝ2 x_hi y_hi ) ) =
|
|
||||||
-- sqrt $ sup $ ( 𝕀 x_lo x_hi ) Ring.^ 2 + ( 𝕀 y_lo y_hi ) Ring.^ 2
|
|
||||||
normVI3 :: 𝕀ℝ 3 -> Double
|
|
||||||
normVI3 ( 𝕀 ( ℝ3 lo x_lo y_lo ) ( ℝ3 hi x_hi y_hi ) ) =
|
|
||||||
sqrt $ max ( abs lo ) ( abs hi ) Ring.^ 2
|
|
||||||
+ max ( abs x_lo ) ( abs x_hi ) Ring.^ 2
|
|
||||||
+ max ( abs y_lo ) ( abs y_hi ) Ring.^ 2
|
|
||||||
|
|
||||||
-- Use the univariate interval Newton method to narrow from the left
|
-- Use the univariate interval Newton method to narrow from the left
|
||||||
-- a candidate interval.
|
-- a candidate interval.
|
||||||
|
|
@ -704,43 +830,36 @@ pipeFunctionsWhileTrue fns = go fns
|
||||||
concat <$> traverse ( go fs ) xs
|
concat <$> traverse ( go fs ) xs
|
||||||
|
|
||||||
allNarrowingOperators
|
allNarrowingOperators
|
||||||
:: Double
|
:: forall n d
|
||||||
|
. BoxCt n d
|
||||||
|
=> Double
|
||||||
-> Double
|
-> Double
|
||||||
-> ( 𝕀ℝ 2 -> D 1 ( 𝕀ℝ 2 ) ( 𝕀ℝ 3 ) )
|
-> ( 𝕀ℝ n -> D 1 ( 𝕀ℝ n ) ( 𝕀ℝ d ) )
|
||||||
-> [ Box -> State Bool [ Box ] ]
|
-> [ Box n -> State Bool [ Box n ] ]
|
||||||
allNarrowingOperators eps_eq eps_bis eqs =
|
allNarrowingOperators eps_eq eps_bis eqs =
|
||||||
[ \ cand ->
|
[ \ cand ->
|
||||||
let getter = ( `index` coordIndex )
|
let getter = ( `index` coordIndex )
|
||||||
setter = set coordIndex
|
setter = set coordIndex
|
||||||
newCands = map ( `setter` cand ) $ narrowFn eps_eq eps_bis ( \ x0 -> ff' $ setter x0 cand ) ( getter cand )
|
newCands = map ( `setter` cand ) $ narrowFn eps_eq eps_bis ( \ x0 -> fn $ setter x0 cand ) ( getter cand )
|
||||||
in do
|
in do
|
||||||
when ( ( width ( getter cand ) - sum ( map ( width . getter ) newCands ) ) > eps_eq ) $
|
when ( ( width ( getter cand ) - sum ( map ( width . getter ) newCands ) ) > eps_eq ) $
|
||||||
-- TODO: do a check with the relative reduction in size?
|
-- TODO: do a check with the relative reduction in size?
|
||||||
State.put True
|
State.put True
|
||||||
return newCands
|
return newCands
|
||||||
| narrowFn <- [ leftNarrow, rightNarrow ]
|
| narrowFn <- [ leftNarrow, rightNarrow ]
|
||||||
, ( coordIndex, ff' ) <-
|
, ( coordIndex, fn ) <-
|
||||||
[ ( Fin 1, ff'_t i ) | i <- [ Fin 1, Fin 2, Fin 3 ] ]
|
[ ( i, ff' i d )
|
||||||
++
|
| i <- toList $ universe @n
|
||||||
[ ( Fin 2, ff'_s i ) | i <- [ Fin 1, Fin 2, Fin 3 ] ]
|
, d <- toList $ universe @d
|
||||||
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
|
|
||||||
ff'_t i ts =
|
ff' :: Fin n -> Fin d -> 𝕀ℝ n -> ( 𝕀 Double, 𝕀 Double )
|
||||||
let D12 { _D12_v = f
|
ff' i d ts =
|
||||||
, _D12_dx = T f_t
|
let df = eqs ts
|
||||||
} = eqs ts
|
f, f' :: Box d
|
||||||
in ( f `index` i, f_t `index` i )
|
f = df `monIndex` zeroMonomial
|
||||||
ff'_s i ts =
|
f' = df `monIndex` linearMonomial i
|
||||||
let D12 { _D12_v = f
|
in ( f `index` d, f' `index` d )
|
||||||
, _D12_dy = T f_t
|
{-# INLINEABLE allNarrowingOperators #-}
|
||||||
} = eqs ts
|
|
||||||
in ( f `index` i, f_t `index` i )
|
|
||||||
|
|
||||||
get_t, get_s :: Box -> 𝕀 Double
|
|
||||||
get_t = ( `index` ( Fin 1 ) )
|
|
||||||
get_s = ( `index` ( Fin 2 ) )
|
|
||||||
|
|
||||||
set_t, set_s :: 𝕀 Double -> Box -> Box
|
|
||||||
set_t = set ( Fin 1 )
|
|
||||||
set_s = set ( Fin 2 )
|
|
||||||
|
|
|
||||||
|
|
@ -25,7 +25,7 @@ import Math.Linear
|
||||||
import Math.Module
|
import Math.Module
|
||||||
import Math.Monomial
|
import Math.Monomial
|
||||||
( multiSubsetSum, multiSubsetsSum
|
( multiSubsetSum, multiSubsetsSum
|
||||||
, MonomialBasis ( monTabulate, monIndex )
|
, MonomialBasisQ ( monTabulateQ, monIndexQ )
|
||||||
)
|
)
|
||||||
import Math.Ring
|
import Math.Ring
|
||||||
|
|
||||||
|
|
@ -65,7 +65,7 @@ main =
|
||||||
Tasty.testGroup "brush-strokes property tests"
|
Tasty.testGroup "brush-strokes property tests"
|
||||||
[ Tasty.testGroup "Automatic differentiation"
|
[ Tasty.testGroup "Automatic differentiation"
|
||||||
[ Tasty.testGroup "Monomial basis"
|
[ Tasty.testGroup "Monomial basis"
|
||||||
[ testProperty "Round trip D33" testMonomialBasisD33
|
[ testProperty "Round trip D33" testMonomialBasisQD33
|
||||||
]
|
]
|
||||||
, Tasty.testGroup "Monomials"
|
, Tasty.testGroup "Monomials"
|
||||||
[ Tasty.testGroup "multiSubsetSum"
|
[ Tasty.testGroup "multiSubsetSum"
|
||||||
|
|
@ -172,9 +172,9 @@ testRoundTrip g roundTrip = do
|
||||||
.$ ("value", d )
|
.$ ("value", d )
|
||||||
.$ ("round tripped", roundTrip d )
|
.$ ("round tripped", roundTrip d )
|
||||||
|
|
||||||
testMonomialBasisD33 :: Falsify.Property ()
|
testMonomialBasisQD33 :: Falsify.Property ()
|
||||||
testMonomialBasisD33 =
|
testMonomialBasisQD33 =
|
||||||
testRoundTrip genD33 \ d -> $$( monTabulate \ mon -> monIndex [|| d ||] mon )
|
testRoundTrip genD33 \ d -> $$( monTabulateQ \ mon -> monIndexQ [|| d ||] mon )
|
||||||
where
|
where
|
||||||
genD33 :: Falsify.Gen ( D3𝔸3 Double )
|
genD33 :: Falsify.Gen ( D3𝔸3 Double )
|
||||||
genD33 =
|
genD33 =
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue