mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
add more info to cusps benchmark output
This commit is contained in:
parent
af66b3b5ac
commit
77a36e1f0b
2
brush-strokes/.gitignore
vendored
2
brush-strokes/.gitignore
vendored
|
@ -1,3 +1,5 @@
|
||||||
dist-newstyle/
|
dist-newstyle/
|
||||||
logs/
|
logs/
|
||||||
cabal.project.local
|
cabal.project.local
|
||||||
|
*.log
|
||||||
|
*.prof
|
||||||
|
|
|
@ -1,6 +1,10 @@
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Control.Arrow
|
||||||
|
( second )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( when )
|
( when )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
|
@ -10,11 +14,13 @@ import qualified Data.List.NonEmpty as NE
|
||||||
, fromList, head, length, sort
|
, fromList, head, length, sort
|
||||||
)
|
)
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
( Arg(..) )
|
( Arg(..), Sum(..), Product(..) )
|
||||||
import Data.Traversable
|
import Data.Traversable
|
||||||
( for )
|
( for )
|
||||||
import GHC.Clock
|
import GHC.Clock
|
||||||
( getMonotonicTime )
|
( getMonotonicTime )
|
||||||
|
import Numeric
|
||||||
|
( showFFloat )
|
||||||
|
|
||||||
-- code-page
|
-- code-page
|
||||||
import System.IO.CodePage
|
import System.IO.CodePage
|
||||||
|
@ -23,6 +29,8 @@ import System.IO.CodePage
|
||||||
-- containers
|
-- containers
|
||||||
import qualified Data.IntMap.Strict as IntMap
|
import qualified Data.IntMap.Strict as IntMap
|
||||||
( fromList, toList )
|
( fromList, toList )
|
||||||
|
import Data.Tree
|
||||||
|
( foldTree )
|
||||||
|
|
||||||
-- deepseq
|
-- deepseq
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
|
@ -30,7 +38,12 @@ import Control.DeepSeq
|
||||||
|
|
||||||
-- brush-strokes
|
-- brush-strokes
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
import Math.Root.Isolation
|
import Math.Root.Isolation
|
||||||
|
import Math.Root.Isolation.Core
|
||||||
|
import Math.Root.Isolation.Newton
|
||||||
|
import Math.Root.Isolation.Newton.GaussSeidel
|
||||||
|
|
||||||
-- brush-strokes bench:cusps
|
-- brush-strokes bench:cusps
|
||||||
import Bench.Cases
|
import Bench.Cases
|
||||||
|
@ -66,10 +79,10 @@ benchTestCase testName ( TestCase { testDescription, testBrushStroke, testCuspOp
|
||||||
, " --" ]
|
, " --" ]
|
||||||
before <- getMonotonicTime
|
before <- getMonotonicTime
|
||||||
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
||||||
( dunno, sols ) =
|
( trees, dunno, sols ) =
|
||||||
foldMap
|
foldMap
|
||||||
( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = mbCusps } ) ) ->
|
( \ ( i, ( trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = mbCusps } ) ) ->
|
||||||
( map ( ( i , ) . fst ) mbCusps, map ( i, ) defCusps ) ) $
|
( map ( i, ) trees, map ( ( i , ) . fst ) mbCusps, map ( i, ) defCusps ) ) $
|
||||||
IntMap.toList $
|
IntMap.toList $
|
||||||
findCuspsIn testCuspOptions testStrokeFnI $
|
findCuspsIn testCuspOptions testStrokeFnI $
|
||||||
IntMap.fromList
|
IntMap.fromList
|
||||||
|
@ -84,22 +97,124 @@ benchTestCase testName ( TestCase { testDescription, testBrushStroke, testCuspOp
|
||||||
++
|
++
|
||||||
( map ( \ sol -> " -- • " ++ show sol ) sols )
|
( map ( \ sol -> " -- • " ++ show sol ) sols )
|
||||||
++
|
++
|
||||||
[ " -- #dunno: " ++ show ( length dunno )
|
[ " -- #dunno: " ++ show dunno --( length dunno )
|
||||||
, " -- Time elapsed: " ++ show dt ++ "s" ]
|
, " -- Time elapsed: " ++ show dt ++ "s"
|
||||||
|
, " -- Tree size: " ++ show (getSum $ foldMap (foldMap sizeRootIsolationTree) trees)
|
||||||
|
, " -- Newton stats: "
|
||||||
|
] ++ map ( " -- " ++ ) ( showNewtonStats (foldMap (foldMap newtonStats) trees) )
|
||||||
return dt
|
return dt
|
||||||
|
|
||||||
|
sizeRootIsolationTree :: ( Box 2, RootIsolationTree ( Box 2 ) ) -> Sum Int
|
||||||
|
sizeRootIsolationTree ( box, tree ) = foldMap ( const $ Sum 1 ) ( showRootIsolationTree box tree )
|
||||||
|
|
||||||
|
|
||||||
|
data NewtonStats
|
||||||
|
= NewtonStats
|
||||||
|
{ newtonImprovement :: !( Sum Double )
|
||||||
|
, newtonElimination :: !( Sum Int, BigBoxes )
|
||||||
|
, newtonTime :: !( Sum Double )
|
||||||
|
, newtonTotal :: !( Sum Int )
|
||||||
|
}
|
||||||
|
instance Semigroup NewtonStats where
|
||||||
|
NewtonStats imp1 el1 t1 tot1 <> NewtonStats imp2 el2 t2 tot2 =
|
||||||
|
NewtonStats ( imp1 <> imp2 ) ( el1 <> el2 ) ( t1 <> t2 ) ( tot1 <> tot2 )
|
||||||
|
instance Monoid NewtonStats where
|
||||||
|
mempty = NewtonStats mempty mempty mempty mempty
|
||||||
|
|
||||||
|
showNewtonStats :: NewtonStats -> [ String ]
|
||||||
|
showNewtonStats ( NewtonStats ( Sum improv ) ( Sum elims, big ) ( Sum time ) ( Sum tot ) )
|
||||||
|
| tot == 0
|
||||||
|
= [ ]
|
||||||
|
| otherwise
|
||||||
|
= [ "average improvement: " ++ showPercent ( improv / fromIntegral tot )
|
||||||
|
, "average eliminations: " ++ showPercent ( fromIntegral elims / fromIntegral tot )
|
||||||
|
, "time elapsed: " ++ show ( time / fromIntegral tot ) ++ "s"
|
||||||
|
]
|
||||||
|
|
||||||
|
showPercent :: Double -> String
|
||||||
|
showPercent x = fixed 3 2 ( 100 * x ) <> "%"
|
||||||
|
|
||||||
|
fixed :: Int -> Int -> Double -> String
|
||||||
|
fixed digitsBefore digitsAfter x =
|
||||||
|
case second ( drop 1 ) . break ( == '.' ) $ showFFloat ( Just digitsAfter ) x "" of
|
||||||
|
( as, bs ) ->
|
||||||
|
let
|
||||||
|
l, r :: Int
|
||||||
|
l = length as
|
||||||
|
r = length bs
|
||||||
|
in
|
||||||
|
replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0'
|
||||||
|
|
||||||
|
data BigBoxes =
|
||||||
|
BigBoxes
|
||||||
|
{ biggestArea :: Maybe ( Box 2 )
|
||||||
|
, biggestX :: Maybe ( Box 2 )
|
||||||
|
, biggestY :: Maybe ( Box 2 )
|
||||||
|
}
|
||||||
|
deriving stock ( Show, Eq )
|
||||||
|
instance Semigroup BigBoxes where
|
||||||
|
BigBoxes area1 x1 y1 <> BigBoxes area2 x2 y2 =
|
||||||
|
BigBoxes
|
||||||
|
( pickBig boxArea area1 area2 )
|
||||||
|
( pickBig widthX x1 x2 )
|
||||||
|
( pickBig widthY y1 y2 )
|
||||||
|
where
|
||||||
|
pickBig _ Nothing Nothing = Nothing
|
||||||
|
pickBig _ (Just x1) Nothing = Just x1
|
||||||
|
pickBig _ Nothing (Just x2) = Just x2
|
||||||
|
pickBig f j1@(Just x1) j2@(Just x2)
|
||||||
|
| f x1 >= f x2
|
||||||
|
= j1
|
||||||
|
| otherwise
|
||||||
|
= j2
|
||||||
|
widthX ( 𝕀 ( ℝ2 x_lo _y_lo ) ( ℝ2 x_hi _y_hi ) )
|
||||||
|
= x_hi - x_lo
|
||||||
|
widthY ( 𝕀 ( ℝ2 _x_lo y_lo ) ( ℝ2 _x_hi y_hi ) )
|
||||||
|
= y_hi - y_lo
|
||||||
|
instance Monoid BigBoxes where
|
||||||
|
mempty = BigBoxes Nothing Nothing Nothing
|
||||||
|
|
||||||
|
|
||||||
|
newtonStats :: ( Box 2, RootIsolationTree ( Box 2 ) ) -> NewtonStats
|
||||||
|
newtonStats ( _box, RootIsolationLeaf {} ) = mempty
|
||||||
|
newtonStats ( box, RootIsolationStep step boxes )
|
||||||
|
| IsolationStep @Newton ( TimeInterval dt ) <- step
|
||||||
|
= thisImprovement dt <> foldMap newtonStats boxes
|
||||||
|
| otherwise
|
||||||
|
= foldMap newtonStats boxes
|
||||||
|
where
|
||||||
|
thisImprovement dt =
|
||||||
|
NewtonStats
|
||||||
|
{ newtonImprovement = Sum $ ( old - new ) / old
|
||||||
|
, newtonElimination =
|
||||||
|
if new == 0
|
||||||
|
then ( Sum 1, BigBoxes ( Just box ) ( Just box ) ( Just box ) )
|
||||||
|
else mempty
|
||||||
|
, newtonTime = Sum dt
|
||||||
|
, newtonTotal = Sum 1
|
||||||
|
}
|
||||||
|
where
|
||||||
|
old = boxArea box
|
||||||
|
new = sum ( map ( boxArea . fst ) boxes )
|
||||||
|
|
||||||
benchGroups :: [ ( String, NE.NonEmpty TestCase ) ]
|
benchGroups :: [ ( String, NE.NonEmpty TestCase ) ]
|
||||||
benchGroups =
|
benchGroups =
|
||||||
[ ( "ellipse"
|
[ ( "ellipse"
|
||||||
, NE.fromList
|
, NE.fromList
|
||||||
[ ellipseTestCase opts ("ε_bis=" ++ show ε_bis)
|
[ ellipseTestCase opts newtMeth
|
||||||
( 0, 1 ) pi
|
( 0, 1 ) pi
|
||||||
( defaultStartBoxes [ 0 .. 3 ] )
|
( defaultStartBoxes [ 0 .. 3 ] )
|
||||||
| ε_bis <- [ 1e-6, 5e-6, 1e-5, 5e-5, 1e-4, 5e-4, 1e-4, 5e-4, 1e-3, 5e-3, 1e-2, 5e-2, 0.1, 0.2, 0.3 ]
|
| let ε_bis = 5e-3 -- <- [ 1e-6, 5e-6, 1e-5, 5e-5, 1e-4, 5e-4, 1e-4, 5e-4, 1e-3, 5e-3, 1e-2, 5e-2, 0.1, 0.2, 0.3 ]
|
||||||
|
, (newtMeth, newtOpts)
|
||||||
|
<- [ ( "LP", \ hist -> NewtonLP )
|
||||||
|
, ( "GS_Complete", defaultNewtonOptions @2 @3 )
|
||||||
|
, ( "GS_Partial", \hist -> NewtonGaussSeidel $ ( defaultGaussSeidelOptions @2 @3 hist ) { gsUpdate = GS_Partial } )
|
||||||
|
]
|
||||||
, let opts =
|
, let opts =
|
||||||
RootIsolationOptions
|
RootIsolationOptions
|
||||||
{ rootIsolationAlgorithms =
|
{ rootIsolationAlgorithms = \ hist ->
|
||||||
defaultRootIsolationAlgorithms minWidth ε_bis
|
defaultRootIsolationAlgorithms minWidth ε_bis
|
||||||
|
( newtOpts hist ) hist
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
|
|
|
@ -45,7 +45,7 @@ import Data.Act
|
||||||
|
|
||||||
-- deepseq
|
-- deepseq
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
( NFData, NFData1 )
|
( NFData(..), NFData1 )
|
||||||
|
|
||||||
-- groups
|
-- groups
|
||||||
import Data.Group
|
import Data.Group
|
||||||
|
@ -139,6 +139,8 @@ deriving via ZipList
|
||||||
instance Applicative ( Vec n )
|
instance Applicative ( Vec n )
|
||||||
instance Traversable ( Vec n ) where
|
instance Traversable ( Vec n ) where
|
||||||
traverse f ( Vec as ) = Vec <$> traverse f as
|
traverse f ( Vec as ) = Vec <$> traverse f as
|
||||||
|
instance NFData a => NFData ( Vec n a ) where
|
||||||
|
rnf ( Vec as ) = rnf as
|
||||||
|
|
||||||
universe :: forall n. KnownNat n => Vec n ( Fin n )
|
universe :: forall n. KnownNat n => Vec n ( Fin n )
|
||||||
universe = Vec [ Fin i | i <- [ 1 .. fromIntegral ( natVal' @n proxy# ) ] ]
|
universe = Vec [ Fin i | i <- [ 1 .. fromIntegral ( natVal' @n proxy# ) ] ]
|
||||||
|
|
|
@ -102,10 +102,12 @@ newtype RootIsolationOptions n d
|
||||||
-> Either String ( NE.NonEmpty ( RootIsolationAlgorithmWithOptions n d ) )
|
-> Either String ( NE.NonEmpty ( RootIsolationAlgorithmWithOptions n d ) )
|
||||||
}
|
}
|
||||||
|
|
||||||
defaultRootIsolationOptions :: BoxCt n d => RootIsolationOptions n d
|
defaultRootIsolationOptions :: forall n d. BoxCt n d => RootIsolationOptions n d
|
||||||
defaultRootIsolationOptions =
|
defaultRootIsolationOptions =
|
||||||
RootIsolationOptions
|
RootIsolationOptions
|
||||||
{ rootIsolationAlgorithms = defaultRootIsolationAlgorithms minWidth ε_eq
|
{ rootIsolationAlgorithms = \ hist ->
|
||||||
|
defaultRootIsolationAlgorithms minWidth ε_eq
|
||||||
|
( defaultNewtonOptions @n @d hist ) hist
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
minWidth = 1e-5
|
minWidth = 1e-5
|
||||||
|
@ -117,10 +119,11 @@ defaultRootIsolationAlgorithms
|
||||||
. BoxCt n d
|
. BoxCt n d
|
||||||
=> Double -- ^ minimum width of boxes (don't bisect further)
|
=> Double -- ^ minimum width of boxes (don't bisect further)
|
||||||
-> Double -- ^ threshold for progress
|
-> Double -- ^ threshold for progress
|
||||||
|
-> NewtonOptions n d -- ^ options for Newton's method
|
||||||
-> BoxHistory n
|
-> BoxHistory n
|
||||||
-> Box n
|
-> Box n
|
||||||
-> Either String ( NE.NonEmpty ( RootIsolationAlgorithmWithOptions n d ) )
|
-> Either String ( NE.NonEmpty ( RootIsolationAlgorithmWithOptions n d ) )
|
||||||
defaultRootIsolationAlgorithms minWidth ε_eq history box =
|
defaultRootIsolationAlgorithms minWidth ε_eq newtonOptions history box =
|
||||||
case history of
|
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...
|
||||||
|
@ -137,14 +140,13 @@ defaultRootIsolationAlgorithms minWidth ε_eq history box =
|
||||||
-- Currently: we try an interval Gauss–Seidel.
|
-- Currently: we try an interval Gauss–Seidel.
|
||||||
-- (box(1)- and box(2)-consistency don't seem to help when using
|
-- (box(1)- and box(2)-consistency don't seem to help when using
|
||||||
-- the complete interval union Gauss–Seidel step)
|
-- the complete interval union Gauss–Seidel step)
|
||||||
_ -> Right $ AlgoWithOptions @Newton _newtonOptions
|
_ -> Right $ AlgoWithOptions @Newton newtonOptions
|
||||||
NE.:| []
|
NE.:| []
|
||||||
|
|
||||||
where
|
where
|
||||||
verySmall = and $ ( \ cd -> width cd <= minWidth ) <$> coordinates box
|
verySmall = and $ ( \ cd -> width cd <= minWidth ) <$> coordinates box
|
||||||
|
|
||||||
_bisOptions = defaultBisectionOptions @n @d minWidth ε_eq box
|
_bisOptions = defaultBisectionOptions @n @d minWidth ε_eq box
|
||||||
_newtonOptions = NewtonLP -- defaultNewtonOptions @n @d history
|
|
||||||
_box1Options = defaultBox1Options @n @d ( minWidth * 100 ) ε_eq
|
_box1Options = defaultBox1Options @n @d ( minWidth * 100 ) ε_eq
|
||||||
_box2Options = ( defaultBox2Options @n @d minWidth ε_eq ) { box2LambdaMin = 0.001 }
|
_box2Options = ( defaultBox2Options @n @d minWidth ε_eq ) { box2LambdaMin = 0.001 }
|
||||||
|
|
||||||
|
@ -200,7 +202,7 @@ isolateRootsIn ( RootIsolationOptions { rootIsolationAlgorithms } )
|
||||||
| -- Check the range of the equations contains zero.
|
| -- Check the range of the equations contains zero.
|
||||||
not $ ( unT ( origin @Double ) ∈ iRange )
|
not $ ( unT ( origin @Double ) ∈ iRange )
|
||||||
-- Box doesn't contain a solution: discard it.
|
-- Box doesn't contain a solution: discard it.
|
||||||
= return []
|
= return [ RootIsolationLeaf "rangeTest" cand ]
|
||||||
| otherwise
|
| otherwise
|
||||||
= case rootIsolationAlgorithms history cand of
|
= case rootIsolationAlgorithms history cand of
|
||||||
Right strats -> doStrategies history strats cand
|
Right strats -> doStrategies history strats cand
|
||||||
|
|
|
@ -22,11 +22,15 @@ module Math.Root.Isolation.Core
|
||||||
|
|
||||||
-- ** Visualising history
|
-- ** Visualising history
|
||||||
, RootIsolationTree(..)
|
, RootIsolationTree(..)
|
||||||
|
, boxArea
|
||||||
, showRootIsolationTree
|
, showRootIsolationTree
|
||||||
|
|
||||||
-- * Utility functions
|
-- * Utility functions
|
||||||
, pipeFunctionsWhileTrue
|
, pipeFunctionsWhileTrue
|
||||||
, forEachCoord
|
, forEachCoord
|
||||||
|
|
||||||
|
-- * Timing
|
||||||
|
, TimeInterval(..), timeInterval
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
@ -40,15 +44,23 @@ import Data.Type.Equality
|
||||||
( (:~~:)(HRefl) )
|
( (:~~:)(HRefl) )
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
( Typeable, heqT )
|
( Typeable, heqT )
|
||||||
import GHC.TypeNats
|
|
||||||
( Nat, KnownNat, type (<=) )
|
|
||||||
import Numeric
|
import Numeric
|
||||||
( showFFloat )
|
( showFFloat )
|
||||||
|
import GHC.Clock
|
||||||
|
( getMonotonicTime )
|
||||||
|
import GHC.TypeNats
|
||||||
|
( Nat, KnownNat, type (<=) )
|
||||||
|
import System.IO.Unsafe
|
||||||
|
( unsafePerformIO )
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import Data.Tree
|
import Data.Tree
|
||||||
( Tree(..) )
|
( Tree(..) )
|
||||||
|
|
||||||
|
-- deepseq
|
||||||
|
import Control.DeepSeq
|
||||||
|
( NFData(..), deepseq )
|
||||||
|
|
||||||
-- transformers
|
-- transformers
|
||||||
import Control.Monad.Trans.State.Strict as State
|
import Control.Monad.Trans.State.Strict as State
|
||||||
( State, get, put )
|
( State, get, put )
|
||||||
|
@ -78,8 +90,7 @@ type Box n = 𝕀ℝ n
|
||||||
-- NB: we require n <= d (no support for under-constrained systems).
|
-- NB: we require n <= d (no support for under-constrained systems).
|
||||||
--
|
--
|
||||||
-- NB: in practice, this constraint should specialise away.
|
-- NB: in practice, this constraint should specialise away.
|
||||||
type BoxCt n d = ( n ~ 2, d ~ 3 )
|
type BoxCt n d =
|
||||||
{-
|
|
||||||
( KnownNat n, KnownNat d
|
( KnownNat n, KnownNat d
|
||||||
, 1 <= n, 1 <= d, n <= d
|
, 1 <= n, 1 <= d, n <= d
|
||||||
|
|
||||||
|
@ -91,12 +102,13 @@ type BoxCt n d = ( n ~ 2, d ~ 3 )
|
||||||
, Vars ( D 1 ( ℝ n ) ) ~ n
|
, Vars ( D 1 ( ℝ n ) ) ~ n
|
||||||
, Module Double ( T ( ℝ n ) )
|
, Module Double ( T ( ℝ n ) )
|
||||||
, Module ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
, Module ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
||||||
|
, NFData ( 𝕀ℝ n )
|
||||||
|
|
||||||
, Ord ( ℝ d )
|
, Ord ( ℝ d )
|
||||||
, Module Double ( T ( ℝ d ) )
|
, Module Double ( T ( ℝ d ) )
|
||||||
, Representable Double ( ℝ d )
|
, Representable Double ( ℝ d )
|
||||||
|
, NFData ( ℝ d )
|
||||||
)
|
)
|
||||||
-}
|
|
||||||
-- | Boxes we are done with and will not continue processing.
|
-- | Boxes we are done with and will not continue processing.
|
||||||
data DoneBoxes n =
|
data DoneBoxes n =
|
||||||
DoneBoxes
|
DoneBoxes
|
||||||
|
@ -272,3 +284,14 @@ pipeFunctionsWhileTrue fns = go fns
|
||||||
concat <$> traverse ( go fs ) xs
|
concat <$> traverse ( go fs ) xs
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
newtype TimeInterval = TimeInterval Double
|
||||||
|
deriving newtype Show
|
||||||
|
|
||||||
|
timeInterval :: NFData b => ( a -> b ) -> a -> ( b, TimeInterval )
|
||||||
|
timeInterval f a = unsafePerformIO $ do
|
||||||
|
bef <- getMonotonicTime
|
||||||
|
let !b = f a
|
||||||
|
b `deepseq` return ()
|
||||||
|
aft <- getMonotonicTime
|
||||||
|
return $ ( b, TimeInterval ( aft - bef ) )
|
||||||
|
|
|
@ -26,6 +26,10 @@ import Data.List
|
||||||
import GHC.TypeNats
|
import GHC.TypeNats
|
||||||
( Nat, KnownNat, type (<=) )
|
( Nat, KnownNat, type (<=) )
|
||||||
|
|
||||||
|
-- deepseq
|
||||||
|
import Control.DeepSeq
|
||||||
|
( force )
|
||||||
|
|
||||||
-- transformers
|
-- transformers
|
||||||
import Control.Monad.Trans.Writer.CPS
|
import Control.Monad.Trans.Writer.CPS
|
||||||
( Writer, tell )
|
( Writer, tell )
|
||||||
|
@ -50,11 +54,10 @@ import Math.Root.Isolation.Utils
|
||||||
-- | The interval Newton method; see 'intervalNewton'.
|
-- | The interval Newton method; see 'intervalNewton'.
|
||||||
data Newton
|
data Newton
|
||||||
instance BoxCt n d => RootIsolationAlgorithm Newton n d where
|
instance BoxCt n d => RootIsolationAlgorithm Newton n d where
|
||||||
type instance StepDescription Newton = ()
|
type instance StepDescription Newton = TimeInterval
|
||||||
type instance RootIsolationAlgorithmOptions Newton n d = NewtonOptions n d
|
type instance RootIsolationAlgorithmOptions Newton n d = NewtonOptions n d
|
||||||
rootIsolationAlgorithm opts _thisRoundHist _prevRoundsHist eqs box = do
|
rootIsolationAlgorithm opts _thisRoundHist _prevRoundsHist eqs box =
|
||||||
res <- intervalNewton @n @d opts eqs box
|
intervalNewton @n @d opts eqs box
|
||||||
return ( (), res )
|
|
||||||
{-# INLINEABLE rootIsolationAlgorithm #-}
|
{-# INLINEABLE rootIsolationAlgorithm #-}
|
||||||
{-# SPECIALISE rootIsolationAlgorithm
|
{-# SPECIALISE rootIsolationAlgorithm
|
||||||
:: RootIsolationAlgorithmOptions Newton 2 3
|
:: RootIsolationAlgorithmOptions Newton 2 3
|
||||||
|
@ -99,7 +102,7 @@ intervalNewton
|
||||||
-- ^ equations
|
-- ^ equations
|
||||||
-> 𝕀ℝ n
|
-> 𝕀ℝ n
|
||||||
-- ^ box
|
-- ^ box
|
||||||
-> Writer ( DoneBoxes n ) [ 𝕀ℝ n ]
|
-> Writer ( DoneBoxes n ) ( TimeInterval, [ 𝕀ℝ n ] )
|
||||||
intervalNewton opts eqs x = case opts of
|
intervalNewton opts eqs x = case opts of
|
||||||
NewtonGaussSeidel
|
NewtonGaussSeidel
|
||||||
( GaussSeidelOptions
|
( GaussSeidelOptions
|
||||||
|
@ -118,13 +121,18 @@ intervalNewton opts eqs x = case opts of
|
||||||
minus_f_x_mid = unT $ -1 *^ T ( boxMidpoint $ f x_mid )
|
minus_f_x_mid = unT $ -1 *^ T ( boxMidpoint $ f x_mid )
|
||||||
|
|
||||||
-- Precondition the above linear system into A ( x - x_mid ) = B.
|
-- Precondition the above linear system into A ( x - x_mid ) = B.
|
||||||
( a, b ) = precondition precondMeth
|
!( !a, !b ) = force $
|
||||||
f'_x ( singleton minus_f_x_mid )
|
precondition precondMeth
|
||||||
|
f'_x ( singleton minus_f_x_mid )
|
||||||
|
!x'_0 = force ( T x ^-^ T x_mid )
|
||||||
|
|
||||||
-- NB: we have to change coordinates, putting the midpoint of the box
|
-- NB: we have to change coordinates, putting the midpoint of the box
|
||||||
-- at the origin, in order to take a Gauss–Seidel step.
|
-- at the origin, in order to take a Gauss–Seidel step.
|
||||||
gsGuesses = map ( first ( \ x' -> unT $ x' ^+^ T x_mid ) )
|
( x's, dt ) =
|
||||||
$ gaussSeidelUpdate gsUpdate a b ( T x ^-^ T x_mid )
|
timeInterval
|
||||||
|
( gaussSeidelUpdate gsUpdate a b )
|
||||||
|
x'_0
|
||||||
|
gsGuesses = map ( first ( \ x' -> unT $ x' ^+^ T x_mid ) ) x's
|
||||||
( done, todo ) = bimap ( map fst ) ( map fst )
|
( done, todo ) = bimap ( map fst ) ( map fst )
|
||||||
$ partition snd gsGuesses
|
$ partition snd gsGuesses
|
||||||
in -- If the Gauss–Seidel step was a contraction, then the box
|
in -- If the Gauss–Seidel step was a contraction, then the box
|
||||||
|
@ -133,7 +141,7 @@ intervalNewton opts eqs x = case opts of
|
||||||
-- These boxes can thus be directly added to the solution set:
|
-- These boxes can thus be directly added to the solution set:
|
||||||
-- Newton's method is guaranteed to converge to the unique solution.
|
-- Newton's method is guaranteed to converge to the unique solution.
|
||||||
do tell $ noDoneBoxes { doneSolBoxes = done }
|
do tell $ noDoneBoxes { doneSolBoxes = done }
|
||||||
return todo
|
return ( dt, todo )
|
||||||
NewtonLP ->
|
NewtonLP ->
|
||||||
-- TODO: reduce duplication with the above.
|
-- TODO: reduce duplication with the above.
|
||||||
let x_mid = singleton $ boxMidpoint x
|
let x_mid = singleton $ boxMidpoint x
|
||||||
|
@ -143,13 +151,16 @@ intervalNewton opts eqs x = case opts of
|
||||||
f'_x = fmap ( \ i -> eqs x `monIndex` linearMonomial i ) ( universe @2 )
|
f'_x = fmap ( \ i -> eqs x `monIndex` linearMonomial i ) ( universe @2 )
|
||||||
|
|
||||||
minus_f_x_mid = unT $ -1 *^ T ( boxMidpoint $ f x_mid )
|
minus_f_x_mid = unT $ -1 *^ T ( boxMidpoint $ f x_mid )
|
||||||
( a, b ) = ( f'_x, singleton minus_f_x_mid )
|
!( !a, !b ) = force ( f'_x, singleton minus_f_x_mid )
|
||||||
lpGuesses = map ( first ( \ x' -> unT $ x' ^+^ T x_mid ) )
|
!x'_0 = force ( T x ^-^ T x_mid )
|
||||||
$ solveIntervalLinearEquations a b ( T x ^-^ T x_mid )
|
( x's, dt ) =
|
||||||
|
timeInterval
|
||||||
|
( solveIntervalLinearEquations a b ) x'_0
|
||||||
|
lpGuesses = map ( first ( \ x' -> unT $ x' ^+^ T x_mid ) ) x's
|
||||||
( done, todo ) = bimap ( map fst ) ( map fst )
|
( done, todo ) = bimap ( map fst ) ( map fst )
|
||||||
$ partition snd lpGuesses
|
$ partition snd lpGuesses
|
||||||
in do tell $ noDoneBoxes { doneSolBoxes = done }
|
in do tell $ noDoneBoxes { doneSolBoxes = done }
|
||||||
return todo
|
return ( dt, todo )
|
||||||
{-# INLINEABLE intervalNewton #-}
|
{-# INLINEABLE intervalNewton #-}
|
||||||
{-
|
{-
|
||||||
|
|
||||||
|
|
|
@ -42,7 +42,7 @@ import Math.Linear
|
||||||
-- | Solve the system of linear equations \( A X = B \)
|
-- | Solve the system of linear equations \( A X = B \)
|
||||||
-- using linear programming.
|
-- using linear programming.
|
||||||
solveIntervalLinearEquations
|
solveIntervalLinearEquations
|
||||||
:: ( KnownNat d, Representable Double ( ℝ d ), Show ( ℝ d ) )
|
:: ( KnownNat d, Representable Double ( ℝ d ) )
|
||||||
=> Vec 2 ( 𝕀ℝ d ) -- ^ columns of \( A \)
|
=> Vec 2 ( 𝕀ℝ d ) -- ^ columns of \( A \)
|
||||||
-> 𝕀ℝ d -- ^ \( B \)
|
-> 𝕀ℝ d -- ^ \( B \)
|
||||||
-> T ( 𝕀ℝ 2 ) -- ^ initial box \( X \)
|
-> T ( 𝕀ℝ 2 ) -- ^ initial box \( X \)
|
||||||
|
|
Loading…
Reference in a new issue