mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
Clean up benchmarking component
This commit is contained in:
sheaf
parent
0c54de8b1c
commit
ac9deb968a
|
|
@ -81,7 +81,6 @@ common common
|
||||||
StandaloneDeriving
|
StandaloneDeriving
|
||||||
StandaloneKindSignatures
|
StandaloneKindSignatures
|
||||||
TupleSections
|
TupleSections
|
||||||
TypeAbstractions
|
|
||||||
TypeApplications
|
TypeApplications
|
||||||
TypeFamilyDependencies
|
TypeFamilyDependencies
|
||||||
TypeOperators
|
TypeOperators
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,8 @@ common common
|
||||||
build-depends:
|
build-depends:
|
||||||
base
|
base
|
||||||
>= 4.17 && < 4.20
|
>= 4.17 && < 4.20
|
||||||
|
, code-page
|
||||||
|
^>= 0.2.1
|
||||||
, containers
|
, containers
|
||||||
>= 0.6.0.1 && < 0.8
|
>= 0.6.0.1 && < 0.8
|
||||||
, tree-view
|
, tree-view
|
||||||
|
|
@ -52,13 +54,16 @@ common common
|
||||||
StandaloneDeriving
|
StandaloneDeriving
|
||||||
StandaloneKindSignatures
|
StandaloneKindSignatures
|
||||||
TupleSections
|
TupleSections
|
||||||
TypeAbstractions
|
|
||||||
TypeApplications
|
TypeApplications
|
||||||
TypeFamilyDependencies
|
TypeFamilyDependencies
|
||||||
TypeOperators
|
TypeOperators
|
||||||
UnboxedTuples
|
UnboxedTuples
|
||||||
ViewPatterns
|
ViewPatterns
|
||||||
|
|
||||||
|
if impl(ghc >= 9.8)
|
||||||
|
default-extensions:
|
||||||
|
TypeAbstractions
|
||||||
|
|
||||||
ghc-options:
|
ghc-options:
|
||||||
-O2
|
-O2
|
||||||
-fexpose-all-unfoldings
|
-fexpose-all-unfoldings
|
||||||
|
|
@ -127,9 +132,9 @@ library
|
||||||
, Math.Roots
|
, Math.Roots
|
||||||
, Math.Root.Isolation
|
, Math.Root.Isolation
|
||||||
, Math.Root.Isolation.Bisection
|
, Math.Root.Isolation.Bisection
|
||||||
|
, Math.Root.Isolation.Core
|
||||||
, Math.Root.Isolation.GaussSeidel
|
, Math.Root.Isolation.GaussSeidel
|
||||||
, Math.Root.Isolation.Narrowing
|
, Math.Root.Isolation.Narrowing
|
||||||
, Math.Root.Isolation.Core
|
|
||||||
, Debug.Utils
|
, Debug.Utils
|
||||||
|
|
||||||
other-modules:
|
other-modules:
|
||||||
|
|
@ -148,8 +153,6 @@ library
|
||||||
>= 2.18 && < 2.22
|
>= 2.18 && < 2.22
|
||||||
, bifunctors
|
, bifunctors
|
||||||
>= 5.5.4 && < 5.7
|
>= 5.5.4 && < 5.7
|
||||||
, code-page
|
|
||||||
^>= 0.2.1
|
|
||||||
, deepseq
|
, deepseq
|
||||||
>= 1.4.4.0 && < 1.6
|
>= 1.4.4.0 && < 1.6
|
||||||
, directory
|
, directory
|
||||||
|
|
@ -257,6 +260,10 @@ benchmark cusps
|
||||||
main-is:
|
main-is:
|
||||||
Main.hs
|
Main.hs
|
||||||
|
|
||||||
|
other-modules:
|
||||||
|
Bench.Types
|
||||||
|
Bench.Cases
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
brush-strokes
|
brush-strokes
|
||||||
, deepseq
|
, deepseq
|
||||||
|
|
|
||||||
78
brush-strokes/src/cusps/bench/Bench/Cases.hs
Normal file
78
brush-strokes/src/cusps/bench/Bench/Cases.hs
Normal file
|
|
@ -0,0 +1,78 @@
|
||||||
|
module Bench.Cases where
|
||||||
|
|
||||||
|
-- brush-strokes
|
||||||
|
import Calligraphy.Brushes
|
||||||
|
import Math.Bezier.Spline
|
||||||
|
import Math.Bezier.Stroke
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
|
import Math.Module
|
||||||
|
import Math.Root.Isolation
|
||||||
|
|
||||||
|
-- brush-strokes bench:cusps
|
||||||
|
import Bench.Types
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
ellipseTestCase :: RootIsolationOptions N 3 -> String -> ( Double, Double ) -> Double -> [ ( Int, [ Box 2 ] ) ] -> TestCase
|
||||||
|
ellipseTestCase opts descr k0k1 rot startBoxes =
|
||||||
|
TestCase
|
||||||
|
{ testDescription = descr
|
||||||
|
, testBrushStroke = ellipseBrushStroke k0k1 rot
|
||||||
|
, testCuspOptions = opts
|
||||||
|
, testStartBoxes = startBoxes
|
||||||
|
}
|
||||||
|
|
||||||
|
ellipseBrushStroke :: ( Double, Double ) -> Double -> BrushStroke
|
||||||
|
ellipseBrushStroke ( k0, k1 ) rot =
|
||||||
|
BrushStroke
|
||||||
|
{ brush = ellipseBrush
|
||||||
|
, stroke = ( p0, LineTo ( NextPoint p1 ) () ) }
|
||||||
|
where
|
||||||
|
mkPt x y w h phi =
|
||||||
|
Point
|
||||||
|
{ pointCoords = ℝ2 x y
|
||||||
|
, pointParams = Params $ ℝ3 w h phi
|
||||||
|
}
|
||||||
|
l :: Double -> Double -> Double -> Double
|
||||||
|
l k = lerp @( T Double ) k
|
||||||
|
p k = mkPt ( l k 0 100 ) 0 ( l k 10 15 ) ( l k 25 40 ) ( l k 0 rot )
|
||||||
|
p0 = p k0
|
||||||
|
p1 = p k1
|
||||||
|
|
||||||
|
trickyCusp2TestCase :: TestCase
|
||||||
|
trickyCusp2TestCase =
|
||||||
|
TestCase
|
||||||
|
{ testDescription = ""
|
||||||
|
, testBrushStroke = trickyCusp2BrushStroke
|
||||||
|
, testCuspOptions = defaultRootIsolationOptions
|
||||||
|
, testStartBoxes = defaultStartBoxes [ 0 .. 3 ]
|
||||||
|
}
|
||||||
|
|
||||||
|
trickyCusp2BrushStroke :: BrushStroke
|
||||||
|
trickyCusp2BrushStroke =
|
||||||
|
BrushStroke
|
||||||
|
{ brush = circleBrush
|
||||||
|
, stroke = ( p0, Bezier3To p1 p2 ( NextPoint p3 ) () )
|
||||||
|
}
|
||||||
|
where
|
||||||
|
mkPt x y =
|
||||||
|
Point
|
||||||
|
{ pointCoords = ℝ2 x y
|
||||||
|
, pointParams = Params $ ℝ1 5.0
|
||||||
|
}
|
||||||
|
p0 = mkPt 5e+1 -5e+1
|
||||||
|
p1 = mkPt -7.72994362904069e+1 -3.124468786098509e+1
|
||||||
|
p2 = mkPt -5.1505430313958364e+1 -3.9826386521527986e+1
|
||||||
|
p3 = mkPt -5e+1 -5e+1
|
||||||
|
|
||||||
|
|
||||||
|
defaultStartBoxes :: [ Int ] -> [ ( Int, [ Box 2 ] ) ]
|
||||||
|
defaultStartBoxes is =
|
||||||
|
[ ( i, [ 𝕀 ( ℝ2 zero zero ) ( ℝ2 one one ) ] ) | i <- is ]
|
||||||
|
|
||||||
|
zero, one :: Double
|
||||||
|
zero = 1e-6
|
||||||
|
one = 1 - zero
|
||||||
|
{-# INLINE zero #-}
|
||||||
|
{-# INLINE one #-}
|
||||||
120
brush-strokes/src/cusps/bench/Bench/Types.hs
Normal file
120
brush-strokes/src/cusps/bench/Bench/Types.hs
Normal file
|
|
@ -0,0 +1,120 @@
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
module Bench.Types
|
||||||
|
( BrushStroke(..)
|
||||||
|
, TestCase(..)
|
||||||
|
, Point(..)
|
||||||
|
, Params(..)
|
||||||
|
, brushStrokeFunctions
|
||||||
|
) where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import Data.Coerce
|
||||||
|
( coerce )
|
||||||
|
import GHC.Generics
|
||||||
|
( Generic )
|
||||||
|
|
||||||
|
-- containers
|
||||||
|
import Data.Sequence
|
||||||
|
( Seq )
|
||||||
|
|
||||||
|
-- brush-strokes
|
||||||
|
import Calligraphy.Brushes
|
||||||
|
import Math.Algebra.Dual
|
||||||
|
import Math.Bezier.Spline
|
||||||
|
import Math.Bezier.Stroke
|
||||||
|
import Math.Bezier.Stroke.EnvelopeEquation
|
||||||
|
import Math.Interval
|
||||||
|
import Math.Linear
|
||||||
|
import Math.Module
|
||||||
|
import Math.Ring
|
||||||
|
( Transcendental )
|
||||||
|
import Math.Root.Isolation
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
data BrushStroke =
|
||||||
|
forall nbParams. ParamsCt nbParams =>
|
||||||
|
BrushStroke
|
||||||
|
{ brush :: !( Brush ( ℝ nbParams ) )
|
||||||
|
, stroke :: !( Point nbParams, Curve Open () ( Point nbParams ) )
|
||||||
|
}
|
||||||
|
|
||||||
|
data TestCase =
|
||||||
|
TestCase
|
||||||
|
{ testDescription :: String
|
||||||
|
, testBrushStroke :: BrushStroke
|
||||||
|
, testCuspOptions :: RootIsolationOptions N 3
|
||||||
|
, testStartBoxes :: [ ( Int, [ Box 2 ] ) ]
|
||||||
|
}
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
type ParamsCt nbParams
|
||||||
|
= ( Show ( ℝ nbParams )
|
||||||
|
, HasChainRule Double 2 ( ℝ nbParams )
|
||||||
|
, HasChainRule ( 𝕀 Double ) 3 ( 𝕀 ( ℝ nbParams ) )
|
||||||
|
, Applicative ( D 2 ( ℝ nbParams ) )
|
||||||
|
, Applicative ( D 3 ( ℝ nbParams ) )
|
||||||
|
, Traversable ( D 2 ( ℝ nbParams ) )
|
||||||
|
, Traversable ( D 3 ( ℝ nbParams ) )
|
||||||
|
, Representable Double ( ℝ nbParams )
|
||||||
|
, Module Double ( T ( ℝ nbParams ) )
|
||||||
|
, Module ( 𝕀 Double ) ( T ( 𝕀 ( ℝ nbParams ) ) )
|
||||||
|
, Module ( D 2 ( ℝ nbParams ) Double ) ( D 2 ( ℝ nbParams ) ( ℝ 2 ) )
|
||||||
|
, Module ( D 3 ( ℝ nbParams ) ( 𝕀 Double ) ) ( D 3 ( ℝ nbParams ) ( 𝕀 ( ℝ 2 ) ) )
|
||||||
|
, Transcendental ( D 2 ( ℝ nbParams ) Double )
|
||||||
|
, Transcendental ( D 3 ( ℝ nbParams ) ( 𝕀 Double ) )
|
||||||
|
)
|
||||||
|
|
||||||
|
newtype Params nbParams = Params { getParams :: ( ℝ nbParams ) }
|
||||||
|
deriving newtype instance Show ( ℝ nbParams ) => Show ( Params nbParams )
|
||||||
|
|
||||||
|
data Point nbParams =
|
||||||
|
Point
|
||||||
|
{ pointCoords :: !( ℝ 2 )
|
||||||
|
, pointParams :: !( Params nbParams ) }
|
||||||
|
deriving stock Generic
|
||||||
|
deriving stock instance Show ( ℝ nbParams ) => Show ( Point nbParams )
|
||||||
|
|
||||||
|
getStrokeFunctions
|
||||||
|
:: forall nbParams
|
||||||
|
. ParamsCt nbParams
|
||||||
|
=> Brush ( ℝ nbParams )
|
||||||
|
-- ^ brush shape
|
||||||
|
-> Point nbParams
|
||||||
|
-- ^ start point
|
||||||
|
-> Curve Open () ( Point nbParams )
|
||||||
|
-- ^ curve points
|
||||||
|
-> ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () )
|
||||||
|
, 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
||||||
|
getStrokeFunctions ( Brush brushShape brushShapeI mbRot ) sp0 crv =
|
||||||
|
let
|
||||||
|
usedParams :: C 2 ( ℝ 1 ) ( ℝ nbParams )
|
||||||
|
path :: C 2 ( ℝ 1 ) ( ℝ 2 )
|
||||||
|
( path, usedParams ) =
|
||||||
|
pathAndUsedParams @2 @() coerce id ( getParams . pointParams )
|
||||||
|
sp0 crv
|
||||||
|
usedParamsI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ nbParams )
|
||||||
|
pathI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 )
|
||||||
|
( pathI, usedParamsI ) =
|
||||||
|
pathAndUsedParams @3 @𝕀 coerce singleton ( getParams . pointParams )
|
||||||
|
sp0 crv
|
||||||
|
in ( brushStrokeData @2 @( ℝ nbParams ) coerce coerce
|
||||||
|
path usedParams
|
||||||
|
brushShape
|
||||||
|
mbRot
|
||||||
|
, brushStrokeData @3 @( ℝ nbParams ) coerce coerce
|
||||||
|
pathI usedParamsI
|
||||||
|
brushShapeI
|
||||||
|
( fmap nonDecreasing mbRot )
|
||||||
|
)
|
||||||
|
{-# INLINEABLE getStrokeFunctions #-}
|
||||||
|
|
||||||
|
brushStrokeFunctions
|
||||||
|
:: BrushStroke
|
||||||
|
-> ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () )
|
||||||
|
, 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
||||||
|
brushStrokeFunctions ( BrushStroke { stroke = ( sp0, crv ), brush } ) =
|
||||||
|
getStrokeFunctions brush sp0 crv
|
||||||
|
|
@ -1,123 +1,69 @@
|
||||||
{-# LANGUAGE PolyKinds #-}
|
module Main where
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
module Main
|
|
||||||
( main
|
|
||||||
|
|
||||||
-- Testing
|
|
||||||
, TestCase(..)
|
|
||||||
, testCases
|
|
||||||
, BrushStroke(..)
|
|
||||||
, brushStrokeFunctions
|
|
||||||
, eval
|
|
||||||
, mkVal, mkBox
|
|
||||||
, potentialCusp
|
|
||||||
, dEdsdcdt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Control.Concurrent.MVar
|
import Control.Monad
|
||||||
( newMVar )
|
( when )
|
||||||
import Data.Coerce
|
|
||||||
( coerce )
|
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_ )
|
( for_ )
|
||||||
import Data.List
|
import qualified Data.List.NonEmpty as NE
|
||||||
( intercalate, sortOn )
|
( NonEmpty(..)
|
||||||
|
, fromList, head, length, sort
|
||||||
|
)
|
||||||
|
import Data.Semigroup
|
||||||
|
( Arg(..) )
|
||||||
import Data.Traversable
|
import Data.Traversable
|
||||||
( for )
|
( for )
|
||||||
import GHC.Clock
|
import GHC.Clock
|
||||||
( getMonotonicTime )
|
( getMonotonicTime )
|
||||||
import GHC.Exts
|
|
||||||
( Proxy#, proxy# )
|
-- code-page
|
||||||
import GHC.Generics
|
import System.IO.CodePage
|
||||||
( Generic )
|
( withCP65001 )
|
||||||
import GHC.TypeNats
|
|
||||||
( Nat, type (-) )
|
|
||||||
import Numeric
|
|
||||||
( showFFloat )
|
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import qualified Data.IntMap.Strict as IntMap
|
import qualified Data.IntMap.Strict as IntMap
|
||||||
( fromList, toList )
|
( fromList, toList )
|
||||||
import Data.Sequence
|
|
||||||
( Seq )
|
|
||||||
import qualified Data.Sequence as Seq
|
|
||||||
( index )
|
|
||||||
import Data.Tree
|
|
||||||
( foldTree )
|
|
||||||
|
|
||||||
-- deepseq
|
-- deepseq
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
( rnf )
|
( rnf )
|
||||||
|
|
||||||
-- gauge
|
|
||||||
--import qualified Gauge
|
|
||||||
|
|
||||||
-- tree-view
|
|
||||||
import Data.Tree.View
|
|
||||||
( showTree )
|
|
||||||
|
|
||||||
-- brush-strokes
|
-- brush-strokes
|
||||||
import Calligraphy.Brushes
|
|
||||||
import Debug.Utils
|
|
||||||
( logToFile )
|
|
||||||
import Math.Algebra.Dual
|
|
||||||
import Math.Bezier.Spline
|
|
||||||
import Math.Bezier.Stroke
|
import Math.Bezier.Stroke
|
||||||
import Math.Bezier.Stroke.EnvelopeEquation
|
|
||||||
import Math.Differentiable
|
|
||||||
import Math.Interval
|
|
||||||
import Math.Linear
|
|
||||||
import Math.Module
|
|
||||||
import Math.Ring
|
|
||||||
( Transcendental )
|
|
||||||
import Math.Root.Isolation
|
import Math.Root.Isolation
|
||||||
|
|
||||||
|
-- brush-strokes bench:cusps
|
||||||
|
import Bench.Cases
|
||||||
|
import Bench.Types
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
{-
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = Gauge.defaultMainWith benchConfig
|
main = withCP65001 $ do
|
||||||
[ Gauge.bgroup "Cusp finding"
|
|
||||||
[ Gauge.bench testName $ Gauge.nf benchTest benchCase
|
|
||||||
| benchCase@( TestCase { testName } ) <- benchCases
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
benchConfig :: Gauge.Config
|
|
||||||
benchConfig = Gauge.defaultConfig
|
|
||||||
{ Gauge.timeLimit = Just 0
|
|
||||||
, Gauge.minSamples = Nothing
|
|
||||||
, Gauge.minDuration = 0
|
|
||||||
}
|
|
||||||
|
|
||||||
benchTest :: TestCase -> ()
|
|
||||||
benchTest ( TestCase { testBrushStroke, testCuspOptions, testStartBoxes } ) =
|
|
||||||
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
|
||||||
( _, ( dunno, sols ) ) = computeCusps testCuspOptions testStrokeFnI testStartBoxes
|
|
||||||
in dunno `seq` sols `seq` ()
|
|
||||||
-}
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
putStrLn "Running cusp-finding benchmarks."
|
putStrLn "Running cusp-finding benchmarks."
|
||||||
testsWithTime <-
|
for_ benchGroups $ \ ( groupName, benchGroupCases ) -> do
|
||||||
for testCases $ \ tst -> do { dt <- benchTestCase tst; return ( tst, dt ) }
|
|
||||||
let (bestTest, bestTime) = head $ sortOn snd testsWithTime
|
|
||||||
putStrLn $ unlines
|
putStrLn $ unlines
|
||||||
[ replicate 40 '='
|
[ replicate 40 '='
|
||||||
, "Best time: " ++ show bestTime ++ "s"
|
, "Benchmark group '" ++ groupName ++ "':" ]
|
||||||
, "Best parameters: " ++ show (testName bestTest)
|
testsWithTime <- for benchGroupCases $ \ tst -> do
|
||||||
|
dt <- benchTestCase groupName tst
|
||||||
|
return $ Arg dt tst
|
||||||
|
let Arg bestTime bestTest = NE.head $ NE.sort testsWithTime
|
||||||
|
when ( NE.length benchGroupCases >= 1 ) $
|
||||||
|
putStrLn $ unlines $
|
||||||
|
[ "Best time in '" ++ groupName ++ "' group: " ++ show bestTime ++ "s" ]
|
||||||
|
++ [ " (" ++ descr ++ ")"
|
||||||
|
| let descr = testDescription bestTest
|
||||||
|
, not ( null descr )
|
||||||
]
|
]
|
||||||
|
|
||||||
benchTestCase :: TestCase -> IO Double
|
-- TODO: run the benchmark multiple times to reduce noise.
|
||||||
benchTestCase ( TestCase { testName, testBrushStroke, testCuspOptions, testStartBoxes } ) = do
|
benchTestCase :: String -> TestCase -> IO Double
|
||||||
putStrLn $ unlines
|
benchTestCase testName ( TestCase { testDescription, testBrushStroke, testCuspOptions, testStartBoxes } ) = do
|
||||||
[ replicate 40 '='
|
putStr $ unlines
|
||||||
, "Test case " ++ testName ]
|
[ " " ++ replicate 38 '-'
|
||||||
|
, " -- Test case: " ++ testName ++ ( if null testDescription then "" else " (" ++ testDescription ++ ")" )
|
||||||
|
, " --" ]
|
||||||
before <- getMonotonicTime
|
before <- getMonotonicTime
|
||||||
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
||||||
( dunno, sols ) =
|
( dunno, sols ) =
|
||||||
|
|
@ -133,90 +79,40 @@ benchTestCase ( TestCase { testName, testBrushStroke, testCuspOptions, testStart
|
||||||
rnf dunno `seq` rnf sols `seq` return ()
|
rnf dunno `seq` rnf sols `seq` return ()
|
||||||
after <- getMonotonicTime
|
after <- getMonotonicTime
|
||||||
let dt = after - before
|
let dt = after - before
|
||||||
putStrLn $ unlines
|
putStrLn $ unlines $
|
||||||
[ " - #sols: " ++ show sols --( length sols )
|
[ " -- sols:" ++ ( if null sols then " ∅" else "" ) ]
|
||||||
, " - #dunno: " ++ show ( length dunno )
|
++
|
||||||
, " - Time elapsed: " ++ show dt ++ "s"
|
( map ( \ sol -> " -- • " ++ show sol ) sols )
|
||||||
, "" ]
|
++
|
||||||
|
[ " -- #dunno: " ++ show ( length dunno )
|
||||||
|
, " -- Time elapsed: " ++ show dt ++ "s" ]
|
||||||
return dt
|
return dt
|
||||||
|
|
||||||
{-
|
benchGroups :: [ ( String, NE.NonEmpty TestCase ) ]
|
||||||
main :: IO ()
|
benchGroups =
|
||||||
main =
|
[ ( "ellipse"
|
||||||
for_ testCases $ \ testCase@( TestCase { testName, testBrushStroke, testCuspOptions, testStartBoxes } ) -> do
|
, NE.fromList
|
||||||
let ( _, testStrokeFnI ) = brushStrokeFunctions testBrushStroke
|
[ ellipseTestCase opts ("ε=" ++ show narrowAbs)
|
||||||
( newtTrees, ( dunno, sols ) ) = computeCusps testCuspOptions testStrokeFnI testStartBoxes
|
( 0, 1 ) pi
|
||||||
showedTrees = map ( uncurry showIntervalNewtonTree ) newtTrees
|
( defaultStartBoxes [ 0 .. 3 ] )
|
||||||
testHeader =
|
| narrowAbs <- [ 5e-2, 1e-6 ]
|
||||||
[ "", "Test case '" ++ testName ++ "':" ]
|
|
||||||
putStrLn $ unlines $
|
|
||||||
testHeader ++
|
|
||||||
map ( " " ++ )
|
|
||||||
[ " #sols: " ++ show (length sols)
|
|
||||||
, "#dunno: " ++ show (length dunno)
|
|
||||||
, "#trees: " ++ show @Int (sum @_ @Int $ map (foldTree ( \ _ bs -> 1 + sum bs )) showedTrees)
|
|
||||||
, " dunno: " ++ show dunno
|
|
||||||
, " sols: " ++ show sols
|
|
||||||
]
|
|
||||||
-- logFileMVar <- newMVar "logs/fnData.log"
|
|
||||||
-- logToFile logFileMVar (unlines logLines)
|
|
||||||
-- `seq` return ()
|
|
||||||
-}
|
|
||||||
|
|
||||||
testCases :: [ TestCase ]
|
|
||||||
testCases = benchCases
|
|
||||||
-- [ --trickyCusp2
|
|
||||||
-- ellipse "full" (0,1) pi $ defaultStartBoxes [ 2 ]
|
|
||||||
-- ]
|
|
||||||
-- ++
|
|
||||||
{-
|
|
||||||
[ ellipse ( "(k1, k2) = " ++ show (k1, k2) ) (k1, k2) pi $ defaultStartBoxes [ 2 ]
|
|
||||||
| (k1, k2) <-
|
|
||||||
[(0.5,0.6), (0.55, 0.56)]
|
|
||||||
] ++
|
|
||||||
[ ellipse ( "'(k1, k2) = " ++ show (k1, k2) ) (0,1) pi [ mkBox (k1 + zero, k2 + zero) 2 (zero, one) ]
|
|
||||||
| (k1, k2) <-
|
|
||||||
[(0.5,0.6), (0.55, 0.56)]
|
|
||||||
]
|
|
||||||
-}
|
|
||||||
|
|
||||||
benchCases :: [ TestCase ]
|
|
||||||
benchCases =
|
|
||||||
[ ellipseTestCase opts ("minWidth=" ++ show minWidth ++ ",ε=" ++ show narrowAbs) ( 0, 1 ) pi $ defaultStartBoxes [ 2 ]
|
|
||||||
| minWidth <- [ 1e-5 ]
|
|
||||||
, narrowAbs <- [ 5e-2 ]
|
|
||||||
, let opts =
|
, let opts =
|
||||||
RootIsolationOptions
|
RootIsolationOptions
|
||||||
{ rootIsolationAlgorithms = defaultRootIsolationAlgorithms minWidth narrowAbs
|
{ rootIsolationAlgorithms =
|
||||||
|
defaultRootIsolationAlgorithms minWidth narrowAbs
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
|
)
|
||||||
|
, ( "trickyCusp2", NE.fromList [ trickyCusp2TestCase ] )
|
||||||
|
]
|
||||||
|
where
|
||||||
|
minWidth = 1e-5
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data BrushStroke =
|
{- -- Old testing code.
|
||||||
forall nbParams. ParamsCt nbParams =>
|
|
||||||
BrushStroke
|
|
||||||
{ brush :: !( Brush ( ℝ nbParams ) )
|
|
||||||
, stroke :: !( Point nbParams, Curve Open () ( Point nbParams ) )
|
|
||||||
}
|
|
||||||
|
|
||||||
|
getR1 (ℝ1 u) = u
|
||||||
data TestCase =
|
|
||||||
TestCase
|
|
||||||
{ testName :: String
|
|
||||||
, testBrushStroke :: BrushStroke
|
|
||||||
, testCuspOptions :: RootIsolationOptions N 3
|
|
||||||
, testStartBoxes :: [ ( Int, [ Box 2 ] ) ]
|
|
||||||
}
|
|
||||||
|
|
||||||
brushStrokeFunctions
|
|
||||||
:: BrushStroke
|
|
||||||
-> ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () )
|
|
||||||
, 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
|
||||||
brushStrokeFunctions ( BrushStroke { stroke = ( sp0, crv ), brush } ) =
|
|
||||||
getStrokeFunctions brush sp0 crv
|
|
||||||
|
|
||||||
-- Utilities to use in GHCi to help debugging.
|
|
||||||
|
|
||||||
eval
|
eval
|
||||||
:: ( I i ( ℝ 1 ) -> Seq ( I i ( ℝ 1 ) -> StrokeDatum k i ) )
|
:: ( I i ( ℝ 1 ) -> Seq ( I i ( ℝ 1 ) -> StrokeDatum k i ) )
|
||||||
|
|
@ -234,12 +130,6 @@ 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 ) )
|
||||||
|
|
||||||
zero, one :: Double
|
|
||||||
zero = 1e-6
|
|
||||||
one = 1 - zero
|
|
||||||
{-# INLINE zero #-}
|
|
||||||
{-# INLINE one #-}
|
|
||||||
|
|
||||||
potentialCusp :: StrokeDatum 3 𝕀 -> Bool
|
potentialCusp :: StrokeDatum 3 𝕀 -> Bool
|
||||||
potentialCusp
|
potentialCusp
|
||||||
( StrokeDatum
|
( StrokeDatum
|
||||||
|
|
@ -253,118 +143,6 @@ potentialCusp
|
||||||
dEdsdcdt :: StrokeDatum k i -> D ( k - 2 ) ( I i ( ℝ 2 ) ) ( T ( I i ( ℝ 2 ) ) )
|
dEdsdcdt :: StrokeDatum k i -> D ( k - 2 ) ( I i ( ℝ 2 ) ) ( T ( I i ( ℝ 2 ) ) )
|
||||||
dEdsdcdt ( StrokeDatum { 𝛿E𝛿sdcdt = v } ) = v
|
dEdsdcdt ( StrokeDatum { 𝛿E𝛿sdcdt = v } ) = v
|
||||||
|
|
||||||
{-
|
|
||||||
let (f, fI) = testCaseStrokeFunctions trickyCusp2
|
|
||||||
|
|
||||||
take 10 $ Data.List.sortOn ( \ ( _, ℝ1 e, v) -> abs e + norm v ) [ let { v = mkVal x 3 y; d = eval f v } in ( v, _D12_v $ ee d, _D0_v $ dEdsdcdt d ) | x <- [0.57,0.5701 .. 0.58], y <- [0.29,0.291..0.3] ]
|
|
||||||
> ((ℝ1 0.5798800000000057,3,ℝ1 0.267980000000008),ℝ1 -2.8596965543670194e-4,V2 7.79559474412963e-2 2.0389671921293484e-2)
|
|
||||||
|
|
||||||
potentialCusp $ eval fI $ mkBox (0.5798, 0.5799) 3 (0.26798, 0.26799)
|
|
||||||
> True
|
|
||||||
|
|
||||||
let nbPotentialSols b = let ( _newtTrees, ( dunno, sols ) ) = isolateRootsIn NoPreconditioning 1e-7 fI b in length dunno + length sols
|
|
||||||
|
|
||||||
nbPotentialSols $ mkBox (0.5798, 0.5799) 3 (0.26798, 0.26799)
|
|
||||||
1
|
|
||||||
|
|
||||||
nbPotentialSols $ mkBox (0.5798, 0.675) 3 (0.26798, 0.26799)
|
|
||||||
0
|
|
||||||
|
|
||||||
let showTrees b = map ( uncurry showIntervalNewtonTree ) $ fst $ isolateRootsIn NoPreconditioning 1e-7 fI b
|
|
||||||
|
|
||||||
putStrLn $ unlines $ map Data.Tree.View.showTree $ showTrees $ mkBox (0.5798, 0.675) 3 (0.26798, 0.26799)
|
|
||||||
|
|
||||||
([ℝ1 0.5798, ℝ1 0.675],3,[ℝ1 0.26798, ℝ1 0.26799]) (area 0.000001) N []
|
|
||||||
└─ ([ℝ1 0.5973000285624527, ℝ1 0.6750000000000002],3,[ℝ1 0.26798, ℝ1 0.26799000000000006]) (area 0.000001) NoSolution "ee" ([ℝ1 0.5973000285624527, ℝ1 0.6750000000000002],3,[ℝ1 0.26798, ℝ1 0.26799000000000006])
|
|
||||||
|
|
||||||
eval fI $ mkBox (0.5798, 0.675) 3 (0.26798, 0.26799)
|
|
||||||
> D12 {_D12_v = T[ℝ2 -10088.6674944889 -3281.3820867312834, ℝ2 4124.668381545453 4524.807156085763], _D12_dx = TT[ℝ2 -173746.97965005718 -33281.18494907289, ℝ2 298.2609121556852 23639.772884799597], _D12_dy = TT[ℝ2 -18454.27716258352 -28337.509817580823, ℝ2 1163.6949532017436 -13936.383137525536]}}
|
|
||||||
i.e.
|
|
||||||
> f = [ℝ2 -10088.6674944889 -3281.3820867312834, ℝ2 4124.668381545453 4524.807156085763]
|
|
||||||
> f_t = [ℝ2 -173746.97965005718 -33281.18494907289, ℝ2 298.2609121556852 23639.772884799597]
|
|
||||||
> f_s = [ℝ2 -18454.27716258352 -28337.509817580823, ℝ2 1163.6949532017436 -13936.383137525536]
|
|
||||||
|
|
||||||
(f, fI) = testCaseStrokeFunctions trickyCusp2
|
|
||||||
t = 𝕀 (ℝ1 0.5798) (ℝ1 0.675)
|
|
||||||
s = 𝕀 (ℝ1 0.26798) (ℝ1 0.26799)
|
|
||||||
t_mid = 0.5 * ( 0.5798 + 0.675 )
|
|
||||||
s_mid = 0.5 * ( 0.26798 + 0.26799 )
|
|
||||||
D12 ( T f ) ( T ( T f_t ) ) ( T ( T f_s ) ) = dEdsdcdt $ eval fI (t, 3, s)
|
|
||||||
t' = coerce ( (-) @( 𝕀 Double ) ) t ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s' = coerce ( (-) @( 𝕀 Double ) ) s ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
a = ( f_t, f_s )
|
|
||||||
b = negV2 $ singleton $ midV2 f
|
|
||||||
[((t2', s2'), isContr)] = gaussSeidel a b (t', s')
|
|
||||||
t2 = coerce ( (+) @( 𝕀 Double ) ) t2' ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s2 = coerce ( (+) @( 𝕀 Double ) ) s2' ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
|
|
||||||
t2
|
|
||||||
> [ℝ1 0.6102365832093095, ℝ1 0.6750000000000002]
|
|
||||||
s2
|
|
||||||
> [ℝ1 0.26798, ℝ1 0.26799000000000006]
|
|
||||||
|
|
||||||
|
|
||||||
let ( 𝕀 ( ℝ2 a11_lo a21_lo ) ( ℝ2 a11_hi a21_hi ), 𝕀 ( ℝ2 a12_lo a22_lo ) ( ℝ2 a12_hi a22_hi ) ) = a
|
|
||||||
let ( 𝕀 ( ℝ2 b1_lo b2_lo ) ( ℝ2 b1_hi b2_hi ) ) = b
|
|
||||||
let ( 𝕀 ( ℝ1 x1_lo ) ( ℝ1 x1_hi ), 𝕀 ( ℝ1 x2_lo ) ( ℝ1 x2_hi ) ) = ( t', s' )
|
|
||||||
|
|
||||||
a11 = 𝕀 a11_lo a11_hi
|
|
||||||
a12 = 𝕀 a12_lo a12_hi
|
|
||||||
a21 = 𝕀 a21_lo a21_hi
|
|
||||||
a22 = 𝕀 a22_lo a22_hi
|
|
||||||
b1 = 𝕀 b1_lo b1_hi
|
|
||||||
b2 = 𝕀 b2_lo b2_hi
|
|
||||||
x1 = 𝕀 x1_lo x1_hi
|
|
||||||
x2 = 𝕀 x2_lo x2_hi
|
|
||||||
|
|
||||||
( b1 - a12 * x2 )
|
|
||||||
> [2981.90728508591, 2982.0918278575364]
|
|
||||||
|
|
||||||
extendedRecip a11
|
|
||||||
|
|
||||||
-----------------------
|
|
||||||
|
|
||||||
fI k rot = snd $ testCaseStrokeFunctions $ ellipse k rot
|
|
||||||
d k rot = width $ _D22_v $ ee $ eval (fI k rot) $ mkBox (1e-6, 1-1e-6) 3 (1e-6, 1-1e-6)
|
|
||||||
|
|
||||||
-----------------------
|
|
||||||
|
|
||||||
(f, fI) = testCaseStrokeFunctions $ ellipse 1 pi
|
|
||||||
t = 𝕀 (ℝ1 0.001) (ℝ1 0.099)
|
|
||||||
s = 𝕀 (ℝ1 0.001) (ℝ1 0.999)
|
|
||||||
t_mid = 0.5 * ( 0.001 + 0.099 )
|
|
||||||
s_mid = 0.5 * ( 0.001 + 0.999 )
|
|
||||||
D12 ( T f ) ( T ( T f_t ) ) ( T ( T f_s ) ) = dEdsdcdt $ eval fI (t, 3, s)
|
|
||||||
t' = coerce ( (-) @( 𝕀 Double ) ) t ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s' = coerce ( (-) @( 𝕀 Double ) ) s ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
a = ( f_t, f_s )
|
|
||||||
b = negV2 $ singleton $ midV2 f
|
|
||||||
[((t2', s2'), isContr)] = gaussSeidel a b (t', s')
|
|
||||||
t2 = coerce ( (+) @( 𝕀 Double ) ) t2' ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s2 = coerce ( (+) @( 𝕀 Double ) ) s2' ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
|
|
||||||
> t = [0.001, 0.099]
|
|
||||||
> t' = [-0.049, 0.049]
|
|
||||||
|
|
||||||
(f, fI) = testCaseStrokeFunctions $ ellipse 0.1 pi
|
|
||||||
t = 𝕀 (ℝ1 0.001) (ℝ1 0.999)
|
|
||||||
s = 𝕀 (ℝ1 0.001) (ℝ1 0.999)
|
|
||||||
t_mid = 0.5 * ( 0.001 + 0.999 )
|
|
||||||
s_mid = 0.5 * ( 0.001 + 0.999 )
|
|
||||||
D12 ( T f ) ( T ( T f_t ) ) ( T ( T f_s ) ) = dEdsdcdt $ eval fI (t, 3, s)
|
|
||||||
t' = coerce ( (-) @( 𝕀 Double ) ) t ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s' = coerce ( (-) @( 𝕀 Double ) ) s ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
a = ( f_t, f_s )
|
|
||||||
b = negV2 $ singleton $ midV2 f
|
|
||||||
[((t2', s2'), isContr)] = gaussSeidel a b (t', s')
|
|
||||||
t2 = coerce ( (+) @( 𝕀 Double ) ) t2' ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s2 = coerce ( (+) @( 𝕀 Double ) ) s2' ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
|
|
||||||
> t = [0.001, 0.999]
|
|
||||||
> t' = [-0.499, 0.499]
|
|
||||||
|
|
||||||
-}
|
|
||||||
|
|
||||||
width :: 𝕀ℝ 1 -> Double
|
width :: 𝕀ℝ 1 -> Double
|
||||||
width (𝕀 (ℝ1 lo) (ℝ1 hi)) = hi - lo
|
width (𝕀 (ℝ1 lo) (ℝ1 hi)) = hi - lo
|
||||||
|
|
||||||
|
|
@ -409,276 +187,10 @@ logLines =
|
||||||
midPoint2 (𝕀 (ℝ2 lo_x lo_y) (ℝ2 hi_x hi_y))
|
midPoint2 (𝕀 (ℝ2 lo_x lo_y) (ℝ2 hi_x hi_y))
|
||||||
= ℝ2 ( 0.5 * ( lo_x + hi_x ) ) ( 0.5 * ( lo_y + hi_y ) )
|
= ℝ2 ( 0.5 * ( lo_x + hi_x ) ) ( 0.5 * ( lo_y + hi_y ) )
|
||||||
|
|
||||||
|
|
||||||
-- t = 0.5486102, s = 0.5480951
|
|
||||||
|
|
||||||
|
|
||||||
bloo =
|
|
||||||
[ ( e * e + vx * vx + vy * vy, ( t, s ) )
|
|
||||||
| t <- [ 0.548609, 0.548609 + 0.0000001 .. 0.54862 ]
|
|
||||||
, s <- [ 0.548094, 0.548094 + 0.0000001 .. 0.548096 ]
|
|
||||||
, let StrokeDatum
|
|
||||||
{ ee = D22 ee _ _ _ _ _
|
|
||||||
, 𝛿E𝛿sdcdt = D12 (T f) _ _
|
|
||||||
} = (curvesI (singleton (ℝ1 t)) `Seq.index` i) (singleton (ℝ1 s))
|
|
||||||
e = midPoint ee
|
|
||||||
ℝ2 vx vy = midPoint2 f
|
|
||||||
vals = [ showD ( midPoint ee )
|
|
||||||
, "{" ++ showD vx ++ "," ++ showD vy ++ "}"
|
|
||||||
]
|
|
||||||
]
|
|
||||||
where
|
|
||||||
i = 2
|
|
||||||
( curves, curvesI ) = brushStrokeFunctions $ ellipseBrushStroke ( 0, 1 ) pi
|
|
||||||
midPoint (𝕀 (ℝ1 lo) (ℝ1 hi)) = 0.5 * ( lo + hi )
|
|
||||||
midPoint2 (𝕀 (ℝ2 lo_x lo_y) (ℝ2 hi_x hi_y))
|
|
||||||
= ℝ2 ( 0.5 * ( lo_x + hi_x ) ) ( 0.5 * ( lo_y + hi_y ) )
|
|
||||||
|
|
||||||
{-
|
|
||||||
|
|
||||||
(f, fI) = brushStrokeFunctions $ ellipseBrushStroke ( 0, 1 ) pi
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
_D22_v $ ee $ eval fI $ mkBox (0.5, 0.6) 2 (0,1)
|
|
||||||
> [ℝ1 -9531.427315889887, ℝ1 10135.074304695485]
|
|
||||||
|
|
||||||
minimum $ map inf $ [ _D22_v $ ee $ eval fI $ mkBox (t, t + 0.01) 2 (0,1) | t <- [ 0.5, 0.51 .. 0.59 ] ]
|
|
||||||
> ℝ1 -5718.905635365308
|
|
||||||
|
|
||||||
maximum $ map sup $ [ _D22_v $ ee $ eval fI $ mkBox (t, t + 0.01) 2 (0,1) | t <- [ 0.5, 0.51 .. 0.59 ] ]
|
|
||||||
> ℝ1 5099.008191092755
|
|
||||||
|
|
||||||
minimum $ map inf $ [ _D22_v $ ee $ eval fI $ mkBox (t, t) 2 (s, s) | t <- [ 0.5, 0.501 .. 0.6 ], s <- [ zero, zero + 0.001 .. one ] ]
|
|
||||||
> ℝ1 -675.9595496147458
|
|
||||||
|
|
||||||
maximum $ map sup $ [ _D22_v $ ee $ eval fI $ mkBox (t, t) 2 (s, s) | t <- [ 0.5, 0.501 .. 0.6 ], s <- [ zero, zero + 0.001 .. one ] ]
|
|
||||||
> ℝ1 2401.9644509525997
|
|
||||||
|
|
||||||
_D12_v $ dEdsdcdt $ eval fI $ mkBox (0.5, 0.6) 2 (0,1)
|
|
||||||
> T[ℝ2 -1.7300637136531524e7 -1.262824151868635e7, ℝ2 1.632868898735965e7 1.1869759856947478e7]
|
|
||||||
|
|
||||||
minimum [ _x $ inf $ unT $ _D12_v $ dEdsdcdt $ eval fI $ mkBox (t, t + 0.01) 2 (0,1) | t <- [ 0.5, 0.51 .. 0.59 ] ]
|
|
||||||
-5606615.948203902
|
|
||||||
|
|
||||||
maximum [ _x $ sup $ unT $ _D12_v $ dEdsdcdt $ eval fI $ mkBox (t, t + 0.01) 2 (0,1) | t <- [ 0.5, 0.51 .. 0.59 ] ]
|
|
||||||
4340858.832347277
|
|
||||||
|
|
||||||
minimum [ _x $ inf $ unT $ _D12_v $ dEdsdcdt $ eval fI $ mkBox (t, t) 2 (s, s) | t <- [ 0.5, 0.501 .. 0.6 ], s <- [ zero, zero + 0.001 .. one ] ]
|
|
||||||
-1785730.2396688666
|
|
||||||
|
|
||||||
maximum [ _x $ sup $ unT $ _D12_v $ dEdsdcdt $ eval fI $ mkBox (t, t) 2 (s, s) | t <- [ 0.5, 0.501 .. 0.6 ], s <- [ zero, zero + 0.001 .. one ] ]
|
|
||||||
974842.6547409865
|
|
||||||
|
|
||||||
maximum [ _y $ sup $ unT $ _D12_v $ dEdsdcdt $ eval fI $ mkBox (t, t) 2 (s, s) | t <- [ 0.5, 0.501 .. 0.6 ], s <- [ zero, zero + 0.001 .. one ] ]
|
|
||||||
845211.4833711373
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
let showTrees b = map ( uncurry showIntervalNewtonTree ) $ fst $ isolateRootsIn NoPreconditioning 1e-7 fI b
|
|
||||||
|
|
||||||
putStrLn $ unlines $ map Data.Tree.View.showTree $ showTrees $ mkBox (0.5486101933245248, 0.5486102071493622) 2 (0.548095036738487, 0.5480952)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
([ℝ1 0.5486101960904595, ℝ1 0.5486102071493623],2,[ℝ1 0.5480950771755867, ℝ1 0.5480952000000001])
|
|
||||||
|
|
||||||
-}
|
|
||||||
|
|
||||||
_x ( ℝ2 x _ ) = x
|
_x ( ℝ2 x _ ) = x
|
||||||
_y ( ℝ2 _ y ) = y
|
_y ( ℝ2 _ y ) = y
|
||||||
|
|
||||||
showD :: Double -> String
|
showD :: Double -> String
|
||||||
showD float = showFFloat (Just 6) float ""
|
showD float = showFFloat (Just 6) float ""
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
ellipseTestCase :: RootIsolationOptions N 3 -> String -> ( Double, Double ) -> Double -> [ ( Int, [ Box 2 ] ) ] -> TestCase
|
|
||||||
ellipseTestCase opts str k0k1 rot startBoxes =
|
|
||||||
TestCase
|
|
||||||
{ testName = "ellipse (" ++ str ++ ")"
|
|
||||||
, testBrushStroke = ellipseBrushStroke k0k1 rot
|
|
||||||
, testCuspOptions = opts
|
|
||||||
, testStartBoxes = startBoxes
|
|
||||||
}
|
|
||||||
|
|
||||||
ellipseBrushStroke :: ( Double, Double ) -> Double -> BrushStroke
|
|
||||||
ellipseBrushStroke ( k0, k1 ) rot =
|
|
||||||
BrushStroke
|
|
||||||
{ brush = ellipseBrush
|
|
||||||
, stroke = ( p0, LineTo ( NextPoint p1 ) () ) }
|
|
||||||
where
|
|
||||||
mkPt x y w h phi =
|
|
||||||
Point
|
|
||||||
{ pointCoords = ℝ2 x y
|
|
||||||
, pointParams = Params $ ℝ3 w h phi
|
|
||||||
}
|
|
||||||
l k = lerp @( T Double ) k
|
|
||||||
p k = mkPt ( l k 0 100 ) 0 ( l k 10 15 ) ( l k 25 40 ) ( l k 0 rot )
|
|
||||||
p0 = p k0
|
|
||||||
p1 = p k1
|
|
||||||
|
|
||||||
trickyCusp2TestCase :: TestCase
|
|
||||||
trickyCusp2TestCase =
|
|
||||||
TestCase
|
|
||||||
{ testName = "trickyCusp2"
|
|
||||||
, testBrushStroke = trickyCusp2BrushStroke
|
|
||||||
, testCuspOptions = defaultRootIsolationOptions
|
|
||||||
, testStartBoxes = defaultStartBoxes [ 0 .. 3 ]
|
|
||||||
}
|
|
||||||
|
|
||||||
trickyCusp2BrushStroke :: BrushStroke
|
|
||||||
trickyCusp2BrushStroke =
|
|
||||||
BrushStroke
|
|
||||||
{ brush = circleBrush
|
|
||||||
, stroke = ( p0, Bezier3To p1 p2 ( NextPoint p3 ) () )
|
|
||||||
}
|
|
||||||
where
|
|
||||||
mkPt x y =
|
|
||||||
Point
|
|
||||||
{ pointCoords = ℝ2 x y
|
|
||||||
, pointParams = Params $ ℝ1 5.0
|
|
||||||
}
|
|
||||||
p0 = mkPt 5e+1 -5e+1
|
|
||||||
p1 = mkPt -7.72994362904069e+1 -3.124468786098509e+1
|
|
||||||
p2 = mkPt -5.1505430313958364e+1 -3.9826386521527986e+1
|
|
||||||
p3 = mkPt -5e+1 -5e+1
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
type ParamsCt nbParams
|
|
||||||
= ( Show ( ℝ nbParams )
|
|
||||||
, HasChainRule Double 2 ( ℝ nbParams )
|
|
||||||
, HasChainRule ( 𝕀 Double ) 3 ( 𝕀 ( ℝ nbParams ) )
|
|
||||||
, Applicative ( D 2 ( ℝ nbParams ) )
|
|
||||||
, Applicative ( D 3 ( ℝ nbParams ) )
|
|
||||||
, Traversable ( D 2 ( ℝ nbParams ) )
|
|
||||||
, Traversable ( D 3 ( ℝ nbParams ) )
|
|
||||||
, Representable Double ( ℝ nbParams )
|
|
||||||
, Module Double ( T ( ℝ nbParams ) )
|
|
||||||
, Module ( 𝕀 Double ) ( T ( 𝕀 ( ℝ nbParams ) ) )
|
|
||||||
, Module ( D 2 ( ℝ nbParams ) Double ) ( D 2 ( ℝ nbParams ) ( ℝ 2 ) )
|
|
||||||
, Module ( D 3 ( ℝ nbParams ) ( 𝕀 Double ) ) ( D 3 ( ℝ nbParams ) ( 𝕀 ( ℝ 2 ) ) )
|
|
||||||
, Transcendental ( D 2 ( ℝ nbParams ) Double )
|
|
||||||
, Transcendental ( D 3 ( ℝ nbParams ) ( 𝕀 Double ) )
|
|
||||||
)
|
|
||||||
|
|
||||||
newtype Params nbParams = Params { getParams :: ( ℝ nbParams ) }
|
|
||||||
deriving newtype instance Show ( ℝ nbParams ) => Show ( Params nbParams )
|
|
||||||
|
|
||||||
data Point nbParams =
|
|
||||||
Point
|
|
||||||
{ pointCoords :: !( ℝ 2 )
|
|
||||||
, pointParams :: !( Params nbParams ) }
|
|
||||||
deriving stock Generic
|
|
||||||
deriving stock instance Show ( ℝ nbParams ) => Show ( Point nbParams )
|
|
||||||
|
|
||||||
getStrokeFunctions
|
|
||||||
:: forall nbParams
|
|
||||||
. ParamsCt nbParams
|
|
||||||
=> Brush ( ℝ nbParams )
|
|
||||||
-- ^ brush shape
|
|
||||||
-> Point nbParams
|
|
||||||
-- ^ start point
|
|
||||||
-> Curve Open () ( Point nbParams )
|
|
||||||
-- ^ curve points
|
|
||||||
-> ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 () )
|
|
||||||
, 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
|
|
||||||
getStrokeFunctions ( Brush brushShape brushShapeI mbRot ) sp0 crv =
|
|
||||||
let
|
|
||||||
usedParams :: C 2 ( ℝ 1 ) ( ℝ nbParams )
|
|
||||||
path :: C 2 ( ℝ 1 ) ( ℝ 2 )
|
|
||||||
( path, usedParams ) =
|
|
||||||
pathAndUsedParams @2 @() coerce id ( getParams . pointParams )
|
|
||||||
sp0 crv
|
|
||||||
usedParamsI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ nbParams )
|
|
||||||
pathI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 )
|
|
||||||
( pathI, usedParamsI ) =
|
|
||||||
pathAndUsedParams @3 @𝕀 coerce singleton ( getParams . pointParams )
|
|
||||||
sp0 crv
|
|
||||||
in ( brushStrokeData @2 @( ℝ nbParams ) coerce coerce
|
|
||||||
path usedParams
|
|
||||||
brushShape
|
|
||||||
mbRot
|
|
||||||
, brushStrokeData @3 @( ℝ nbParams ) coerce coerce
|
|
||||||
pathI usedParamsI
|
|
||||||
brushShapeI
|
|
||||||
( fmap nonDecreasing mbRot )
|
|
||||||
)
|
|
||||||
{-# INLINEABLE getStrokeFunctions #-}
|
|
||||||
|
|
||||||
defaultStartBoxes :: [ Int ] -> [ ( Int, [ Box 2 ] ) ]
|
|
||||||
defaultStartBoxes is =
|
|
||||||
[ ( i, [ 𝕀 ( ℝ2 zero zero ) ( ℝ2 one one ) ] ) | i <- is ]
|
|
||||||
-- [ ( i, [ 𝕀 ( ℝ2 t s ) ( ℝ2 ( t + 0.099999 ) ( s + 0.099999 ) )
|
|
||||||
-- | t <- [ 0.00001, 0.1 .. 0.9 ]
|
|
||||||
-- , s <- [ 0.00001, 0.1 .. 0.9 ]
|
|
||||||
-- ] )
|
|
||||||
-- | i <- is
|
|
||||||
-- ]
|
|
||||||
|
|
||||||
getR1 (ℝ1 u) = u
|
|
||||||
|
|
||||||
{-
|
|
||||||
|
|
||||||
(f, fI) = brushStrokeFunctions $ ellipseBrushStroke (0,1) pi
|
|
||||||
nbPotentialSols box = let ( _newtTrees, ( dunno, sols ) ) = isolateRootsIn NoPreconditioning 1e-7 fI box in length dunno + length sols
|
|
||||||
showTrees box = putStrLn $ unlines $ map Data.Tree.View.showTree $ map ( uncurry showIntervalNewtonTree ) $ fst $ isolateRootsIn NoPreconditioning 1e-7 fI box
|
|
||||||
|
|
||||||
sol_t = 0.5486100729150693796677845183880669025324233347060776339185 :: Double
|
|
||||||
sol_s = 0.5480950141859386853197594577293968665598143630958601978245 :: Double
|
|
||||||
containsSol (t, _i, s) = getR1 (inf t) <= sol_t && getR1 (sup t) >= sol_t && getR1 (inf s) <= sol_s && getR1 (sup s) >= sol_s
|
|
||||||
|
|
||||||
(t, i, s) = mkBox (0.54, 0.55) 2 (0.5480, 0.5481)
|
|
||||||
containsSol (t, i, s)
|
|
||||||
nbPotentialSols (t,i,s)
|
|
||||||
|
|
||||||
t_mid = 0.5 * ( getR1 ( inf t ) + getR1 ( sup t ) )
|
|
||||||
s_mid = 0.5 * ( getR1 ( inf s ) + getR1 ( sup s ) )
|
|
||||||
D12 ( T _f ) ( T ( T f_t ) ) ( T ( T f_s ) ) = dEdsdcdt $ eval fI (t, i, s)
|
|
||||||
D0 ( T f_mid ) = dEdsdcdt $ eval f $ mkVal t_mid 2 s_mid
|
|
||||||
t' = coerce ( (-) @( 𝕀 Double ) ) t ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s' = coerce ( (-) @( 𝕀 Double ) ) s ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
a = ( f_t, f_s )
|
|
||||||
b = negV2 $ singleton f_mid
|
|
||||||
[((t2', s2'), isContr)] = gaussSeidel a b (t', s')
|
|
||||||
t2 = coerce ( (+) @( 𝕀 Double ) ) t2' ( singleton ( ℝ1 t_mid ) ) :: 𝕀ℝ 1
|
|
||||||
s2 = coerce ( (+) @( 𝕀 Double ) ) s2' ( singleton ( ℝ1 s_mid ) ) :: 𝕀ℝ 1
|
|
||||||
|
|
||||||
t2
|
|
||||||
> [ℝ1 0.5451193766263323, ℝ1 0.545225929860598]
|
|
||||||
s2
|
|
||||||
> [ℝ1 0.548, ℝ1 0.5481]
|
|
||||||
containsSol (t2, i, s2)
|
|
||||||
> False
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
let ( 𝕀 ( ℝ2 a11_lo a21_lo ) ( ℝ2 a11_hi a21_hi ), 𝕀 ( ℝ2 a12_lo a22_lo ) ( ℝ2 a12_hi a22_hi ) ) = a
|
|
||||||
let ( 𝕀 ( ℝ2 b1_lo b2_lo ) ( ℝ2 b1_hi b2_hi ) ) = b
|
|
||||||
let ( 𝕀 ( ℝ1 x1_lo ) ( ℝ1 x1_hi ), 𝕀 ( ℝ1 x2_lo ) ( ℝ1 x2_hi ) ) = ( t', s' )
|
|
||||||
|
|
||||||
a11 = 𝕀 a11_lo a11_hi
|
|
||||||
a12 = 𝕀 a12_lo a12_hi
|
|
||||||
a21 = 𝕀 a21_lo a21_hi
|
|
||||||
a22 = 𝕀 a22_lo a22_hi
|
|
||||||
b1 = 𝕀 b1_lo b1_hi
|
|
||||||
b2 = 𝕀 b2_lo b2_hi
|
|
||||||
x1 = 𝕀 x1_lo x1_hi
|
|
||||||
x2 = 𝕀 x2_lo x2_hi
|
|
||||||
|
|
||||||
( b1 - a12 * x2 ) `extendedDivide` a11
|
|
||||||
-}
|
|
||||||
|
|
||||||
{-
|
|
||||||
|
|
||||||
bound consistency / box consistency
|
|
||||||
|
|
||||||
ghci> (f, fI) = brushStrokeFunctions $ ellipseBrushStroke (0,1) pi
|
|
||||||
ghci> ee $ eval fI $ mkBox (0, succFP 0) 2 (0.5,0.75)
|
|
||||||
D22 {_D22_v = [ℝ1 -4379.198802308688, ℝ1 -1791.4548164846506], _D22_dx = T[ℝ1 -3417.0023260831304, ℝ1 6215.362085329192], _D22_dy = T[ℝ1 3524.130928930924, ℝ1 8849.881134814816], _D22_dxdx = T[ℝ1 -13397.019488083239, ℝ1 61439.0409103
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
@ -64,6 +64,7 @@ instance RootIsolationAlgorithm Bisection where
|
||||||
( fallbackBisectionCoord thisRoundHist prevRoundsHist eqs )
|
( fallbackBisectionCoord thisRoundHist prevRoundsHist eqs )
|
||||||
box
|
box
|
||||||
return ( whatBis, boxes )
|
return ( whatBis, boxes )
|
||||||
|
{-# INLINEABLE rootIsolationAlgorithm #-}
|
||||||
|
|
||||||
-- | Options for the bisection method.
|
-- | Options for the bisection method.
|
||||||
type BisectionOptions :: Nat -> Nat -> Type
|
type BisectionOptions :: Nat -> Nat -> Type
|
||||||
|
|
|
||||||
|
|
@ -234,7 +234,11 @@ showArea :: Double -> String
|
||||||
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
|
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Utilities.
|
-- Utilities for feeding one computation into the next.
|
||||||
|
|
||||||
|
-- NB: I tried adding RULES on these functions in order to perform
|
||||||
|
-- "loop unrolling"-like optimisations, but this does not seem to
|
||||||
|
-- improve the performance.
|
||||||
|
|
||||||
-- | Run an effectful computation several times in sequence, piping its output
|
-- | Run an effectful computation several times in sequence, piping its output
|
||||||
-- into the next input, once for each coordinate dimension.
|
-- into the next input, once for each coordinate dimension.
|
||||||
|
|
@ -263,3 +267,5 @@ pipeFunctionsWhileTrue fns = go fns
|
||||||
go ( f : fs ) x = do
|
go ( f : fs ) x = do
|
||||||
xs <- f x
|
xs <- f x
|
||||||
concat <$> traverse ( go fs ) xs
|
concat <$> traverse ( go fs ) xs
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
||||||
|
|
@ -227,7 +227,7 @@ narrowingMethods ε_eq ε_bis ( AdaptiveShaving opts )
|
||||||
-- TODO: haven't implemented right shaving yet
|
-- TODO: haven't implemented right shaving yet
|
||||||
narrowingMethods _ε_eq ε_bis TwoSidedShaving
|
narrowingMethods _ε_eq ε_bis TwoSidedShaving
|
||||||
= [ sbc ε_bis ]
|
= [ sbc ε_bis ]
|
||||||
{-# INLINE narrowingMethods #-}
|
{-# INLINEABLE narrowingMethods #-}
|
||||||
|
|
||||||
allNarrowingOperators
|
allNarrowingOperators
|
||||||
:: forall n d
|
:: forall n d
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue