Improve intervallic rotation computations

This commit bakes in a certain kind of representation for brush strokes:

  c(t,s) = p(t) + R(theta(t)) b(t,s)

This representation allows us to cancel out some rotation terms when
computing the envelope equation, improving the efficiency of the
cusp-finding methods.
This commit is contained in:
sheaf 2024-04-20 18:28:41 +02:00
parent 2b167f594a
commit 1338d7ddbe
16 changed files with 594 additions and 415 deletions

View file

@ -133,8 +133,8 @@ benchTestCase ( TestCase { testName, testBrushStroke, testCuspOptions, testStart
after <- getMonotonicTime
let dt = after - before
putStrLn $ unlines
[ " - #sols: " ++ show (length sols)
, " - #dunno: " ++ show (length dunno)
[ " - #sols: " ++ show sols --( length sols )
, " - #dunno: " ++ show ( length dunno )
, " - Time elapsed: " ++ show dt ++ "s"
, "" ]
return dt
@ -181,7 +181,7 @@ testCases = benchCases
benchCases :: [ TestCase ]
benchCases =
[ ellipseTestCase opts "full" ( 0, 1 ) pi $ defaultStartBoxes [ 0 .. 3 ] ]
[ ellipseTestCase opts "full" ( 0, 1 ) pi $ defaultStartBoxes [ 2 ] ] -- [ 0 .. 3 ] ]
where
opts = defaultRootIsolationOptions
@ -190,7 +190,7 @@ benchCases =
data BrushStroke =
forall nbParams. ParamsCt nbParams =>
BrushStroke
{ brush :: !( Brush nbParams )
{ brush :: !( Brush ( nbParams ) )
, stroke :: !( Point nbParams, Curve Open () ( Point nbParams ) )
}
@ -500,7 +500,7 @@ ellipseTestCase opts str k0k1 rot startBoxes =
ellipseBrushStroke :: ( Double, Double ) -> Double -> BrushStroke
ellipseBrushStroke ( k0, k1 ) rot =
BrushStroke
{ brush = ellipseBrush
{ brush = ellipseBrush
, stroke = ( p0, LineTo ( NextPoint p1 ) () ) }
where
mkPt x y w h phi =
@ -568,18 +568,10 @@ data Point nbParams =
deriving stock Generic
deriving stock instance Show ( nbParams ) => Show ( Point nbParams )
type Brush nbParams
= forall {t} k (i :: t)
. DiffInterp k i ( nbParams )
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k ( I i ( nbParams ) )
( Spline Closed () ( I i ( 2 ) ) )
getStrokeFunctions
:: forall nbParams
. ParamsCt nbParams
=> Brush nbParams
=> Brush ( nbParams )
-- ^ brush shape
-> Point nbParams
-- ^ start point
@ -587,7 +579,7 @@ getStrokeFunctions
-- ^ curve points
-> ( 1 -> Seq ( 1 -> StrokeDatum 2 () )
, 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 3 𝕀 ) )
getStrokeFunctions brush sp0 crv =
getStrokeFunctions ( Brush brushShape brushShapeI mbRot ) sp0 crv =
let
usedParams :: C 2 ( 1 ) ( nbParams )
path :: C 2 ( 1 ) ( 2 )
@ -600,11 +592,14 @@ getStrokeFunctions brush sp0 crv =
pathAndUsedParams @3 @𝕀 coerce singleton ( getParams . pointParams )
sp0 crv
in ( brushStrokeData @2 @( nbParams ) coerce coerce
path usedParams $
brush @2 @() proxy# id
path usedParams
brushShape
mbRot
, brushStrokeData @3 @( nbParams ) coerce coerce
pathI usedParamsI $
brush @3 @𝕀 proxy# singleton )
pathI usedParamsI
brushShapeI
( fmap nonDecreasing mbRot )
)
{-# INLINEABLE getStrokeFunctions #-}
defaultStartBoxes :: [ Int ] -> [ ( Int, [ Box 2 ] ) ]

View file

@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}

View file

@ -6,7 +6,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Calligraphy.Brushes
( circleBrush
( BrushFn, Brush(..)
, circleBrush
, ellipseBrush
, tearDropBrush
) where
@ -15,10 +16,12 @@ module Calligraphy.Brushes
import Prelude
hiding
( Num(..), Floating(..), (^), (/), fromInteger, fromRational )
import Data.Kind
( Type )
import GHC.Exts
( Proxy# )
( Proxy#, proxy# )
import GHC.TypeNats
( type (<=) )
( Nat, type (<=) )
-- containers
import qualified Data.Sequence as Seq
@ -29,11 +32,71 @@ import Math.Algebra.Dual
import Math.Bezier.Spline
import Math.Differentiable
( I )
import Math.Interval
( 𝕀, singleton )
import Math.Linear
import Math.Module
( Module((^+^), (*^)) )
import Math.Ring
--------------------------------------------------------------------------------
-- | The shape of a brush (before applying any rotation).
type BrushFn :: forall {kd}. kd -> Nat -> Type -> Type
type BrushFn i k brushParams
= C k ( I i brushParams )
( Spline Closed () ( I i ( 2 ) ) )
-- | A brush, described as a base shape + an optional rotation.
data Brush brushParams
= Brush
{ brushShape :: BrushFn () 2 brushParams
, brushShapeI :: BrushFn 𝕀 3 brushParams
, mbRotation :: Maybe ( brushParams -> Double )
}
--------------------------------------------------------------------------------
-- Brushes
-- Some convenience type synonyms for brush types... a bit horrible
type ParamsCt rec = ( ParamsICt 2 () rec, ParamsICt 3 𝕀 rec )
type ParamsICt k i rec =
( Module
( D k ( I i rec ) ( I i Double ) )
( D k ( I i rec ) ( I i ( 2 ) ) )
, Module ( I i Double ) ( T ( I i Double ) )
, HasChainRule ( I i Double ) k ( I i rec )
, Representable ( I i Double ) ( I i rec )
, Applicative ( D k ( I i rec ) )
)
{-# INLINEABLE circleBrush #-}
circleBrush :: ( 1 <= RepDim params, ParamsCt params ) => Brush params
circleBrush =
Brush
{ brushShape = circleBrushFn @() @2 proxy# id
, brushShapeI = circleBrushFn @𝕀 @3 proxy# singleton
, mbRotation = Nothing
}
{-# INLINEABLE ellipseBrush #-}
ellipseBrush :: ( 3 <= RepDim params, ParamsCt params ) => Brush params
ellipseBrush =
Brush
{ brushShape = ellipseBrushFn @() @2 proxy# id
, brushShapeI = ellipseBrushFn @𝕀 @3 proxy# singleton
, mbRotation = Just ( `index` ( Fin 3 ) )
}
{-# INLINEABLE tearDropBrush #-}
tearDropBrush :: ( 3 <= RepDim params, ParamsCt params ) => Brush params
tearDropBrush =
Brush
{ brushShape = tearDropBrushFn @() @2 proxy# id
, brushShapeI = tearDropBrushFn @𝕀 @3 proxy# singleton
, mbRotation = Just ( `index` ( Fin 3 ) )
}
--------------------------------------------------------------------------------
-- Circle & ellipse
@ -60,93 +123,55 @@ circleSpline p = sequenceA $
Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart ()
{-# INLINE circleSpline #-}
circleBrush :: forall {t} (i :: t) k irec
. ( 1 <= RepDim irec
, 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 )
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k irec ( Spline 'Closed () ( I i ( 2 ) ) )
circleBrush _ mkI =
circleBrushFn :: forall {t} (i :: t) k rec
. ( 1 <= RepDim ( I i rec )
, ParamsICt k i rec
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k ( I i rec ) ( Spline 'Closed () ( I i ( 2 ) ) )
circleBrushFn _ mkI =
D \ params ->
let r :: D k irec ( I i Double )
let r :: D k ( I i rec ) ( I i Double )
r = runD ( var @_ @k $ Fin 1 ) params
mkPt :: Double -> Double -> D k irec ( I i ( 2 ) )
mkPt :: Double -> Double -> D k ( I i rec ) ( I i ( 2 ) )
mkPt x y
= ( r `scaledBy` x ) *^ e_x
^+^ ( r `scaledBy` y ) *^ e_y
in circleSpline mkPt
where
e_x, e_y :: D k irec ( I i ( 2 ) )
e_x, e_y :: D k ( I i rec ) ( I i ( 2 ) )
e_x = pure $ mkI $ 2 1 0
e_y = pure $ mkI $ 2 0 1
scaledBy d x = fmap ( mkI x * ) d
{-# INLINEABLE circleBrush #-}
{-# INLINEABLE circleBrushFn #-}
ellipseBrush :: forall {t} (i :: t) k irec
. ( 3 <= RepDim irec
, 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 =
ellipseBrushFn :: forall {t} (i :: t) k rec
. ( 3 <= RepDim ( I i rec )
, ParamsICt k i rec
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k ( I i rec ) ( Spline 'Closed () ( I i ( 2 ) ) )
ellipseBrushFn _ mkI =
D \ params ->
let a, b, phi :: D k irec ( I i Double )
a = runD ( var @_ @k $ Fin 1 ) params
b = runD ( var @_ @k $ Fin 2 ) params
phi = runD ( var @_ @k $ Fin 3 ) params
mkPt :: Double -> Double -> D k irec ( I i ( 2 ) )
let a, b :: D k ( I i rec ) ( I i Double )
a = runD ( var @_ @k $ Fin 1 ) params
b = runD ( var @_ @k $ Fin 2 ) params
mkPt :: Double -> Double -> D k ( I i rec ) ( I i ( 2 ) )
mkPt x y
= let !x' = a `scaledBy` x
!y' = b `scaledBy` y
-- {-
in
( x' * cos phi - y' * sin phi ) *^ e_x
^+^ ( y' * cos phi + x' * sin phi ) *^ e_y
-- -}
{-
r = sqrt ( x' ^ 2 + y' ^ 2 )
arctgt = atan ( y' / x' )
-- a and b are always strictly positive, so we can compute
-- the quadrant using only x and y, which are constants.
!theta
| x > 0
= arctgt
| x < 0
= if y >= 0 then arctgt + pi else arctgt - pi
| otherwise
= if y >= 0 then 0.5 * pi else -0.5 * pi
!phi' = phi + theta
in
( r * cos phi' ) *^ e_x
^+^ ( r * sin phi' ) *^ e_y
-}
in x' *^ e_x ^+^ y' *^ e_y
in circleSpline mkPt
where
e_x, e_y :: D k irec ( I i ( 2 ) )
e_x, e_y :: D k ( I i rec ) ( I i ( 2 ) )
e_x = pure $ mkI $ 2 1 0
e_y = pure $ mkI $ 2 0 1
scaledBy d x = fmap ( mkI x * ) d
{-# INLINEABLE ellipseBrush #-}
{-# INLINEABLE ellipseBrushFn #-}
--------------------------------------------------------------------------------
-- Tear drop
@ -168,27 +193,19 @@ tearHeight = 3 * sqrt 3 / 8
sqrt3_over_2 :: Double
sqrt3_over_2 = 0.5 * sqrt 3
tearDropBrush :: forall {t} (i :: t) k irec
. ( 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 ) )
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k irec ( Spline 'Closed () ( I i ( 2 ) ) )
tearDropBrush _ mkI =
tearDropBrushFn :: forall {t} (i :: t) k rec
. ( 3 <= RepDim ( I i rec )
, ParamsICt k i rec
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k ( I i rec ) ( Spline 'Closed () ( I i ( 2 ) ) )
tearDropBrushFn _ mkI =
D \ params ->
let w, h, phi :: D k irec ( I i Double )
w = runD ( var @_ @k ( Fin 1 ) ) params
h = runD ( var @_ @k ( Fin 2 ) ) params
phi = runD ( var @_ @k ( Fin 3 ) ) params
mkPt :: Double -> Double -> D k irec ( I i ( 2 ) )
let w, h :: D k ( I i rec ) ( I i Double )
w = runD ( var @_ @k ( Fin 1 ) ) params
h = runD ( var @_ @k ( Fin 2 ) ) params
mkPt :: Double -> Double -> D k ( I i rec ) ( I i ( 2 ) )
mkPt x y
-- 1. translate the teardrop so that the center of mass is at the origin
-- 2. scale the teardrop so that it has the requested width/height
@ -196,8 +213,8 @@ tearDropBrush _ mkI =
= let !x' = w `scaledBy` (x / tearWidth)
!y' = ( h `scaledBy` ( ( y - tearCenter ) / tearHeight) )
in
( x' * cos phi - y' * sin phi ) *^ e_x
^+^ ( y' * cos phi + x' * sin phi ) *^ e_y
x' *^ e_x
^+^ y' *^ e_y
in sequenceA $
Spline { splineStart = mkPt 0 0
@ -207,9 +224,9 @@ tearDropBrush _ mkI =
( mkPt -0.5 sqrt3_over_2 )
BackToStart () }
where
e_x, e_y :: D k irec ( I i ( 2 ) )
e_x, e_y :: D k ( I i rec ) ( I i ( 2 ) )
e_x = pure $ mkI $ 2 1 0
e_y = pure $ mkI $ 2 0 1
scaledBy d x = fmap ( mkI x * ) d
{-# INLINEABLE tearDropBrush #-}
{-# INLINEABLE tearDropBrushFn #-}

View file

@ -12,7 +12,7 @@ module Math.Bezier.Stroke
-- * Brush stroking
, brushStroke, envelopeEquation
, envelopeEquation
, line, bezier2, bezier3
, brushStrokeData, pathAndUsedParams
@ -39,6 +39,8 @@ import Data.Fixed
( divMod' )
import Data.Foldable
( for_ )
import Data.Functor
( (<&>) )
import Data.Functor.Identity
( Identity(..) )
import Data.List
@ -49,11 +51,12 @@ import qualified Data.List.NonEmpty as NE
( cons, singleton, unzip )
import Data.Maybe
( fromMaybe, isJust, listToMaybe, mapMaybe )
import Data.Proxy
( Proxy(..) )
import Data.Semigroup
( sconcat )
import GHC.Exts
( newMutVar#, runRW#, inline
, Proxy#, proxy#
)
import GHC.STRef
( STRef(..), readSTRef, writeSTRef )
@ -105,6 +108,8 @@ import Control.Monad.Trans.Writer.CPS
( WriterT, execWriterT, runWriter, tell )
-- MetaBrush
import Calligraphy.Brushes
( Brush(..) )
import Math.Algebra.Dual
import qualified Math.Bezier.Cubic as Cubic
import Math.Bezier.Cubic.Fit
@ -131,6 +136,8 @@ import Math.Module
( Module(..), Inner((^.^)), Cross((×)), Interpolatable
, lerp, convexCombination, strictlyParallel
)
import Math.Ring
( Transcendental )
import Math.Orientation
( Orientation(..), splineOrientation
, between
@ -250,20 +257,14 @@ computeStrokeOutline ::
-> FitParameters
-> ( ptData -> usedParams )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
-> ( forall {t} k (i :: t)
. DiffInterp k i brushParams
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k ( I i brushParams )
( Spline Closed () ( I i ( 2 ) ) )
)
-> Brush brushParams
-> Spline clo crvData ptData
-> ST s
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
, Seq FitPoint
, [ Cusp ]
)
computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams brush spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
-- Open brush path with at least one segment.
-- Need to add caps at both ends of the path.
SOpen
@ -365,7 +366,7 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
where
outlineInfo :: ptData -> Curve Open crvData ptData -> OutlineInfo
outlineInfo = inline ( outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brushFn )
outlineInfo = inline ( outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brush )
outlineFns :: Seq OutlineInfo
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
@ -379,7 +380,17 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru
outlineInfo p0 crv :<| go ( openCurveEnd crv ) crvs
brushShape :: ptData -> SplinePts Closed
brushShape pt = fun @Double ( brushFn @2 @() proxy# id ) $ toBrushParams $ ptParams pt
brushShape pt =
let Brush { brushShape = shapeFn, mbRotation = mbRot } = brush
brushParams = toBrushParams $ ptParams pt
shape = fun @Double shapeFn brushParams
in case mbRot of
Nothing -> shape
Just getθ ->
let θ = getθ brushParams
cosθ = cos θ
sinθ = sin θ
in fmap ( unT . rotate cosθ sinθ . T ) shape
updateSpline :: ( T ( 2 ), T ( 2 ), T ( 2 ) ) -> ST s OutlineData
updateSpline ( lastTgt, lastTgtFwd, lastTgtBwd )
@ -528,17 +539,12 @@ outlineFunction
-> Maybe ( RootIsolationOptions N 3 )
-> ( ptData -> usedParams )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
-> ( forall {t} k (i :: t)
. DiffInterp k i brushParams
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k ( I i brushParams )
( Spline Closed () ( I i ( 2 ) ) )
)
-> Brush brushParams
-> ptData
-> Curve Open crvData ptData
-> OutlineInfo
outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brushFromParams = \ sp0 crv ->
outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams
( Brush { brushShape, brushShapeI, mbRotation } ) = \ sp0 crv ->
let
usedParams :: C 2 ( 1 ) usedParams
@ -552,22 +558,19 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brushFromParams =
brushStrokeData @2 @brushParams
coerce coerce
path
( chainRule @Double @2
usedParams
( linear toBrushParams )
)
( brushFromParams @2 @() proxy# id )
( fmap toBrushParams usedParams )
brushShape
mbRotation
curvesI :: 𝕀 1 -- t
-> Seq ( 𝕀 1 {- s -} -> StrokeDatum 3 𝕀 )
curvesI = brushStrokeData @3 @brushParams
coerce coerce
pathI
( chainRule @( 𝕀 Double ) @3
usedParamsI
( linear ( nonDecreasing toBrushParams ) )
)
( brushFromParams @3 @𝕀 proxy# singleton )
curvesI =
brushStrokeData @3 @brushParams
coerce coerce
pathI
( fmap ( nonDecreasing toBrushParams ) usedParamsI )
brushShapeI
( fmap nonDecreasing mbRotation )
usedParamsI :: C 3 ( 𝕀 1 ) ( 𝕀 usedParams )
pathI :: C 3 ( 𝕀 1 ) ( 𝕀 2 )
@ -585,7 +588,7 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams brushFromParams =
D21 path_t path'_t _ = runD path t
D21 params_t _ _ = runD usedParams t
brush_t = value @Double @2 @brushParams
$ runD ( brushFromParams @2 @() proxy# id )
$ runD brushShape
$ toBrushParams params_t
( potentialCusps, definiteCusps ) =
@ -981,9 +984,12 @@ brushStrokeData :: forall k brushParams i arr
, D k ( I i ( 1 ) ) ~ D k ( 1 )
, D k ( I i ( 1 ) ) ~ D k ( 1 )
, D k ( I i ( 2 ) ) ~ D k ( 2 )
, Transcendental ( I i Double )
, Module ( I i Double ) ( T ( I i ( 1 ) ) )
, Cross ( I i Double ) ( T ( I i ( 2 ) ) )
, Torsor ( T ( I i ( 2 ) ) ) ( I i ( 2 ) )
, Show brushParams
, Representable ( I i Double ) ( I i ( 2 ) ), RepDim ( I i ( 2 ) ) ~ 2
)
=> ( I i Double -> I i ( 1 ) )
-> ( I i ( 1 ) -> I i Double )
@ -993,8 +999,10 @@ brushStrokeData :: forall k brushParams i arr
-- ^ brush parameters
-> ( I i brushParams `arr` Spline Closed () ( I i ( 2 ) ) )
-- ^ brush from parameters
-> ( Maybe ( I i brushParams -> I i Double ) )
-- ^ rotation parameter
-> ( I i ( 1 ) -> Seq ( I i ( 1 ) -> StrokeDatum k i ) )
brushStrokeData co1 co2 path params brush =
brushStrokeData co1 co2 path params brush mbBrushRotation =
\ t ->
let
dpath_t :: D k ( I i ( 1 ) ) ( I i ( 2 ) )
@ -1009,35 +1017,17 @@ brushStrokeData co1 co2 path params brush =
!dbrushes_t = force $ fmap ( uncurryD @k . chain @( I i Double ) @k dparams_t ) splines
-- This is the crucial use of the chain rule.
in fmap ( mkStrokeDatum dpath_t ) dbrushes_t
in fmap ( mkStrokeDatum dpath_t dparams_t ) dbrushes_t
where
mkStrokeDatum :: D k ( I i ( 1 ) ) ( I i ( 2 ) )
-> D k ( I i ( 1 ) ) ( I i brushParams )
-> ( I i ( 1 ) -> D k ( I i ( 2 ) ) ( I i ( 2 ) ) )
-> ( I i ( 1 ) -> StrokeDatum k i )
mkStrokeDatum dpath_t dbrush_t s =
mkStrokeDatum dpath_t dparams_t dbrush_t s =
let dbrush_t_s = dbrush_t s
dstroke = brushStroke @k dpath_t dbrush_t_s
( ee, 𝛿E𝛿sdcdt ) = envelopeEquation @k @i co1 dstroke
in -- trace
-- ( unlines
-- [ "envelopeEquation:"
-- , " t = " ++ show t
-- , " s = " ++ show s
-- , " c = " ++ show _c
-- , " ∂c/∂t = " ++ show _𝛿c𝛿t
-- , " ∂c/∂s = " ++ show _𝛿c𝛿s
-- , " E = " ++ show ee
-- , " ∂E/∂t = " ++ show _𝛿E𝛿t
-- , " ∂E/∂s = " ++ show ee_s
-- , " dc/dt = " ++ show dcdt ] ) $
StrokeDatum
{ dpath = dpath_t
, dbrush = dbrush_t_s
, dstroke
, ee
, 𝛿E𝛿sdcdt
}
mbRotation = mbBrushRotation <&> \ getTheta -> fmap getTheta dparams_t
in envelopeEquation @k @i Proxy co1 dpath_t dbrush_t_s mbRotation
--------------------------------------------------------------------------------
-- Solving the envelolpe equation: root-finding.
@ -1105,7 +1095,7 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
let (i, s) = fromDomain is in
case evalStrokeDatum fs is of -- TODO: a bit redundant to have to compute this again...
StrokeDatum
{ dstroke
{ stroke
, ee = D12 ( 1 _ee ) _ ( T ( 1 𝛿E𝛿s ) )
, 𝛿E𝛿sdcdt = D0 𝛿E𝛿sdcdt
} ->
@ -1119,7 +1109,7 @@ solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strok
-> recip 𝛿E𝛿s' *^ 𝛿E𝛿sdcdt'
| otherwise
= recip 𝛿E𝛿s *^ 𝛿E𝛿sdcdt
in ( value @Double @2 @( 2 ) dstroke, dcdt )
in ( stroke, dcdt )
evalStrokeDatum :: Seq ( 1 -> StrokeDatum 2 () ) -> ( Double -> StrokeDatum 2 () )
evalStrokeDatum fs is =
@ -1154,8 +1144,7 @@ cuspCoords :: ( 1 -> Seq ( 1 -> StrokeDatum 2 () ) )
-> Cusp
cuspCoords eqs ( i, box )
| StrokeDatum
{ dpath
, dstroke = D22 { _D22_v = stroke } }
{ dpath, stroke }
<- ( eqs ( 1 t_mid ) `Seq.index` i ) ( 1 s_mid )
= Cusp
{ cuspParameters = 2 t_mid s_mid
@ -1168,8 +1157,6 @@ cuspCoords eqs ( i, box )
t_mid = 0.5 * ( t_lo + t_hi )
s_mid = 0.5 * ( s_lo + s_hi )
type N = 2
-- | Find cusps in the envelope for values of the parameters in
-- \( 0 \leqslant t, s \leqslant 1 \), using interval arithmetic.
--
@ -1233,10 +1220,12 @@ findCuspsIn opts boxStrokeData initBoxes =
let t = 𝕀 ( 1 t_lo ) ( 1 t_hi )
s = 𝕀 ( 1 s_lo ) ( 1 s_hi )
StrokeDatum
{ dstroke =
D32
{ _D32_dx = T ( 𝕀 ( 2 cx_t_lo cy_t_lo ) ( 2 cx_t_hi cy_t_hi ) )
, _D32_dy = T ( 𝕀 ( 2 cx_s_lo cy_s_lo ) ( 2 cx_s_hi cy_s_hi ) )}
{ du =
D22
{ _D22_v = 𝕀 ( 2 ux_lo uy_lo ) ( 2 ux_hi uy_hi )}
, dv =
D22
{ _D22_v = 𝕀 ( 2 vx_lo vy_lo ) ( 2 vx_hi vy_hi ) }
, ee =
D22
{ _D22_dx = T ( 𝕀 ( 1 ee_t_lo ) ( 1 ee_t_hi ) )
@ -1244,9 +1233,9 @@ findCuspsIn opts boxStrokeData initBoxes =
} = ( boxStrokeData t `Seq.index` i ) s
-- λ = ∂E/∂t / ∂E/∂s
λ1 = 𝕀 ee_t_lo ee_t_hi `extendedDivide` 𝕀 ee_s_lo ee_s_hi
-- λ = ∂c/∂t / ∂c/∂s
λ2 = 𝕀 cx_t_lo cx_t_hi `extendedDivide` 𝕀 cx_s_lo cx_s_hi
λ3 = 𝕀 cy_t_lo cy_t_hi `extendedDivide` 𝕀 cy_s_lo cy_s_hi
-- λ = u / v
λ2 = 𝕀 ux_lo ux_hi `extendedDivide` 𝕀 vx_lo vx_hi
λ3 = 𝕀 uy_lo uy_hi `extendedDivide` 𝕀 vy_lo vy_hi
λ = [ 𝕀 ( recip -0 ) ( recip 0 ) ]
`intersectMany` λ1
`intersectMany` λ2
@ -1264,9 +1253,12 @@ findCuspsIn opts boxStrokeData initBoxes =
λ = 𝕀 λ_lo λ_hi
StrokeDatum
{ dstroke =
D32 { _D32_dx = T c_t, _D32_dy = T c_s
, _D32_dxdx = T c_tt, _D32_dxdy = T c_ts, _D32_dydy = T c_ss }
{ du =
D22 { _D22_v = u
, _D22_dx = T u_t , _D22_dy = T u_s }
, dv =
D22 { _D22_v = v
, _D22_dx = T v_t , _D22_dy = T v_s }
, ee =
D22 { _D22_dx = T ee_t, _D22_dy = T ee_s
, _D22_dxdx = T ee_tt, _D22_dxdy = T ee_ts, _D22_dydy = T ee_ss }
@ -1278,11 +1270,11 @@ findCuspsIn opts boxStrokeData initBoxes =
𝕀 ( 1 f1_s_lo ) ( 1 f1_s_hi ) = unT $ λ *^ T ee_ss ^-^ T ee_ts
𝕀 ( 1 f1_λ_lo ) ( 1 f1_λ_hi ) = ee_s
-- λ ∂c/∂s - ∂c/∂t = 0
𝕀 ( 2 f2_lo f3_lo ) ( 2 f2_hi f3_hi ) = unT $ λ *^ T c_s ^-^ T c_t
𝕀 ( 2 f2_t_lo f3_t_lo ) ( 2 f2_t_hi f3_t_hi ) = unT $ λ *^ T c_ts ^-^ T c_tt
𝕀 ( 2 f2_s_lo f3_s_lo ) ( 2 f2_s_hi f3_s_hi ) = unT $ λ *^ T c_ss ^-^ T c_ts
𝕀 ( 2 f2_λ_lo f3_λ_lo ) ( 2 f2_λ_hi f3_λ_hi ) = c_s
-- λ v - u = 0
𝕀 ( 2 f2_lo f3_lo ) ( 2 f2_hi f3_hi ) = unT $ λ *^ T v ^-^ T u
𝕀 ( 2 f2_t_lo f3_t_lo ) ( 2 f2_t_hi f3_t_hi ) = unT $ λ *^ T v_t ^-^ T u_t
𝕀 ( 2 f2_s_lo f3_s_lo ) ( 2 f2_s_hi f3_s_hi ) = unT $ λ *^ T v_s ^-^ T u_s
𝕀 ( 2 f2_λ_lo f3_λ_lo ) ( 2 f2_λ_hi f3_λ_hi ) = v
in D13 ( 𝕀 ( 3 f1_lo f2_lo f3_lo ) ( 3 f1_hi f2_hi f3_hi ) )
( T $ 𝕀 ( 3 f1_t_lo f2_t_lo f3_t_lo ) ( 3 f1_t_hi f2_t_hi f3_t_hi ) )

View file

@ -10,11 +10,13 @@ module Math.Bezier.Stroke.EnvelopeEquation
) where
-- base
import Prelude hiding ( Num(..), (^) )
import Prelude hiding ( Num(..), (^), pi, sin, cos )
import Data.Kind
( Type, Constraint )
import Data.List.NonEmpty
( NonEmpty(..) )
import Data.Proxy
( Proxy(..) )
import GHC.TypeNats
( Nat, type (-) )
@ -37,20 +39,26 @@ import Math.Ring
--------------------------------------------------------------------------------
-- | The value and derivative of a brush stroke at a given coordinate
-- \( (t_0, s_0) \), together with the value of the envelope equation at that
-- \( (t, s) \), together with the value of the envelope equation at that
-- point.
type StrokeDatum :: Nat -> k -> Type
data StrokeDatum k i
= StrokeDatum
{ -- | Path \( p(t_0) \).
{ -- | Path \( p(t) \).
dpath :: D k ( I i ( 1 ) ) ( I i ( 2 ) )
-- | Brush shape \( b(t_0, s_0) \).
-- | Brush shape \( b(t, s) \).
, dbrush :: D k ( I i ( 2 ) ) ( I i ( 2 ) )
-- | (Optional) rotation angle \( \theta(t) \).
, mbRotation :: Maybe ( D k ( I i ( 1 ) ) ( I i Double ) )
-- Everything below can be computed in terms of the first two fields.
-- Everything below is computed in terms of the first three fields.
-- | Stroke \( c(t_0,s_0) = p(t_0) + b(t_0,s_0) \).
, dstroke :: D k ( I i ( 2 ) ) ( I i ( 2 ) )
-- | Stroke shape \( c(t,s) = p(t) + R(\theta(t)) b(t,s) \).
, stroke :: I i ( 2 )
-- | \( u(t,s) = R(-\theta(t)) \frac{\partial c}{\partial t} \),
-- \( v(t,s) = R(-\theta(t)) \frac{\partial c}{\partial s} \)
, du, dv :: D ( k - 1 ) ( I i ( 2 ) ) ( I i ( 2 ) )
-- | Envelope function
--
@ -108,19 +116,6 @@ class HasEnvelopeEquation k where
uncurryD :: D k a ~ D k ( 1 )
=> D k ( 1 ) ( C k a b ) -> a -> D k ( 2 ) b
-- | A brush stroke, as described by the equation
--
-- \[ c(t,s) = p(t) + b(t,s) \]
--
-- where:
--
-- - \( p(t) \) is the path that the brush follows, and
-- - \( b(t,s) \) is the brush shape, as it varies along the path.
brushStroke :: Module r ( T v )
=> D k ( 1 ) v -- ^ stroke path \( p(t) \)
-> D k ( 2 ) v -- ^ brush \( b(t,s) \)
-> D k ( 2 ) v
-- | The envelope function
--
-- \[ E = \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s}, \]
@ -136,12 +131,19 @@ class HasEnvelopeEquation k where
. ( D ( k - 2 ) ( I i ( 2 ) ) ~ D ( k - 2 ) ( 2 )
, D ( k - 1 ) ( I i ( 2 ) ) ~ D ( k - 1 ) ( 2 )
, D k ( I i ( 2 ) ) ~ D k ( 2 )
, D k ( I i ( 1 ) ) ~ D k ( 1 )
, Module ( I i Double ) ( T ( I i ( 1 ) ) )
, Cross ( I i Double ) ( T ( I i ( 2 ) ) )
, Transcendental ( I i Double )
, Representable ( I i Double ) ( I i ( 2 ) )
, RepDim ( I i ( 2 ) ) ~ 2
)
=> ( I i Double -> I i ( 1 ) )
=> Proxy i
-> ( I i Double -> I i ( 1 ) )
-> D k ( I i ( 1 ) ) ( I i ( 2 ) )
-> D k ( I i ( 2 ) ) ( I i ( 2 ) )
-> ( D ( k - 1 ) ( I i ( 2 ) ) ( I i ( 1 ) )
, D ( k - 2 ) ( I i ( 2 ) ) ( T ( I i ( 2 ) ) ) )
-> Maybe ( D k ( I i ( 1 ) ) ( I i Double ) )
-> StrokeDatum k i
instance HasBézier 2 () where
line co ( Segment a b :: Segment b ) =
@ -166,34 +168,85 @@ instance HasEnvelopeEquation 2 where
uncurryD = uncurryD2
brushStroke ( D21 p p_t p_tt ) ( D22 b b_t b_s b_tt b_ts b_ss ) =
D22 ( unT $ T p ^+^ T b )
-- c = p + b
envelopeEquation ( _ :: Proxy i ) co
dp@( D21 ( T -> p ) p_t p_tt )
db@( D22 ( T -> b ) b_t b_s
b_tt b_ts b_ss )
mbRotation =
StrokeDatum
{ dpath = dp
, dbrush = db
, mbRotation
, stroke = c
, du, dv, ee, 𝛿E𝛿sdcdt
}
where
(ee, 𝛿E𝛿sdcdt) =
let
D12 (T -> u) u_t u_s = du
D12 (T -> v) v_t v_s = dv
ee_val, ee_t, ee_s :: I i Double
ee_val= u × v
ee_t = u_t × v
+ u × v_t
ee_s = u_s × v
+ u × v_s
( p_t ^+^ b_t ) b_s
-- ∂c/∂t = dp/dt + ∂b/∂t
-- ∂c/∂s = ∂b/∂s
𝛿E𝛿sdcdt_val = ee_s *^ u ^-^ ee_t *^ v
in ( D12
( co ee_val )
( T $ co ee_t ) ( T $ co ee_s )
, D0 𝛿E𝛿sdcdt_val
)
(c, du, dv) = case mbRotation of
Nothing ->
-- c(t,s) = p(t) + b(t,s)
( unT $ p ^+^ b
, D12 ( unT $ p_t ^+^ b_t )
( p_tt ^+^ b_tt ) b_ts
, D12 ( unT $ b_s )
b_ts b_ss
)
Just ( D21 θ ( T θ_t ) ( T θ_tt ) ) ->
-- c(t,s) = p(t) + R(θ(t)) b(t,s)
-- E = ∂c/∂t × ∂c/ds
-- = ( R(-θ(t)) ∂c/∂t ) × ( R(-θ(t)) ∂c/ds )
-- = ( R(-θ(t)) p'(t) + θ'(t) S b(t,s) + ∂b/∂t ) × ∂b/ds
--
let rot, rot' :: T ( I i ( 2 ) ) -> T ( I i ( 2 ) )
cosθ = cos θ
sinθ = sin θ
-- rot = R(-θ), rot' = R'(-θ)
-- NB: rot' is not the derivative of f(θ) = R(-θ)
rot = rotate cosθ -sinθ
rot' = rotate sinθ cosθ
swap :: T ( I i ( 2 ) ) -> T ( I i ( 2 ) )
swap ( T xy ) =
let x = xy `index` Fin 1
y = xy `index` Fin 2
in T $ tabulate \ case
Fin 1 -> -y
_ -> x
( p_tt ^+^ b_tt ) b_ts b_ss
-- ∂²c/∂t² = d²p/dt² + ∂²b/∂t²
-- ∂²c/∂t∂s = ∂²b/∂t∂s
-- ∂²c/∂s² = ∂²b/∂s²
u, v, u_t, u_s, v_t, v_s :: T ( I i ( 2 ) )
u = rot p_t ^+^ θ_t *^ swap b ^+^ b_t
v = b_s
u_t = ( -θ_t *^ rot' p_t
^+^ rot p_tt
)
^+^
( θ_tt *^ swap b
^+^ θ_t *^ swap b_t
)
^+^ b_tt
u_s = θ_t *^ swap b_s ^+^ b_ts
v_t = b_ts
v_s = b_ss
envelopeEquation co ( D22 _ c_t c_s c_tt c_ts c_ss ) =
let ee = c_t × c_s
ee_t = c_tt × c_s + c_t × c_ts
ee_s = c_ts × c_s + c_t × c_ss
𝛿E𝛿sdcdt = ee_s *^ c_t ^-^ ee_t *^ c_s
-- TODO: we get c_t * c_t and c_s * c_s terms...
-- These could be squares (better with interval arithmetic)?
in ( D12 ( co ee ) ( T $ co ee_t ) ( T $ co ee_s )
, D0 𝛿E𝛿sdcdt )
-- Computation of total derivative dc/dt:
--
-- dc/dt = ∂c/∂t + ∂c/∂s ∂s/∂t
-- ∂s/∂t = - ∂E/∂t / ∂E/∂s
--
-- ∂E/∂s dc/dt = ∂E/∂s ∂c/∂t - ∂E/∂t ∂c/∂s.
in ( unT $ p ^+^ rotate cosθ sinθ b
, D12 ( unT u ) u_t u_s
, D12 ( unT v ) v_t v_s
)
instance HasBézier 3 () where
@ -222,42 +275,123 @@ instance HasEnvelopeEquation 3 where
uncurryD = uncurryD3
brushStroke
( D31 p p_t p_tt p_ttt )
( D32 b b_t b_s b_tt b_ts b_ss b_ttt b_tts b_tss b_sss ) =
D32
( unT $ T p ^+^ T b )
( p_t ^+^ b_t ) b_s
( p_tt ^+^ b_tt ) b_ts b_ss
( p_ttt ^+^ b_ttt ) b_tts b_tss b_sss
envelopeEquation ( _ :: Proxy i ) co
dp@( D31 ( T -> p ) p_t p_tt p_ttt )
db@( D32 ( T -> b ) b_t b_s
b_tt b_ts b_ss
b_ttt b_tts b_tss b_sss )
mbRotation =
StrokeDatum
{ dpath = dp
, dbrush = db
, mbRotation
, stroke = c
, du, dv, ee, 𝛿E𝛿sdcdt
}
where
(ee, 𝛿E𝛿sdcdt) =
let
D22 (T -> u) u_t u_s u_tt u_ts u_ss = du
D22 (T -> v) v_t v_s v_tt v_ts v_ss = dv
ee_val, ee_t, ee_s, ee_tt, ee_ts, ee_ss :: I i Double
ee_val= u × v
ee_t = u_t × v
+ u × v_t
ee_s = u_s × v
+ u × v_s
ee_tt = u_tt × v
+ 2 * ( u_t × v_t )
+ u × v_tt
ee_ts = u_ts × v
+ u_t × v_s
+ u_s × v_t
+ u × v_ts
ee_ss = u_ss × v
+ 2 * ( u_s × v_s )
+ u × v_ss
envelopeEquation co
( D32 _ c_t c_s
c_tt c_ts c_ss
c_ttt c_tts c_tss c_sss )
= let ee = c_t × c_s
ee_t = c_tt × c_s + c_t × c_ts
ee_s = c_ts × c_s + c_t × c_ss
ee_tt = c_ttt × c_s
+ c_tt × c_ts * 2
+ c_t × c_tts
ee_ts = c_tts × c_s
+ c_tt × c_ss
-- + c_ts × c_ts -- cancels out
+ c_t × c_tss
ee_ss = c_tss × c_s
+ c_ts × c_ss * 2
+ c_t × c_sss
𝛿E𝛿sdcdt = ee_s *^ c_t ^-^ ee_t *^ c_s
𝛿E𝛿sdcdt_t = ee_ts *^ c_t ^+^ ee_s *^ c_tt
^-^ ( ee_tt *^ c_s ^+^ ee_t *^ c_ts )
𝛿E𝛿sdcdt_s = ee_ss *^ c_t ^+^ ee_s *^ c_ts
^-^ ( ee_ts *^ c_s ^+^ ee_t *^ c_ss )
in ( D22
( co ee )
( T $ co ee_t ) ( T $ co ee_s )
( T $ co ee_tt) ( T $ co ee_ts ) ( T $ co ee_ss )
, D12 𝛿E𝛿sdcdt ( T 𝛿E𝛿sdcdt_t ) ( T 𝛿E𝛿sdcdt_s ) )
𝛿E𝛿sdcdt_val = ee_s *^ u ^-^ ee_t *^ v
𝛿E𝛿sdcdt_t = ee_ts *^ u ^+^ ee_s *^ u_t
^-^ ( ee_tt *^ v ^+^ ee_t *^ v_t )
𝛿E𝛿sdcdt_s = ee_ss *^ u ^+^ ee_s *^ u_s
^-^ ( ee_ts *^ v ^+^ ee_t *^ v_s )
in ( D22
( co ee_val )
( T $ co ee_t ) ( T $ co ee_s )
( T $ co ee_tt) ( T $ co ee_ts ) ( T $ co ee_ss )
, D12 𝛿E𝛿sdcdt_val ( T 𝛿E𝛿sdcdt_t ) ( T 𝛿E𝛿sdcdt_s )
)
(c, du, dv) = case mbRotation of
Nothing ->
-- c(t,s) = p(t) + b(t,s)
( unT $ p ^+^ b
, D22 ( unT $ p_t ^+^ b_t )
( p_tt ^+^ b_tt ) b_ts
( p_ttt ^+^ b_ttt ) b_tts b_tss
, D22 ( unT $ b_s )
b_ts b_ss
b_tts b_tss b_sss
)
Just ( D31 θ ( T θ_t ) ( T θ_tt ) ( T θ_ttt ) ) ->
-- c(t,s) = p(t) + R(θ(t)) b(t,s)
-- E = ∂c/∂t × ∂c/ds
-- = ( R(-θ(t)) ∂c/∂t ) × ( R(-θ(t)) ∂c/ds )
-- = ( R(-θ(t)) p'(t) + θ'(t) S b(t,s) + ∂b/∂t ) × ∂b/ds
--
let rot, rot', rot'' :: T ( I i ( 2 ) ) -> T ( I i ( 2 ) )
cosθ = cos θ
sinθ = sin θ
-- rot = R(-θ), rot' = R'(-θ), rot'' = R''(-θ)
-- NB: rot' is not the derivative of f(θ) = R(-θ)
rot = rotate cosθ -sinθ
rot' = rotate sinθ cosθ
rot'' z = -1 *^ rot z
swap :: T ( I i ( 2 ) ) -> T ( I i ( 2 ) )
swap ( T xy ) =
let x = xy `index` Fin 1
y = xy `index` Fin 2
in T $ tabulate \ case
Fin 1 -> -y
_ -> x
u, v, u_t, u_s, u_tt, u_ts, u_ss, v_t, v_s, v_tt, v_ts, v_ss :: T ( I i ( 2 ) )
u = rot p_t ^+^ θ_t *^ swap b ^+^ b_t
v = b_s
u_t = ( -θ_t *^ rot' p_t
^+^ rot p_tt
)
^+^
( θ_tt *^ swap b
^+^ θ_t *^ swap b_t
)
^+^ b_tt
u_s = θ_t *^ swap b_s ^+^ b_ts
u_tt = ( ( θ_t ^ 2 ) *^ rot'' p_t
^-^ θ_tt *^ rot' p_t
^+^ ( 2 * θ_t ) *^ rot' p_tt
^+^ rot p_ttt
)
^+^ ( θ_ttt *^ swap b
^+^ ( 2 * θ_tt ) *^ swap b_t
^+^ θ_t *^ swap b_tt
)
^+^ b_ttt
u_ts = θ_tt *^ swap b_s
^+^ θ_t *^ swap b_ts
^+^ b_tts
u_ss = θ_t *^ swap b_ss
^+^ b_tss
v_t = b_ts
v_s = b_ss
v_tt = b_tts
v_ts = b_tss
v_ss = b_sss
in ( unT $ p ^+^ rotate cosθ sinθ b
, D22 ( unT u ) u_t u_s u_tt u_ts u_ss
, D22 ( unT v ) v_t v_s v_tt v_ts v_ss
)
instance HasBézier 3 𝕀 where
@ -292,7 +426,7 @@ are convex combinations
b_0(t) [p_0,q_0] + b_1(t) [p_1,q_1] + ... + b_n(t) [p_n,q_n]
-- Here b_1, ..., b_n are Bernstein polynomials.
-- Here b_0, ..., b_n are Bernstein polynomials.
This means that the minimum value attained by the Bézier curve as we vary
both the time parameter and the values of the points within their respective
@ -334,31 +468,3 @@ evaluateQuadratic bez t =
maxs = fmap (Quadratic.bezier @( T Double ) sup_bez)
$ inf t :| ( sup t : filter ( `inside` t ) ( Quadratic.extrema sup_bez ) )
in 𝕀 ( minimum mins ) ( maximum maxs )
{-
evaluateCubic :: Cubic.Bezier ( 𝕀 Double ) -> 𝕀 Double -> 𝕀 Double
evaluateCubic bez t =
-- assert (inf t >= 0 && sup t <= 1) "evaluateCubic: t ⊊ [0,1]" $ -- Requires t ⊆ [0,1]
let inf_bez = Cubic.restrict @( T Double ) ( fmap inf bez ) ( inf t, sup t )
sup_bez = Cubic.restrict @( T Double ) ( fmap sup bez ) ( inf t, sup t )
mins = fmap (Cubic.bezier @( T Double ) inf_bez)
$ 0 :| ( 1 : Cubic.extrema inf_bez )
maxs = fmap (Cubic.bezier @( T Double ) sup_bez)
$ 0 :| ( 1 : Cubic.extrema sup_bez )
in 𝕀 ( minimum mins ) ( maximum maxs )
-- | Evaluate a quadratic Bézier curve, when both the coefficients and the
-- parameter are intervals.
evaluateQuadratic :: Quadratic.Bezier ( 𝕀 Double ) -> 𝕀 Double -> 𝕀 Double
evaluateQuadratic bez t =
-- assert (inf t >= 0 && sup t <= 1) "evaluateCubic: t ⊊ [0,1]" $ -- Requires t ⊆ [0,1]
let inf_bez = Quadratic.restrict @( T Double ) ( fmap inf bez ) ( inf t, sup t )
sup_bez = Quadratic.restrict @( T Double ) ( fmap sup bez ) ( inf t, sup t )
mins = fmap (Quadratic.bezier @( T Double ) inf_bez)
$ 0 :| ( 1 : Quadratic.extrema inf_bez )
maxs = fmap (Quadratic.bezier @( T Double ) sup_bez)
$ 0 :| ( 1 : Quadratic.extrema sup_bez )
in 𝕀 ( minimum mins ) ( maximum maxs )
-}

View file

@ -15,6 +15,8 @@ module Math.Linear
, Representable(..), set, injection, projection
, Vec(..), (!), find, zipIndices
, rotate
) where
-- base
@ -52,6 +54,9 @@ import Data.Group.Generics
-- brush-strokes
import Math.Linear.Internal
import Math.Ring
( Ring )
import qualified Math.Ring as Ring
--------------------------------------------------------------------------------
@ -151,3 +156,20 @@ zipIndices ( Vec v ) = zipIndices_ 1 v
zipIndices_ :: Word -> [ a ] -> [ ( Fin n, a ) ]
zipIndices_ _ [] = []
zipIndices_ i (a : as) = ( Fin i, a ) : zipIndices_ ( i + 1 ) as
--------------------------------------------------------------------------------
-- | Rotate a vector by the given angle (counter-clockwise),
-- given the cosine and sine of the angle (in that order)
rotate :: ( Representable r m, RepDim m ~ 2, Ring r )
=> r -- \( \cos \theta \)
-> r -- \( \sin \theta \)
-> T m
-> T m
rotate cosθ sinθ ( T xy ) =
let x = xy `index` Fin 1
y = xy `index` Fin 2
in T $ tabulate \ case
Fin 1 -> x Ring.* cosθ Ring.- y Ring.* sinθ
_ -> y Ring.* cosθ Ring.+ x Ring.* sinθ
{-# INLINEABLE rotate #-}

View file

@ -45,15 +45,15 @@ data instance 0 = 0
newtype instance 1 = 1 { un1 :: Double }
deriving stock ( Generic )
deriving newtype ( Eq, Ord, NFData )
data instance 2 = 2 { _2_x, _2_y :: {-# UNPACK #-} !Double }
data instance 2 = 2 { _2_x, _2_y :: Double }
deriving stock Generic
deriving anyclass NFData
deriving stock ( Eq, Ord )
data instance 3 = 3 { _3_x, _3_y, _3_z :: {-# UNPACK #-} !Double }
data instance 3 = 3 { _3_x, _3_y, _3_z :: Double }
deriving stock Generic
deriving anyclass NFData
deriving stock ( Eq, Ord )
data instance 4 = 4 { _4_x, _4_y, _4_z, _4_w :: {-# UNPACK #-} !Double }
data instance 4 = 4 { _4_x, _4_y, _4_z, _4_w :: Double }
deriving stock Generic
deriving anyclass NFData
deriving stock ( Eq, Ord )

View file

@ -24,6 +24,10 @@ module Math.Root.Isolation
-- ** Trees recording search space of root isolation algorithms
, RootIsolationTree(..), showRootIsolationTree
, RootIsolationStep(..)
-- * Hack for changing between 2 and 3 d formulations
-- for my personal testing
, N
)
where
@ -130,7 +134,8 @@ showArea area = "(area " ++ showFFloat (Just 6) area "" ++ ")"
type Box n = 𝕀 n
type BoxHistory n = [ NE.NonEmpty ( RootIsolationStep, Box n ) ]
type BoxCt n d = ( n ~ 2, d ~ 3 )
type N = 2
type BoxCt n d = ( n ~ N, d ~ 3 )
{-
( Show ( 𝕀 n ), Show ( n )
, Eq ( n )
@ -167,9 +172,9 @@ data RootIsolationAlgorithm n d
-- | GaussSeidel step with the given preconditioning method.
| GaussSeidel !( GaussSeidelOptions n d )
-- | @box(1)@-consistency.
| Box1 !Box1Options
| Box1 !( Box1Options n d )
-- | @box(2)@-consistency.
| Box2 !Box2Options
| Box2 !( Box2Options n d )
-- | Options for the bisection method.
type BisectionOptions :: Nat -> Nat -> Type
@ -191,15 +196,20 @@ data GaussSeidelOptions n d =
, gsDims :: ( 𝕀 d -> 𝕀 n ) }
-- | Options for the @box(1)@-consistency method.
data Box1Options =
data Box1Options n d =
Box1Options
{ box1EpsEq :: !Double }
{ box1EpsEq :: !Double
, box1CoordsToNarrow :: [ Fin n ]
, box1EqsToUse :: [ Fin d ]
}
-- | Options for the @box(2)@-consistency method.
data Box2Options =
data Box2Options n d =
Box2Options
{ box2EpsEq :: !Double
, box2LambdaMin :: !Double
, box2CoordsToNarrow :: [ Fin n ]
, box2EqsToUse :: [ Fin d ]
}
defaultRootIsolationOptions :: BoxCt n d => RootIsolationOptions n d
@ -236,8 +246,16 @@ defaultRootIsolationAlgorithms minWidth narrowAbs box history
-- Otherwise, do a normal round.
-- Currently: we try an interval GaussSeidel step followed by box(1)-consistency.
_ -> GaussSeidel defaultGaussSeidelOptions
NE.:| [ Box1 ( Box1Options { box1EpsEq = narrowAbs } ) ]
NE.:| [ Box1 box1Options ]
where
box1Options :: Box1Options n d
box1Options =
Box1Options
{ box1EpsEq = narrowAbs
, box1CoordsToNarrow = toList $ universe @n -- [ Fin 1, Fin 2 ]
, box1EqsToUse = toList $ universe @d
}
-- Did we reduce the box width by at least "narrowAbs" in at least one of the dimensions?
sufficientlySmallerThan :: Box n -> Box n -> Bool
b1 `sufficientlySmallerThan` b2 =
@ -247,12 +265,12 @@ defaultRootIsolationAlgorithms minWidth narrowAbs box history
<*> coordinates b2
{-# INLINEABLE defaultRootIsolationAlgorithms #-}
defaultGaussSeidelOptions :: GaussSeidelOptions 2 3
defaultGaussSeidelOptions :: GaussSeidelOptions N 3
defaultGaussSeidelOptions =
GaussSeidelOptions
{ gsPreconditioner = InverseMidJacobian
, gsDims = \ ( 𝕀 ( 3 _a_lo b_lo c_lo ) ( 3 _a_hi b_hi c_hi ) )
-> 𝕀 ( 2 b_lo c_lo ) ( 2 b_hi c_hi )
-> 𝕀 ( 2 b_lo c_lo ) ( 2 b_hi c_hi )
}
defaultBisectionOptions
@ -431,10 +449,10 @@ doStrategy roundHistory previousRoundsHistory eqs minWidth algo box =
GaussSeidel gsOptions -> do
boxes <- intervalGaussSeidel gsOptions eqs box
return ( GaussSeidelStep, boxes )
Box1 ( Box1Options { box1EpsEq } ) ->
return ( Box1Step, makeBox1Consistent eqs minWidth box1EpsEq box )
Box2 ( Box2Options { box2LambdaMin, box2EpsEq } ) ->
return ( Box2Step, [ makeBox2Consistent eqs minWidth box2EpsEq box2LambdaMin box ] )
Box1 box1Options ->
return ( Box1Step, makeBox1Consistent minWidth box1Options eqs box )
Box2 box2Options ->
return ( Box2Step, [ makeBox2Consistent minWidth box2Options eqs box ] )
Bisection ( BisectionOptions { canHaveSols, fallbackBisectionDim } ) -> do
let ( boxes, ( whatBis, mid ) ) = bisect ( canHaveSols eqs ) ( fallbackBisectionDim roundHistory previousRoundsHistory eqs ) box
return ( BisectionStep whatBis mid, boxes )
@ -625,23 +643,29 @@ data Preconditioner
-- "Presentation of a highly tuned multithreaded interval solver for underdetermined and well-determined nonlinear systems"
makeBox1Consistent
:: BoxCt n d
=> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> Double -> Double
=> Double -> Box1Options n d
-> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> Box n -> [ Box n ]
makeBox1Consistent eqs minWidth epsEq x =
makeBox1Consistent minWidth box1Options eqs x =
( `State.evalState` False ) $
pipeFunctionsWhileTrue ( allNarrowingOperators epsEq minWidth eqs ) x
pipeFunctionsWhileTrue ( allNarrowingOperators minWidth box1Options eqs ) x
-- | An implementation of "bound-consistency" from the paper
-- "Parallelization of a bound-consistency enforcing procedure and its application in solving nonlinear systems"
makeBox2Consistent
:: forall n d
. BoxCt n d
=> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> Double -> Double -> Double
=> Double
-> Box2Options n d
-> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> Box n -> Box n
makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False ) $ doLoop 0.25 x0
makeBox2Consistent minWidth (Box2Options epsEq lambdaMin coordsToNarrow eqsToUse) eqs x0
= ( `State.evalState` False ) $ doLoop 0.25 x0
where
box1Options :: Box1Options n d
box1Options = Box1Options epsEq coordsToNarrow eqsToUse
doBox1 :: Box n -> [ Box n ]
doBox1 = makeBox1Consistent minWidth box1Options eqs
doLoop :: Double -> Box n -> State Bool ( Box n )
doLoop lambda x = do
x'' <- forEachDim @n x $ \ i ->
@ -660,11 +684,11 @@ makeBox2Consistent eqs minWidth epsEq lambdaMin x0 = ( `State.evalState` False )
c1 = ( 1 - lambda ) * x_inf + lambda * x_sup
c2 = lambda * x_inf + ( 1 - lambda ) * x_sup
x'_inf =
case makeBox1Consistent eqs minWidth epsEq ( setter ( 𝕀 x_inf c1 ) box ) of
case doBox1 ( setter ( 𝕀 x_inf c1 ) box ) of
[] -> c1
x's -> minimum $ map ( inf . getter ) x's
x'_sup =
case makeBox1Consistent eqs minWidth epsEq ( setter ( 𝕀 c2 x_sup ) box ) of
case doBox1 ( setter ( 𝕀 c2 x_sup ) box ) of
[] -> c2
x's -> maximum $ map ( sup . getter ) x's
x' = 𝕀 x'_inf x'_sup
@ -832,10 +856,10 @@ allNarrowingOperators
:: forall n d
. BoxCt n d
=> Double
-> Double
-> Box1Options n d
-> ( 𝕀 n -> D 1 ( 𝕀 n ) ( 𝕀 d ) )
-> [ Box n -> State Bool [ Box n ] ]
allNarrowingOperators eps_eq eps_bis eqs =
allNarrowingOperators eps_bis ( Box1Options eps_eq coordsToNarrow eqsToUse ) eqs =
[ \ cand ->
let getter = ( `index` coordIndex )
setter = set coordIndex
@ -848,8 +872,8 @@ allNarrowingOperators eps_eq eps_bis eqs =
| narrowFn <- [ leftNarrow, rightNarrow ]
, ( coordIndex, fn ) <-
[ ( i, ff' i d )
| i <- toList $ universe @n
, d <- toList $ universe @d
| i <- coordsToNarrow
, d <- eqsToUse
]
]
where

View file

@ -73,13 +73,16 @@ import Control.Monad.Trans.Reader
( runReaderT )
-- MetaBrush
import Math.Root.Isolation
( RootIsolationOptions(..), defaultRootIsolationOptions
, N
)
import Math.Bezier.Cubic.Fit
( FitParameters(..) )
import Math.Bezier.Spline
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
import Math.Bezier.Stroke
( RootSolvingAlgorithm(..)
, CuspFindingOptions(..), Preconditioner(..)
, invalidateCache
)
import Math.Linear
@ -172,9 +175,9 @@ runApplication application = do
Spline
{ splineStart = mkPoint ( 2 0 0 ) 10 25 0
, splineCurves = OpenCurves $ Seq.fromList
[ LineTo { curveEnd = NextPoint ( mkPoint ( 2 100 0 ) 15 40 (0.1 * pi) ), curveData = invalidateCache undefined }
--, LineTo { curveEnd = NextPoint ( mkPoint ( 2 -10 10 ) 8 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
--, LineTo { curveEnd = NextPoint ( mkPoint ( 2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
[ LineTo { curveEnd = NextPoint ( mkPoint ( 2 100 0 ) 15 40 0 ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( 2 -10 10 ) 8 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( 2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
]
}
}
@ -215,8 +218,8 @@ runApplication application = do
--HalleyM2
NewtonRaphson
{ maxIters = 20, precision = 8 }
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe CuspFindingOptions ) $
Just defaultCuspFindingOptions
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions N 3 ) ) $
Just defaultRootIsolationOptions
-- Put all these stateful variables in a record for conciseness.
let

View file

@ -19,8 +19,6 @@ import Data.Functor.Compose
( Compose(..) )
import Data.Int
( Int32 )
import GHC.Exts
( proxy# )
import GHC.Generics
( Generic, Generic1, Generically1(..) )
@ -56,6 +54,8 @@ import Control.Monad.Trans.State.Strict
( StateT, evalStateT, get, put )
-- MetaBrush
import Calligraphy.Brushes
( Brush(..) )
import Math.Algebra.Dual
( D2𝔸1(..), fun )
import qualified Math.Bezier.Cubic as Cubic
@ -74,16 +74,20 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke
( Cusp(..), CachedStroke(..), invalidateCache
, computeStrokeOutline
, RootSolvingAlgorithm, CuspFindingOptions
, RootSolvingAlgorithm
)
import Math.Linear
( (..), T(..) )
( (..), T(..)
, rotate
)
import Math.Module
( Module((*^)), normalise )
import Math.Root.Isolation
( RootIsolationOptions, N )
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Brush
( Brush(..), WithParams(..) )
( NamedBrush(..), WithParams(..) )
import MetaBrush.Context
( Modifier(..)
, HoldAction(..), PartialPath(..)
@ -149,7 +153,7 @@ blankRender _ = pure ()
getDocumentRender
:: Colours
-> RootSolvingAlgorithm -> Maybe CuspFindingOptions -> FitParameters
-> RootSolvingAlgorithm -> Maybe ( RootIsolationOptions N 3 ) -> FitParameters
-> Mode -> Bool
-> Set Modifier -> Maybe ( 2 ) -> Maybe HoldAction -> Maybe PartialPath
-> Document
@ -285,22 +289,22 @@ instance NFData StrokeRenderData where
-- - Otherwise, this consists of the underlying spline path only.
strokeRenderData
:: RootSolvingAlgorithm
-> Maybe CuspFindingOptions
-> Maybe ( RootIsolationOptions N 3 )
-> FitParameters
-> Stroke
-> Maybe ( ST RealWorld StrokeRenderData )
strokeRenderData rootAlgo mbCuspOptions fitParams
( Stroke
{ strokeSpline = spline :: StrokeSpline clo ( Record pointFields )
, strokeBrush = ( strokeBrush :: Maybe ( Brush brushFields ) )
, strokeBrush = ( strokeBrush :: Maybe ( NamedBrush brushFields ) )
, ..
}
) | strokeVisible
= Just $ case strokeBrush of
Just ( BrushData { brushFunction = fn } )
Just ( NamedBrush { brushFunction = fn } )
| WithParams
{ defaultParams = brush_defaults
, withParams = brushFn
, withParams = brush@( Brush { brushShape, mbRotation = mbRot } )
} <- fn
-> -- This is the key place where we need to perform impedance matching
-- between the collection of parameters supplied along a stroke and
@ -315,15 +319,26 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
-- Compute the outline using the brush function.
( outline, fitPts, cusps ) <-
computeStrokeOutline @clo rootAlgo mbCuspOptions fitParams
( toUsedParams . brushParams ) embedUsedParams brushFn
spline
( toUsedParams . brushParams ) embedUsedParams
brush spline
pure $
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts, cusps )
, strokeBrushFunction = fun @Double ( brushFn @2 @() proxy# id )
. embedUsedParams
. toUsedParams
, strokeBrushFunction =
\ params ->
let brushParams = embedUsedParams $ toUsedParams params
shape = fun @Double brushShape brushParams
-- TODO: remove this logic which is duplicated
-- from elsewhere. The type should make it
-- impossible to forget to apply the rotation.
in case mbRot of
Nothing -> shape
Just getθ ->
let θ = getθ brushParams
cosθ = cos θ
sinθ = sin θ
in fmap ( unT . rotate cosθ sinθ . T ) shape
}
_ -> pure $
StrokeRenderData

View file

@ -15,6 +15,8 @@ module MetaBrush.Asset.Brushes
import Prelude
hiding
( Num(..), Floating(..), (^), (/), fromInteger, fromRational )
import Data.Coerce
( coerce )
import GHC.Exts
( fromString )
@ -30,12 +32,13 @@ import qualified Data.HashMap.Strict as HashMap
-- brush-strokes
import Calligraphy.Brushes
( circleBrush, ellipseBrush, tearDropBrush )
import Math.Linear
import Math.Ring
-- MetaBrush
import MetaBrush.Brush
( Brush(..), SomeBrush(..), WithParams(..) )
( NamedBrush(..), SomeBrush(..), WithParams(..) )
import MetaBrush.Records
( Record(MkR) )
@ -48,7 +51,7 @@ lookupBrush nm = HashMap.lookup nm brushes
brushes :: HashMap Text SomeBrush
brushes = HashMap.fromList
[ ( nm, b )
| b@( SomeBrush ( BrushData { brushName = nm } ) )
| b@( SomeBrush ( NamedBrush { brushName = nm } ) )
<- [ SomeBrush circle, SomeBrush ellipse, SomeBrush tearDrop ]
]
@ -56,8 +59,8 @@ brushes = HashMap.fromList
type CircleBrushFields = '[ "r" ]
-- | A circular brush with the given radius.
circle :: Brush CircleBrushFields
circle = BrushData "circle" ( WithParams deflts circleBrush )
circle :: NamedBrush CircleBrushFields
circle = NamedBrush "circle" ( WithParams deflts $ coerce circleBrush )
where
deflts :: Record CircleBrushFields
deflts = MkR ( 1 1 )
@ -66,8 +69,8 @@ circle = BrushData "circle" ( WithParams deflts circleBrush )
type EllipseBrushFields = '[ "a", "b", "phi" ]
-- | An elliptical brush with the given semi-major and semi-minor axes and
-- angle of rotation.
ellipse :: Brush EllipseBrushFields
ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
ellipse :: NamedBrush EllipseBrushFields
ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush )
where
deflts :: Record EllipseBrushFields
deflts = MkR ( 3 1 1 0 )
@ -75,8 +78,8 @@ ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
type TearDropBrushFields = '[ "w", "h", "phi" ]
-- | A tear-drop shape with the given width, height and angle of rotation.
tearDrop :: Brush TearDropBrushFields
tearDrop = BrushData "tear-drop" ( WithParams deflts tearDropBrush )
tearDrop :: NamedBrush TearDropBrushFields
tearDrop = NamedBrush "tear-drop" ( WithParams deflts $ coerce tearDropBrush )
where
deflts :: Record TearDropBrushFields
deflts = MkR ( 3 1 2.25 0 )

View file

@ -6,7 +6,7 @@
module MetaBrush.Brush
( WithParams(..)
, Brush(..), SomeBrush(..), BrushFunction
, NamedBrush(..), SomeBrush(..), BrushFunction
, PointFields, provePointFields, duplicates
)
where
@ -39,16 +39,18 @@ import Data.Text
import qualified Data.Text as Text
( unpack )
-- MetaBrush
import Math.Algebra.Dual
( C )
-- brush-strokes
import Calligraphy.Brushes
( Brush(..) )
import Math.Bezier.Spline
( SplineType(Closed), Spline )
import Math.Differentiable
( DiffInterp, I )
( DiffInterp )
import Math.Interval
( 𝕀 )
import Math.Linear
-- MetaBrush
import MetaBrush.Records
( KnownSymbols, Length, Record )
import MetaBrush.Serialisable
@ -56,18 +58,12 @@ import MetaBrush.Serialisable
--------------------------------------------------------------------------------
-- | A differentiable function from a given record type,
-- with provided default values that can be overridden.
type WithParams :: Type -> ( Type -> Type ) -> Type
data WithParams params f =
-- | A brush, with default parameter values.
type WithParams :: Type -> Type
data WithParams params =
WithParams
{ defaultParams :: params
, withParams
:: forall {t} k (i :: t)
. ( DiffInterp k i params )
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k ( I i params ) ( f ( I i ( 2 ) ) )
, withParams :: Brush params
}
--------------------------------------------------------------------------------
@ -75,11 +71,11 @@ data WithParams params f =
-- | A brush function: a function from a record of parameters to a closed spline.
type BrushFunction :: [ Symbol ] -> Type
type BrushFunction brushFields =
WithParams ( Record brushFields ) ( Spline Closed () )
WithParams ( Record brushFields )
type Brush :: [ Symbol ] -> Type
data Brush brushFields where
BrushData
type NamedBrush :: [ Symbol ] -> Type
data NamedBrush brushFields where
NamedBrush
:: forall brushFields
. ( KnownSymbols brushFields, Typeable brushFields
, Representable Double ( ( Length brushFields ) )
@ -89,28 +85,28 @@ data Brush brushFields where
=> { brushName :: !Text
, brushFunction :: BrushFunction brushFields
}
-> Brush brushFields
-> NamedBrush brushFields
data SomeBrush where
SomeBrush
:: { someBrush :: !( Brush brushFields ) }
:: { someBrush :: !( NamedBrush brushFields ) }
-> SomeBrush
instance Show ( Brush brushFields ) where
show ( BrushData { brushName } ) =
"BrushData\n\
instance Show ( NamedBrush brushFields ) where
show ( NamedBrush { brushName } ) =
"NamedBrush\n\
\ { brushName = " <> Text.unpack brushName <> "\n\
\ }"
instance NFData ( Brush brushFields ) where
rnf ( BrushData { brushName } )
instance NFData ( NamedBrush brushFields ) where
rnf ( NamedBrush { brushName } )
= rnf brushName
instance Eq ( Brush brushFields ) where
BrushData name1 _ == BrushData name2 _ = name1 == name2
instance Ord ( Brush brushFields ) where
compare ( BrushData name1 _ ) ( BrushData name2 _ ) = compare name1 name2
instance Hashable ( Brush brushFields ) where
hashWithSalt salt ( BrushData { brushName } ) =
instance Eq ( NamedBrush brushFields ) where
NamedBrush name1 _ == NamedBrush name2 _ = name1 == name2
instance Ord ( NamedBrush brushFields ) where
compare ( NamedBrush name1 _ ) ( NamedBrush name2 _ ) = compare name1 name2
instance Hashable ( NamedBrush brushFields ) where
hashWithSalt salt ( NamedBrush { brushName } ) =
hashWithSalt salt brushName
type PointFields :: [ Symbol ] -> Constraint
@ -153,6 +149,12 @@ provePointFields fieldNames k =
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
, SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
-> k ( proxy# @'[ f1, f2, f3 ] )
[ f1, f2, f3, f4 ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
, SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
, SomeSymbol @f4 _ <- someSymbolVal ( Text.unpack f4 )
-> k ( proxy# @'[ f1, f2, f3, f4 ] )
_ -> error $ "I haven't defined " ++ show ( length fieldNames )
{-# INLINE provePointFields #-}

View file

@ -89,7 +89,7 @@ import Math.Module
import Math.Linear
( (..), T(..) )
import MetaBrush.Brush
( Brush, PointFields )
( NamedBrush, PointFields )
import MetaBrush.Records
import MetaBrush.Unique
( UniqueSupply, Unique, freshUnique )
@ -174,7 +174,7 @@ data Stroke where
{ strokeName :: !Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
, strokeBrush :: !( Maybe ( Brush brushFields ) )
, strokeBrush :: !( Maybe ( NamedBrush brushFields ) )
, strokeSpline :: !( StrokeSpline clo pointParams )
}
-> Stroke

View file

@ -63,7 +63,7 @@ import Math.Linear
import MetaBrush.Assert
( assert )
import MetaBrush.Brush
( Brush(..), PointFields )
( NamedBrush(..), PointFields )
import MetaBrush.Document
( Document(..), DocumentContent(..)
, Stroke(..), StrokeHierarchy(..), StrokeSpline
@ -123,7 +123,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
, strokeVisible = True
, strokeUnique = uniq
, strokeSpline = newSpline
, strokeBrush = Nothing :: Maybe ( Brush ( '[] :: [ Symbol ] ) )
, strokeBrush = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) )
}
newDoc' :: Document
newDoc'
@ -234,7 +234,7 @@ withAnchorBrushData
. ( pointParams ~ Record pointFields
, PointFields pointFields
)
=> Maybe ( Brush brushFields )
=> Maybe ( NamedBrush brushFields )
-> pointParams
-> r
)

View file

@ -110,7 +110,7 @@ import Math.Linear
import MetaBrush.Asset.Brushes
( lookupBrush )
import MetaBrush.Brush
( Brush(..), SomeBrush(..), provePointFields, duplicates )
( NamedBrush(..), SomeBrush(..), provePointFields, duplicates )
import MetaBrush.Document
( Document(..), DocumentContent(..), Guide(..)
, Stroke(..), StrokeHierarchy(..), StrokeSpline
@ -223,9 +223,9 @@ decodeFields = do
dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups )
encodeBrush :: Applicative f => JSON.Encoder f (Brush brushFields)
encodeBrush :: Applicative f => JSON.Encoder f (NamedBrush brushFields)
encodeBrush = JSON.Encoder.mapLikeObj
\ ( BrushData { brushName } ) ->
\ ( NamedBrush { brushName } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
decodeBrush :: MonadIO m => JSON.Decoder m SomeBrush
@ -277,14 +277,14 @@ decodeStroke uniqueSupply = do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
else do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }

View file

@ -25,7 +25,7 @@ import GHC.TypeLits
, SomeSymbol(..), someSymbolVal
)
import GHC.TypeNats
( Nat, type (+) )
( Nat, KnownNat, type (+) )
import Unsafe.Coerce
( unsafeCoerce )
@ -139,7 +139,8 @@ instance ( Torsor ( T ( 𝕀 ( Length ks ) ) ) ( 𝕀 ( Length ks ) )
T ( 𝕀 ( MkR c_lo ) ( MkR c_hi ) )
type instance RepDim ( Record ks ) = Length ks
deriving newtype instance Representable r ( ( Length ks ) )
deriving newtype instance ( KnownNat (Length ks)
, Representable r ( ( Length ks ) ) )
=> Representable r ( Record ks )
type instance D k ( Record ks ) = D k ( ( Length ks ) )
@ -238,16 +239,16 @@ doIntersection k =
| ( _ :: Proxy# r1r2 ) <- proxy# @'[ ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
VZ
VZ
( Vec [] )
( Vec [] )
[ ( f1, r1_i1, r2_i1 ) ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1 ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
( VS ( Fin r1_i1 ) VZ )
( VS ( Fin r2_i1 ) VZ )
( Vec [ Fin r1_i1 ] )
( Vec [ Fin r2_i1 ] )
[ ( f1, r1_i1, r2_i1 )
, ( f2, r1_i2, r2_i2 ) ]
@ -256,8 +257,8 @@ doIntersection k =
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2 ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
( VS ( Fin r1_i1 ) $ VS ( Fin r1_i2 ) VZ )
( VS ( Fin r2_i1 ) $ VS ( Fin r2_i2 ) VZ )
( Vec [ Fin r1_i1, Fin r1_i2 ] )
( Vec [ Fin r2_i1, Fin r2_i2 ] )
[ ( f1, r1_i1, r2_i1 )
, ( f2, r1_i2, r2_i2 )
@ -268,8 +269,8 @@ doIntersection k =
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3 ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
( VS ( Fin r1_i1 ) $ VS ( Fin r1_i2 ) $ VS ( Fin r1_i3 ) VZ )
( VS ( Fin r2_i1 ) $ VS ( Fin r2_i2 ) $ VS ( Fin r2_i3 ) VZ )
( Vec [ Fin r1_i1, Fin r1_i2, Fin r1_i3 ] )
( Vec [ Fin r2_i1, Fin r2_i2, Fin r2_i3 ] )
[ ( f1, r1_i1, r2_i1 )
, ( f2, r1_i2, r2_i2 )
@ -282,8 +283,8 @@ doIntersection k =
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3, f4 ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
( VS ( Fin r1_i1 ) $ VS ( Fin r1_i2 ) $ VS ( Fin r1_i3 ) $ VS ( Fin r1_i4 ) VZ )
( VS ( Fin r2_i1 ) $ VS ( Fin r2_i2 ) $ VS ( Fin r2_i3 ) $ VS ( Fin r2_i4 ) VZ )
( Vec [ Fin r1_i1, Fin r1_i2, Fin r1_i3, Fin r1_i4 ] )
( Vec [ Fin r2_i1, Fin r2_i2, Fin r2_i3, Fin r2_i4 ] )
other -> error $ "Intersection not defined in dimension " ++ show ( length other )