hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

Add mechanisms to log envelope equation data

Browse source
This commit is contained in:
sheaf 2024-02-19 16:46:09 +01:00
parent 6b658acedd
commit b70f7ba133
25 changed files with 366 additions and 158 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
brush-strokes/.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
dist-newstyle/
logs/
cabal.project.local

10
brush-strokes/brush-strokes.cabal
View file

@ -12,7 +12,7 @@ description:
flag use-fma
description: Use fused-muliply add instructions to implement interval arithmetic.
default: True
manual: True
manual: False
common common
@ -27,6 +27,10 @@ common common
>= 0.6.0.1 && < 0.8
, deepseq
>= 1.4.4.0 && < 1.6
, directory
>= 1.3.7.1 && < 1.4
, filepath
>= 1.4 && < 1.6
, generic-lens
>= 2.2 && < 2.3
, groups
@ -37,8 +41,12 @@ common common
^>= 0.9.0.0
, rounded-hw
^>= 0.4
, time
^>= 1.12.2
, transformers
>= 0.5.6.2 && < 0.7
, tree-view
^>= 0.5
default-extensions:
BangPatterns

53
brush-strokes/src/Debug/Utils.hs
View file

@ -1,21 +1,44 @@
module Debug.Utils ( trace ) where
module Debug.Utils
( trace
, logToFile
) where
-- base
import Control.Concurrent.MVar
( MVar, withMVarMasked )
import Control.Monad
( void )
import System.IO
( BufferMode(..), hSetBuffering, hFlush, hPutStrLn, stdout )
import System.IO.Unsafe
( unsafePerformIO )
-- deepseq
import Control.DeepSeq
( force )
-- code-page
import System.IO.CodePage
( withCP65001 )
-- deepseq
import Control.DeepSeq
( force )
-- directory
import qualified System.Directory as Directory
( createDirectoryIfMissing )
-- filepath
import qualified System.FilePath as FilePath
( takeDirectory )
-- time
import qualified Data.Time.Clock as Time
( getCurrentTime )
import qualified Data.Time.Format as Time
( defaultTimeLocale, formatTime )
--------------------------------------------------------------------------------
-- | Like 'Debug.Trace.trace', but using 'withCP65001` in order to handle
-- Unicode without crashing on Windows.
trace :: String -> a -> a
trace ( force -> !str ) expr =
unsafePerformIO $ withCP65001 do
@ -23,3 +46,23 @@ trace ( force -> !str ) expr =
hPutStrLn stdout str
hFlush stdout
return expr
-- | Log the second argument to the file stored in the 'MVar' in the first
-- argument.
--
-- The 'MVar' is used to avoid jumbled contents when attempting to write to
-- the file concurrently.
logToFile :: MVar FilePath -> String -> ()
logToFile logFileMVar logContents =
unsafePerformIO $ withCP65001 $ void $ withMVarMasked logFileMVar $ \ logFile -> do
now <- Time.getCurrentTime
let timeString = Time.formatTime Time.defaultTimeLocale "%0Y-%m-%d (%Hh %Mm %Ss)" now
logContentsWithHeader = unlines
[ replicate 80 '='
, timeString
, logContents
]
Directory.createDirectoryIfMissing True $
FilePath.takeDirectory logFile
appendFile logFile logContentsWithHeader
return logFile

2
brush-strokes/src/Math/Algebra/Dual.hs
View file

@ -33,7 +33,7 @@ import Data.Kind
import GHC.TypeNats
( Nat )
-- MetaBrush
-- brush-strokes
import Math.Algebra.Dual.Internal
import Math.Interval.Internal
import Math.Linear

2
brush-strokes/src/Math/Algebra/Dual/Internal.hs
View file

