diff --git a/brush-strokes/src/lib/Calligraphy/Brushes.hs b/brush-strokes/src/lib/Calligraphy/Brushes.hs index 38f2fbb..2ccd40c 100644 --- a/brush-strokes/src/lib/Calligraphy/Brushes.hs +++ b/brush-strokes/src/lib/Calligraphy/Brushes.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} module Calligraphy.Brushes - ( BrushFn, Brush(..) + ( BrushFn, Brush(..), Corner(..) , circleBrush , ellipseBrush , tearDropBrush @@ -21,19 +22,25 @@ import Data.Kind import GHC.Exts ( Proxy#, proxy# ) import GHC.TypeNats - ( Nat, type (<=) ) + ( Nat ) + +-- acts +import Data.Act + ( Torsor((-->)) ) -- containers +import Data.Sequence + ( Seq ) import qualified Data.Sequence as Seq - ( empty, fromList ) + ( empty, fromList, singleton ) -- brush-strokes import Math.Algebra.Dual import Math.Bezier.Spline import Math.Differentiable - ( I ) + ( I, IVness(..), SingIVness (..) ) import Math.Interval - ( 𝕀, singleton, point ) + ( 𝕀ℝ, singleton, point ) import Math.Linear import Math.Module ( Module((^+^), (*^)) ) @@ -42,28 +49,43 @@ import Math.Ring -------------------------------------------------------------------------------- -- | The shape of a brush (before applying any rotation). -type BrushFn :: forall {kd}. kd -> Nat -> Nat -> Type +type BrushFn :: IVness -> Nat -> Nat -> Type type BrushFn i k nbBrushParams = C k ( I i nbBrushParams ) ( Spline Closed () ( I i 2 ) ) +-- | A corner of a brush. +type Corner :: Type -> Type +data Corner a + = Corner + { cornerPoint :: a + , cornerStartTangent, cornerEndTangent :: !( T a ) + } + deriving stock ( Eq, Show, Functor, Foldable, Traversable ) + -- | A brush, described as a base shape + an optional rotation. data Brush nbBrushParams = Brush - { -- | Base brush shape, before applying any rotation (if any). - brushBaseShape :: BrushFn ℝ 2 nbBrushParams - -- | Base brush shape, before applying any rotation (if any). - , brushBaseShapeI :: BrushFn 𝕀 3 nbBrushParams + { -- | Base brush shape, before applying rotation (if any). + brushBaseShape :: BrushFn NonIV 2 nbBrushParams + -- | Base brush shape, before applying rotation (if any). + , brushBaseShapeI :: BrushFn IsIV 3 nbBrushParams + + -- | Brush corners, before applying rotation (if any). + , brushCorners :: Seq ( C 2 ( ℝ nbBrushParams ) ( Corner ( I NonIV 2 ) ) ) + -- | Brush corners, before applying rotation (if any). + , brushCornersI :: Seq ( C 3 ( 𝕀ℝ nbBrushParams ) ( Corner ( I IsIV 2 ) ) ) + -- | Optional rotation angle function -- (assumed to be a linear function). - , mbRotation :: Maybe ( ℝ nbBrushParams -> Double ) + , mbRotation :: Maybe ( ℝ nbBrushParams -> Double ) } -------------------------------------------------------------------------------- -- Brushes -- Some convenience type synonyms for brush types... a bit horrible -type ParamsICt :: Nat -> k -> Nat -> Constraint +type ParamsICt :: Nat -> IVness -> Nat -> Constraint type ParamsICt k i nbParams = ( Module ( D k nbParams ( I i Double ) ) @@ -79,8 +101,10 @@ type ParamsICt k i nbParams = circleBrush :: Brush 1 circleBrush = Brush - { brushBaseShape = circleBrushFn @ℝ @2 @1 proxy# id id - , brushBaseShapeI = circleBrushFn @𝕀 @3 @1 proxy# singleton point + { brushBaseShape = circleBrushFn @2 SNonIV + , brushBaseShapeI = circleBrushFn @3 SIsIV + , brushCorners = Seq.empty + , brushCornersI = Seq.empty , mbRotation = Nothing } @@ -88,8 +112,10 @@ circleBrush = ellipseBrush :: Brush 3 ellipseBrush = Brush - { brushBaseShape = ellipseBrushFn @ℝ @2 @3 proxy# id id - , brushBaseShapeI = ellipseBrushFn @𝕀 @3 @3 proxy# singleton point + { brushBaseShape = ellipseBrushFn @2 SNonIV + , brushBaseShapeI = ellipseBrushFn @3 SIsIV + , brushCorners = Seq.empty + , brushCornersI = Seq.empty , mbRotation = Just ( `index` ( Fin 3 ) ) } @@ -97,11 +123,24 @@ ellipseBrush = tearDropBrush :: Brush 3 tearDropBrush = Brush - { brushBaseShape = tearDropBrushFn @ℝ @2 @3 proxy# id id - , brushBaseShapeI = tearDropBrushFn @𝕀 @3 @3 proxy# singleton point + { brushBaseShape = tearDropBrushFn @2 SNonIV + , brushBaseShapeI = tearDropBrushFn @3 SIsIV + , brushCorners = Seq.singleton $ tearDropCorner @2 proxy# SNonIV + , brushCornersI = Seq.singleton $ tearDropCorner @3 proxy# SIsIV , mbRotation = Just ( `index` ( Fin 3 ) ) } +-------------------------------------------------------------------------------- + +type SplineFn k i nbParams + = SingIVness i + -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) + +type CornerFn k i nbParams + = Proxy# k + -> SingIVness i + -> C k ( I i nbParams ) ( Corner ( I i 2 ) ) + -------------------------------------------------------------------------------- -- Circle & ellipse @@ -128,15 +167,24 @@ circleSpline p = sequenceA $ Bezier3To ( p ΞΊ -1 ) ( p 1 -ΞΊ ) BackToStart () {-# INLINE circleSpline #-} -circleBrushFn :: forall {t} (i :: t) k nbParams - . ( 1 <= nbParams - , ParamsICt k i nbParams - ) - => Proxy# i - -> ( Double -> I i Double ) - -> ( I ℝ 2 -> I i 2 ) - -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) -circleBrushFn _ mkI1 mkI2 = +mkI1 :: SingIVness i -> Double -> I i Double +mkI1 = \case + SNonIV -> id + SIsIV -> singleton +{-# INLINE mkI1 #-} + +mkI2 :: SingIVness i -> ℝ 2 -> I i 2 +mkI2 = \case + SNonIV -> id + SIsIV -> point +{-# INLINE mkI2 #-} + +circleBrushFn :: forall k i nbParams + . ( nbParams ~ 1 + , ParamsICt k i nbParams + ) + => SplineFn k i nbParams +circleBrushFn ivness = D \ params -> let r :: D k nbParams ( I i Double ) r = runD ( var @_ @k $ Fin 1 ) params @@ -147,22 +195,20 @@ circleBrushFn _ mkI1 mkI2 = in circleSpline mkPt where e_x, e_y :: D k nbParams ( I i 2 ) - e_x = pure $ mkI2 $ ℝ2 1 0 - e_y = pure $ mkI2 $ ℝ2 0 1 + e_x = pure $ mkI2 ivness $ ℝ2 1 0 + e_y = pure $ mkI2 ivness $ ℝ2 0 1 scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double ) - scaledBy d x = fmap ( mkI1 x * ) d -{-# INLINEABLE circleBrushFn #-} + scaledBy d x = fmap ( mkI1 ivness x * ) d +{-# SPECIALISE circleBrushFn :: SplineFn 2 NonIV 1 #-} +{-# SPECIALISE circleBrushFn :: SplineFn 3 IsIV 1 #-} -ellipseBrushFn :: forall {t} (i :: t) k nbParams - . ( 3 <= nbParams - , ParamsICt k i nbParams - ) - => Proxy# i - -> ( Double -> I i Double ) - -> ( I ℝ 2 -> I i 2 ) - -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) -ellipseBrushFn _ mkI1 mkI2 = +ellipseBrushFn :: forall k i nbParams + . ( nbParams ~ 3 + , ParamsICt k i nbParams + ) + => SplineFn k i nbParams +ellipseBrushFn ivness = D \ params -> let a, b :: D k nbParams ( I i Double ) a = runD ( var @_ @k $ Fin 1 ) params @@ -175,12 +221,13 @@ ellipseBrushFn _ mkI1 mkI2 = in circleSpline mkPt where e_x, e_y :: D k nbParams ( I i 2 ) - e_x = pure $ mkI2 $ ℝ2 1 0 - e_y = pure $ mkI2 $ ℝ2 0 1 + e_x = pure $ mkI2 ivness $ ℝ2 1 0 + e_y = pure $ mkI2 ivness $ ℝ2 0 1 scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double ) - scaledBy d x = fmap ( mkI1 x * ) d -{-# INLINEABLE ellipseBrushFn #-} + scaledBy d x = fmap ( mkI1 ivness x * ) d +{-# SPECIALISE ellipseBrushFn :: SplineFn 2 NonIV 3 #-} +{-# SPECIALISE ellipseBrushFn :: SplineFn 3 IsIV 3 #-} -------------------------------------------------------------------------------- -- Tear drop @@ -202,15 +249,12 @@ tearHeight = 3 * sqrt 3 / 8 sqrt3_over_2 :: Double sqrt3_over_2 = 0.5 * sqrt 3 -tearDropBrushFn :: forall {t} (i :: t) k nbParams - . ( 3 <= nbParams - , ParamsICt k i nbParams - ) - => Proxy# i - -> ( Double -> I i Double ) - -> ( I ℝ 2 -> I i 2 ) - -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) ) -tearDropBrushFn _ mkI1 mkI2 = +tearDropBrushFn :: forall k i nbParams + . ( nbParams ~ 3 + , ParamsICt k i nbParams + ) + => SplineFn k i nbParams +tearDropBrushFn ivness = D \ params -> let w, h :: D k nbParams ( I i Double ) w = 2 * runD ( var @_ @k ( Fin 1 ) ) params @@ -233,9 +277,41 @@ tearDropBrushFn _ mkI1 mkI2 = BackToStart () } where e_x, e_y :: D k nbParams ( I i 2 ) - e_x = pure $ mkI2 $ ℝ2 1 0 - e_y = pure $ mkI2 $ ℝ2 0 1 + e_x = pure $ mkI2 ivness $ ℝ2 1 0 + e_y = pure $ mkI2 ivness $ ℝ2 0 1 scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double ) - scaledBy d x = fmap ( mkI1 x * ) d -{-# INLINEABLE tearDropBrushFn #-} + scaledBy d x = fmap ( mkI1 ivness x * ) d +{-# SPECIALISE tearDropBrushFn :: SplineFn 2 NonIV 3 #-} +{-# SPECIALISE tearDropBrushFn :: SplineFn 3 IsIV 3 #-} + +tearDropCorner :: forall k i nbParams. ( nbParams ~ 3, ParamsICt k i nbParams, Torsor ( T ( I i 2 ) ) ( I i 2 ) ) => CornerFn k i nbParams +tearDropCorner _ ivness = + D \ params -> + let w, h :: D k nbParams ( I i Double ) + w = 2 * runD ( var @_ @k ( Fin 1 ) ) params + h = 2 * runD ( var @_ @k ( Fin 2 ) ) params + mkPt :: Double -> Double -> D k nbParams ( I i 2 ) + mkPt x y + -- 1. translate the teardrop so that the centre of mass is at the origin + -- 2. scale the teardrop so that it has the requested width/height + -- 3. rotate (done separately) + = let !x' = w `scaledBy` ( x / tearWidth ) + !y' = h `scaledBy` ( ( y - tearCenter ) / tearHeight ) + in x' *^ e_x ^+^ y' *^ e_y + !cornerPoint = mkPt 0 0 + in sequenceA $ + Corner + { cornerPoint + , cornerStartTangent = T $ liftA2 ( \ x y -> unT $ x --> y ) ( mkPt -0.5 sqrt3_over_2 ) cornerPoint + , cornerEndTangent = T $ liftA2 ( \ x y -> unT $ x --> y ) cornerPoint ( mkPt 0.5 sqrt3_over_2 ) + } + where + e_x, e_y :: D k nbParams ( I i 2 ) + e_x = pure $ mkI2 ivness $ ℝ2 1 0 + e_y = pure $ mkI2 ivness $ ℝ2 0 1 + + scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double ) + scaledBy d x = fmap ( mkI1 ivness x * ) d +{-# SPECIALISE tearDropCorner :: CornerFn 2 NonIV 3 #-} +{-# SPECIALISE tearDropCorner :: CornerFn 3 IsIV 3 #-} diff --git a/brush-strokes/src/lib/Math/Algebra/Dual.hs b/brush-strokes/src/lib/Math/Algebra/Dual.hs index cde608b..f648dd1 100644 --- a/brush-strokes/src/lib/Math/Algebra/Dual.hs +++ b/brush-strokes/src/lib/Math/Algebra/Dual.hs @@ -9,12 +9,15 @@ module Math.Algebra.Dual ( C(..), D, Dim + , Differential(..) , HasChainRule(..), chainRule , uncurryD2, uncurryD3 , linear, fun, var , chainRuleN1Q, chainRule1NQ + , DiffModule(..) + , D𝔸0(..) , D1𝔸1(..), D2𝔸1(..), D3𝔸1(..) , D1𝔸2(..), D2𝔸2(..), D3𝔸2(..) @@ -30,7 +33,7 @@ import Prelude import Data.Coerce ( coerce ) import Data.Kind - ( Type ) + ( Constraint, Type ) import GHC.TypeNats ( Nat ) @@ -94,18 +97,27 @@ instance ( Applicative ( D k ( Dim u ) ), Module r ( T v ) ) T ( D f ) ^-^ T ( D g ) = T $ D \ t -> liftA2 ( coerce $ (^-^) @r @( T v ) ) ( f t ) ( g t ) a *^ T ( D f ) = T $ D \ t -> fmap ( coerce $ (*^) @r @( T v ) a ) $ f t +newtype DiffModule k n v = DiffModule { getDiffModule :: D k n v } + +instance ( Applicative ( D k n ), Module r ( T v ) ) + => Module r ( T ( DiffModule k n v ) ) where + origin = T $ DiffModule $ pure $ coerce $ origin @r @( T v ) + T ( DiffModule f ) ^+^ T ( DiffModule g ) = T $ DiffModule $ liftA2 ( coerce $ (^+^) @r @( T v ) ) f g + T ( DiffModule f ) ^-^ T ( DiffModule g ) = T $ DiffModule $ liftA2 ( coerce $ (^-^) @r @( T v ) ) f g + a *^ T ( DiffModule f ) = T $ DiffModule $ fmap ( coerce $ (*^) @r @( T v ) a ) f + -------------------------------------------------------------------------------- --- TODO: split up this class into the chain rule operation --- and all the other operations. +type Differential :: Nat -> Nat -> Constraint +class Differential k n where + konst :: AbelianGroup w => w -> D k n w + value :: D k n w -> w -- | @HasChainRule r k v@ means we have a chain rule -- with @D k v w@ in the middle, for any @r@-module @w@. -class HasChainRule r k v where +class Differential k ( Dim v ) => HasChainRule r k v where chain :: Module r ( T w ) => D k 1 v -> D k ( Dim v ) w -> D k 1 w - konst :: AbelianGroup w => w -> D k ( Dim v ) w - value :: D k ( Dim v ) w -> w linearD :: Module r ( T w ) => ( v -> w ) -> v -> D k ( Dim v ) w linear :: forall k r v w @@ -122,27 +134,24 @@ chainRule ( D df ) ( D dg ) = D \ x -> case df x of df_x -> - chain @r @k @v df_x ( dg $ value @r @k @u df_x ) + chain @r @k @v df_x ( dg $ value @k @( Dim u ) df_x ) - -uncurryD2 :: Dim a ~ 1 - => D 2 1 ( C 2 a b ) -> a -> D 2 2 b -uncurryD2 ( D21 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 = - let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_t0 s0 - D21 dbdt_t0s0 d2bdtds_t0s0 _ = dbdt_t0 s0 - D21 d2bdt2_t0s0 _ _ = d2bdt2_t0 s0 +uncurryD2 :: D 2 1 ( D 2 1 b ) -> D 2 2 b +uncurryD2 ( D21 ( b_t0 ) ( T ( dbdt_t0 ) ) ( T ( d2bdt2_t0 ) ) ) = + let D21 b_t0s0 dbds_t0s0 d2bds2_t0s0 = b_t0 + D21 dbdt_t0s0 d2bdtds_t0s0 _ = dbdt_t0 + D21 d2bdt2_t0s0 _ _ = d2bdt2_t0 in D22 b_t0s0 ( T dbdt_t0s0 ) dbds_t0s0 ( T d2bdt2_t0s0 ) d2bdtds_t0s0 d2bds2_t0s0 -uncurryD3 :: Dim a ~ 1 - => D 3 1 ( C 3 a b ) -> a -> D 3 2 b -uncurryD3 ( D31 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ( T ( D d3bdt3_t0 ) ) ) s0 = - let D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 = b_t0 s0 - D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ = dbdt_t0 s0 - D31 d2bdt2_t0s0 d3bdt2ds_t0s0 _ _ = d2bdt2_t0 s0 - D31 d3bdt3_t0s0 _ _ _ = d3bdt3_t0 s0 +uncurryD3 :: D 3 1 ( D 3 1 b ) -> D 3 2 b +uncurryD3 ( D31 b_t0 ( T dbdt_t0 ) ( T d2bdt2_t0 ) ( T d3bdt3_t0 ) ) = + let D31 b_t0s0 dbds_t0s0 d2bds2_t0s0 d3bds3_t0s0 = b_t0 + D31 dbdt_t0s0 d2bdtds_t0s0 d3bdtds2_t0s0 _ = dbdt_t0 + D31 d2bdt2_t0s0 d3bdt2ds_t0s0 _ _ = d2bdt2_t0 + D31 d3bdt3_t0s0 _ _ _ = d3bdt3_t0 in D32 b_t0s0 ( T dbdt_t0s0 ) dbds_t0s0 @@ -150,8 +159,8 @@ uncurryD3 ( D31 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ( T ( D d3b ( T d3bdt3_t0s0 ) d3bdt2ds_t0s0 d3bdtds2_t0s0 d3bds3_t0s0 -- | Recover the underlying function, discarding all infinitesimal information. -fun :: forall r k v w. HasChainRule r k v => C k v w -> ( v -> w ) -fun ( D df ) = value @r @k @v . df +fun :: forall k v w. Differential k ( Dim v ) => C k v w -> ( v -> w ) +fun ( D df ) = value @k @( Dim v ) . df {-# INLINE fun #-} -- | The differentiable germ of a coordinate variable. @@ -216,7 +225,7 @@ instance ( Applicative ( D k ( Dim u ) ) negate ( ApAp2 !x ) = ApAp2 $ fmap ( negate @r ) x -- DO NOT USE PURE!! - fromInteger !i = ApAp2 $ konst @Double @k @u ( fromInteger @r i ) + fromInteger !i = ApAp2 $ konst @k @( Dim u ) ( fromInteger @r i ) deriving newtype instance AbelianGroup r => AbelianGroup ( D𝔸0 r ) @@ -498,7 +507,7 @@ deriving newtype instance Field r => Field ( D𝔸0 r ) --instance Field r => Field ( D1𝔸3 r ) where --instance Field r => Field ( D1𝔸4 r ) where instance Field r => Field ( D2𝔸1 r ) where - fromRational q = konst @Double @2 @( ℝ 1 ) ( fromRational q ) + fromRational q = konst @2 @1 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -511,7 +520,7 @@ instance Field r => Field ( D2𝔸1 r ) where {-# SPECIALISE instance Field ( D2𝔸1 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸1 𝕀 ) #-} instance Field r => Field ( D2𝔸2 r ) where - fromRational q = konst @Double @2 @( ℝ 2 ) ( fromRational q ) + fromRational q = konst @2 @2 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -524,7 +533,7 @@ instance Field r => Field ( D2𝔸2 r ) where {-# SPECIALISE instance Field ( D2𝔸2 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸2 𝕀 ) #-} instance Field r => Field ( D2𝔸3 r ) where - fromRational q = konst @Double @2 @( ℝ 3 ) ( fromRational q ) + fromRational q = konst @2 @3 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -537,7 +546,7 @@ instance Field r => Field ( D2𝔸3 r ) where {-# SPECIALISE instance Field ( D2𝔸3 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸3 𝕀 ) #-} instance Field r => Field ( D2𝔸4 r ) where - fromRational q = konst @Double @2 @( ℝ 4 ) ( fromRational q ) + fromRational q = konst @2 @4 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -550,7 +559,7 @@ instance Field r => Field ( D2𝔸4 r ) where {-# SPECIALISE instance Field ( D2𝔸4 Double ) #-} {-# SPECIALISE instance Field ( D2𝔸4 𝕀 ) #-} instance Field r => Field ( D3𝔸1 r ) where - fromRational q = konst @Double @3 @( ℝ 1 ) ( fromRational q ) + fromRational q = konst @3 @1 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -563,7 +572,7 @@ instance Field r => Field ( D3𝔸1 r ) where {-# SPECIALISE instance Field ( D3𝔸1 Double ) #-} {-# SPECIALISE instance Field ( D3𝔸1 𝕀 ) #-} instance Field r => Field ( D3𝔸2 r ) where - fromRational q = konst @Double @3 @( ℝ 2 ) ( fromRational q ) + fromRational q = konst @3 @2 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -576,7 +585,7 @@ instance Field r => Field ( D3𝔸2 r ) where {-# SPECIALISE instance Field ( D3𝔸2 Double ) #-} {-# SPECIALISE instance Field ( D3𝔸2 𝕀 ) #-} instance Field r => Field ( D3𝔸3 r ) where - fromRational q = konst @Double @3 @( ℝ 3 ) ( fromRational q ) + fromRational q = konst @3 @3 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -589,7 +598,7 @@ instance Field r => Field ( D3𝔸3 r ) where {-# SPECIALISE instance Field ( D3𝔸3 Double ) #-} {-# SPECIALISE instance Field ( D3𝔸3 𝕀 ) #-} instance Field r => Field ( D3𝔸4 r ) where - fromRational q = konst @Double @3 @( ℝ 4 ) ( fromRational q ) + fromRational q = konst @3 @4 ( fromRational q ) recip df = let fromInt = fromInteger @r @@ -786,7 +795,7 @@ deriving newtype instance Transcendental r => Transcendental ( D𝔸0 r ) --instance Transcendental r => Transcendental ( D1𝔸3 r ) where --instance Transcendental r => Transcendental ( D1𝔸4 r ) where instance Transcendental r => Transcendental ( D2𝔸1 r ) where - pi = konst @Double @2 @( ℝ 1 ) pi + pi = konst @2 @1 pi sin df = let fromInt = fromInteger @r @@ -817,7 +826,7 @@ instance Transcendental r => Transcendental ( D2𝔸1 r ) where {-# SPECIALISE instance Transcendental ( D2𝔸1 Double ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸1 𝕀 ) #-} instance Transcendental r => Transcendental ( D2𝔸2 r ) where - pi = konst @Double @2 @( ℝ 2 ) pi + pi = konst @2 @2 pi sin df = let fromInt = fromInteger @r @@ -848,7 +857,7 @@ instance Transcendental r => Transcendental ( D2𝔸2 r ) where {-# SPECIALISE instance Transcendental ( D2𝔸2 Double ) #-} {-# SPECIALISE instance Transcendental ( D2𝔸2 𝕀 ) #-} instance Transcendental r => Transcendental ( D2𝔸3 r ) where - pi = konst @Double @2 @( ℝ 3 ) pi + pi = konst @2 @3 pi sin df = let fromInt = fromInteger @r @@ -880,7 +889,7 @@ instance Transcendental r => Transcendental ( D2𝔸3 r ) where {-# SPECIALISE instance Transcendental ( D2𝔸3 𝕀 ) #-} instance Transcendental r => Transcendental ( D2𝔸4 r ) where - pi = konst @Double @2 @( ℝ 4 ) pi + pi = konst @2 @4 pi sin df = let fromInt = fromInteger @r @@ -912,7 +921,7 @@ instance Transcendental r => Transcendental ( D2𝔸4 r ) where {-# SPECIALISE instance Transcendental ( D2𝔸4 𝕀 ) #-} instance Transcendental r => Transcendental ( D3𝔸1 r ) where - pi = konst @Double @3 @( ℝ 1 ) pi + pi = konst @3 @1 pi sin df = let fromInt = fromInteger @r @@ -944,7 +953,7 @@ instance Transcendental r => Transcendental ( D3𝔸1 r ) where {-# SPECIALISE instance Transcendental ( D3𝔸1 𝕀 ) #-} instance Transcendental r => Transcendental ( D3𝔸2 r ) where - pi = konst @Double @3 @( ℝ 2 ) pi + pi = konst @3 @2 pi sin df = let fromInt = fromInteger @r @@ -976,7 +985,7 @@ instance Transcendental r => Transcendental ( D3𝔸2 r ) where {-# SPECIALISE instance Transcendental ( D3𝔸2 𝕀 ) #-} instance Transcendental r => Transcendental ( D3𝔸3 r ) where - pi = konst @Double @3 @( ℝ 3 ) pi + pi = konst @3 @3 pi sin df = let fromInt = fromInteger @r @@ -1008,7 +1017,7 @@ instance Transcendental r => Transcendental ( D3𝔸3 r ) where {-# SPECIALISE instance Transcendental ( D3𝔸3 𝕀 ) #-} instance Transcendental r => Transcendental ( D3𝔸4 r ) where - pi = konst @Double @3 @( ℝ 4 ) pi + pi = konst @3 @4 pi sin df = let fromInt = fromInteger @r @@ -1042,35 +1051,41 @@ instance Transcendental r => Transcendental ( D3𝔸4 r ) where -------------------------------------------------------------------------------- -- HasChainRule instances. +instance Differential 2 0 where + konst w = D0 w + value ( D0 v ) = v + {-# INLINEABLE konst #-} + + {-# INLINEABLE value #-} instance HasChainRule Double 2 ( ℝ 0 ) where - konst w = D0 w linearD f v = D0 ( f v ) - value ( D0 v ) = v chain _ ( D0 gfx ) = D21 gfx origin origin - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 3 ( ℝ 0 ) where +instance Differential 3 0 where konst w = D0 w - linearD f v = D0 ( f v ) + value ( D0 v ) = v - chain _ ( D0 gfx ) = D31 gfx origin origin origin {-# INLINEABLE konst #-} - {-# INLINEABLE linearD #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 3 ( ℝ 0 ) where + linearD f v = D0 ( f v ) + chain _ ( D0 gfx ) = D31 gfx origin origin origin + {-# INLINEABLE linearD #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 2 ( ℝ 1 ) where - +instance Differential 2 1 where konst :: forall w. AbelianGroup w => w -> D2𝔸1 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) - + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 2 ( ℝ 1 ) where linearD :: forall w. Module Double ( T w ) => ( ℝ 1 -> w ) -> ℝ 1 -> D2𝔸1 w linearD f v = let !o = origin @Double @( T w ) @@ -1087,7 +1102,6 @@ instance HasChainRule Double 2 ( ℝ 1 ) where | otherwise -> [|| unT o ||] ) - chain :: forall w. Module Double ( T w ) => D2𝔸1 ( ℝ 1 ) -> D2𝔸1 w -> D2𝔸1 w chain !df !dg = let !o = origin @Double @( T w ) @@ -1096,20 +1110,28 @@ instance HasChainRule Double 2 ( ℝ 1 ) where in $$( chainRule1NQ [|| o ||] [|| p ||] [|| s ||] [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 3 ( ℝ 1 ) where - +instance Differential 3 1 where konst :: forall w. AbelianGroup w => w -> D3𝔸1 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 3 ( ℝ 1 ) where + chain :: forall w. Module Double ( T w ) => D3𝔸1 ( ℝ 1 ) -> D3𝔸1 w -> D3𝔸1 w + chain !df !dg = + let !o = origin @Double @( T w ) + !p = (^+^) @Double @( T w ) + !s = (^*) @Double @( T w ) + in $$( chainRule1NQ + [|| o ||] [|| p ||] [|| s ||] + [|| df ||] [|| dg ||] ) linearD :: forall w. Module Double ( T w ) => ( ℝ 1 -> w ) -> ℝ 1 -> D3𝔸1 w linearD f v = let !o = origin @Double @( T w ) @@ -1126,29 +1148,19 @@ instance HasChainRule Double 3 ( ℝ 1 ) where | otherwise -> [|| unT o ||] ) - - chain :: forall w. Module Double ( T w ) => D3𝔸1 ( ℝ 1 ) -> D3𝔸1 w -> D3𝔸1 w - chain !df !dg = - let !o = origin @Double @( T w ) - !p = (^+^) @Double @( T w ) - !s = (^*) @Double @( T w ) - in $$( chainRule1NQ - [|| o ||] [|| p ||] [|| s ||] - [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 2 ( ℝ 2 ) where - +instance Differential 2 2 where konst :: forall w. AbelianGroup w => w -> D2𝔸2 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) - + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 2 ( ℝ 2 ) where linearD :: forall w. Module Double ( T w ) => ( ℝ 2 -> w ) -> ℝ 2 -> D2𝔸2 w linearD f v = let !o = origin @Double @( T w ) @@ -1165,7 +1177,6 @@ instance HasChainRule Double 2 ( ℝ 2 ) where | otherwise -> [|| unT o ||] ) - chain :: forall w. Module Double ( T w ) => D2𝔸1 ( ℝ 2 ) -> D2𝔸2 w -> D2𝔸1 w chain !df !dg = let !o = origin @Double @( T w ) @@ -1174,20 +1185,19 @@ instance HasChainRule Double 2 ( ℝ 2 ) where in $$( chainRule1NQ [|| o ||] [|| p ||] [|| s ||] [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 3 ( ℝ 2 ) where - +instance Differential 3 2 where konst :: forall w. AbelianGroup w => w -> D3𝔸2 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) - + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 3 ( ℝ 2 ) where linearD :: forall w. Module Double ( T w ) => ( ℝ 2 -> w ) -> ℝ 2 -> D3𝔸2 w linearD f v = let !o = origin @Double @( T w ) @@ -1204,7 +1214,6 @@ instance HasChainRule Double 3 ( ℝ 2 ) where | otherwise -> [|| unT o ||] ) - chain :: forall w. Module Double ( T w ) => D3𝔸1 ( ℝ 2 ) -> D3𝔸2 w -> D3𝔸1 w chain !df !dg = let !o = origin @Double @( T w ) @@ -1213,20 +1222,19 @@ instance HasChainRule Double 3 ( ℝ 2 ) where in $$( chainRule1NQ [|| o ||] [|| p ||] [|| s ||] [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 2 ( ℝ 3 ) where - +instance Differential 2 3 where konst :: forall w. AbelianGroup w => w -> D2𝔸3 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) - + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 2 ( ℝ 3 ) where linearD :: forall w. Module Double ( T w ) => ( ℝ 3 -> w ) -> ℝ 3 -> D2𝔸3 w linearD f v = let !o = origin @Double @( T w ) @@ -1243,7 +1251,6 @@ instance HasChainRule Double 2 ( ℝ 3 ) where | otherwise -> [|| unT o ||] ) - chain :: forall w. Module Double ( T w ) => D2𝔸1 ( ℝ 3 ) -> D2𝔸3 w -> D2𝔸1 w chain !df !dg = let !o = origin @Double @( T w ) @@ -1252,20 +1259,19 @@ instance HasChainRule Double 2 ( ℝ 3 ) where in $$( chainRule1NQ [|| o ||] [|| p ||] [|| s ||] [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 3 ( ℝ 3 ) where - +instance Differential 3 3 where konst :: forall w. AbelianGroup w => w -> D3𝔸3 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) - + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 3 ( ℝ 3 ) where linearD :: forall w. Module Double ( T w ) => ( ℝ 3 -> w ) -> ℝ 3 -> D3𝔸3 w linearD f v = let !o = origin @Double @( T w ) @@ -1282,7 +1288,6 @@ instance HasChainRule Double 3 ( ℝ 3 ) where | otherwise -> [|| unT o ||] ) - chain :: forall w. Module Double ( T w ) => D3𝔸1 ( ℝ 3 ) -> D3𝔸3 w -> D3𝔸1 w chain !df !dg = let !o = origin @Double @( T w ) @@ -1291,20 +1296,20 @@ instance HasChainRule Double 3 ( ℝ 3 ) where in $$( chainRule1NQ [|| o ||] [|| p ||] [|| s ||] [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} - {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} + {-# INLINEABLE linearD #-} -instance HasChainRule Double 2 ( ℝ 4 ) where - +instance Differential 2 4 where konst :: forall w. AbelianGroup w => w -> D2𝔸4 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 2 ( ℝ 4 ) where linearD :: forall w. Module Double ( T w ) => ( ℝ 4 -> w ) -> ℝ 4 -> D2𝔸4 w linearD f v = let !o = origin @Double @( T w ) @@ -1321,7 +1326,6 @@ instance HasChainRule Double 2 ( ℝ 4 ) where | otherwise -> [|| unT o ||] ) - chain :: forall w. Module Double ( T w ) => D2𝔸1 ( ℝ 4 ) -> D2𝔸4 w -> D2𝔸1 w chain !df !dg = let !o = origin @Double @( T w ) @@ -1330,20 +1334,19 @@ instance HasChainRule Double 2 ( ℝ 4 ) where in $$( chainRule1NQ [|| o ||] [|| p ||] [|| s ||] [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} -instance HasChainRule Double 3 ( ℝ 4 ) where - +instance Differential 3 4 where konst :: forall w. AbelianGroup w => w -> D3𝔸4 w konst w = let !o = fromInteger @w 0 in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) value df = $$( monIndexQ [|| df ||] zeroMonomial ) - + {-# INLINEABLE konst #-} + {-# INLINEABLE value #-} +instance HasChainRule Double 3 ( ℝ 4 ) where linearD :: forall w. Module Double ( T w ) => ( ℝ 4 -> w ) -> ℝ 4 -> D3𝔸4 w linearD f v = let !o = origin @Double @( T w ) @@ -1360,7 +1363,6 @@ instance HasChainRule Double 3 ( ℝ 4 ) where | otherwise -> [|| unT o ||] ) - chain :: forall w. Module Double ( T w ) => D3𝔸1 ( ℝ 4 ) -> D3𝔸4 w -> D3𝔸1 w chain !df !dg = let !o = origin @Double @( T w ) @@ -1369,7 +1371,5 @@ instance HasChainRule Double 3 ( ℝ 4 ) where in $$( chainRule1NQ [|| o ||] [|| p ||] [|| s ||] [|| df ||] [|| dg ||] ) - {-# INLINEABLE konst #-} {-# INLINEABLE linearD #-} - {-# INLINEABLE value #-} {-# INLINEABLE chain #-} diff --git a/brush-strokes/src/lib/Math/Algebra/Dual/Internal.hs b/brush-strokes/src/lib/Math/Algebra/Dual/Internal.hs index 5652779..39c3d07 100644 --- a/brush-strokes/src/lib/Math/Algebra/Dual/Internal.hs +++ b/brush-strokes/src/lib/Math/Algebra/Dual/Internal.hs @@ -312,6 +312,19 @@ instance MonomialBasisQ D1𝔸1 where Mon ( Vec [ 1 ] ) -> [|| unT $ _D11_dx $$d ||] _ -> [|| _D11_v $$d ||] +instance MonomialBasis D1𝔸1 where + monTabulate f = + let + _D11_v = f $ Mon ( Vec [ 0 ] ) + _D11_dx = T $ f $ Mon ( Vec [ 1 ] ) + in D11 { .. } + {-# INLINE monTabulate #-} + + monIndex d = \ case + Mon ( Vec [ 1 ] ) -> unT $ _D11_dx d + _ -> _D11_v d + {-# INLINE monIndex #-} + type instance Deg D2𝔸1 = 2 type instance Vars D2𝔸1 = 1 instance MonomialBasisQ D2𝔸1 where diff --git a/brush-strokes/src/lib/Math/Bezier/Cubic/Fit.hs b/brush-strokes/src/lib/Math/Bezier/Cubic/Fit.hs index 7ff9e15..89ec016 100644 --- a/brush-strokes/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/brush-strokes/src/lib/Math/Bezier/Cubic/Fit.hs @@ -99,6 +99,8 @@ data FitPoint { fitPoint :: !( ℝ 2 ) , fitTangent :: !( T ( ℝ 2 ) ) } + | JoinPoint + { joinPoint :: !( ℝ 2 ) } deriving stock ( Show, Generic ) deriving anyclass NFData diff --git a/brush-strokes/src/lib/Math/Bezier/Stroke.hs b/brush-strokes/src/lib/Math/Bezier/Stroke.hs index c29d718..1f31184 100644 --- a/brush-strokes/src/lib/Math/Bezier/Stroke.hs +++ b/brush-strokes/src/lib/Math/Bezier/Stroke.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -51,9 +52,9 @@ import Data.List.NonEmpty ( NonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe - ( catMaybes, fromMaybe, isJust, listToMaybe, mapMaybe ) -import Data.Proxy - ( Proxy(..) ) + ( catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe ) +import Data.Monoid + ( First(..) ) import Data.Semigroup ( sconcat ) import GHC.Exts @@ -108,35 +109,26 @@ import Control.Monad.Trans.Writer.CPS -- MetaBrush import Calligraphy.Brushes - ( Brush(..) ) + ( Brush(..), Corner(..) ) import Math.Algebra.Dual -import qualified Math.Bezier.Cubic as Cubic +import qualified Math.Bezier.Cubic as Cubic import Math.Bezier.Cubic.Fit - ( FitPoint, FitParameters, fitSpline ) + ( FitPoint (..), FitParameters, fitSpline ) import Math.Bezier.Spline - ( SplineType(..), SSplineType(..), SplineTypeI - , ssplineType, adjustSplineType, reverseSpline - , NextPoint(..), fromNextPoint - , KnownSplineType - ( bifoldSpline, ibifoldSpline ) - , Spline(..), SplinePts, Curves(..), Curve(..) - , openCurveStart, openCurveEnd, splitSplineAt, dropCurves - , showSplinePoints - ) import qualified Math.Bezier.Quadratic as Quadratic import Math.Bezier.Stroke.EnvelopeEquation import Math.Differentiable - ( Differentiable, DiffInterp, I ) + ( I, IVness(..), SingIVness (..) + , Differentiable, DiffInterp + ) import Math.Epsilon ( epsilon ) import Math.Interval import Math.Linear import Math.Module - ( Module(..), Inner((^.^)), Cross((Γ—)), Interpolatable - , lerp, convexCombination, strictlyParallel - ) import Math.Ring ( Transcendental ) +import qualified Math.Ring as Ring import Math.Orientation ( Orientation(..), splineOrientation , between @@ -240,9 +232,10 @@ computeStrokeOutline :: -- Differentiability. , Interpolatable Double ( ℝ nbUsedParams ) - , DiffInterp 2 ℝ nbBrushParams - , DiffInterp 3 𝕀 nbBrushParams + , DiffInterp 2 NonIV nbBrushParams + , DiffInterp 3 IsIV nbBrushParams , HasChainRule Double 2 ( ℝ nbUsedParams ) + , HasChainRule 𝕀 2 ( 𝕀ℝ nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbUsedParams ) , HasChainRule Double 2 ( ℝ nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbBrushParams ) @@ -254,13 +247,13 @@ computeStrokeOutline :: -- Debugging. , Show ptData, Show crvData, Show ( ℝ nbBrushParams ) - ) => RootSolvingAlgorithm - -> Maybe ( RootIsolationOptions N 3 ) + -> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) -> FitParameters -> ( ptData -> ℝ nbUsedParams ) - -> ( ℝ nbUsedParams -> ℝ nbBrushParams ) -- ^ assumed to be linear and non-decreasing + -> ( ℝ nbUsedParams -> ℝ nbBrushParams ) + -- ^ assumed to be linear and non-decreasing -> Brush nbBrushParams -> Spline clo crvData ptData -> ST s @@ -302,21 +295,29 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru etx, ety :: Double V2 etx ety = endTgt - startCap, endCap :: SplinePts Open - startCap + mbStartCap, mbEndCap :: Maybe ( SplinePts Open ) + mbStartCap + | startTgtBwd `strictlyParallel` startTgtFwd + = Nothing | isJust $ between CCW startTgtBwd startTgtFwd startTestTgt - = fmap ( T ( coords spt0 ) β€’ ) + = Just + . fmap ( T ( coords spt0 ) β€’ ) $ joinWithBrush startBrush startTgtBwd startTgtFwd | otherwise - = fmap ( T ( coords spt0 ) β€’ ) + = Just + . fmap ( T ( coords spt0 ) β€’ ) . reverseSpline $ joinWithBrush startBrush startTgtFwd startTgtBwd - endCap + mbEndCap + | endTgtBwd `strictlyParallel` endTgtFwd + = Nothing | isJust $ between CCW endTgtBwd endTgtFwd endTestTgt - = fmap ( T ( coords endPt ) β€’ ) + = Just + . fmap ( T ( coords endPt ) β€’ ) $ joinWithBrush endBrush endTgtFwd endTgtBwd | otherwise - = fmap ( T ( coords endPt ) β€’ ) + = Just + . fmap ( T ( coords endPt ) β€’ ) . reverseSpline $ joinWithBrush endBrush endTgtBwd endTgtFwd @@ -326,8 +327,14 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru cusps <- updateSpline ( startTgt, startTgtFwd, startTgtBwd ) pure - ( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts ) - , fwdFits <> bwdFits + ( Left ( adjustSplineType @Closed $ sconcat $ NE.fromList $ catMaybes [ mbStartCap, Just fwdPts, mbEndCap, Just bwdPts ] ) + , ( Seq.fromList $ fmap JoinPoint $ catMaybes + [ fmap splineEnd mbStartCap + , fmap splineStart mbEndCap + , fmap splineEnd mbEndCap + , fmap splineStart mbStartCap ] + ) + <> fwdFits <> bwdFits , cusps ) -- Closed brush path with at least one segment. @@ -387,7 +394,7 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru brushShape pt = let Brush { brushBaseShape = shapeFn, mbRotation = mbRot } = brush brushParams = toBrushParams $ ptParams pt - shape = fun @Double shapeFn brushParams + shape = fun shapeFn brushParams in case mbRot of Nothing -> shape Just getΞΈ -> @@ -463,7 +470,10 @@ computeStrokeOutline rootAlgo mbCuspOptions fitParams ptParams toBrushParams bru -> WriterT OutlineData m () tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) = tell $ OutlineData - ( TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty ) ) + ( TwoSided + ( fwdJoin, Seq.fromList $ map JoinPoint [ splineStart fwdJoin, splineEnd fwdJoin ] ) + ( bwdJoin, Seq.fromList $ map JoinPoint [ splineStart bwdJoin, splineEnd bwdJoin ] ) + ) [] where ptOffset :: T ( ℝ 2 ) @@ -524,9 +534,10 @@ outlineFunction -- Differentiability. , Interpolatable Double ( ℝ nbUsedParams ) - , DiffInterp 2 ℝ nbBrushParams - , DiffInterp 3 𝕀 nbBrushParams + , DiffInterp 2 NonIV nbBrushParams + , DiffInterp 3 IsIV nbBrushParams , HasChainRule Double 2 ( ℝ nbUsedParams ) + , HasChainRule 𝕀 2 ( 𝕀ℝ nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbUsedParams ) , HasChainRule Double 2 ( ℝ nbBrushParams ) , HasChainRule 𝕀 3 ( 𝕀ℝ nbBrushParams ) @@ -542,7 +553,7 @@ outlineFunction , Show ptData, Show crvData, Show ( ℝ nbBrushParams ) ) => RootSolvingAlgorithm - -> Maybe ( RootIsolationOptions N 3 ) + -> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) -> ( ptData -> ℝ nbUsedParams ) -> ( ℝ nbUsedParams -> ℝ nbBrushParams ) -- ^ assumed to be linear and non-decreasing -> Brush nbBrushParams @@ -550,37 +561,42 @@ outlineFunction -> Curve Open crvData ptData -> OutlineInfo outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams - ( Brush { brushBaseShape, brushBaseShapeI, mbRotation } ) = \ sp0 crv -> + ( Brush { brushBaseShape, brushBaseShapeI + , brushCorners, brushCornersI + , mbRotation } ) = \ sp0 crv -> let usedParams :: C 2 ( ℝ 1 ) ( ℝ nbUsedParams ) path :: C 2 ( ℝ 1 ) ( ℝ 2 ) ( path, usedParams ) - = pathAndUsedParams @2 @ℝ @nbUsedParams coerce id id ptParams sp0 crv + = pathAndUsedParams @2 @NonIV @nbUsedParams coerce id id ptParams sp0 crv curves :: ℝ 1 -- t - -> Seq ( ℝ 1 {- s -} -> StrokeDatum 2 ℝ ) + -> ( Seq ( CornerStrokeDatum 2 NonIV ) + , Seq ( ℝ 1 {- s -} -> StrokeDatum 2 NonIV ) ) curves = - brushStrokeData @2 @nbBrushParams - coerce coerce + brushStrokeData @2 @nbBrushParams SNonIV path ( fmap toBrushParams usedParams ) brushBaseShape + brushCorners mbRotation curvesI :: 𝕀ℝ 1 -- t - -> Seq ( 𝕀ℝ 1 {- s -} -> StrokeDatum 3 𝕀 ) + -> ( Seq ( CornerStrokeDatum 3 IsIV ) + , Seq ( 𝕀ℝ 1 {- s -} -> StrokeDatum 3 IsIV ) + ) curvesI = - brushStrokeData @3 @nbBrushParams - coerce coerce + brushStrokeData @3 @nbBrushParams SIsIV pathI ( fmap ( nonDecreasing toBrushParams ) usedParamsI ) brushBaseShapeI + brushCornersI ( fmap ( \ rot -> un𝕀ℝ1 . nonDecreasing ( ℝ1 . rot ) ) mbRotation ) usedParamsI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ nbUsedParams ) pathI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) - ( pathI, usedParamsI ) = pathAndUsedParams @3 @𝕀 @nbUsedParams coerce point point ptParams sp0 crv + ( pathI, usedParamsI ) = pathAndUsedParams @3 @IsIV @nbUsedParams coerce point point ptParams sp0 crv fwdBwd :: OutlineFn fwdBwd t @@ -604,12 +620,12 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams in fmap ( unT . rotate cosΞΈ sinΞΈ . T ) in applyRot $ - value @Double @2 @( ℝ nbBrushParams ) $ + value @2 @nbBrushParams $ runD brushBaseShape brushParams - ( potentialCusps, definiteCusps ) = + ( potentialCusps :: [Cusp], definiteCusps :: [Cusp] ) = case mbCuspOptions of - Just cuspOptions + Just ( cusp1Opts, cusp2Opts ) -- Don't try to compute cusps for a trivial curve -- (e.g. a line segment with identical start- and end-points), -- as the root isolation code chokes on this. @@ -617,19 +633,28 @@ outlineFunction rootAlgo mbCuspOptions ptParams toBrushParams -- TODO: introduce a maximum time budget for the cusp computation, -- and bail out if the computation exceeds the budget. -- (Record such bailing out and warn the user if this happens often.) + , let ( cornerCusps, normalCusps ) = findCusps ( cusp1Opts, cusp2Opts ) curvesI -> foldMap ( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = potCusps } ) ) -> - ( map ( ( i , ) . fst ) potCusps, map ( i , ) defCusps ) + ( map ( \ ( box, _ ) -> cornerCuspCoords ( fst . curves ) ( i, box ) ) potCusps + , map ( \ box -> cornerCuspCoords ( fst . curves ) ( i, box ) ) defCusps ) ) - ( IntMap.toList $ findCusps cuspOptions curvesI ) + ( IntMap.toList cornerCusps ) + <> + foldMap + ( \ ( i, ( _trees, DoneBoxes { doneSolBoxes = defCusps, doneGiveUpBoxes = potCusps } ) ) -> + ( map ( \ ( box, _ ) -> cuspCoords ( snd . curves ) ( i, box ) ) potCusps + , map ( \ box -> cuspCoords ( snd . curves ) ( i, box ) ) defCusps ) + ) + ( IntMap.toList normalCusps ) _ -> ( [], [] ) in OutlineInfo { outlineFn = fwdBwd - , outlineDefiniteCusps = map ( cuspCoords curves ) definiteCusps - , outlinePotentialCusps = map ( cuspCoords curves ) potentialCusps + , outlineDefiniteCusps = definiteCusps + , outlinePotentialCusps = potentialCusps } {-# INLINEABLE outlineFunction #-} @@ -648,15 +673,15 @@ pathAndUsedParams :: forall k i (nbUsedParams :: Nat) arr crvData ptData , Torsor ( T ( I i 2 ) ) ( I i 2 ) , Module ( I i Double ) ( T ( I i nbUsedParams ) ) , Torsor ( T ( I i nbUsedParams ) ) ( I i nbUsedParams ) - , Module Double ( T ( I ℝ nbUsedParams ) ) - , Torsor ( T ( ( I ℝ nbUsedParams ) ) ) ( I ℝ nbUsedParams ) + , Module Double ( T ( ℝ nbUsedParams ) ) + , Torsor ( T ( ( ℝ nbUsedParams ) ) ) ( ℝ nbUsedParams ) , Representable Double ( ℝ nbUsedParams ) , Representable 𝕀 ( 𝕀ℝ nbUsedParams ) ) => ( I i 1 -> I i Double ) - -> ( I ℝ 2 -> I i 2 ) - -> ( I ℝ nbUsedParams -> I i nbUsedParams ) - -> ( ptData -> I ℝ nbUsedParams ) + -> ( ℝ 2 -> I i 2 ) + -> ( ℝ nbUsedParams -> I i nbUsedParams ) + -> ( ptData -> ℝ nbUsedParams ) -> ptData -> Curve Open crvData ptData -> ( I i 1 `arr` I i 2, I i 1 `arr` I i nbUsedParams ) @@ -1004,15 +1029,19 @@ instance Applicative ZipSeq where liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys ) {-# INLINE liftA2 #-} -brushStrokeData :: forall {kd} (k :: Nat) (nbBrushParams :: Nat) (i :: kd) arr +brushStrokeData :: forall (k :: Nat) (nbBrushParams :: Nat) (i :: IVness) arr . ( arr ~ C k , HasBΓ©zier k i, HasEnvelopeEquation k , Differentiable k i nbBrushParams , HasChainRule ( I i Double ) k ( I i 1 ) + , HasChainRule 𝕀 k ( 𝕀ℝ nbBrushParams ) , Applicative ( D k 1 ) , Dim ( I i 1 ) ~ 1 , Dim ( I i nbBrushParams ) ~ nbBrushParams , Traversable ( D k nbBrushParams ) + , Traversable ( D k 1 ) + , Module ( D k 1 𝕀 ) ( D k 1 ( 𝕀ℝ 2 ) ) + , Transcendental ( D k 1 𝕀 ) , Transcendental ( I i Double ) , Module ( I i Double ) ( T ( I i 1 ) ) @@ -1020,88 +1049,161 @@ brushStrokeData :: forall {kd} (k :: Nat) (nbBrushParams :: Nat) (i :: kd) arr , Torsor ( T ( I i 2 ) ) ( I i 2 ) , Show ( ℝ nbBrushParams ) , Show ( StrokeDatum k i ) + , Show ( StrokeDatum k IsIV ) , Representable ( I i Double ) ( I i 2 ), RepDim ( I i 2 ) ~ 2 + ) - => ( I i Double -> I i 1 ) - -> ( I i 1 -> I i Double ) + => SingIVness i -> ( I i 1 `arr` I i 2 ) -- ^ path -> ( I i 1 `arr` I i nbBrushParams ) -- ^ brush parameters -> ( I i nbBrushParams `arr` Spline Closed () ( I i 2 ) ) -- ^ brush from parameters + -> ( Seq ( I i nbBrushParams `arr` Corner ( I i 2 ) ) ) + -- ^ brush corners from parameters -> ( Maybe ( I i nbBrushParams -> I i Double ) ) -- ^ rotation parameter - -> ( I i 1 -> Seq ( I i 1 -> StrokeDatum k i ) ) -brushStrokeData co1 co2 path params brush mbBrushRotation = + -> ( I i 1 -> ( Seq ( CornerStrokeDatum k i ), Seq ( I i 1 -> StrokeDatum k i ) ) ) +brushStrokeData ivness path params brush brushCorners mbBrushRotation = \ t -> let - dpath_t :: D k 1 ( I i 2 ) - !dpath_t = runD path t - dparams_t :: D k 1 ( I i nbBrushParams ) - !dparams_t = runD params t - dbrush_params :: D k nbBrushParams ( Spline Closed () ( I i 2 ) ) - !dbrush_params = runD brush $ value @( I i Double ) @k @( I i 1 ) dparams_t - splines :: Seq ( D k nbBrushParams ( I i 1 `arr` I i 2 ) ) - !splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns @k @i co2 ) dbrush_params - dbrushes_t :: Seq ( I i 1 -> D k 2 ( I i 2 ) ) - !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 dparams_t ) dbrushes_t + co :: I i 1 -> I i Double + !co = case ivness of + SNonIV -> coerce + SIsIV -> coerce + + dpath_t :: D k 1 ( I i 2 ) + !dpath_t = runD path t + dparams_t :: D k 1 ( I i nbBrushParams ) + !dparams_t = runD params t + brushParams :: I i nbBrushParams + !brushParams = value @k @1 dparams_t + dbrush_params :: D k nbBrushParams ( Spline Closed () ( I i 2 ) ) + !dbrush_params = runD brush brushParams + splines :: Seq ( D k nbBrushParams ( I i 1 `arr` I i 2 ) ) + !splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns @k @i co ) dbrush_params + dbrushes_t :: Seq ( I i 1 -> D k 2 ( I i 2 ) ) + !dbrushes_t = + force $ + fmap + ( fmap ( uncurryD @k ) + . ( \ db s -> fmap ( `runD` s ) db ) + . chain @( I i Double ) @k dparams_t + -- This is the crucial use of the chain rule. + ) + splines + + in ( brushCorners <&> \ cornerFn -> + let !dcorner = runD cornerFn brushParams + !corner = value @k @nbBrushParams dcorner + !dcornerPt = chain @_ @k dparams_t $ fmap cornerPoint dcorner + in mkCornerStrokeDatum dpath_t dparams_t corner dcornerPt + , fmap ( mkStrokeDatum dpath_t dparams_t . ) dbrushes_t ) + where mkStrokeDatum :: D k 1 ( I i 2 ) -> D k 1 ( I i nbBrushParams ) - -> ( I i 1 -> D k 2 ( I i 2 ) ) - -> ( I i 1 -> StrokeDatum k i ) - mkStrokeDatum dpath_t dparams_t dbrush_t s = - let dbrush_t_s = dbrush_t s - mbRotation = mbBrushRotation <&> \ getTheta -> fmap getTheta dparams_t - in envelopeEquation @k @i Proxy co1 dpath_t dbrush_t_s mbRotation -{-# INLINEABLE brushStrokeData #-} + -> D k 2 ( I i 2 ) + -> StrokeDatum k i + mkStrokeDatum dpath_t dparams_t dbrush_t = + let mbRotation = mbBrushRotation <&> \ getTheta -> fmap getTheta dparams_t + in envelopeEquation @k ivness dpath_t dbrush_t mbRotation -{- -{-# SPECIALISE brushStrokeData - :: ( 𝕀 -> ( 𝕀ℝ 1 ) ) - -> ( 𝕀ℝ 1 -> 𝕀 ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 1 ) ) - -> ( C 3 ( 𝕀ℝ 1 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) - -> ( Maybe ( 𝕀ℝ 1 -> 𝕀 ) ) - -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) + mkCornerStrokeDatum :: D k 1 ( I i 2 ) + -> D k 1 ( I i nbBrushParams ) + -> Corner ( I i 2 ) + -> D k 1 ( I i 2 ) + -> CornerStrokeDatum k i + mkCornerStrokeDatum dpath_t dparams_t corner dbrush_t = + let mbRotation = mbBrushRotation <&> \ getTheta -> fmap getTheta dparams_t + in CornerStrokeDatum + { dpath = dpath_t + , dbrush = dbrush_t + , corner + , stroke = unT $ + T ( value @k @1 dpath_t ) + ^+^ ( let b = T $ value @k @1 dbrush_t in case mbRotation of + Nothing -> b + Just dΞΈ -> let { ΞΈ = value @k @1 dΞΈ; cosΞΈ = Ring.cos ΞΈ; sinΞΈ = Ring.sin ΞΈ } in rotate cosΞΈ sinΞΈ b + ) + , mbRotation } + +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness NonIV + -> ( C 2 ( ℝ 1 ) ( ℝ 2 ) ) + -> ( C 2 ( ℝ 1 ) ( ℝ 1 ) ) + -> ( C 2 ( ℝ 1 ) ( Spline Closed () ( ℝ 2 ) ) ) + -> ( Seq ( C 2 ( ℝ 1 ) ( Corner ( ℝ 2 ) ) ) ) + -> ( Maybe ( ℝ 1 -> Double ) ) + -> ( ℝ 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) ) ) #-} -{-# SPECIALISE brushStrokeData - :: ( 𝕀 -> ( 𝕀ℝ 1 ) ) - -> ( 𝕀ℝ 1 -> 𝕀 ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) - -> ( C 3 ( 𝕀ℝ 2 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) - -> ( Maybe ( 𝕀ℝ 2 -> 𝕀) ) - -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness NonIV + -> ( C 2 ( ℝ 1 ) ( ℝ 2 ) ) + -> ( C 2 ( ℝ 1 ) ( ℝ 2 ) ) + -> ( C 2 ( ℝ 2 ) ( Spline Closed () ( ℝ 2 ) ) ) + -> ( Seq ( C 2 ( ℝ 2 ) ( Corner ( ℝ 2 ) ) ) ) + -> ( Maybe ( ℝ 2 -> Double ) ) + -> ( ℝ 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) ) ) #-} -{-# SPECIALISE brushStrokeData - :: ( 𝕀 -> ( 𝕀ℝ 1 ) ) - -> ( 𝕀ℝ 1 -> 𝕀 ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 3 ) ) - -> ( C 3 ( 𝕀ℝ 3 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) - -> ( Maybe ( 𝕀ℝ 3 -> 𝕀 ) ) - -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness NonIV + -> ( C 2 ( ℝ 1 ) ( ℝ 2 ) ) + -> ( C 2 ( ℝ 1 ) ( ℝ 3 ) ) + -> ( C 2 ( ℝ 3 ) ( Spline Closed () ( ℝ 2 ) ) ) + -> ( Seq ( C 2 ( ℝ 3 ) ( Corner ( ℝ 2 ) ) ) ) + -> ( Maybe ( ℝ 3 -> Double ) ) + -> ( ℝ 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) ) ) #-} -{-# SPECIALISE brushStrokeData - :: ( 𝕀 -> ( 𝕀ℝ 1 ) ) - -> ( 𝕀ℝ 1 -> 𝕀 ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) - -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 4 ) ) - -> ( C 3 ( 𝕀ℝ 4 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) - -> ( Maybe ( 𝕀ℝ 4 -> 𝕀 ) ) - -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness NonIV + -> ( C 2 ( ℝ 1 ) ( ℝ 2 ) ) + -> ( C 2 ( ℝ 1 ) ( ℝ 4 ) ) + -> ( C 2 ( ℝ 4 ) ( Spline Closed () ( ℝ 2 ) ) ) + -> ( Seq ( C 2 ( ℝ 4 ) ( Corner ( ℝ 2 ) ) ) ) + -> ( Maybe ( ℝ 4 -> Double ) ) + -> ( ℝ 1 -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) ) ) #-} --} --- TODO: these specialisations fire in the benchmarking code because --- we instantiate brushParams with ( ℝ nbBrushParams ), but they won't fire --- in the main app code because we are using types such as "Record EllipseBrushFields". +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness IsIV + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 1 ) ) + -> ( C 3 ( 𝕀ℝ 1 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) + -> ( Seq ( C 3 ( 𝕀ℝ 1 ) ( Corner ( 𝕀ℝ 2 ) ) ) ) + -> ( Maybe ( 𝕀ℝ 1 -> 𝕀 ) ) + -> ( 𝕀ℝ 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀ℝ 1 -> StrokeDatum 3 IsIV ) ) ) + #-} +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness IsIV + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) + -> ( C 3 ( 𝕀ℝ 2 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) + -> ( Seq ( C 3 ( 𝕀ℝ 2 ) ( Corner ( 𝕀ℝ 2 ) ) ) ) + -> ( Maybe ( 𝕀ℝ 2 -> 𝕀 ) ) + -> ( 𝕀ℝ 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀ℝ 1 -> StrokeDatum 3 IsIV ) ) ) + #-} +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness IsIV + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 3 ) ) + -> ( C 3 ( 𝕀ℝ 3 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) + -> ( Seq ( C 3 ( 𝕀ℝ 3 ) ( Corner ( 𝕀ℝ 2 ) ) ) ) + -> ( Maybe ( 𝕀ℝ 3 -> 𝕀 ) ) + -> ( 𝕀ℝ 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀ℝ 1 -> StrokeDatum 3 IsIV ) ) ) + #-} +{-# SPECIALISE INLINE brushStrokeData + :: SingIVness IsIV + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 ) ) + -> ( C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 4 ) ) + -> ( C 3 ( 𝕀ℝ 4 ) ( Spline Closed () ( 𝕀ℝ 2 ) ) ) + -> ( Seq ( C 3 ( 𝕀ℝ 4 ) ( Corner ( 𝕀ℝ 2 ) ) ) ) + -> ( Maybe ( 𝕀ℝ 4 -> 𝕀 ) ) + -> ( 𝕀ℝ 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀ℝ 1 -> StrokeDatum 3 IsIV ) ) ) + #-} + -------------------------------------------------------------------------------- -- Solving the envelolpe equation: root-finding. @@ -1113,6 +1215,11 @@ data RootSolvingAlgorithm -- | Use the modified Halley M2 method. | HalleyM2 { maxIters :: Word, precision :: Int } +data FwdBwd + = Fwd + | Bwd + deriving stock ( Eq, Show ) + -- | Solve the envelope equations at a given point \( t = t_0 \), to find -- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke. solveEnvelopeEquations :: RootSolvingAlgorithm @@ -1120,39 +1227,44 @@ solveEnvelopeEquations :: RootSolvingAlgorithm -> ℝ 2 -> T ( ℝ 2 ) -> ( Offset, Offset ) - -> Seq ( ℝ 1 -> StrokeDatum 2 ℝ ) + -> ( Seq ( CornerStrokeDatum 2 NonIV ), Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) ) -> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) ) -solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffset ) strokeData - = ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) ) +solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffset ) ( corners, strokeData ) + = ( fromMaybe fwdSol mbFwdCornerSol + , maybe ( bwdPt, -1 *^ bwdTgt ) ( \ ( pt, tgt ) -> ( pt, -1 *^ tgt ) ) mbBwdCornerSol + ) where - fwdSol = findSolFrom "fwd" fwdOffset - ( bwdPt, bwdTgt ) = findSolFrom "bwd" bwdOffset + fwdSol = findSolFrom Fwd fwdOffset + ( bwdPt, bwdTgt ) = findSolFrom Bwd bwdOffset - findSolFrom :: String -> Offset -> ( ℝ 2, T ( ℝ 2 ) ) - findSolFrom desc ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } ) + mbFwdCornerSol = getFirst $ foldMap ( First . cornerSol Fwd ) corners + mbBwdCornerSol = getFirst $ foldMap ( First . cornerSol Bwd ) corners + + findSolFrom :: FwdBwd -> Offset -> ( ℝ 2, T ( ℝ 2 ) ) + findSolFrom fwdOrBwd ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } ) = go ( fromIntegral i00 + fromMaybe 0.5 s00 ) where go :: Double -> ( ℝ 2, T ( ℝ 2 ) ) go is0 = - case sol desc strokeData is0 of + case sol fwdOrBwd strokeData is0 of ( goodSoln, pt, tgt ) | goodSoln -> ( pt, tgt ) | otherwise -> ( off β€’ path_t, path'_t ) - sol :: String -> Seq ( ℝ 1 -> StrokeDatum 2 ℝ ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) ) - sol desc f is0 = + sol :: FwdBwd -> Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) ) + sol fwdOrBwd f is0 = let ( solRes, _solSteps ) = runSolveMethod ( eqn f ) is0 ( good, is ) = case solRes of Nothing -> ( False, is0 ) - Just is1 -> ( if desc == "fwd" - then sgn >= 0 - else sgn <= 0 + Just is1 -> ( case fwdOrBwd of + Fwd -> sgn >= 0 + Bwd -> sgn <= 0 , is1 ) ( sgn, ds, dcdt ) = finish f is @@ -1164,7 +1276,7 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse NewtonRaphson { maxIters, precision } -> newtonRaphson maxIters precision domain - finish :: Seq ( ℝ 1 -> StrokeDatum 2 ℝ ) -> Double -> ( Double, ℝ 2, T ( ℝ 2 ) ) + finish :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> Double -> ( Double, ℝ 2, T ( ℝ 2 ) ) finish fs is = let (i, s) = fromDomain is in case evalStrokeDatum fs is of -- TODO: a bit redundant to have to compute this again... @@ -1192,21 +1304,67 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse let cosΞΈ = cos ΞΈ sinΞΈ = sin ΞΈ in rotate cosΞΈ sinΞΈ $ unrot_dcdt + -- TODO: reduce duplication with 'cornerSol'. in ( T u ^.^ T v, stroke, dcdt ) -- Compute the dot product of u and v (which are rotated versions of βˆ‚c/βˆ‚t and βˆ‚c/βˆ‚s). -- The sign of this quantity determines which side of the envelope -- we are on. - evalStrokeDatum :: Seq ( ℝ 1 -> StrokeDatum 2 ℝ ) -> ( Double -> StrokeDatum 2 ℝ ) + evalStrokeDatum :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> ( Double -> StrokeDatum 2 NonIV ) evalStrokeDatum fs is = let (i, s) = fromDomain is in ( fs `Seq.index` i ) ( ℝ1 $ max 1e-6 $ min (1 - 1e-6) $ s ) - eqn :: Seq ( ℝ 1 -> StrokeDatum 2 ℝ ) -> ( Double -> (# Double, Double #) ) + eqn :: Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) -> ( Double -> (# Double, Double #) ) eqn fs is = case evalStrokeDatum fs is of StrokeDatum { ee = D12 ee _ ee_s } -> coerce (# ee, ee_s #) + cornerSol :: FwdBwd -> CornerStrokeDatum 2 NonIV -> Maybe ( ℝ 2, T ( ℝ 2 ) ) + cornerSol fwdOrBwd + cornerDatum@( + CornerStrokeDatum + { dpath = _dp@( D21 p _ _ ) + , dbrush = D21 b _b_t _b_tt + , mbRotation + , corner = Corner _ startTgt endTgt } + ) + = + let D11 u _u_t = cornerStrokeDatum cornerDatum + flipWhenBwd = + case fwdOrBwd of + Fwd -> id + Bwd -> ( -1 *^ ) + b_s = flipWhenBwd ( T u ) + ori = CCW --case fwdOrBwd of { Fwd -> CCW ; Bwd -> CW } + res@( _pt, _tgt ) = case mbRotation of + Nothing -> ( unT $ T p ^+^ T b + , T u ) + Just ( D21 ΞΈ _ _ ) -> + let cosΞΈ = cos ΞΈ + sinΞΈ = sin ΞΈ + in ( unT $ T p ^+^ rotate cosΞΈ sinΞΈ ( T b ) + , rotate cosΞΈ sinΞΈ ( T u ) ) + in +{- + trace (unlines + [ "cornerSol" + , "fwdOrBwd: " ++ show fwdOrBwd + , "ori: " ++ show ori + , "dp: " ++ show _dp + , "startTgt: " ++ show startTgt + , "endTgt: " ++ show endTgt + , "u: " ++ show u + , "b_s: " ++ show b_s + , "ok: " ++ show ( between ori startTgt endTgt b_s ) + , "pt: " ++ show _pt + , "tgt: " ++ show _tgt + ]) $ +-} + if isNothing $ between ori startTgt endTgt b_s + then Nothing + else Just res + n :: Int n = Seq.length strokeData domain :: ( Double, Double ) @@ -1222,42 +1380,69 @@ solveEnvelopeEquations rootAlgo ( ℝ1 _t ) path_t path'_t ( fwdOffset, bwdOffse -- | Computes the brush stroke coordinates of a cusp from -- the @(t,s)@ parameter values. --- --- TODO: use Newton's method starting at the midpoint of the box, --- instead of just taking the midpoint of the box. -cuspCoords :: ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 ℝ ) ) +cuspCoords :: ( ℝ 1 -> Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) ) -> ( Int, Box N ) -> Cusp +-- TODO: use Newton's method starting at the midpoint of the box, +-- instead of just taking the midpoint of the box. cuspCoords eqs ( i, box ) | StrokeDatum { dpath, stroke } <- ( eqs ( ℝ1 t_mid ) `Seq.index` i ) ( ℝ1 s_mid ) = Cusp { cuspParameters = ℝ2 t_mid s_mid - , cuspPathCoords = coerce dpath - , cuspStrokeCoords = coerce stroke + , cuspPathCoords = dpath + , cuspStrokeCoords = stroke } where - 𝕀 t_lo t_hi = box `index` Fin 1 - 𝕀 s_lo s_hi = box `index` Fin 2 - t_mid = 0.5 * ( t_lo + t_hi ) - s_mid = 0.5 * ( s_lo + s_hi ) + t = box `index` Fin 1 + s = box `index` Fin 2 + t_mid = midpoint t + s_mid = midpoint s + +cornerCuspCoords :: ( ℝ 1 -> Seq ( CornerStrokeDatum 2 NonIV ) ) + -> ( Int, Box 1 ) + -> Cusp +-- TODO: use Newton's method. +cornerCuspCoords eqs ( i, box ) + | CornerStrokeDatum { dpath, stroke } <- eqs ( ℝ1 t_mid ) `Seq.index` i + = Cusp + { cuspParameters = ℝ2 t_mid 0 + , cuspPathCoords = dpath + , cuspStrokeCoords = stroke + } + where + t = box `index` Fin 1 + t_mid = midpoint t -- | Find cusps in the envelope for values of the parameters in -- \( 0 \leqslant t, s \leqslant 1 \), using interval arithmetic. -- -- See 'isolateRootsIn' for details of the algorithms used. findCusps - :: RootIsolationOptions N 3 - -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) - -> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], DoneBoxes N ) -findCusps opts boxStrokeData = - findCuspsIn opts boxStrokeData $ - IntMap.fromList - [ ( i, [ 𝕀ℝ2 ( 𝕀 zero one ) ( 𝕀 zero one ) ] ) - | i <- [ 0 .. length ( boxStrokeData ( 𝕀ℝ1 ( 𝕀 zero one ) ) ) - 1 ] - ] + :: ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) + -> ( 𝕀ℝ 1 -> ( Seq ( CornerStrokeDatum 3 IsIV ), Seq ( 𝕀ℝ 1 -> StrokeDatum 3 IsIV ) ) ) + -> ( IntMap ( [ ( Box 1, RootIsolationTree ( Box 1 ) ) ], DoneBoxes 1 ) + , IntMap ( [ ( Box 2, RootIsolationTree ( Box 2 ) ) ], DoneBoxes 2 ) + ) +findCusps ( opts1, opts2 ) boxStrokeData = + ( findCornerCuspsIn opts1 ( fst . boxStrokeData ) + ( IntMap.fromList + [ ( i, [ 𝕀ℝ1 unit ] ) + | i <- [ 0 .. length ( fst $ boxStrokeData ( 𝕀ℝ1 unit ) ) - 1 ] + ] + ) + , findCuspsIn opts2 ( snd . boxStrokeData ) + ( IntMap.fromList + [ ( i, [ 𝕀ℝ2 unit unit ] ) + | i <- [ 0 .. length ( snd $ boxStrokeData ( 𝕀ℝ1 unit ) ) - 1 ] + ] + ) + ) where + unit :: 𝕀 + unit = 𝕀 zero one + {-# INLINE unit #-} zero, one :: Double zero = 1e-6 one = 1 - zero @@ -1268,7 +1453,7 @@ findCusps opts boxStrokeData = -- root isolation method. findCuspsIn :: RootIsolationOptions N 3 - -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) + -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 IsIV ) ) -> IntMap [ Box 2 ] -> IntMap ( [ ( Box N, RootIsolationTree ( Box N ) ) ], DoneBoxes N ) findCuspsIn opts boxStrokeData initBoxes = @@ -1289,95 +1474,58 @@ findCuspsIn opts boxStrokeData initBoxes = ( T $ 𝕀ℝ3 ee_t f_t g_t ) ( T $ 𝕀ℝ3 ee_s f_s g_s ) -{- -findCuspsIn - :: RootIsolationOptions N 3 - -> ( 𝕀ℝ 1 -> Seq ( 𝕀ℝ 1 -> StrokeDatum 3 𝕀 ) ) - -> IntMap [ Box 2 ] - -> IntMap ( [ ( Box 3, RootIsolationTree ( Box 3 ) ) ], ( [ Box 3 ], [ Box 3 ] ) ) -findCuspsIn opts boxStrokeData initBoxes = - IntMap.mapWithKey ( \ i boxes -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) $ concatMap ( mkInitBox i ) boxes ) initBoxes +-- | Like 'findCuspsIn' but in the case that the envelope is traced out +-- by a brush corner. +findCornerCuspsIn + :: RootIsolationOptions 1 2 + -> ( 𝕀ℝ 1 -> Seq ( CornerStrokeDatum 3 IsIV ) ) + -> IntMap [ Box 1 ] + -> IntMap ( [ ( Box 1, RootIsolationTree ( Box 1 ) ) ], DoneBoxes 1 ) +findCornerCuspsIn opts boxStrokeData initBoxes = + IntMap.mapWithKey ( \ i -> foldMap ( isolateRootsIn opts ( eqnPiece i ) ) ) initBoxes where - mkInitBox :: Int -> Box 2 -> [ Box 3 ] - mkInitBox i ( 𝕀 ( ℝ2 t_lo s_lo ) ( ℝ2 t_hi s_hi ) ) = - let t = 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) - s = 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) - StrokeDatum - { 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 ) ) - , _D22_dy = T ( 𝕀 ( ℝ1 ee_s_lo ) ( ℝ1 ee_s_hi ) ) } - } = ( boxStrokeData t `Seq.index` i ) s - -- Ξ» = βˆ‚E/βˆ‚t / βˆ‚E/βˆ‚s - Ξ»1 = 𝕀 ee_t_lo ee_t_hi ⊘ 𝕀 ee_s_lo ee_s_hi - -- Ξ» = u / v - Ξ»2 = 𝕀 ux_lo ux_hi ⊘ 𝕀 vx_lo vx_hi - Ξ»3 = 𝕀 uy_lo uy_hi ⊘ 𝕀 vy_lo vy_hi - Ξ» = [ 𝕀 ( recip -0 ) ( recip 0 ) ] - `intersectMany` Ξ»1 - `intersectMany` Ξ»2 - `intersectMany` Ξ»3 - in - let boxes = [ 𝕀 ( ℝ3 t_lo s_lo Ξ»_lo ) ( ℝ3 t_hi s_hi Ξ»_hi ) - | 𝕀 Ξ»_lo' Ξ»_hi' <- Ξ» - , let Ξ»_lo = max Ξ»_lo' ( min ( Ξ»_hi' - 10 ) -100 ) - Ξ»_hi = min Ξ»_hi' ( max ( Ξ»_lo' + 10 ) 100 ) ] - in boxes - eqnPiece :: Int -> 𝕀 ( ℝ 3 ) -> D1𝔸3 ( 𝕀 ( ℝ 3 ) ) - eqnPiece i ( 𝕀 ( ℝ3 t_lo s_lo Ξ»_lo ) ( ℝ3 t_hi s_hi Ξ»_hi ) ) = - let t = 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) - s = 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) - Ξ» = 𝕀 Ξ»_lo Ξ»_hi + eqnPiece i ( 𝕀ℝ1 t ) = + let CornerStrokeDatum + { dpath = + D31 { _D31_dx = p' + , _D31_dxdx = p'' + } + , dbrush = + D31 { _D31_v = b + , _D31_dx = b' + , _D31_dxdx = b'' + } + , mbRotation + } = ( boxStrokeData ( 𝕀ℝ1 t ) `Seq.index` i ) + in case mbRotation of + Nothing -> + D11 ( unT $ p' ^+^ b' ) + ( p'' ^+^ b'' ) + Just ( D31 { _D31_v = ΞΈ, _D31_dx = T ΞΈ', _D31_dxdx = T ΞΈ'' } ) -> + let cosΞΈ = Ring.cos ΞΈ + sinΞΈ = Ring.sin ΞΈ + swap ( T ( 𝕀ℝ2 x y ) ) = T ( 𝕀ℝ2 -y x ) + rot = rotate cosΞΈ sinΞΈ + rot' = rot . swap + rot'' = rot . ( -1 *^ ) - StrokeDatum - { 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 } - } = ( boxStrokeData t `Seq.index` i ) s + in + -- TODO: I shouldn't have to do this by hand. + -- + -- c(t) = p(t) + rot(ΞΈ(t)) b(t) + -- + -- abbreviate; let R = rot(ΞΈ(t)), R'=rot'(ΞΈ(t)), ... + -- + -- c = p + R b + -- c' = p' + R b' + ΞΈ' R' b + -- c'' = p'' + R b'' + 2 ΞΈ' R' b' + ΞΈ'Β² R'' b + ΞΈ'' R' b + -- + D11 ( unT $ p' ^+^ rot b' ^+^ ( ΞΈ' *^ rot' ( T b ) ) ) + ( p'' ^+^ rot b'' + ^+^ ( 2 * ΞΈ' ) *^ rot' b' + ^+^ ( ΞΈ' Ring.^ 2 ) *^ rot'' ( T b ) + ^+^ ΞΈ'' *^ rot' ( T b ) + ) - -- Ξ» βˆ‚E/βˆ‚s - βˆ‚E/βˆ‚t = 0 - 𝕀 ( ℝ1 f1_lo ) ( ℝ1 f1_hi ) = unT $ Ξ» *^ T ee_s ^-^ T ee_t - 𝕀 ( ℝ1 f1_t_lo ) ( ℝ1 f1_t_hi ) = unT $ Ξ» *^ T ee_ts ^-^ T ee_tt - 𝕀 ( ℝ1 f1_s_lo ) ( ℝ1 f1_s_hi ) = unT $ Ξ» *^ T ee_ss ^-^ T ee_ts - 𝕀 ( ℝ1 f1_Ξ»_lo ) ( ℝ1 f1_Ξ»_hi ) = ee_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 ) ) - ( T $ 𝕀 ( ℝ3 f1_s_lo f2_s_lo f3_s_lo ) ( ℝ3 f1_s_hi f2_s_hi f3_s_hi ) ) - ( T $ 𝕀 ( ℝ3 f1_Ξ»_lo f2_Ξ»_lo f3_Ξ»_lo ) ( ℝ3 f1_Ξ»_hi f2_Ξ»_hi f3_Ξ»_hi ) ) - -intersectMany :: [𝕀] -> [𝕀] -> [𝕀] -intersectMany _ [] = [] -intersectMany is (j : js) = intersectOne is j ++ intersectMany is js - -intersectOne :: [ 𝕀 ] -> 𝕀 -> [ 𝕀 ] -intersectOne is i = concatMap ( intersect i ) is - -intersect :: 𝕀 -> 𝕀 -> [ 𝕀 ] -intersect ( 𝕀 lo1 hi1 ) ( 𝕀 lo2 hi2 ) - | lo > hi - = [ ] - | otherwise - = [ 𝕀 lo hi ] - where - lo = max lo1 lo2 - hi = min hi1 hi2 --} \ No newline at end of file + -- TODO: instead of c'(t) and c''(t), it might be simpler + -- to compute g(t) = rot(-ΞΈ(t)) c'(t) and g'(t)? diff --git a/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs b/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs index 52cca6f..931d147 100644 --- a/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs +++ b/brush-strokes/src/lib/Math/Bezier/Stroke/EnvelopeEquation.hs @@ -1,22 +1,25 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} module Math.Bezier.Stroke.EnvelopeEquation - ( StrokeDatum(..) + ( StrokeDatum(..), CornerStrokeDatum(..) , HasBΓ©zier(..) , HasEnvelopeEquation(..) + , cornerStrokeDatum ) where -- base import Prelude hiding ( Num(..), (^), pi, sin, cos ) +import Data.Coerce + ( coerce ) import Data.Kind ( Type, Constraint ) import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Proxy - ( Proxy(..) ) import GHC.TypeNats ( Nat, type (-) ) @@ -25,11 +28,13 @@ import Data.Act ( Torsor ((-->)) ) -- brush-strokes +import Calligraphy.Brushes + ( Corner ) import Math.Algebra.Dual import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Quadratic as Quadratic import Math.Differentiable - ( type I ) + ( I, IVness(..), SingIVness (..) ) import Math.Interval import Math.Linear import Math.Module @@ -41,7 +46,7 @@ import Math.Ring -- | The value and derivative of a brush stroke at a given coordinate -- \( (t, s) \), together with the value of the envelope equation at that -- point. -type StrokeDatum :: Nat -> k -> Type +type StrokeDatum :: Nat -> IVness -> Type data StrokeDatum k i = StrokeDatum { -- | Path \( p(t) \). @@ -62,7 +67,11 @@ data StrokeDatum k i -- | Envelope function -- - -- \[ E(t_0,s_0) = \left ( \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} \right )_{(t_0,s_0)}. \] + -- \[ \begin{align} E(t,s) &= \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} \\ + -- &= \left ( R(-\theta(t)) \frac{\partial c}{\partial t} \right ) \times \left ( R(-\theta(t)) \frac{\partial c}{\partial s} \right ) \\ + -- &= \left ( R(-\theta(t)) p'(t) + \theta'(t) S b(t,s) + \frac{\partial b}{\partial t} \right ) \times \frac{\partial b}{\partial s} \] + -- + -- where \( S \) denotes the 2D swap function \( S(x,y) = (y,x) \). , ee :: D ( k - 1 ) 2 ( I i 1 ) -- \[ \frac{\partial E}{\partial s} \frac{\mathrm{d} c}{\mathrm{d} t}, \] @@ -73,12 +82,43 @@ data StrokeDatum k i , 𝛿E𝛿sdcdt :: D ( k - 2 ) 2 ( T ( I i 2 ) ) } -deriving stock instance Show ( StrokeDatum 2 ℝ ) -deriving stock instance Show ( StrokeDatum 3 𝕀 ) +deriving stock instance + ( Show ( I i 2 ) + , Show ( D k 1 ( I i Double ) ) + , Show ( D k 1 ( I i 2 ) ) + , Show ( D k 2 ( I i 2 ) ) + , Show ( D ( k - 1 ) 2 ( I i 1 ) ) + , Show ( D ( k - 1 ) 2 ( I i 2 ) ) + , Show ( D ( k - 2 ) 2 ( T ( I i 2 ) ) ) + ) + => Show ( StrokeDatum k i ) + + +-- | A slimmed down version of 'StrokeDatum' for use at brush corners. +type CornerStrokeDatum :: Nat -> IVness -> Type +data CornerStrokeDatum k i + = CornerStrokeDatum + { -- | Path \( p(t) \). + dpath :: D k 1 ( I i 2 ) + -- | Brush shape \( b(t) \). + , dbrush :: D k 1 ( I i 2 ) + -- | (Optional) rotation angle \( \theta(t) \). + , mbRotation :: Maybe ( D k 1 ( I i Double ) ) + , corner :: Corner ( I i 2 ) + , stroke :: I i 2 + } + +deriving stock instance + ( Show ( I i Double ) + , Show ( I i 2 ) + , Show ( D k 1 ( I i Double ) ) + , Show ( D k 1 ( I i 2 ) ) + ) + => Show ( CornerStrokeDatum k i ) -------------------------------------------------------------------------------- -type HasBΓ©zier :: forall {t}. Nat -> t -> Constraint +type HasBΓ©zier :: Nat -> IVness -> Constraint class HasBΓ©zier k i where -- | Linear interpolation, as a differentiable function. @@ -112,8 +152,7 @@ class HasBΓ©zier k i where type HasEnvelopeEquation :: Nat -> Constraint class HasEnvelopeEquation k where - uncurryD :: Dim a ~ 1 - => D k 1 ( C k a b ) -> a -> D k 2 b + uncurryD :: D k 1 ( D k 1 b ) -> D k 2 b -- | The envelope function -- @@ -135,14 +174,13 @@ class HasEnvelopeEquation k where , Show ( StrokeDatum k i ) ) - => Proxy i - -> ( I i Double -> I i 1 ) + => SingIVness i -> D k 1 ( I i 2 ) -> D k 2 ( I i 2 ) -> Maybe ( D k 1 ( I i Double ) ) -> StrokeDatum k i -instance HasBΓ©zier 2 ℝ where +instance HasBΓ©zier 2 NonIV where line co ( Segment a b :: Segment b ) = D \ ( co -> t ) -> D21 ( lerp @( T b ) t a b ) @@ -169,7 +207,7 @@ instance HasEnvelopeEquation 2 where uncurryD = uncurryD2 {-# INLINEABLE uncurryD #-} - envelopeEquation ( _ :: Proxy i ) co + envelopeEquation ( ivness :: SingIVness i ) dp@( D21 ( T -> p ) p_t p_tt ) db@( D22 ( T -> b ) b_t b_s b_tt b_ts b_ss ) @@ -182,6 +220,10 @@ instance HasEnvelopeEquation 2 where , du, dv, ee, 𝛿E𝛿sdcdt } where + co :: I i Double -> I i 1 + co = case ivness of + SNonIV -> coerce + SIsIV -> coerce (ee, 𝛿E𝛿sdcdt) = let D12 (T -> u) u_t u_s = du @@ -250,7 +292,46 @@ instance HasEnvelopeEquation 2 where ) {-# INLINEABLE envelopeEquation #-} -instance HasBΓ©zier 3 ℝ where +-- | Computes \( u \) and \( u_t \), where \( u \) is as in 'StrokeDatum'. +cornerStrokeDatum + :: CornerStrokeDatum 2 NonIV + -> D 1 1 ( ℝ 2 ) +cornerStrokeDatum + CornerStrokeDatum + { dpath = D21 _ p_t p_tt + , dbrush = D21 ( T -> b ) b_t b_tt + , mbRotation } = + case mbRotation of + Nothing -> D11 ( unT $ p_t ^+^ b_t ) ( p_tt ^+^ b_tt ) + Just ( D21 ΞΈ ( T ΞΈ_t ) ( T ΞΈ_tt ) ) -> + let + rot, rot' :: T ( ℝ 2 ) -> T ( ℝ 2 ) + cosΞΈ = cos ΞΈ + sinΞΈ = sin ΞΈ + rot = rotate cosΞΈ -sinΞΈ + rot' = rotate sinΞΈ cosΞΈ + swap :: T ( ℝ 2 ) -> T ( ℝ 2 ) + swap ( T xy ) = + let x = xy `index` Fin 1 + y = xy `index` Fin 2 + in T $ tabulate \ case + Fin 1 -> -y + _ -> x + + u, u_t :: T ( ℝ 2 ) + u = rot p_t ^+^ ΞΈ_t *^ swap b ^+^ b_t + u_t = ( -ΞΈ_t *^ rot' p_t + ^+^ rot p_tt + ) + ^+^ + ( ΞΈ_tt *^ swap b + ^+^ ΞΈ_t *^ swap b_t + ) + ^+^ b_tt + + in D11 ( unT u ) u_t + +instance HasBΓ©zier 3 NonIV where line co ( Segment a b :: Segment b ) = D \ ( co -> t ) -> @@ -281,7 +362,7 @@ instance HasEnvelopeEquation 3 where uncurryD = uncurryD3 {-# INLINEABLE uncurryD #-} - envelopeEquation ( _ :: Proxy i ) co + envelopeEquation ( ivness :: SingIVness i ) dp@( D31 ( T -> p ) p_t p_tt p_ttt ) db@( D32 ( T -> b ) b_t b_s b_tt b_ts b_ss @@ -295,6 +376,10 @@ instance HasEnvelopeEquation 3 where , du, dv, ee, 𝛿E𝛿sdcdt } where + co :: I i Double -> I i 1 + co = case ivness of + SNonIV -> coerce + SIsIV -> coerce (ee, 𝛿E𝛿sdcdt) = let D22 (T -> u) u_t u_s u_tt u_ts u_ss = du @@ -400,7 +485,7 @@ instance HasEnvelopeEquation 3 where ) {-# INLINEABLE envelopeEquation #-} -instance HasBΓ©zier 3 𝕀 where +instance HasBΓ©zier 3 IsIV where line co ( Segment a b :: Segment b ) = D \ ( co -> t ) -> diff --git a/brush-strokes/src/lib/Math/Differentiable.hs b/brush-strokes/src/lib/Math/Differentiable.hs index 8196803..6fe1030 100644 --- a/brush-strokes/src/lib/Math/Differentiable.hs +++ b/brush-strokes/src/lib/Math/Differentiable.hs @@ -2,7 +2,9 @@ {-# LANGUAGE UndecidableInstances #-} module Math.Differentiable - ( I, Differentiable, DiffInterp ) + ( IVness(..), SingIVness(..) + , I, Differentiable, DiffInterp + ) where -- base @@ -23,17 +25,24 @@ import Math.Ring -------------------------------------------------------------------------------- +data IVness + = NonIV + | IsIV + +type SingIVness :: IVness -> Type +data SingIVness iv where + SNonIV :: SingIVness NonIV + SIsIV :: SingIVness IsIV + -- | Type family to parametrise over both pointwise and interval computations. --- --- Use 'ℝ' parameter for points, and '𝕀' parameter for intervals. -type I :: k -> l -> Type +type I :: forall l. IVness -> l -> Type type family I i t -type instance I @(Nat -> Type) @Type ℝ Double = Double -type instance I @Type @Type 𝕀 Double = 𝕀 -type instance I @(Nat -> Type) @Nat ℝ n = ℝ n -type instance I @Type @Nat 𝕀 n = 𝕀ℝ n +type instance I @Type NonIV Double = Double +type instance I @Type IsIV Double = 𝕀 +type instance I @Nat NonIV n = ℝ n +type instance I @Nat IsIV n = 𝕀ℝ n -type Differentiable :: Nat -> k -> Nat -> Constraint +type Differentiable :: Nat -> IVness -> Nat -> Constraint class ( Module ( I i Double ) ( T ( I i u ) ) , HasChainRule ( I i Double ) k ( I i u ) @@ -47,7 +56,7 @@ instance , Representable ( I i Double ) ( I i u ) ) => Differentiable k i u -type DiffInterp :: Nat -> k -> Nat -> Constraint +type DiffInterp :: Nat -> IVness -> Nat -> Constraint class ( Differentiable k i u , Interpolatable ( I i Double ) ( I i u ) diff --git a/brush-strokes/src/lib/Math/Interval.hs b/brush-strokes/src/lib/Math/Interval.hs index 46a587c..289b4bb 100644 --- a/brush-strokes/src/lib/Math/Interval.hs +++ b/brush-strokes/src/lib/Math/Interval.hs @@ -242,26 +242,15 @@ deriving via ( ViaModule 𝕀 ( 𝕀ℝ n ) ) -- HasChainRule instances. instance HasChainRule 𝕀 2 ( 𝕀ℝ 0 ) where - konst w = D0 w linearD f v = D0 ( f v ) - value ( D0 v ) = v chain _ ( D0 gfx ) = D21 gfx origin origin instance HasChainRule 𝕀 3 ( 𝕀ℝ 0 ) where - konst w = D0 w linearD f v = D0 ( f v ) - value ( D0 v ) = v chain _ ( D0 gfx ) = D31 gfx origin origin origin instance HasChainRule 𝕀 2 ( 𝕀ℝ 1 ) where - konst :: forall w. AbelianGroup w => w -> D2𝔸1 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 1 -> w ) -> 𝕀ℝ 1 -> D2𝔸1 w linearD f v = let !o = origin @𝕀 @( T w ) @@ -290,13 +279,6 @@ instance HasChainRule 𝕀 2 ( 𝕀ℝ 1 ) where instance HasChainRule 𝕀 3 ( 𝕀ℝ 1 ) where - konst :: forall w. AbelianGroup w => w -> D3𝔸1 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 1 -> w ) -> 𝕀ℝ 1 -> D3𝔸1 w linearD f v = let !o = origin @𝕀 @( T w ) @@ -325,13 +307,6 @@ instance HasChainRule 𝕀 3 ( 𝕀ℝ 1 ) where instance HasChainRule 𝕀 2 ( 𝕀ℝ 2 ) where - konst :: forall w. AbelianGroup w => w -> D2𝔸2 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 2 -> w ) -> 𝕀ℝ 2 -> D2𝔸2 w linearD f v = let !o = origin @𝕀 @( T w ) @@ -360,13 +335,6 @@ instance HasChainRule 𝕀 2 ( 𝕀ℝ 2 ) where instance HasChainRule 𝕀 3 ( 𝕀ℝ 2 ) where - konst :: forall w. AbelianGroup w => w -> D3𝔸2 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 2 -> w ) -> 𝕀ℝ 2 -> D3𝔸2 w linearD f v = let !o = origin @𝕀 @( T w ) @@ -395,13 +363,6 @@ instance HasChainRule 𝕀 3 ( 𝕀ℝ 2 ) where instance HasChainRule 𝕀 2 ( 𝕀ℝ 3 ) where - konst :: forall w. AbelianGroup w => w -> D2𝔸3 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 3 -> w ) -> 𝕀ℝ 3 -> D2𝔸3 w linearD f v = let !o = origin @𝕀 @( T w ) @@ -430,13 +391,6 @@ instance HasChainRule 𝕀 2 ( 𝕀ℝ 3 ) where instance HasChainRule 𝕀 3 ( 𝕀ℝ 3 ) where - konst :: forall w. AbelianGroup w => w -> D3𝔸3 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 3 -> w ) -> 𝕀ℝ 3 -> D3𝔸3 w linearD f v = let !o = origin @𝕀 @( T w ) @@ -465,13 +419,6 @@ instance HasChainRule 𝕀 3 ( 𝕀ℝ 3 ) where instance HasChainRule 𝕀 2 ( 𝕀ℝ 4 ) where - konst :: forall w. AbelianGroup w => w -> D2𝔸4 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 4 -> w ) -> 𝕀ℝ 4 -> D2𝔸4 w linearD f v = let !o = origin @𝕀 @( T w ) @@ -500,13 +447,6 @@ instance HasChainRule 𝕀 2 ( 𝕀ℝ 4 ) where instance HasChainRule 𝕀 3 ( 𝕀ℝ 4 ) where - konst :: forall w. AbelianGroup w => w -> D3𝔸4 w - konst w = - let !o = fromInteger @w 0 - in $$( monTabulateQ \ mon -> if isZeroMonomial mon then [|| w ||] else [|| o ||] ) - - value df = $$( monIndexQ [|| df ||] zeroMonomial ) - linearD :: forall w. Module 𝕀 ( T w ) => ( 𝕀ℝ 4 -> w ) -> 𝕀ℝ 4 -> D3𝔸4 w linearD f v = let !o = origin @𝕀 @( T w ) diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 61be6b5..bbea452 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -232,7 +232,10 @@ runApplication application = do NewtonRaphson { maxIters = 20, precision = 8 } cuspFindingOptionsTVar <- STM.newTVarIO $ - Just defaultRootIsolationOptions + Just + ( defaultRootIsolationOptions @1 @2 + , defaultRootIsolationOptions @2 @3 + ) -- Put all these stateful variables in a record for conciseness. let diff --git a/src/app/MetaBrush/Application/Context.hs b/src/app/MetaBrush/Application/Context.hs index 786615a..22e1b6a 100644 --- a/src/app/MetaBrush/Application/Context.hs +++ b/src/app/MetaBrush/Application/Context.hs @@ -115,19 +115,19 @@ data Variables , selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) ) - , mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) ) - , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) - , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) - , toolTVar :: !( STM.TVar Tool ) - , modeTVar :: !( STM.TVar Mode ) - , debugTVar :: !( STM.TVar Bool ) - , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) - , fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) ) - , showGuidesTVar :: !( STM.TVar Bool ) - , maxHistorySizeTVar :: !( STM.TVar Int ) - , fitParametersTVar :: !( STM.TVar FitParameters ) - , rootsAlgoTVar :: !( STM.TVar RootSolvingAlgorithm ) - , cuspFindingOptionsTVar :: !( STM.TVar ( Maybe ( RootIsolationOptions 2 3 ) ) ) + , mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) ) + , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) + , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) + , toolTVar :: !( STM.TVar Tool ) + , modeTVar :: !( STM.TVar Mode ) + , debugTVar :: !( STM.TVar Bool ) + , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) + , fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) ) + , showGuidesTVar :: !( STM.TVar Bool ) + , maxHistorySizeTVar :: !( STM.TVar Int ) + , fitParametersTVar :: !( STM.TVar FitParameters ) + , rootsAlgoTVar :: !( STM.TVar RootSolvingAlgorithm ) + , cuspFindingOptionsTVar :: !( STM.TVar ( Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) ) ) } -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index afbe667..a6c2792 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -148,7 +148,9 @@ blankRender _ = pure () getDocumentRender :: Colours - -> RootSolvingAlgorithm -> Maybe ( RootIsolationOptions 2 3 ) -> FitParameters + -> RootSolvingAlgorithm + -> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) + -> FitParameters -> Mode -> Bool -> Set Modifier -> Maybe ( ℝ 2 ) -> Maybe HoldAction -> Maybe PartialPath -> Document @@ -300,7 +302,7 @@ instance NFData StrokeRenderData where -- - Otherwise, this consists of the underlying spline path only. strokeRenderData :: RootSolvingAlgorithm - -> Maybe ( RootIsolationOptions 2 3 ) + -> Maybe ( RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) -> FitParameters -> Stroke -> ST RealWorld StrokeRenderData @@ -325,6 +327,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams -> do let embedUsedParams = inject2 $ MkR brush_defaults + -- Compute the outline using the brush function. ( outline, fitPts, cusps ) <- computeStrokeOutline @clo rootAlgo mbCuspOptions fitParams @@ -337,7 +340,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams , strokeBrushFunction = \ params -> let MkR brushParams = embedUsedParams $ toUsedParams params - shape = fun @Double brushBaseShape brushParams + shape = fun brushBaseShape brushParams -- TODO: remove this logic which is duplicated -- from elsewhere. The type should make it -- impossible to forget to apply the rotation. @@ -703,6 +706,17 @@ drawFitPoint _ ( Zoom { zoomFactor } ) ( FitPoint { fitPoint = ℝ2 x y } ) = do Cairo.fill Cairo.restore +drawFitPoint _ ( Zoom { zoomFactor } ) ( JoinPoint { joinPoint = ℝ2 x y } ) = lift do + + -- Draw a little white circle. + Cairo.save + Cairo.translate x y + Cairo.arc 0 0 ( 3 / zoomFactor ) 0 ( 2 * pi ) + Cairo.setSourceRGBA 255 255 255 0.9 + Cairo.setLineWidth ( 1 / zoomFactor ) + Cairo.stroke + Cairo.restore + drawFitPoint _ ( Zoom { zoomFactor } ) ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do hue <- get diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index 264672f..d55470a 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/src/metabrushes/MetaBrush/Brush.hs @@ -44,10 +44,12 @@ import qualified Data.Text as Text -- brush-strokes import Calligraphy.Brushes ( Brush(..) ) +import Math.Algebra.Dual + ( HasChainRule ) import Math.Differentiable - ( DiffInterp ) + ( DiffInterp, IVness(..) ) import Math.Interval - ( 𝕀 ) + ( 𝕀, 𝕀ℝ ) import Math.Linear -- MetaBrush @@ -78,13 +80,19 @@ type BrushFunction brushFields = type NamedBrush :: [ Symbol ] -> Type data NamedBrush brushFields where NamedBrush - :: forall brushFields - . ( KnownSymbols brushFields - , Representable Double ( ℝ ( Length brushFields ) ) - , DiffInterp 2 ℝ ( Length brushFields ) - , DiffInterp 3 𝕀 ( Length brushFields ) - , Show ( ℝ ( Length brushFields ) ) - , NFData ( ℝ ( Length brushFields ) ) + :: forall brushFields nbBrushFields + . ( nbBrushFields ~ Length brushFields + , KnownSymbols brushFields + , Representable Double ( ℝ nbBrushFields ) + , DiffInterp 2 NonIV nbBrushFields + , DiffInterp 3 IsIV nbBrushFields + + -- TODO: clean up this constraint? + , HasChainRule 𝕀 2 ( 𝕀ℝ nbBrushFields ) + + , Show ( ℝ nbBrushFields ) + , NFData ( ℝ nbBrushFields ) + ) => { brushName :: !Text , brushFunction :: !( BrushFunction brushFields ) @@ -122,8 +130,8 @@ class ( KnownSymbols pointFields, Typeable pointFields , NFData ( Record pointFields ) , Representable Double ( ℝ ( Length pointFields ) ) , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields - , DiffInterp 2 ℝ ( Length pointFields ) - , DiffInterp 3 𝕀 ( Length pointFields ) + , DiffInterp 2 NonIV ( Length pointFields ) + , DiffInterp 3 IsIV ( Length pointFields ) ) => PointFields pointFields where { } instance ( KnownSymbols pointFields, Typeable pointFields @@ -133,8 +141,8 @@ instance ( KnownSymbols pointFields, Typeable pointFields , NFData ( Record pointFields ) , Representable Double ( ℝ ( Length pointFields ) ) , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields - , DiffInterp 2 ℝ ( Length pointFields ) - , DiffInterp 3 𝕀 ( Length pointFields ) + , DiffInterp 2 NonIV ( Length pointFields ) + , DiffInterp 3 IsIV ( Length pointFields ) ) => PointFields pointFields where { } diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index 71ed4cd..4cfb242 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/src/metabrushes/MetaBrush/Records.hs @@ -55,7 +55,6 @@ import qualified Data.Text as Text -- MetaBrush import Math.Differentiable -import Math.Interval import Math.Linear import Math.Module ( Module ) @@ -146,8 +145,9 @@ intersect :: forall r1 r2 l1 l2 , Representable Double ( ℝ l2 ) , Show ( ℝ l1 ) , Show ( ℝ l2 ) - , Differentiable 2 ℝ l2 - , Differentiable 3 𝕀 l2 + , Differentiable 2 NonIV l2 + , Differentiable 2 IsIV l2 + , Differentiable 3 IsIV l2 ) => Intersection r1 r2 intersect @@ -178,8 +178,9 @@ data Intersection r1 r2 where , KnownSymbols r1r2 , Representable Double ( ℝ l12 ) , Show ( ℝ l12 ) - , Differentiable 2 ℝ l12 - , Differentiable 3 𝕀 l12 + , Differentiable 2 NonIV l12 + , Differentiable 2 IsIV l12 + , Differentiable 3 IsIV l12 ) => { project1 :: Record r1 -> Record r1r2 -- ^ project out fields present in both rows @@ -204,8 +205,9 @@ doIntersection => ( forall r1r2 l12. ( r1r2 ~ Intersect r1 r2 , KnownSymbols r1r2, l12 ~ Length r1r2 - , Differentiable 2 ℝ l12 - , Differentiable 3 𝕀 l12 + , Differentiable 2 NonIV l12 + , Differentiable 2 IsIV l12 + , Differentiable 3 IsIV l12 , Representable Double ( ℝ l12 ) , Show ( ℝ l12 ) ) @@ -304,17 +306,17 @@ type family Elem k ks where data Union r1 r2 where Union - :: forall r1r2_rocky r1 r2 l12_rocky - . ( l12_rocky ~ Length r1r2_rocky - , KnownSymbols r1r2_rocky - , Representable Double ( ℝ l12_rocky ) - , Show ( ℝ l12_rocky ) - , NFData ( ℝ l12_rocky ) - , DiffInterp 2 ℝ l12_rocky - , DiffInterp 3 𝕀 l12_rocky + :: forall r1r2 r1 r2 l12 + . ( l12 ~ Length r1r2 + , KnownSymbols r1r2 + , Representable Double ( ℝ l12 ) + , Show ( ℝ l12 ) + , NFData ( ℝ l12 ) + , DiffInterp 2 NonIV l12 + , DiffInterp 3 IsIV l12 ) => { unionWith :: ( Double -> Double -> Double ) - -> Record r1 -> Record r2 -> Record r1r2_rocky + -> Record r1 -> Record r2 -> Record r1r2 -- ^ union of two records } -> Union r1 r2 @@ -327,8 +329,8 @@ union :: forall r1 r2 l1 l2 , Show ( ℝ l1 ) , Show ( ℝ l2 ) , NFData ( ℝ l2 ) - , DiffInterp 2 ℝ l2 - , DiffInterp 3 𝕀 l2 + , DiffInterp 2 NonIV l2 + , DiffInterp 3 IsIV l2 ) => Union r1 r2 union @@ -380,8 +382,8 @@ doUnion ) => ( forall r1r2 l12. ( KnownSymbols r1r2, l12 ~ Length r1r2 - , DiffInterp 2 ℝ l12 - , DiffInterp 3 𝕀 l12 + , DiffInterp 2 NonIV l12 + , DiffInterp 3 IsIV l12 , Representable Double ( ℝ l12 ) , Show ( ℝ l12 ) , NFData ( ℝ l12 )