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

Improve intervallic rotation computations

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

33
brush-strokes/src/cusps/bench/Main.hs
View file

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

1
brush-strokes/src/cusps/inspect/Main.hs
View file

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

201
brush-strokes/src/lib/Calligraphy/Brushes.hs
View file

@ -6,7 +6,8 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Calligraphy.Brushes module Calligraphy.Brushes
( circleBrush ( BrushFn, Brush(..)
, circleBrush
, ellipseBrush , ellipseBrush
, tearDropBrush , tearDropBrush
) where ) where
@ -15,10 +16,12 @@ module Calligraphy.Brushes
import Prelude import Prelude
hiding hiding
( Num(..), Floating(..), (^), (/), fromInteger, fromRational ) ( Num(..), Floating(..), (^), (/), fromInteger, fromRational )
import Data.Kind
( Type )
import GHC.Exts import GHC.Exts
( Proxy# ) ( Proxy#, proxy# )
import GHC.TypeNats import GHC.TypeNats
( type (<=) ) ( Nat, type (<=) )
-- containers -- containers
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -29,11 +32,71 @@ import Math.Algebra.Dual
import Math.Bezier.Spline import Math.Bezier.Spline
import Math.Differentiable import Math.Differentiable
( I ) ( I )
import Math.Interval
( 𝕀, singleton )
import Math.Linear import Math.Linear
import Math.Module import Math.Module
( Module((^+^), (*^)) ) ( Module((^+^), (*^)) )
import Math.Ring 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 -- Circle & ellipse
@ -60,93 +123,55 @@ circleSpline p = sequenceA $
Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart () Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart ()
{-# INLINE circleSpline #-} {-# INLINE circleSpline #-}
circleBrush :: forall {t} (i :: t) k irec circleBrushFn :: forall {t} (i :: t) k rec
. ( 1 <= RepDim irec . ( 1 <= RepDim ( I i rec )
, Module , ParamsICt k i rec
( D k irec ( I i Double ) ) )
( D k irec ( I i ( ℝ 2 ) ) ) => Proxy# i
, Module ( I i Double ) ( T ( I i Double ) ) -> ( forall a. a -> I i a )
, HasChainRule ( I i Double ) k irec -> C k ( I i rec ) ( Spline 'Closed () ( I i ( ℝ 2 ) ) )
, Representable ( I i Double ) irec circleBrushFn _ mkI =
, Applicative ( D k irec )
)
=> Proxy# i
-> ( forall a. a -> I i a )
-> C k irec ( Spline 'Closed () ( I i ( ℝ 2 ) ) )
circleBrush _ mkI =
D \ params -> 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 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 mkPt x y
= ( r `scaledBy` x ) *^ e_x = ( r `scaledBy` x ) *^ e_x
^+^ ( r `scaledBy` y ) *^ e_y ^+^ ( r `scaledBy` y ) *^ e_y
in circleSpline mkPt in circleSpline mkPt
where 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_x = pure $ mkI $ ℝ2 1 0
e_y = pure $ mkI $ ℝ2 0 1 e_y = pure $ mkI $ ℝ2 0 1
scaledBy d x = fmap ( mkI x * ) d scaledBy d x = fmap ( mkI x * ) d
{-# INLINEABLE circleBrush #-} {-# INLINEABLE circleBrushFn #-}
ellipseBrush :: forall {t} (i :: t) k irec ellipseBrushFn :: forall {t} (i :: t) k rec
. ( 3 <= RepDim irec . ( 3 <= RepDim ( I i rec )
, Module , ParamsICt k i rec
( D k irec ( I i Double ) ) )
( D k irec ( I i ( ℝ 2 ) ) ) => Proxy# i
, Module ( I i Double ) ( T ( I i Double ) ) -> ( forall a. a -> I i a )
, HasChainRule ( I i Double ) k irec -> C k ( I i rec ) ( Spline 'Closed () ( I i ( ℝ 2 ) ) )
, Representable ( I i Double ) irec ellipseBrushFn _ mkI =
, 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 -> D \ params ->
let a, b, phi :: D k irec ( I i Double ) let a, b :: D k ( I i rec ) ( I i Double )
a = runD ( var @_ @k $ Fin 1 ) params a = runD ( var @_ @k $ Fin 1 ) params
b = runD ( var @_ @k $ Fin 2 ) params b = runD ( var @_ @k $ Fin 2 ) params
phi = runD ( var @_ @k $ Fin 3 ) params mkPt :: Double -> Double -> D k ( I i rec ) ( I i ( ℝ 2 ) )
mkPt :: Double -> Double -> D k irec ( I i ( ℝ 2 ) )
mkPt x y mkPt x y
= let !x' = a `scaledBy` x = let !x' = a `scaledBy` x
!y' = b `scaledBy` y !y' = b `scaledBy` y
-- {- in x' *^ e_x ^+^ y' *^ e_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 circleSpline mkPt in circleSpline mkPt
where 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_x = pure $ mkI $ ℝ2 1 0
e_y = pure $ mkI $ ℝ2 0 1 e_y = pure $ mkI $ ℝ2 0 1
scaledBy d x = fmap ( mkI x * ) d scaledBy d x = fmap ( mkI x * ) d
{-# INLINEABLE ellipseBrush #-} {-# INLINEABLE ellipseBrushFn #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Tear drop -- Tear drop
@ -168,27 +193,19 @@ tearHeight = 3 * sqrt 3 / 8
sqrt3_over_2 :: Double sqrt3_over_2 :: Double
sqrt3_over_2 = 0.5 * sqrt 3 sqrt3_over_2 = 0.5 * sqrt 3
tearDropBrush :: forall {t} (i :: t) k irec tearDropBrushFn :: forall {t} (i :: t) k rec
. ( Module . ( 3 <= RepDim ( I i rec )
( D k irec ( I i Double ) ) , ParamsICt k i rec
( D k irec ( I i ( ℝ 2 ) ) ) )
, Module ( I i Double ) ( T ( I i Double ) ) => Proxy# i
, HasChainRule ( I i Double ) k irec -> ( forall a. a -> I i a )
, Representable ( I i Double ) irec -> C k ( I i rec ) ( Spline 'Closed () ( I i ( ℝ 2 ) ) )
, Applicative ( D k irec ) tearDropBrushFn _ mkI =
, 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 =
D \ params -> D \ params ->
let w, h, phi :: D k irec ( I i Double ) let w, h :: D k ( I i rec ) ( I i Double )
w = runD ( var @_ @k ( Fin 1 ) ) params w = runD ( var @_ @k ( Fin 1 ) ) params
h = runD ( var @_ @k ( Fin 2 ) ) params h = runD ( var @_ @k ( Fin 2 ) ) params
phi = runD ( var @_ @k ( Fin 3 ) ) params mkPt :: Double -> Double -> D k ( I i rec ) ( I i ( ℝ 2 ) )
mkPt :: Double -> Double -> D k irec ( I i ( ℝ 2 ) )
mkPt x y mkPt x y
-- 1. translate the teardrop so that the center of mass is at the origin -- 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 -- 2. scale the teardrop so that it has the requested width/height
@ -196,8 +213,8 @@ tearDropBrush _ mkI =
= let !x' = w `scaledBy` (x / tearWidth) = let !x' = w `scaledBy` (x / tearWidth)
!y' = ( h `scaledBy` ( ( y - tearCenter ) / tearHeight) ) !y' = ( h `scaledBy` ( ( y - tearCenter ) / tearHeight) )
in in
( x' * cos phi - y' * sin phi ) *^ e_x x' *^ e_x
^+^ ( y' * cos phi + x' * sin phi ) *^ e_y ^+^ y' *^ e_y
in sequenceA $ in sequenceA $
Spline { splineStart = mkPt 0 0 Spline { splineStart = mkPt 0 0
@ -207,9 +224,9 @@ tearDropBrush _ mkI =
( mkPt -0.5 sqrt3_over_2 ) ( mkPt -0.5 sqrt3_over_2 )
BackToStart () } BackToStart () }
where 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_x = pure $ mkI $ ℝ2 1 0
e_y = pure $ mkI $ ℝ2 0 1 e_y = pure $ mkI $ ℝ2 0 1
scaledBy d x = fmap ( mkI x * ) d scaledBy d x = fmap ( mkI x * ) d
{-# INLINEABLE tearDropBrush #-} {-# INLINEABLE tearDropBrushFn #-}

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

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

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

@ -10,11 +10,13 @@ module Math.Bezier.Stroke.EnvelopeEquation
) where ) where
-- base -- base
import Prelude hiding ( Num(..), (^) ) import Prelude hiding ( Num(..), (^), pi, sin, cos )
import Data.Kind import Data.Kind
( Type, Constraint ) ( Type, Constraint )
import Data.List.NonEmpty import Data.List.NonEmpty
( NonEmpty(..) ) ( NonEmpty(..) )
import Data.Proxy
( Proxy(..) )
import GHC.TypeNats import GHC.TypeNats
( Nat, type (-) ) ( Nat, type (-) )
@ -37,20 +39,26 @@ import Math.Ring
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | The value and derivative of a brush stroke at a given coordinate -- | 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. -- point.
type StrokeDatum :: Nat -> k -> Type type StrokeDatum :: Nat -> k -> Type
data StrokeDatum k i data StrokeDatum k i
= StrokeDatum = StrokeDatum
{ -- | Path \( p(t_0) \). { -- | Path \( p(t) \).
dpath :: D k ( I i ( ℝ 1 ) ) ( I i ( ℝ 2 ) ) 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 ) ) , 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) \). -- | Stroke shape \( c(t,s) = p(t) + R(\theta(t)) b(t,s) \).
, dstroke :: D k ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) ) , 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 -- | Envelope function
-- --
@ -108,19 +116,6 @@ class HasEnvelopeEquation k where
uncurryD :: D k a ~ D k ( ℝ 1 ) uncurryD :: D k a ~ D k ( ℝ 1 )
=> D k ( ℝ 1 ) ( C k a b ) -> a -> D k ( ℝ 2 ) b => 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 -- | The envelope function
-- --
-- \[ E = \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s}, \] -- \[ 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 - 2 ) ( I i ( ℝ 2 ) ) ~ D ( k - 2 ) ( ℝ 2 )
, D ( k - 1 ) ( I i ( ℝ 2 ) ) ~ D ( k - 1 ) ( ℝ 2 ) , D ( k - 1 ) ( I i ( ℝ 2 ) ) ~ D ( k - 1 ) ( ℝ 2 )
, D k ( I i ( ℝ 2 ) ) ~ D k ( ℝ 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 ) ) ) , 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 ( I i ( ℝ 2 ) ) ( I i ( ℝ 2 ) )
-> ( D ( k - 1 ) ( I i ( ℝ 2 ) ) ( I i ( ℝ 1 ) ) -> Maybe ( D k ( I i ( ℝ 1 ) ) ( I i Double ) )
, D ( k - 2 ) ( I i ( ℝ 2 ) ) ( T ( I i ( ℝ 2 ) ) ) ) -> StrokeDatum k i
instance HasBézier 2 () where instance HasBézier 2 () where
line co ( Segment a b :: Segment b ) = line co ( Segment a b :: Segment b ) =
@ -166,34 +168,85 @@ instance HasEnvelopeEquation 2 where
uncurryD = uncurryD2 uncurryD = uncurryD2
brushStroke ( D21 p p_t p_tt ) ( D22 b b_t b_s b_tt b_ts b_ss ) = envelopeEquation ( _ :: Proxy i ) co
D22 ( unT $ T p ^+^ T b ) dp@( D21 ( T -> p ) p_t p_tt )
-- c = p + b 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 𝛿E𝛿sdcdt_val = ee_s *^ u ^-^ ee_t *^ v
-- ∂c/∂t = dp/dt + ∂b/∂t in ( D12
-- ∂c/∂s = ∂b/∂s ( 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 u, v, u_t, u_s, v_t, v_s :: T ( I i ( ℝ 2 ) )
-- ∂²c/∂t² = d²p/dt² + ∂²b/∂t² u = rot p_t ^+^ θ_t *^ swap b ^+^ b_t
-- ∂²c/∂t∂s = ∂²b/∂t∂s v = b_s
-- ∂²c/∂s² = ∂²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 ) = in ( unT $ p ^+^ rotate cosθ sinθ b
let ee = c_t × c_s , D12 ( unT u ) u_t u_s
ee_t = c_tt × c_s + c_t × c_ts , D12 ( unT v ) v_t v_s
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.
instance HasBézier 3 () where instance HasBézier 3 () where
@ -222,42 +275,123 @@ instance HasEnvelopeEquation 3 where
uncurryD = uncurryD3 uncurryD = uncurryD3
brushStroke envelopeEquation ( _ :: Proxy i ) co
( D31 p p_t p_tt p_ttt ) dp@( D31 ( T -> 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 ) = db@( D32 ( T -> b ) b_t b_s
D32 b_tt b_ts b_ss
( unT $ T p ^+^ T b ) b_ttt b_tts b_tss b_sss )
( p_t ^+^ b_t ) b_s mbRotation =
( p_tt ^+^ b_tt ) b_ts b_ss StrokeDatum
( p_ttt ^+^ b_ttt ) b_tts b_tss b_sss { 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 𝛿E𝛿sdcdt_val = ee_s *^ u ^-^ ee_t *^ v
( D32 _ c_t c_s 𝛿E𝛿sdcdt_t = ee_ts *^ u ^+^ ee_s *^ u_t
c_tt c_ts c_ss ^-^ ( ee_tt *^ v ^+^ ee_t *^ v_t )
c_ttt c_tts c_tss c_sss ) 𝛿E𝛿sdcdt_s = ee_ss *^ u ^+^ ee_s *^ u_s
= let ee = c_t × c_s ^-^ ( ee_ts *^ v ^+^ ee_t *^ v_s )
ee_t = c_tt × c_s + c_t × c_ts in ( D22
ee_s = c_ts × c_s + c_t × c_ss ( co ee_val )
ee_tt = c_ttt × c_s ( T $ co ee_t ) ( T $ co ee_s )
+ c_tt × c_ts * 2 ( T $ co ee_tt) ( T $ co ee_ts ) ( T $ co ee_ss )
+ c_t × c_tts , D12 𝛿E𝛿sdcdt_val ( T 𝛿E𝛿sdcdt_t ) ( T 𝛿E𝛿sdcdt_s )
ee_ts = c_tts × c_s )
+ c_tt × c_ss (c, du, dv) = case mbRotation of
-- + c_ts × c_ts -- cancels out Nothing ->
+ c_t × c_tss -- c(t,s) = p(t) + b(t,s)
ee_ss = c_tss × c_s ( unT $ p ^+^ b
+ c_ts × c_ss * 2 , D22 ( unT $ p_t ^+^ b_t )
+ c_t × c_sss ( p_tt ^+^ b_tt ) b_ts
𝛿E𝛿sdcdt = ee_s *^ c_t ^-^ ee_t *^ c_s ( p_ttt ^+^ b_ttt ) b_tts b_tss
𝛿E𝛿sdcdt_t = ee_ts *^ c_t ^+^ ee_s *^ c_tt , D22 ( unT $ b_s )
^-^ ( ee_tt *^ c_s ^+^ ee_t *^ c_ts ) b_ts b_ss
𝛿E𝛿sdcdt_s = ee_ss *^ c_t ^+^ ee_s *^ c_ts b_tts b_tss b_sss
^-^ ( ee_ts *^ c_s ^+^ ee_t *^ c_ss ) )
in ( D22 Just ( D31 θ ( T θ_t ) ( T θ_tt ) ( T θ_ttt ) ) ->
( co ee ) -- c(t,s) = p(t) + R(θ(t)) b(t,s)
( T $ co ee_t ) ( T $ co ee_s ) -- E = ∂c/∂t × ∂c/ds
( T $ co ee_tt) ( T $ co ee_ts ) ( T $ co ee_ss ) -- = ( R(-θ(t)) ∂c/∂t ) × ( R(-θ(t)) ∂c/ds )
, D12 𝛿E𝛿sdcdt ( T 𝛿E𝛿sdcdt_t ) ( T 𝛿E𝛿sdcdt_s ) ) -- = ( 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 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] 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 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 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) maxs = fmap (Quadratic.bezier @( T Double ) sup_bez)
$ inf t :| ( sup t : filter ( `inside` t ) ( Quadratic.extrema sup_bez ) ) $ inf t :| ( sup t : filter ( `inside` t ) ( Quadratic.extrema sup_bez ) )
in 𝕀 ( minimum mins ) ( maximum maxs ) 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 )
-}

22
brush-strokes/src/lib/Math/Linear.hs
View file

@ -15,6 +15,8 @@ module Math.Linear
, Representable(..), set, injection, projection , Representable(..), set, injection, projection
, Vec(..), (!), find, zipIndices , Vec(..), (!), find, zipIndices
, rotate
) where ) where
-- base -- base
@ -52,6 +54,9 @@ import Data.Group.Generics
-- brush-strokes -- brush-strokes
import Math.Linear.Internal 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_ :: Word -> [ a ] -> [ ( Fin n, a ) ]
zipIndices_ _ [] = [] zipIndices_ _ [] = []
zipIndices_ i (a : as) = ( Fin i, a ) : zipIndices_ ( i + 1 ) as 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 #-}

6
brush-strokes/src/lib/Math/Linear/Internal.hs
View file

@ -45,15 +45,15 @@ data instance ℝ 0 = ℝ0
newtype instance ℝ 1 = ℝ1 { unℝ1 :: Double } newtype instance ℝ 1 = ℝ1 { unℝ1 :: Double }
deriving stock ( Generic ) deriving stock ( Generic )
deriving newtype ( Eq, Ord, NFData ) 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 stock Generic
deriving anyclass NFData deriving anyclass NFData
deriving stock ( Eq, Ord ) 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 stock Generic
deriving anyclass NFData deriving anyclass NFData
deriving stock ( Eq, Ord ) 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 stock Generic
deriving anyclass NFData deriving anyclass NFData
deriving stock ( Eq, Ord ) deriving stock ( Eq, Ord )

76
brush-strokes/src/lib/Math/Root/Isolation.hs
View file

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

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

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

45
src/app/MetaBrush/Render/Document.hs
View file

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

19
src/metabrushes/MetaBrush/Asset/Brushes.hs
View file

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

66
src/metabrushes/MetaBrush/Brush.hs
View file

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

4
src/metabrushes/MetaBrush/Document.hs
View file

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

6
src/metabrushes/MetaBrush/Document/Draw.hs
View file

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

10
src/metabrushes/MetaBrush/Document/Serialise.hs
View file

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

25
src/metabrushes/MetaBrush/Records.hs
View file

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