@ -31,7 +31,7 @@ import Language.Haskell.TH
import Language.Haskell.TH.Syntax
( Lift(..) )
-- MetaBrush
-- brush-strokes
import Math.Linear
( Vec(..), T(..)
, RepresentableQ(..), RepDim

15
brush-strokes/src/Math/Bezier/Cubic.hs
View file

@ -50,7 +50,7 @@ import Data.Group.Generics
import Data.Primitive.Types
( Prim )
-- MetaBrush
-- brush-strokes
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), bezier )
import Math.Epsilon
@ -99,6 +99,7 @@ fromQuadratic ( Quadratic.Bezier { p0 = q0, p1 = q1, p2 = q2 } ) = Bezier {..}
p1 = lerp @v (2/3) q0 q1
p2 = lerp @v (1/3) q1 q2
p3 = q2
{-# INLINEABLE fromQuadratic #-}
-- | Cubic Bézier curve.
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
@ -106,17 +107,20 @@ bezier ( Bezier {..} ) t =
lerp @v t
( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t )
( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t )
{-# INLINEABLE bezier #-}
-- | The derivative of a Cubic Bézier curve, as a quadratic Bézier curve.
derivative :: ( Group v, Module r v ) => Bezier v -> Quadratic.Bezier v
derivative ( Bezier {..} ) = ( Ring.fromInteger 3 *^ )
<$> Quadratic.Bezier ( p0 --> p1 ) ( p1 --> p2 ) ( p2 --> p3 )
{-# INLINEABLE derivative #-}
-- | Derivative of a cubic Bézier curve.
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
bezier' ( Bezier {..} )
= ( Ring.fromInteger 3 *^ )
. Quadratic.bezier @v ( Quadratic.Bezier ( p0 --> p1 ) ( p1 --> p2 ) ( p2 --> p3 ) )
{-# INLINEABLE bezier' #-}
-- | Second derivative of a cubic Bézier curve.
bezier'' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
@ -125,16 +129,19 @@ bezier'' ( Bezier {..} ) t
$ lerp @v t
( p1 --> p0 ^+^ p1 --> p2 )
( p2 --> p1 ^+^ p2 --> p3 )
{-# INLINEABLE bezier'' #-}
-- | Third derivative of a cubic Bézier curve.
bezier''' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> v
bezier''' ( Bezier {..} )
= ( Ring.fromInteger 6 *^ )
$ ( ( p0 --> p3 ) ^+^ Ring.fromInteger 3 *^ ( p2 --> p1 ) )
{-# INLINEABLE bezier''' #-}
-- | Curvature of a cubic Bézier curve.
curvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
curvature bez t = sqrt $ squaredCurvature @v bez t
{-# INLINEABLE curvature #-}
-- | Square of curvature of a cubic Bézier curve.
squaredCurvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
@ -150,6 +157,7 @@ squaredCurvature bez t
g'' = bezier'' @v bez t
sq_nm_g' :: r
sq_nm_g' = squaredNorm @v g'
{-# INLINEABLE squaredCurvature #-}
-- | Signed curvature of a planar cubic Bézier curve.
signedCurvature :: Bezier ( ℝ 2 ) -> Double -> Double
@ -170,6 +178,7 @@ subdivide ( Bezier {..} ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
q2 = lerp @v t q1 s
r1 = lerp @v t s r2
pt = lerp @v t q2 r1
{-# INLINEABLE subdivide #-}
-- | Polynomial coefficients of the derivative of the distance to a cubic Bézier curve.
ddist :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> [ r ]
@ -188,6 +197,7 @@ ddist ( Bezier {..} ) c = [ a5, a4, a3, a2, a1, a0 ]
!a3 = 6 * squaredNorm v'' + 4 * v' ^.^ v'''
!a4 = 5 * v'' ^.^ v'''
!a5 = squaredNorm v'''
{-# INLINEABLE ddist #-}
-- | Finds the closest point to a given point on a cubic Bézier curve.
closestPoint
@ -214,6 +224,7 @@ closestPoint pts c = pickClosest ( 0 :| 1 : roots )
p' = bezier @v pts t'
nm' :: r
nm' = squaredNorm ( c --> p' :: v )
{-# INLINEABLE closestPoint #-}
-- | Drag a cubic Bézier curve to pass through a given point.
--
@ -236,6 +247,7 @@ drag ( Bezier {..} ) t q = Bezier { p0, p1 = p1', p2 = p2', p3 }
p1', p2' :: p
p1' = ( ( 1 - t ) *^ delta ) • p1
p2' = ( t *^ delta ) • p2
{-# INLINEABLE drag #-}
-- | Compute parameter values for the self-intersection of a planar cubic Bézier curve, if such exist.
--
@ -270,3 +282,4 @@ extrema ( Bezier {..} ) = solveQuadratic c b a
a = p3 - 3 * p2 + 3 * p1 - p0
b = 2 * ( p0 - 2 * p1 + p2 )
c = p1 - p0
{-# INLINEABLE extrema #-}

2
brush-strokes/src/Math/Bezier/Cubic/Fit.hs
View file

@ -59,7 +59,7 @@ import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class
( lift )
-- MetaBrush
-- brush-strokes
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), bezier, ddist )
import Math.Bezier.Spline

12
brush-strokes/src/Math/Bezier/Quadratic.hs
View file

@ -48,7 +48,7 @@ import Data.Group.Generics
import Data.Primitive.Types
( Prim )
-- MetaBrush
-- brush-strokes
import Math.Epsilon
( epsilon )
import Math.Module
@ -90,18 +90,22 @@ instance Show p => Show (Bezier p) where
-- | Quadratic Bézier curve.
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
bezier ( Bezier {..} ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
{-# INLINEABLE bezier #-}
-- | Derivative of a quadratic Bézier curve.
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
bezier' ( Bezier {..} ) t = Ring.fromInteger 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
{-# INLINEABLE bezier' #-}
-- | Second derivative of a quadratic Bézier curve.
bezier'' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> v
bezier'' ( Bezier {..} ) = Ring.fromInteger 2 *^ ( p1 --> p0 ^+^ p1 --> p2 )
{-# INLINEABLE bezier'' #-}
-- | Curvature of a quadratic Bézier curve.
curvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
curvature bez t = sqrt $ squaredCurvature @v bez t
{-# INLINEABLE curvature #-}
-- | Square of curvature of a quadratic Bézier curve.
squaredCurvature :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> r -> r
@ -117,6 +121,7 @@ squaredCurvature bez t
g'' = bezier'' @v bez
sq_nm_g' :: r
sq_nm_g' = squaredNorm @v g'
{-# INLINEABLE squaredCurvature #-}
-- | Signed curvature of a planar quadratic Bézier curve.
signedCurvature :: Bezier ( ℝ 2 ) -> Double -> Double
@ -134,6 +139,7 @@ subdivide ( Bezier {..} ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
q1 = lerp @v t p0 p1
r1 = lerp @v t p1 p2
pt = lerp @v t q1 r1
{-# INLINEABLE subdivide #-}
-- | Polynomial coefficients of the derivative of the distance to a quadratic Bézier curve.
ddist :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> [ r ]
@ -149,6 +155,7 @@ ddist ( Bezier {..} ) c = [ a3, a2, a1, a0 ]
!a1 = v ^.^ v'' + 2 * squaredNorm v'
!a2 = 3 * v' ^.^ v''
!a3 = squaredNorm v''
{-# INLINEABLE ddist #-}
-- | Finds the closest point to a given point on a quadratic Bézier curve.
closestPoint
@ -175,6 +182,7 @@ closestPoint pts c = pickClosest ( 0 :| 1 : roots )
p' = bezier @v pts t'
nm' :: r
nm' = squaredNorm ( c --> p' :: v )
{-# INLINEABLE closestPoint #-}
-- | Interpolation of a quadratic Bézier control point, given path points and Bézier parameter.
--
@ -189,9 +197,11 @@ interpolate p0 p2 t q = Bezier {..}
p1 = ( ( 0.5 * ( t - 1 ) / t ) *^ ( q --> p0 :: v )
^+^ ( 0.5 * t / ( t - 1 ) ) *^ ( q --> p2 :: v )
) • q
{-# INLINEABLE interpolate #-}
-- | Extremal values of the Bézier parameter for a quadratic Bézier curve.
extrema :: Fractional r => Bezier r -> [ r ]
extrema ( Bezier {..} ) = [ t ]
where
t = ( p0 - p1 ) / ( p0 - 2 * p1 + p2 )
{-# INLINEABLE extrema #-}

2
brush-strokes/src/Math/Bezier/Spline.hs
View file

@ -52,7 +52,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
( StateT(runStateT), modify' )
-- MetaBrush
-- brush-strokes
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) )
import Math.Linear

332
brush-strokes/src/Math/Bezier/Stroke.hs
View file

@ -24,6 +24,8 @@ module Math.Bezier.Stroke
-- base
import Control.Arrow
( first, (***) )
import Control.Concurrent.MVar
( MVar, newMVar )
import Control.Monad
( unless )
import Control.Monad.ST
@ -39,7 +41,7 @@ import Data.Foldable
import Data.Functor.Identity
( Identity(..) )
import Data.List
( nub, partition, sort )
( intercalate, nub, partition, sort )
import Data.List.NonEmpty
( NonEmpty )
import qualified Data.List.NonEmpty as NE
@ -58,6 +60,10 @@ import GHC.Generics
( Generic, Generic1, Generically(..) )
import GHC.TypeNats
( type (-) )
import Numeric
( showFFloat )
import System.IO.Unsafe
( unsafePerformIO )
-- acts
import Data.Act
@ -72,6 +78,8 @@ import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( empty, index, length, reverse, singleton, zipWith )
import Data.Tree
( Tree(..) )
-- deepseq
import Control.DeepSeq
@ -95,7 +103,11 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.State.Strict
( StateT, runStateT, evalStateT, get, put )
import Control.Monad.Trans.Writer.CPS
( WriterT, execWriterT, runWriter, tell )
( Writer, WriterT, execWriterT, runWriter, tell )
-- tree-view
import Data.Tree.View
( showTree )
-- MetaBrush
import Math.Algebra.Dual
@ -426,9 +438,6 @@ computeStrokeOutline rootAlgo fitParams ptParams toBrushParams brushFn spline@(
OutlineData
( TwoSided fwdData ( bimap reverseSpline Seq.reverse bwdData ) )
cusps
trace ( "bwd at t = 0.58: " ++ show ( ( snd . outlineFn fwdBwd ) $ ℝ1 0.58 ) ) ( return () )
trace ( "bwd at t = 0.5966724346435021: " ++ show ( ( snd . outlineFn fwdBwd ) $ ℝ1 0.5966724346435021 ) ) ( return () )
trace ( "bwd at t = 0.60: " ++ show ( ( snd . outlineFn fwdBwd ) $ ℝ1 0.60 ) ) ( return () )
outlineData `deepseq` tell outlineData
lift $ writeSTRef cachedStrokeRef ( Just outlineData )
@ -581,19 +590,35 @@ outlineFunction rootAlgo ptParams toBrushParams brushFromParams = \ sp0 crv ->
$ runD ( brushFromParams @2 @() proxy# id )
$ toBrushParams params_t
( newtDunno, newtSols ) = intervalNewtonGS InverseMidJacobian 1e-7 curvesI
( newtTrees, ( newtDunno, newtSols ) ) =
intervalNewtonGS
NoPreconditioning --InverseMidJacobian
1e-7
curvesI
in --trace
-- ( unlines $
-- [ "newtonMethod: #(definite zeroes) = " ++ show ( length newtSols )
-- , "newtonMethod: #(unknown) = " ++ show ( length newtDunno )
-- , ""
-- , "definite solutions:"
-- , if null newtSols then "[]" else unlines $ map show newtSols
-- , ""
-- , "unknown:"
-- , if null newtDunno then "[]" else unlines $ map show newtDunno ]
-- ) $
showD :: Double -> String
showD float = showFFloat (Just 6) float ""
functionDataLines =
[ "E, dE/ds, dE/ds * dc/dt:"
, "{" ++
(intercalate ","
[ "{" ++ showD t ++ "," ++ showD (s + fromIntegral i) ++ ",{" ++ intercalate "," vals ++ "}}"
| t <- [0.001, 0.01.. 0.999]
, i <- [0 .. (fromIntegral $ length $ curves (ℝ1 0.5)) - 1]
, s <- [0.001, 0.01.. 0.999]
, let StrokeDatum
{ ee = D12 (ℝ1 e) _dEdt (T (ℝ1 dEds))
, 𝛿E𝛿sdcdt = D0 (T (ℝ2 vx vy))
} = (curves (ℝ1 t) `Seq.index` i) (ℝ1 s)
vals = [showD e, showD dEds, "{" ++ showD vx ++ "," ++ showD vy ++ "}"]
]
) ++ "}"
]
newtTreeLines = map (showTree . showIntervalNewtonTree 1) newtTrees
logContents = unlines $ functionDataLines ++ newtTreeLines
in logToFile cuspFindingMVar logContents `seq`
OutlineInfo
{ outlineFn = fwdBwd
, outlineDefiniteCusps = map ( cuspCoords curves ) newtSols
@ -601,6 +626,11 @@ outlineFunction rootAlgo ptParams toBrushParams brushFromParams = \ sp0 crv ->
}
{-# INLINEABLE outlineFunction #-}
cuspFindingMVar :: MVar FilePath
cuspFindingMVar = unsafePerformIO
$ newMVar "logs/cusps.txt"
{-# NOINLINE cuspFindingMVar #-}
pathAndUsedParams :: forall k i arr crvData ptData usedParams
. ( HasType ( ℝ 2 ) ptData
, HasBézier k i
@ -962,6 +992,11 @@ data RootSolvingAlgorithm
-- | Use the modified Halley M2 method.
| HalleyM2 { maxIters :: Word, precision :: Int }
rootSolvingMVar :: MVar FilePath
rootSolvingMVar = unsafePerformIO
$ newMVar "logs/envelope.txt"
{-# NOINLINE rootSolvingMVar #-}
-- | Solve the envelope equations at a given point \( t = t_0 \), to find
-- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke.
solveEnvelopeEquations :: RootSolvingAlgorithm
@ -986,17 +1021,17 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
-- , " bwdOffset: " ++ show bwdOffset ]
-- ) True
fwdSol = findSolFrom fwdOffset
( bwdPt, bwdTgt ) = findSolFrom bwdOffset
fwdSol = findSolFrom "fwd" fwdOffset
( bwdPt, bwdTgt ) = findSolFrom "bwd" bwdOffset
findSolFrom :: Offset -> ( ℝ 2, T ( ℝ 2 ) )
findSolFrom ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } )
findSolFrom :: String -> Offset -> ( ℝ 2, T ( ℝ 2 ) )
findSolFrom desc ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } )
= go ( fromIntegral i00 + fromMaybe 0.5 s00 )
where
go :: Double -> ( ℝ 2, T ( ℝ 2 ) )
go is0 =
case sol strokeData is0 of
case sol desc strokeData is0 of
( goodSoln, pt, tgt )
| goodSoln && plausibleTangent tgt
-> ( pt, tgt )
@ -1006,59 +1041,100 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
plausibleTangent :: T ( ℝ 2 ) -> Bool
plausibleTangent tgt = path'_t ^.^ tgt > 0
sol :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) )
sol f is0 =
let ( good, is ) =
case runSolveMethod ( eqn f ) is0 of
sol :: String -> Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) )
sol desc f is0 =
let (solRes, solSteps) = runSolveMethod ( eqn f ) is0
( good, is ) =
case solRes of
Nothing -> ( False, is0 )
Just is1 -> ( True , is1 )
( ds, dcdt ) = finish f is
in ( good, ds, dcdt )
showD :: Double -> String
showD float = showFFloat (Just 6) float ""
(x_min, x_max) = domain
logContents = unlines
[ "method = " <> methodName
, desc
, "t = " ++ show _t
, "start (n,s) = " <> show (fromDomain is0)
, "steps = {"
, unlines $ map (\ (x, y, y') -> show (x, (y, y'))) solSteps
, "},"
, "E:"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD y ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let (# y, _y' #) = eqn f x
]
) ++ "}"
, "𝛿E𝛿s:"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD y' ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let (# _y, y' #) = eqn f x
]
) ++ "}"
, "𝛿E𝛿sdcdt (x):"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD 𝛿E𝛿sdcdt_x ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let StrokeDatum { 𝛿E𝛿sdcdt = D0 (T (ℝ2 𝛿E𝛿sdcdt_x _)) } = evalStrokeDatum f x
]
)
++ "}"
, "𝛿E𝛿sdcdt (y):"
, "{" ++
(intercalate ","
[ "{" ++ showD x ++ "," ++ showD 𝛿E𝛿sdcdt_y ++ "}"
| x <- [x_min, x_min + 0.01 .. x_max]
, let StrokeDatum { 𝛿E𝛿sdcdt = D0 (T (ℝ2 _ 𝛿E𝛿sdcdt_y)) } = evalStrokeDatum f x
]
)
++ "}"
]
runSolveMethod = case rootAlgo of
in logToFile rootSolvingMVar logContents `seq`
( good, ds, dcdt )
(runSolveMethod, methodName) = case rootAlgo of
HalleyM2 { maxIters, precision } ->
halleyM2 maxIters precision
(halleyM2 maxIters precision, "HalleyM2")
NewtonRaphson { maxIters, precision } ->
newtonRaphson maxIters precision domain
(newtonRaphson maxIters precision domain, "NewtonRaphson")
finish :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( ℝ 2, T ( ℝ 2 ) )
finish f is =
finish fs is =
let (i, s) = fromDomain is in
case ( f `Seq.index` i ) ( ℝ1 s ) of -- TODO: a bit redundant to have to compute this again...
case evalStrokeDatum fs is of -- TODO: a bit redundant to have to compute this again...
StrokeDatum
{ dstroke
, ee = D12 ( ℝ1 _ee ) ( T ( ℝ1 _𝛿E𝛿t ) ) ( T ( ℝ1 ee_s ) )
, ee = D12 ( ℝ1 _ee ) _ ( T ( ℝ1 𝛿E𝛿s ) )
, 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt
} ->
-- The total derivative dc/dt is computed by dividing by ∂E/∂s,
-- so check it isn't zero first. This corresponds to cusps in the envelope.
let dcdt
| abs ee_s < epsilon
, let s' = if s >= 0.5 then s - 1e-9 else s + 1e-9
= case ( f `Seq.index` i ) ( ℝ1 s' ) of
StrokeDatum { ee = D12 _ _ ( T ( ℝ1 ee_s' ) ), 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt' }
-> recip ee_s' *^ 𝛿E𝛿sdcdt'
| abs 𝛿E𝛿s < epsilon
, let s' = if s >= 0.5 then s - 1e-6 else s + 1e-6
= case ( fs `Seq.index` i ) ( ℝ1 s' ) of
StrokeDatum { ee = D12 _ _ ( T ( ℝ1 𝛿E𝛿s' ) ), 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt' }
-> recip 𝛿E𝛿s' *^ 𝛿E𝛿sdcdt'
| otherwise
= recip ee_s *^ 𝛿E𝛿sdcdt
in --trace
-- ( unlines
-- [ "solveEnvelopeEquations"
-- , " t = " ++ show _t
-- , " s = " ++ show s
-- , " c = " ++ show dstroke
-- , " E = " ++ show _ee
-- , " ∂E/∂t = " ++ show _𝛿E𝛿t
-- , " ∂E/∂s = " ++ show ee_s
-- , " dc/dt = " ++ show dcdt
-- ] )
( value @Double @2 @( ℝ 2 ) dstroke, dcdt )
= recip 𝛿E𝛿s *^ 𝛿E𝛿sdcdt
in ( value @Double @2 @( ℝ 2 ) dstroke, dcdt )
evalStrokeDatum :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> ( Double -> StrokeDatum 2 () )
evalStrokeDatum fs is =
let (i, s) = fromDomain is
in ( fs `Seq.index` i ) ( ℝ1 $ max 1e-6 $ min (1 - 1e-6) $ s )
eqn :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> ( Double -> (# Double, Double #) )
eqn fs is =
let (i, s) = fromDomain is
in case ( fs `Seq.index` i ) ( ℝ1 s ) of
StrokeDatum { ee = D12 ee _ ee_s } ->
coerce (# ee, ee_s #)
case evalStrokeDatum fs is of
StrokeDatum { ee = D12 ee _ ee_s } -> coerce (# ee, ee_s #)
n :: Int
n = Seq.length strokeData
@ -1161,24 +1237,26 @@ gaussSeidel
( 𝕀 ( ℝ2 a11_lo a21_lo ) ( ℝ2 a11_hi a21_hi )
, 𝕀 ( ℝ2 a12_lo a22_lo ) ( ℝ2 a12_hi a22_hi ) )
( 𝕀 ( ℝ2 b1_lo b2_lo ) ( ℝ2 b1_hi b2_hi ) )
( 𝕀 ( ℝ1 t0_lo ) ( ℝ1 t0_hi ), 𝕀 ( ℝ1 s0_lo ) ( ℝ1 s0_hi ) )
( 𝕀 ( ℝ1 x1_lo ) ( ℝ1 x1_hi ), 𝕀 ( ℝ1 x2_lo ) ( ℝ1 x2_hi ) )
= let !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
!t0 = 𝕀 t0_lo t0_hi
!s0 = 𝕀 s0_lo s0_hi
!x1 = 𝕀 x1_lo x1_hi
!x2 = 𝕀 x2_lo x2_hi
in nub $ do
t' <- ( b1 - a12 * s0 ) `extendedDivide` a11
( t@( 𝕀 t_lo t_hi ), sub_t ) <- t' `intersect` t0
s' <- ( b2 - a21 * t ) `extendedDivide` a22
( 𝕀 s_lo s_hi, sub_s ) <- s' `intersect` s0
-- x1' = (b1 - a12 * x2) / a11
x1'_0 <- ( b1 - a12 * x2 ) `extendedDivide` a11
( x1'@( 𝕀 x1'_lo x1'_hi ), sub_x1 ) <- x1'_0 `intersect` x1
-- x2' = (b2 - a21 * x1') / a22
x2'_0 <- ( b2 - a21 * x1' ) `extendedDivide` a22
( 𝕀 x2'_lo x2'_hi, sub_x2 ) <- x2'_0 `intersect` x2
return ( ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ), 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
, sub_t && sub_s )
return ( ( 𝕀 ( ℝ1 x1'_lo ) ( ℝ1 x1'_hi ), 𝕀 ( ℝ1 x2'_lo ) ( ℝ1 x2'_hi ) )
, sub_x1 && sub_x2 )
intersect :: 𝕀 Double -> 𝕀 Double -> [ ( 𝕀 Double, Bool ) ]
intersect ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 )
@ -1227,46 +1305,87 @@ data Preconditioner
| InverseMidJacobian
deriving stock Show
-- | A tree recording the steps taken with the interval Newton method.
data IntervalNewtonTree d
= IntervalNewtonLeaf (IntervalNewtonLeaf d)
| IntervalNewtonStep (IntervalNewtonStep d) [(Double, IntervalNewtonTree d)]
data IntervalNewtonStep d
= IntervalNewtonContraction [d] [d]
| IntervalNewtonBisection (String, Double)
instance Show d => Show (IntervalNewtonStep d) where
showsPrec _ ( IntervalNewtonContraction v w )
= showString "N "
. showsPrec 0 v
. showString " "
. showsPrec 0 w
showsPrec _ ( IntervalNewtonBisection (coord, w) )
= showString "B "
. showParen True
( showString coord
. showString " = "
. showsPrec 0 w
)
data IntervalNewtonLeaf d
= TooSmall d
| NoSolution d
deriving stock Show
showIntervalNewtonTree :: Show d => Double -> IntervalNewtonTree d -> Tree String
showIntervalNewtonTree area (IntervalNewtonLeaf l) = Node (showArea area ++ " " ++ show l) []
showIntervalNewtonTree area (IntervalNewtonStep s ts)
= Node (showArea area ++ " " ++ show s) $ map (\ (d,t) -> showIntervalNewtonTree d t) ts
showArea :: Double -> [Char]
showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
-- | Interval Newton method with Gauss–Seidel step for inversion
-- of the interval Jacobian.
--
-- Returns @(dunno, sols)@ where @sols@ are boxes that contain a unique solution
-- (and to which Newton's method will converge starting from anywhere inside
-- the box), and @dunno@ are small boxes which might or might not
-- contain solutions.
-- Returns @(tree, (dunno, sols))@ where @tree@ is the full tree (useful for debugging),
-- @sols@ are boxes that contain a unique solution (and to which Newton's method
-- will converge starting from anywhere inside the box), and @dunno@ are small
-- boxes which might or might not contain solutions.
intervalNewtonGS :: Preconditioner
-> Double
-> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) )
-> ( [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ], [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ] )
-> ( [ IntervalNewtonTree ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ], ( [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ], [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ] ) )
intervalNewtonGS precondMethod minWidth eqs =
go (0,0)
[ ( 𝕀 ( ℝ1 0 ) ( ℝ1 1 ), i, 𝕀 ( ℝ1 0 ) ( ℝ1 1 ) )
| i <- [ 0 .. length ( eqs ( 𝕀 ( ℝ1 0 ) ( ℝ1 1 ) ) ) - 1 ]
]
[]
[]
first concat $ runWriter $
traverse go
[ ( 𝕀 ( ℝ1 zero ) ( ℝ1 one ), i, 𝕀 ( ℝ1 zero ) ( ℝ1 one ) )
| i <- [ 0 .. length ( eqs ( 𝕀 ( ℝ1 zero ) ( ℝ1 one ) ) ) - 1 ]
]
where
zero, one :: Double
zero = 1e-6
one = 1 - zero
{-# INLINE zero #-}
{-# INLINE one #-}
go :: ( Int, Int ) -- step counts (for debugging)
-> [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ] -- boxes to work on
-> [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ] -- too small: don't shrink further
-> [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ] -- found solutions
-> ( [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ], [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ] )
go ( bis, newt ) [] giveUp sols =
trace ( unlines [ "intervalNewtonGS done"
, " #bisections: " ++ show bis
, " #newtonSteps: " ++ show newt
, " #sols: " ++ show ( length sols )
, " #dunno: " ++ show ( length giveUp ) ] )
( giveUp, sols )
go ( bis, newt ) ( cand@( t@( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) )
, i
, s@( 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
) : cands ) giveUp sols
recur f cands = do
rest <- traverse ( \ c -> do { trees <- go c; return [ (boxArea c, tree) | tree <- trees ] } ) cands
return [ f $ concat rest ]
boxArea :: ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) -> Double
boxArea ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ), _, 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
= abs ( t_hi - t_lo ) * abs ( s_hi - s_lo )
go :: ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) -- box to work on
-> Writer ( [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ], [ ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ] )
[ IntervalNewtonTree ( 𝕀ℝ 1, Int, 𝕀ℝ 1 ) ]
go cand@( t@( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) )
, i
, s@( 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
)
-- Box is small: stop processing it.
| t_hi - t_lo < minWidth && s_hi - s_lo < minWidth
= go ( bis, newt ) cands ( cand : giveUp ) sols
= do let res = TooSmall cand
tell ( [ cand ], [] )
return [ IntervalNewtonLeaf res ]
| StrokeDatum { ee = D22 ee _ _ _ _ _
, 𝛿E𝛿sdcdt = D12 ( T f ) ( T ( T f_t ) ) ( T ( T f_s ) ) }
@ -1274,10 +1393,12 @@ intervalNewtonGS precondMethod minWidth eqs =
, StrokeDatum { 𝛿E𝛿sdcdt = D12 ( T f_mid ) ( T ( T _f_t_mid ) ) ( T ( T _f_s_mid ) ) }
<- ( eqs i_t_mid `Seq.index` i ) i_s_mid
= if | inf ee < ℝ1 0
, sup ee > ℝ1 0
, cmpℝ2 (<) ( inf f ) ( ℝ2 0 0 )
, cmpℝ2 (>) ( sup f ) ( ℝ2 0 0 )
= if | -- Check the envelope equation interval contains zero.
inf ee <= ℝ1 0
, sup ee >= ℝ1 0
-- Check the 𝛿E𝛿sdcdt interval contains zero.
, cmpℝ2 (<=) ( inf f ) ( ℝ2 0 0 )
, cmpℝ2 (>=) ( sup f ) ( ℝ2 0 0 )
-> let -- Interval Newton method: take one Gauss–Seidel step
-- for the equation f'(X) v = - f(x_mid).
!( a, b ) = precondition precondMethod
@ -1296,22 +1417,25 @@ intervalNewtonGS precondMethod minWidth eqs =
-- Newton's method is guaranteed to converge to the unique solution.
let !(done, todo) = bimap ( map ( mkGuess . fst ) ) ( map ( mkGuess . fst ) )
$ partition snd gsGuesses
in go ( bis, newt + 1 ) ( todo ++ cands ) giveUp ( done ++ sols )
in do tell ([], done)
recur (IntervalNewtonStep (IntervalNewtonContraction done todo)) todo
else
-- Gauss–Seidel failed to shrink the boxes.
-- Bisect along the widest dimension instead.
let bisGuesses
let (bisGuesses, whatBis)
| t_hi - t_lo > s_hi - s_lo
= [ ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_mid ), i, s )
, ( 𝕀 ( ℝ1 t_mid ) ( ℝ1 t_hi ), i, s ) ]
= ( [ ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_mid ), i, s )
, ( 𝕀 ( ℝ1 t_mid ) ( ℝ1 t_hi ), i, s ) ]
, ("t", t_mid) )
| otherwise
= [ ( t, i, 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_mid ) )
, ( t, i, 𝕀 ( ℝ1 s_mid ) ( ℝ1 s_hi ) ) ]
in go ( bis + 1, newt ) ( bisGuesses ++ cands ) giveUp sols
= ( [ ( t, i, 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_mid ) )
, ( t, i, 𝕀 ( ℝ1 s_mid ) ( ℝ1 s_hi ) ) ]
, ("s", s_mid) )
in recur (IntervalNewtonStep (IntervalNewtonBisection whatBis)) bisGuesses
-- Box doesn't contain a solution: discard it.
| otherwise
-> go ( bis, newt ) cands giveUp sols
-> return [ IntervalNewtonLeaf $ NoSolution cand ]
where
t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi )

3
brush-strokes/src/Math/Bezier/Stroke/EnvelopeEquation.hs
View file

@ -22,7 +22,7 @@ import GHC.TypeNats
import Data.Act
( Torsor ((-->)) )
-- MetaBrush
-- brush-strokes
import Math.Algebra.Dual
import qualified Math.Bezier.Cubic as Cubic
import qualified Math.Bezier.Quadratic as Quadratic
@ -63,7 +63,6 @@ data StrokeDatum k i
--
-- denotes a total derivative.
, 𝛿E𝛿sdcdt :: D ( k - 2 ) ( I i ( ℝ 2 ) ) ( T ( I i ( ℝ 2 ) ) )
}
deriving stock instance Show ( StrokeDatum 2 () )

2
brush-strokes/src/Math/Differentiable.hs
View file

@ -11,7 +11,7 @@ import Data.Kind
import GHC.TypeNats
( Nat )
-- MetaBrush
-- brush-strokes
import Math.Algebra.Dual
( D, HasChainRule )
import Math.Interval

4
brush-strokes/src/Math/Interval/Internal.hs
View file

@ -28,7 +28,7 @@ import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as Interval
( Interval(..) )
#ifdef USE_FMA
-- MetaBrush
-- brush-strokes
import Math.Interval.FMA
( addI, subI, prodI, divI, posPowI )
@ -38,7 +38,7 @@ import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as Interval
( powInt )
#endif
-- MetaBrush
-- brush-strokes
import Math.Linear
( T(..)
, RepDim, RepresentableQ(..), Representable(..)

2
brush-strokes/src/Math/Linear.hs
View file

@ -46,7 +46,7 @@ import Data.Group
import Data.Group.Generics
( )
-- MetaBrush
-- brush-strokes
import Math.Linear.Internal
--------------------------------------------------------------------------------

2
brush-strokes/src/Math/Linear/Solve.hs
View file

@ -14,7 +14,7 @@ import qualified Eigen.Matrix as Eigen
import qualified Eigen.Solver.LA as Eigen
( Decomposition(..), solve )
-- MetaBrush
-- brush-strokes
import Math.Linear
( Mat22(..), ℝ(..), T(..) )

2
brush-strokes/src/Math/Module.hs
View file

@ -40,7 +40,7 @@ import Data.Act
import Data.Group
( Group(..) )
-- MetaBrush
-- brush-strokes
import Math.Epsilon
( epsilon )
import Math.Linear

2
brush-strokes/src/Math/Module/Internal.hs
View file

@ -10,7 +10,7 @@ import Data.Coerce
import Data.Monoid
( Sum(..) )
-- MetaBrush
-- brush-strokes
import Math.Ring
( Ring )
import qualified Math.Ring as Ring

2
brush-strokes/src/Math/Monomial.hs
View file

@ -36,7 +36,7 @@ import Unsafe.Coerce
import Language.Haskell.TH
( CodeQ )
-- MetaBrush
-- brush-strokes
import Math.Linear
( Vec(..), Fin(..) )
import TH.Utils

2
brush-strokes/src/Math/Orientation.hs
View file

@ -28,7 +28,7 @@ import Data.Generics.Product.Typed
import Data.Generics.Internal.VL
( view )
-- MetaBrush
-- brush-strokes
import Math.Epsilon
( nearZero )
import Math.Module

53
brush-strokes/src/Math/Roots.hs
View file

@ -46,7 +46,7 @@ import Data.Primitive.PrimArray
import Data.Primitive.Types
( Prim )
-- MetaBrush
-- brush-strokes
import Math.Epsilon
( epsilon, nearZero )
@ -298,7 +298,7 @@ derivative p = do
-- https://github.com/boostorg/math/blob/0dc6a70caa6bbec2b6ae25eede36c430f0ccae13/include/boost/math/tools/roots.hpp#L217
{-# SPECIALISE
newtonRaphson
:: Word -> Int -> ( Double, Double ) -> ( Double -> (# Double, Double #) ) -> Double -> Maybe Double
:: Word -> Int -> ( Double, Double ) -> ( Double -> (# Double, Double #) ) -> Double -> (Maybe Double, [(Double,Double,Double)])
#-}
{-# INLINEABLE newtonRaphson #-}
newtonRaphson :: ( RealFloat r, Show r )
@ -307,7 +307,7 @@ newtonRaphson :: ( RealFloat r, Show r )
-> ( r, r ) -- ^ @(min_x, max_x)@.
-> ( r -> (# r, r #) ) -- ^ function and its derivative
-> r -- ^ initial guess
-> Maybe r
-> (Maybe r, [(r,r,r)])
newtonRaphson maxIters digits ( min_x, max_x ) f x0 =
doNewtonRaphson f maxIters factor min_x max_x 0 0 0 x0 maxRealFloat maxRealFloat
where
@ -322,30 +322,31 @@ doNewtonRaphson :: ( Fractional r, Ord r, Show r )
-> r
-> r
-> r -> r
-> Maybe r
-> (Maybe r, [(r,r,r)])
doNewtonRaphson f maxIters factor min_x max_x min_f_x max_f_x f_x_prev x δ1 δ2 =
go min_x max_x min_f_x max_f_x f_x_prev 0 x δ1 δ2
go [] min_x max_x min_f_x max_f_x f_x_prev 0 x δ1 δ2
where
go min_x max_x min_f_x max_f_x f_x_prev !iters !x !δ1 !δ2 =
case f x of
(# f_x, f'_x #)
go prev_acc min_x max_x min_f_x max_f_x f_x_prev !iters !x !δ1 !δ2 =
let (# f_x, f'_x #) = f x
acc = ((x, f_x, f'_x) : prev_acc)
in if
| f_x == 0
-> Just x
-> (Just x, acc)
| ( new_x, δ, δ1 ) <- newtonRaphsonStep f min_x max_x f_x_prev x f_x f'_x δ1 δ2
-> if
| abs δ <= abs ( new_x * factor )
|| new_x == min_x || new_x == max_x
-> Just x
-> (Just x, acc)
| iters >= maxIters
-> Nothing
-> (Nothing, acc)
| ( min_x, max_x, min_f_x, max_f_x ) <-
if δ > 0
then ( min_x, x, min_f_x, f_x )
else ( x, max_x, f_x, max_f_x )
-> if min_f_x * max_f_x > 0
then Nothing
then (Nothing, acc)
else
go min_x max_x min_f_x max_f_x f_x ( iters + 1 ) new_x δ δ1
go acc min_x max_x min_f_x max_f_x f_x ( iters + 1 ) new_x δ δ1
newtonRaphsonStep :: ( Fractional r, Ord r, Show r )
=> ( r -> (# r, r #) )
@ -444,9 +445,14 @@ halleyStep (# x, f, f', f'' #) =
-- by A. Cordero, H. Ramos & J.R. Torregrosa, J Math Chem 58, 751–774 (2020).
--
-- @https://doi.org/10.1007/s10910-020-01108-3@
halleyM2Step :: Fractional a => (# a, (# a, a #) #) -> (# a, (# a, a #) #) -> a
halleyM2Step (# x_nm1, (# f_nm1, f'_nm1 #) #) (# x_n, (# f_n, f'_n #) #) =
num / denom
halleyM2Step :: RealFloat a => (# a, (# a, a #) #) -> (# a, (# a, a #) #) -> a
halleyM2Step (# x_nm1, (# f_nm1, f'_nm1 #) #) (# x_n, (# f_n, f'_n #) #)
| nearZero num && nearZero denom
= 0.1 * signum num * signum denom
| nearZero num
= num
| otherwise
= num / denom
where
u = f_n * f_nm1 * (f_n - f_nm1)
dx = x_n - x_nm1
@ -457,7 +463,7 @@ halleyM2Step (# x_nm1, (# f_nm1, f'_nm1 #) #) (# x_n, (# f_n, f'_n #) #) =
{-# SPECIALISE
halleyM2
:: Word -> Int -> ( Double -> (# Double, Double #) ) -> Double -> Maybe Double
:: Word -> Int -> ( Double -> (# Double, Double #) ) -> Double -> (Maybe Double, [(Double, Double, Double)])
#-}
{-# INLINEABLE halleyM2 #-}
halleyM2 :: ( RealFloat r, Show r )
@ -465,16 +471,17 @@ halleyM2 :: ( RealFloat r, Show r )
-> Int -- ^ desired digits of precision
-> ( r -> (# r, r #) ) -- ^ function and its derivative
-> r -- ^ initial guess
-> Maybe r
-> (Maybe r, [(r,r,r)])
halleyM2 maxIters digits f x0 =
let y0 = (# x0, f x0 #)
in go 0 y0 y0
in go [] 0 y0 y0
where
!factor = encodeFloat 1 ( 1 - digits )
go i y_nm1 y_n@(# x_n, _ #) =
let x_np1 = halleyM2Step y_nm1 y_n
go prev_acc i y_nm1 y_n@(# x_n, (# f_x_n, f'_x_n #) #) =
let acc = (x_n, f_x_n, f'_x_n) : prev_acc
x_np1 = halleyM2Step y_nm1 y_n
in if | i >= maxIters
|| abs ( x_np1 - x_n ) < abs ( x_n * factor )
-> Just x_np1
-> (Just x_np1, acc)
| otherwise
-> go (i+1) y_n (# x_n, f x_np1 #)
-> go acc (i+1) y_n (# x_np1, f x_np1 #)

2
brush-strokes/src/TH/Utils.hs
View file

@ -6,7 +6,7 @@ module TH.Utils where
import Language.Haskell.TH
( CodeQ )
-- MetaBrush
-- brush-strokes
import Math.Ring ( Ring )
import qualified Math.Ring as Ring

5
cabal.project
View file

@ -1,9 +1,8 @@
packages: brush-strokes
, .
packages: ., brush-strokes
constraints:
acts -finitary,
brush-strokes +use-fma,
-- brush-strokes +use-fma,
rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double,
text -simdutf
-- text +simdutf causes the "digit" package to fail to build with undefined symbol linker errors

4
hie.yaml
View file

@ -1,7 +1,7 @@
cradle:
cabal:
- path: "./src/splines"
component: "lib:splines"
- path: "./brush-strokes/src"
component: "lib:brush-strokes"
- path: "./src/metabrushes"
component: "lib:metabrushes"
- path: "./src/convert"

4
src/app/MetaBrush/Application.hs
View file

@ -209,7 +209,9 @@ runApplication application = do
, maxIters = 5 -- 100
}
rootsAlgoTVar <- STM.newTVarIO @RootSolvingAlgorithm $
HalleyM2 { maxIters = 20, precision = 8 }
--HalleyM2
NewtonRaphson
{ maxIters = 20, precision = 8 }
-- Put all these stateful variables in a record for conciseness.
let

2
src/app/MetaBrush/Document/Selection.hs
View file

@ -629,7 +629,7 @@ deleteSelected doc =
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( UseCurve ( LineTo p2 ( invalidateCache dat ) ) )
Bezier3To cp1 cp2 p3 dat ->
case ssplineType @clo' of
SOpen