some optimisations

This commit is contained in:
sheaf 2023-01-29 04:03:36 +01:00
parent 4174d9b5b6
commit 8ac22b4738
8 changed files with 165 additions and 83 deletions

View file

@ -90,10 +90,12 @@ common common
ViewPatterns
ghc-options:
-O1
-O2
-fexpose-all-unfoldings
-funfolding-use-threshold=16
-- -funfolding-use-threshold=1000
-fspecialise-aggressively
-flate-dmd-anal
-fmax-worker-args=200
-optc-O3
-Wall
-Wcompat
@ -102,7 +104,6 @@ common common
-fwarn-incomplete-uni-patterns
-fwarn-missing-deriving-strategies
-fno-warn-unticked-promoted-constructors
-rtsopts
if flag(asserts)
cpp-options:

View file

@ -57,7 +57,7 @@ import Control.Monad.Trans.State.Strict
-- MetaBrush
import Math.Algebra.Dual
( fun )
( D2𝔸1(..), fun )
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), fromQuadratic )
import Math.Bezier.Cubic.Fit
@ -79,6 +79,8 @@ import Math.Interval
( Extent(Point) )
import Math.Linear
( (..), T(..) )
import Math.Module
( Module((*^)), normalise )
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Brush
@ -648,22 +650,28 @@ drawFitPoint _ zoom ( FitTangent { fitPoint = 2 x y, fitTangent = V2 tx ty }
drawCusp :: Colours -> Double -> Cusp -> Cairo.Render ()
drawCusp _ zoom
( Cusp { cuspPathCoords = 2 px py
( Cusp { cuspPathCoords = D21 { _D21_v = 2 px py
, _D21_dx = tgt }
, cuspStrokeCoords = 2 cx cy } ) = do
-- Draw a white circle on the path at the cusp point.
-- Draw a line perpendicular to the underlying path at the cusp.
let
!( V2 tx ty ) = ( 6 / zoom ) *^ normalise tgt
Cairo.save
Cairo.translate px py
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
Cairo.setSourceRGBA 1.0 1.0 1.0 1.0
Cairo.moveTo -ty tx
Cairo.lineTo ty -tx
--withRGBA path Cairo.setSourceRGBA
Cairo.setSourceRGBA 0 0 0 0.75
Cairo.setLineWidth ( 2 / zoom )
Cairo.stroke
Cairo.restore
-- Draw a black circle on the outline at the cusp point.
-- Draw a circle around the outline cusp point.
Cairo.save
Cairo.translate cx cy
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
Cairo.setSourceRGBA 0 0 0 1.0
Cairo.setSourceRGBA 0 0 0 0.75
Cairo.stroke
Cairo.restore

View file

@ -1,9 +1,12 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module MetaBrush.Asset.Brushes where
module MetaBrush.Asset.Brushes
( lookupBrush, brushes
, CircleBrushFields, circle
, EllipseBrushFields, ellipse
) where
-- base
import Prelude
@ -30,7 +33,7 @@ import qualified Data.HashMap.Strict as HashMap
import Math.Algebra.Dual
import Math.Bezier.Spline
import Math.Interval
( type I )
import Math.Linear
import Math.Module
( Module((^+^), (*^)) )
@ -65,6 +68,7 @@ circle = BrushData "circle" ( WithParams deflts circleBrush )
where
deflts :: Record CircleBrushFields
deflts = MkR ( 1 1 )
{-# INLINE circle #-}
type EllipseBrushFields = '[ "a", "b", "phi" ]
ellipse :: Brush EllipseBrushFields
@ -72,6 +76,7 @@ ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
where
deflts :: Record EllipseBrushFields
deflts = MkR ( 3 1 1 0 )
{-# INLINE ellipse #-}
--------------------------------------------------------------------------------
-- Differentiable brushes.
@ -91,6 +96,7 @@ circleSpline p = sequenceA $
]
lastCrv =
Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart ()
{-# INLINE circleSpline #-}
circleBrush :: forall i k irec
. ( irec ~ I i ( Record CircleBrushFields )
@ -120,23 +126,24 @@ circleBrush _ mkI =
e_y = pure $ mkI $ 2 0 1
kon = konst @( I i Double ) @k @irec . mkI
{-# INLINEABLE circleBrush #-}
ellipseBrush :: forall i k irec
. ( irec ~ I i ( Record EllipseBrushFields )
, Module
( D k irec ( I i Double ) )
( D k irec ( I i ( 2 ) ) )
, Module ( I i Double ) ( T ( I i Double ) )
, HasChainRule ( I i Double ) k irec
, Representable ( I i Double ) irec
, Applicative ( D k irec )
, Transcendental ( D k irec ( I i Double ) )
-- TODO: make a synonym for the above...
-- it seems DiffInterp isn't exactly right
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k irec ( Spline 'Closed () ( I i ( 2 ) ) )
. ( irec ~ I i ( Record EllipseBrushFields )
, Module
( D k irec ( I i Double ) )
( D k irec ( I i ( 2 ) ) )
, Module ( I i Double ) ( T ( I i Double ) )
, HasChainRule ( I i Double ) k irec
, Representable ( I i Double ) irec
, Applicative ( D k irec )
, Transcendental ( D k irec ( I i Double ) )
-- TODO: make a synonym for the above...
-- it seems DiffInterp isn't exactly right
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k irec ( Spline 'Closed () ( I i ( 2 ) ) )
ellipseBrush _ mkI =
D \ params ->
let a, b, phi :: D k irec ( I i Double )
@ -154,3 +161,4 @@ ellipseBrush _ mkI =
e_y = pure $ mkI $ 2 0 1
kon = konst @( I i Double ) @k @irec . mkI
{-# INLINEABLE ellipseBrush #-}

View file

@ -37,6 +37,7 @@ import GHC.TypeNats
-- MetaBrush
import Math.Algebra.Dual.Internal
import Math.Interval.Internal
import Math.Linear
import Math.Module
import Math.Monomial
@ -258,29 +259,33 @@ instance Ring r => Ring ( D2𝔸1 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D2𝔸1 Double ) #-}
{-# SPECIALISE instance Ring ( D2𝔸1 ( 𝕀 Double ) ) #-}
instance Ring r => Ring ( D3𝔸1 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D3𝔸1 Double ) #-}
{-# SPECIALISE instance Ring ( D3𝔸1 ( 𝕀 Double ) ) #-}
--instance Ring r => Ring ( D1𝔸2 r ) where
-- !dr1 * !dr2 =
@ -300,29 +305,33 @@ instance Ring r => Ring ( D2𝔸2 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D2𝔸2 Double ) #-}
{-# SPECIALISE instance Ring ( D2𝔸2 ( 𝕀 Double ) ) #-}
instance Ring r => Ring ( D3𝔸2 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D3𝔸2 Double ) #-}
{-# SPECIALISE instance Ring ( D3𝔸2 ( 𝕀 Double ) ) #-}
--instance Ring r => Ring ( D1𝔸3 r ) where
-- !dr1 * !dr2 =
@ -342,29 +351,33 @@ instance Ring r => Ring ( D2𝔸3 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D2𝔸3 Double ) #-}
{-# SPECIALISE instance Ring ( D2𝔸3 ( 𝕀 Double ) ) #-}
instance Ring r => Ring ( D3𝔸3 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D3𝔸3 Double ) #-}
{-# SPECIALISE instance Ring ( D3𝔸3 ( 𝕀 Double ) ) #-}
--instance Ring r => Ring ( D1𝔸4 r ) where
-- !dr1 * !dr2 =
@ -384,29 +397,33 @@ instance Ring r => Ring ( D2𝔸4 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D2𝔸4 Double ) #-}
{-# SPECIALISE instance Ring ( D2𝔸4 ( 𝕀 Double ) ) #-}
instance Ring r => Ring ( D3𝔸4 r ) where
!dr1 * !dr2 =
let
o :: r
o = fromInteger 0
!o = fromInteger 0
p :: r -> r -> r
p = (+) @r
!p = (+) @r
m :: r -> r -> r
m = (*) @r
!m = (*) @r
in
$$( prodRuleQ
[|| o ||] [|| p ||] [|| m ||]
[|| dr1 ||] [|| dr2 ||] )
{-# SPECIALISE instance Ring ( D3𝔸4 Double ) #-}
{-# SPECIALISE instance Ring ( D3𝔸4 ( 𝕀 Double ) ) #-}
--------------------------------------------------------------------------------
-- Field & transcendental instances

View file

@ -21,6 +21,10 @@ import GHC.Generics
import GHC.TypeNats
( KnownNat )
-- deepseq
import Control.DeepSeq
( NFData )
-- template-haskell
import Language.Haskell.TH
( CodeQ )
@ -50,6 +54,7 @@ import TH.Utils
-- | \( \mathbb{Z} \).
newtype D𝔸0 v = D0 { _D0_v :: v }
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D𝔸0
@ -59,6 +64,7 @@ data D1𝔸1 v =
, _D11_dx :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D1𝔸1
@ -69,6 +75,7 @@ data D2𝔸1 v =
, _D21_dxdx :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D2𝔸1
@ -89,6 +96,7 @@ data D1𝔸2 v =
, _D12_dx, _D12_dy :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D1𝔸2
@ -110,6 +118,7 @@ data D3𝔸2 v =
, _D32_dxdxdx, _D32_dxdxdy, _D32_dxdydy, _D32_dydydy :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D3𝔸2
@ -119,6 +128,7 @@ data D1𝔸3 v =
, _D13_dx, _D13_dy, _D13_dz :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D1𝔸3
@ -129,6 +139,7 @@ data D2𝔸3 v =
, _D23_dxdx, _D23_dxdy, _D23_dydy, _D23_dxdz, _D23_dydz, _D23_dzdz :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D2𝔸3
@ -141,6 +152,7 @@ data D3𝔸3 v =
, _D33_dxdxdz, _D33_dxdydz, _D33_dxdzdz, _D33_dydydz, _D33_dydzdz, _D33_dzdzdz :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D3𝔸3
@ -150,6 +162,7 @@ data D1𝔸4 v =
, _D14_dx, _D14_dy, _D14_dz, _D14_dw :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D1𝔸4
@ -161,6 +174,7 @@ data D2𝔸4 v =
, _D24_dydz, _D24_dzdz, _D24_dxdw, _D24_dydw, _D24_dzdw, _D24_dwdw :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D2𝔸4
@ -176,6 +190,7 @@ data D3𝔸4 v =
_D34_dxdwdw, _D34_dydwdw, _D34_dzdwdw, _D34_dwdwdw :: !( T v )
}
deriving stock ( Show, Eq, Functor, Foldable, Traversable, Generic, Generic1 )
deriving anyclass NFData
deriving Applicative
via Generically1 D3𝔸4

View file

@ -74,7 +74,7 @@ import Math.Epsilon
import Math.Linear.Solve
( linearSolve )
import Math.Module
( Module((*^), (^-^))
( Module((*^), (^-^)), lerp
, Inner((^.^)), quadrance
)
import Math.Roots
@ -82,6 +82,8 @@ import Math.Roots
import Math.Linear
( Mat22(..), (..), T(..) )
import Debug.Utils
--------------------------------------------------------------------------------
-- | Parameters to the curve fitting algorithm.
@ -121,37 +123,40 @@ data FitPoint
fitSpline
:: FitParameters
-> ( 1 -> ( 2, T ( 2 ) ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit
-> ( 1, 1 ) -- ^ interval \( [t_min, t_max] \)
-> ( SplinePts Open, Seq FitPoint )
fitSpline ( FitParameters {..} ) = go 0
fitSpline ( FitParameters {..} ) curveFn = go 0
where
dt :: Double
dt = recip ( fromIntegral nbSegments )
go
:: Int
-> ( 1 -> ( 2, T ( 2 ) ) )
-> ( 1, 1 )
-> ( SplinePts Open, Seq FitPoint )
go subdiv curveFn =
go subdiv (t_min, t_max) =
let
p, r :: 2
tp, tr :: T ( 2 )
qs :: [ 2 ]
(p, tp) = curveFn $ 1 0
(r, tr) = curveFn $ 1 1
qs = [ fst $ curveFn ( 1 $ dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
(p, tp) = curveFn $ T ( 1 0.0001 ) t_min
(r, tr) = curveFn $ T ( 1 -0.0001 ) t_max
qs = [ fst $ curveFn ( lerp @( T ( 1 ) ) ( dt * fromIntegral j ) t_min t_max )
| j <- [ 1 .. nbSegments - 1 ] ]
in
case fitPiece dist_tol t_tol maxIters p tp qs r tr of
( bez, Max ( Arg max_sq_error t_split ) )
( bez, Max ( Arg max_sq_error t_split_0 ) )
| subdiv >= maxSubdiv
|| max_sq_error <= dist_tol ^ ( 2 :: Int )
-> ( openCubicBezierCurveSpline () bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
-> trace ( unlines [ "fitSpline: piece is OK", "t_min = " ++ show t_min, "start = " ++ show p, "start tgt = " ++ show tp, "t_max = " ++ show t_max, "end = " ++ show r, "end tgt = " ++ show tr ] )
$ ( openCubicBezierCurveSpline () bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
| let
t_split_eff :: Double
t_split_eff = min ( 1 - dt ) $ max dt t_split
t_split :: 1
t_split = 1 $ min ( 1 - dt ) $ max dt t_split_0
c1, c2 :: SplinePts Open
ps1, ps2 :: Seq FitPoint
( ( c1, ps1 ), ( c2, ps2 ) )
= ( go ( subdiv + 1 ) ( \ ( 1 t ) -> curveFn $ 1 $ t * t_split_eff )
, go ( subdiv + 1 ) ( \ ( 1 t ) -> curveFn $ 1 $ t_split_eff + t * ( 1 - t_split_eff ) )
= ( go ( subdiv + 1 ) (t_min , t_split)
, go ( subdiv + 1 ) (t_split, t_max )
) `Parallel.Strategy.using`
( Parallel.Strategy.parTuple2 Parallel.Strategy.rdeepseq Parallel.Strategy.rdeepseq )
-> ( c1 <> c2, ps1 <> ps2 )

View file

@ -18,8 +18,6 @@ module Math.Bezier.Stroke
where
-- base
import Prelude
hiding ( unzip )
import Control.Arrow
( first, (***) )
import Control.Applicative
@ -37,11 +35,15 @@ import Data.Foldable
import Data.Functor.Identity
( Identity(..) )
import Data.List
( nub, partition )
( nub, partition, sort )
import Data.List.NonEmpty
( unzip )
( NonEmpty )
import qualified Data.List.NonEmpty as NE
( cons, singleton, unzip )
import Data.Maybe
( fromMaybe, isJust, listToMaybe, mapMaybe )
import Data.Semigroup
( sconcat )
import GHC.Exts
( newMutVar#, runRW#
, Proxy#, proxy#
@ -211,8 +213,8 @@ data Cusp
= Cusp
{ cuspParameters :: !( 2 )
-- ^ @(t,s)@ parameter values of the cusp
, cuspPathCoords :: !( 2 )
-- ^ path point coordinates
, cuspPathCoords :: !( D 2 ( 1 ) ( 2 ) )
-- ^ path point coordinates and tangent
, cuspStrokeCoords :: !( 2 )
-- ^ brush stroke point coordinates
}
@ -417,14 +419,19 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
-- No cached fit: compute the fit anew.
Nothing -> do
let
-- Split up the path at the cusps
cusps :: [ Cusp ]
cusps = outlineDefiniteCusps fwdBwd
++ outlinePotentialCusps fwdBwd
-- SLD TODO: here!!!
intervals :: NonEmpty ( 1, 1 )
intervals = splitInterval ( 1 0, 1 1 )
$ sort [ 1 t | Cusp { cuspParameters = 2 t _ } <- cusps ]
fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
( fwdData, bwdData ) =
( fitSpline fitParams ( fst . outlineFn fwdBwd )
, fitSpline fitParams ( snd . outlineFn fwdBwd ) )
( sconcat $ fmap ( fitSpline fitParams ( fst . outlineFn fwdBwd ) ) intervals
, sconcat $ fmap ( fitSpline fitParams ( snd . outlineFn fwdBwd ) ) intervals )
-- TODO: use foldMap1 once that's in base.
`Strats.using`
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
outlineData :: OutlineData
@ -564,7 +571,8 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
path :: C ( ExtentOrder 'Point ) ( 1 ) ( 2 )
( path, usedParams ) = pathAndUsedParams @Point id
curves :: 1 -> Seq ( 1 -> StrokeDatum Point )
curves :: 1 -- t
-> Seq ( 1 {- s -} -> StrokeDatum Point )
curves =
brushStrokeData @Point @( ExtentOrder 'Point ) @brushParams
path
@ -574,7 +582,8 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
)
( brushFromParams @Point proxy# id )
curvesI :: 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 'Interval )
curvesI :: 𝕀 1 -- t
-> Seq ( 𝕀 1 {- s -} -> StrokeDatum 'Interval )
curvesI = brushStrokeData @'Interval @( ExtentOrder 'Interval ) @brushParams
pathI
( chainRule @( 𝕀 Double ) @( ExtentOrder 'Interval )
@ -602,7 +611,7 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
$ runD ( brushFromParams @Point proxy# id )
$ toBrushParams params_t
--( newtDunno, newtSols ) = intervalNewtonGS InverseMidJacobian 0.0001 curvesI
( newtDunno, newtSols ) = intervalNewtonGS InverseMidJacobian 0.0001 curvesI
in --trace
-- ( unlines $
@ -617,8 +626,8 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
-- ) $
OutlineInfo
{ outlineFn = fwdBwd
, outlineDefiniteCusps = [] -- map ( cuspCoords curves ) newtSols
, outlinePotentialCusps = [] -- map ( cuspCoords curves ) newtDunno
, outlineDefiniteCusps = map ( cuspCoords curves ) newtSols
, outlinePotentialCusps = map ( cuspCoords curves ) newtDunno
}
{-# INLINEABLE outlineFunction #-}
@ -640,6 +649,20 @@ lastTangent ( Spline { splineCurves = NoCurves } ) = Nothing
lastTangent ( Spline { splineStart, splineCurves = ClosedCurves Empty lst } ) = Just $ endTangent splineStart splineStart lst
lastTangent ( Spline { splineStart, splineCurves = ClosedCurves ( _ :|> prev ) lst } ) = Just $ endTangent splineStart ( openCurveEnd prev ) lst
-- | Split up the given interval at the list of points provided.
--
-- Assumes the list is sorted.
splitInterval :: Ord a => ( a, a ) -> [ a ] -> NonEmpty ( a, a )
splitInterval ( start, end ) []
= NE.singleton ( start, end )
splitInterval ( start, end ) ( split : splits )
| split >= end
= NE.singleton ( start, end )
| split <= start
= splitInterval ( start, end ) splits
| otherwise
= NE.cons ( start, split ) $ splitInterval ( split, end ) splits
--------------------------------------------------------------------------------
-- | Compute the join at a point of discontinuity of the tangent vector direction (G1 discontinuity).
@ -668,7 +691,7 @@ joinBetweenOffsets
= let
pcs, lastAndRest :: Maybe ( SplinePts Open )
( pcs, lastAndRest )
= unzip
= NE.unzip
$ ( discardCurveData *** discardCurveData )
. splitSplineAt ( i2 - i1 )
<$> dropCurves i1 openSpline
@ -1049,6 +1072,7 @@ newtype ZipSeq a = ZipSeq { getZipSeq :: Seq a }
instance Applicative ZipSeq where
pure _ = error "only use Applicative ZipSeq with non-empty Traversable functors"
liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys )
{-# INLINE liftA2 #-}
brushStrokeData :: forall i k brushParams arr
. ( k ~ ExtentOrder i, CurveOrder k, arr ~ C k
@ -1181,12 +1205,12 @@ cuspCoords :: ( 1 -> Seq ( 1 -> StrokeDatum 'Point ) )
-> Cusp
cuspCoords eqs ( 𝕀 ( 1 t_lo ) ( 1 t_hi ), i, 𝕀 ( 1 s_lo ) ( 1 s_hi ) )
| StrokeDatum
{ dpath = D21 { _D21_v = path }
{ dpath
, dstroke = D22 { _D22_v = stroke } }
<- ( eqs ( 1 t_mid ) `Seq.index` i ) ( 1 s_mid )
= Cusp
{ cuspParameters = 2 t_mid s_mid
, cuspPathCoords = path
, cuspPathCoords = dpath
, cuspStrokeCoords = stroke
}
where

View file

@ -9,7 +9,8 @@ module Math.Module
( Module(..), lerp
, Inner(..), Cross(..)
, Interpolatable
, norm, squaredNorm, quadrance, distance
, norm, squaredNorm, normalise
, quadrance, distance
, proj, projC, closestPointOnSegment
, strictlyParallel, convexCombination
@ -73,6 +74,9 @@ norm = sqrt . squaredNorm
squaredNorm :: forall m r. Inner r m => m -> r
squaredNorm v = v ^.^ v
normalise :: ( Floating r, Inner r m ) => m -> m
normalise v = recip ( norm v ) *^ v
-- | Squared distance between two points.
quadrance :: forall v r p. ( Inner r v, Torsor v p ) => p -> p -> r
quadrance p1 p2 = squaredNorm ( p1 --> p2 :: v )