implement intervallic brushes

This commit is contained in:
sheaf 2023-01-13 23:10:06 +01:00
parent 09c1bdd948
commit 684550a795
11 changed files with 531 additions and 254 deletions

View file

@ -50,6 +50,8 @@ common common
^>= 0.3.1.0
, primitive
^>= 0.7.1.0
, rounded-hw
^>= 0.3
, transformers
^>= 0.5.6.2
@ -195,8 +197,6 @@ library splines
^>= 3.2.2.0
, prim-instances
^>= 0.2
, rounded-hw
^>= 0.3
, vector
>= 0.12.1.2 && < 0.14

View file

@ -19,6 +19,8 @@ import Data.Functor.Compose
( Compose(..) )
import Data.Int
( Int32 )
import GHC.Exts
( proxy# )
import GHC.Generics
( Generic, Generic1, Generically1(..) )
@ -72,13 +74,13 @@ import Math.Bezier.Stroke
, computeStrokeOutline
)
import Math.Linear
( (..), T(..) )
( (..), T(..), Extent(Point) )
import Math.Linear.Dual
( fun )
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Brush
( Brush(..) )
( Brush(..), WithParams(..) )
import MetaBrush.Context
( Modifier(..)
, HoldAction(..), PartialPath(..)
@ -285,7 +287,7 @@ strokeRenderData fitParams
, withParams = brushFn
} <- fn
-> -- This is the key place where we need to perform impedance matching
-- between the collection of parameters supplied along a strong and
-- between the collection of parameters supplied along a stroke and
-- the collection of parameters expected by the brush.
case intersect @pointFields @brushFields of
Intersection
@ -303,7 +305,9 @@ strokeRenderData fitParams
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = fun brushFn . fun embedUsedParams . toUsedParams
, strokeBrushFunction = fun ( brushFn @Point proxy# id )
. embedUsedParams
. toUsedParams
}
_ -> pure $
StrokeRenderData

View file

@ -98,7 +98,7 @@ type LocatedTrail' l = Diagrams.Located (Diagrams.Trail' l Linear.V2 Double)
data SomeSpline ptData where
SomeSpline :: KnownSplineType clo => Spline clo (CachedStroke RealWorld) ptData -> SomeSpline ptData
parseMetaFontPath :: Interpolatable ptParams => Text -> [ptParams] -> Either MetaFontError (SomeSpline (PointData ptParams))
parseMetaFontPath :: Interpolatable Double ptParams => Text -> [ptParams] -> Either MetaFontError (SomeSpline (PointData ptParams))
parseMetaFontPath pathText ptParams = do
locTrail <- Bi.first PathParseError $ MetaFont.fromString @LocatedTrail pathText
let
@ -110,7 +110,7 @@ parseMetaFontPath pathText ptParams = do
SomeSpline <$> trailToSpline @Diagrams.Loop ( Diagrams.Loc { Diagrams.loc = loc, Diagrams.unLoc = trail' } ) ptParams
trailToSpline :: forall l ptParams
. Interpolatable ptParams
. Interpolatable Double ptParams
=> LocatedTrail' l
-> [ptParams]
-> Either MetaFontError (Spline (Openness l) (CachedStroke RealWorld) (PointData ptParams))
@ -167,7 +167,7 @@ trailToSpline (Diagrams.Loc { Diagrams.loc = Linear.P ( Linear.V2 sx sy ), Diagr
go _ (_:_) [] = Left TooFewBrushParams
segmentToCurve :: forall c ptParams
. Interpolatable ptParams
. Interpolatable Double ptParams
=> PointData ptParams -- ^ start point
-> ptParams -- ^ parameters at end of curve
-> Diagrams.Segment c Linear.V2 Double

View file

@ -1,8 +1,13 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MetaBrush.Asset.Brushes where
-- base
import GHC.Exts
( Proxy# )
-- containers
import qualified Data.Sequence as Seq
( fromList )
@ -20,14 +25,14 @@ import qualified Data.HashMap.Strict as HashMap
-- MetaBrush
import Math.Bezier.Spline
import Math.Linear
( (..), Fin(..) )
import Math.Linear.Dual
( D, type (~>)(..), var, konst )
( D, type (~>)(..), Differentiable, Diffy(konst), var )
import Math.Module
( Module((^+^), (*^)) )
import MetaBrush.Brush
( Brush(..), SomeBrush(..) )
( Brush(..), SomeBrush(..), WithParams(..) )
import MetaBrush.Records
( Record(MkR) )
--------------------------------------------------------------------------------
@ -65,51 +70,62 @@ ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
--------------------------------------------------------------------------------
-- Differentiable brushes.
circleSpline :: Applicative ( D u ) => ( Double -> Double -> D u v ) -> D u ( Spline 'Closed () v )
circleSpline :: forall i u v
. Applicative ( D ( I i u ) )
=> ( Double -> Double -> D ( I i u ) ( I i v ) )
-> D ( I i u ) ( Spline 'Closed () ( I i v ) )
circleSpline p = sequenceA $
Spline { splineStart = p 1 0
, splineCurves = ClosedCurves crvs lastCrv }
where
crvs = Seq.fromList
[ Bezier3To (p 1 κ) (p κ 1) (NextPoint (p 0 1)) ()
, Bezier3To (p -κ 1) (p -1 κ) (NextPoint (p -1 0)) ()
, Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) ()
[ Bezier3To ( p 1 κ ) ( p κ 1 ) ( NextPoint (p 0 1) ) ()
, Bezier3To ( p -κ 1 ) ( p -1 κ ) ( NextPoint (p -1 0) ) ()
, Bezier3To ( p -1 -κ ) ( p -κ -1 ) ( NextPoint (p 0 -1) ) ()
]
lastCrv =
Bezier3To (p κ -1) (p 1 -κ) BackToStart ()
Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart ()
circleBrush :: Record CircleBrushFields ~> Spline 'Closed () ( 2 )
circleBrush =
circleBrush :: forall i
. ( Differentiable i ( Record CircleBrushFields ) )
=> Proxy# i
-> ( forall a. a -> I i a )
-> I i ( Record CircleBrushFields ) ~> Spline 'Closed () ( I i ( 2 ) )
circleBrush _ mkI =
D \ params ->
let r :: D ( Record CircleBrushFields ) Double
let r :: D ( I i ( Record CircleBrushFields ) ) ( I i Double )
r = runD ( var ( Fin 1## ) ) params
mkPt :: Double -> Double -> D ( Record CircleBrushFields ) ( 2 )
mkPt :: Double -> Double -> D ( I i ( Record CircleBrushFields ) ) ( I i ( 2 ) )
mkPt ( kon -> x ) ( kon -> y )
= ( x * r ) *^ e_x
^+^ ( y * r ) *^ e_y
in circleSpline @( Record CircleBrushFields ) mkPt
in circleSpline @i @( Record CircleBrushFields ) @( 2 ) mkPt
where
e_x, e_y :: D ( Record CircleBrushFields ) ( 2 )
e_x = pure $ 2 1 0
e_y = pure $ 2 0 1
e_x, e_y :: D ( I i ( Record CircleBrushFields ) ) ( I i ( 2 ) )
e_x = pure $ mkI $ 2 1 0
e_y = pure $ mkI $ 2 0 1
kon = konst @Double @( Record CircleBrushFields )
kon = konst @( I i Double ) @( I i ( Record CircleBrushFields ) ) . mkI
ellipseBrush :: Record EllipseBrushFields ~> Spline 'Closed () ( 2 )
ellipseBrush =
ellipseBrush :: forall i
. ( Differentiable i ( Record EllipseBrushFields ) )
=> Proxy# i
-> ( forall a. a -> I i a )
-> I i ( Record EllipseBrushFields ) ~> Spline 'Closed () ( I i ( 2 ) )
ellipseBrush _ mkI =
D \ params ->
let a, b, phi :: D ( Record EllipseBrushFields ) Double
let a, b, phi :: D ( I i ( Record EllipseBrushFields ) ) ( I i Double )
a = runD ( var ( Fin 1## ) ) params
b = runD ( var ( Fin 2## ) ) params
phi = runD ( var ( Fin 3## ) ) params
mkPt :: Double -> Double -> D ( Record EllipseBrushFields ) ( 2 )
mkPt :: Double -> Double -> D ( I i ( Record EllipseBrushFields ) ) ( I i ( 2 ) )
mkPt ( kon -> x ) ( kon -> y )
= ( x * a * cos phi - y * b * sin phi ) *^ e_x
^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y
in circleSpline @( Record EllipseBrushFields ) mkPt
in circleSpline @i @( Record EllipseBrushFields ) @( 2 ) mkPt
where
e_x, e_y :: D ( Record EllipseBrushFields ) ( 2 )
e_x = pure $ 2 1 0
e_y = pure $ 2 0 1
e_x, e_y :: D ( I i ( Record EllipseBrushFields ) ) ( I i ( 2 ) )
e_x = pure $ mkI $ 2 1 0
e_y = pure $ mkI $ 2 0 1
kon = konst @Double @( Record EllipseBrushFields )
kon = konst @( I i Double ) @( I i ( Record EllipseBrushFields ) ) . mkI

View file

@ -4,7 +4,8 @@
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Brush
( Brush(..), SomeBrush(..), BrushFunction
( WithParams(..)
, Brush(..), SomeBrush(..), BrushFunction
, PointFields, provePointFields, duplicates
)
where
@ -39,32 +40,45 @@ import qualified Data.Text as Text
-- MetaBrush
import Math.Linear
( , Representable )
( , type I, Extent(Point, Interval) )
import Math.Linear.Dual
( Diffy )
import Math.Module
( Interpolatable )
( type (~>), Differentiable )
import Math.Bezier.Spline
( SplineType(Closed), SplinePts)
( SplineType(Closed), Spline )
import MetaBrush.Records
( KnownSymbols, Length, Record, WithParams )
( KnownSymbols, Length, Record )
import MetaBrush.Serialisable
( Serialisable )
--------------------------------------------------------------------------------
-- | A differentiable function from a given record type,
-- with provided default values that can be overridden.
type WithParams :: [ Symbol ] -> ( Type -> Type ) -> Type
data WithParams params f =
WithParams
{ defaultParams :: Record params
, withParams :: forall i
. ( Differentiable i ( Record params ) )
=> Proxy# i
-> ( forall a. a -> I i a )
-> I i ( Record params ) ~> f ( I i ( 2 ) )
}
--------------------------------------------------------------------------------
-- | A brush function: a function from a record of parameters to a closed spline.
type BrushFunction :: [ Symbol ] -> Type
type BrushFunction brushFields = WithParams brushFields ( SplinePts Closed )
type BrushFunction brushFields = WithParams brushFields ( Spline Closed () )
type Brush :: [ Symbol ] -> Type
data Brush brushFields where
BrushData
:: forall brushFields
. ( KnownSymbols brushFields
, Representable Double ( ( Length brushFields) )
, Diffy Double ( ( Length brushFields) )
, Typeable brushFields )
. ( KnownSymbols brushFields, Typeable brushFields
, Differentiable Point ( ( Length brushFields ) )
, Differentiable Interval ( ( Length brushFields ) )
)
=> { brushName :: !Text
, brushFunction :: BrushFunction brushFields
}
@ -97,16 +111,16 @@ class ( KnownSymbols pointFields, Typeable pointFields
, Serialisable ( Record pointFields )
, Show ( Record pointFields )
, NFData ( Record pointFields )
, Interpolatable ( Record pointFields )
, Representable Double ( ( Length pointFields ) )
, Differentiable Point ( ( Length pointFields ) )
, Differentiable Interval ( ( Length pointFields ) )
)
=> PointFields pointFields where { }
instance ( KnownSymbols pointFields, Typeable pointFields
, Serialisable ( Record pointFields )
, Show ( Record pointFields )
, NFData ( Record pointFields )
, Interpolatable ( Record pointFields )
, Representable Double ( ( Length pointFields ) )
, Differentiable Point ( ( Length pointFields ) )
, Differentiable Interval ( ( Length pointFields ) )
)
=> PointFields pointFields where { }

View file

@ -85,7 +85,7 @@ subdivide c doc@( Document { zoomFactor } ) =
where
updateSpline
:: forall clo brushParams
. ( KnownSplineType clo, Interpolatable brushParams )
. ( KnownSplineType clo, Interpolatable Double brushParams )
=> StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams )
updateSpline spline@( Spline { splineStart } )
| not strokeVisible

View file

@ -41,6 +41,12 @@ import Control.DeepSeq
import Data.Group
( Group(..) )
-- rounded-hw
import Numeric.Rounded.Hardware
( Rounded(..) )
import Numeric.Rounded.Hardware.Interval.NonEmpty
( Interval(..) )
-- text
import Data.Text
( Text )
@ -50,18 +56,9 @@ import qualified Data.Text as Text
-- MetaBrush
import Math.Linear
import Math.Linear.Dual
( type (~>)(..), D, Diffy, Differentiable )
import Math.Module
--------------------------------------------------------------------------------
-- | A function from a given record type, with provided default values
-- that can be overridden.
type WithParams :: [ Symbol ] -> Type -> Type
data WithParams params a =
WithParams
{ defaultParams :: Record params
, withParams :: Record params ~> a
}
( Module )
--------------------------------------------------------------------------------
@ -107,6 +104,19 @@ deriving via ( T ( ( Length ks ) ) )
instance Module Double ( T ( ( Length ks ) ) )
=> Module Double ( T ( Record ks ) )
deriving via ( T ( 𝕀 ( Length ks ) ) )
instance Semigroup ( T ( 𝕀 ( Length ks ) ) )
=> Semigroup ( T ( 𝕀 ( Record ks ) ) )
deriving via ( T ( 𝕀 ( Length ks ) ) )
instance Monoid ( T ( 𝕀 ( Length ks ) ) )
=> Monoid ( T ( 𝕀 ( Record ks ) ) )
deriving via ( T ( 𝕀 ( Length ks ) ) )
instance Group ( T ( 𝕀 ( Length ks ) ) )
=> Group ( T ( 𝕀 ( Record ks ) ) )
deriving via ( T ( 𝕀 ( Length ks ) ) )
instance Module ( 𝕀 Double ) ( T ( 𝕀 ( Length ks ) ) )
=> Module ( 𝕀 Double ) ( T ( 𝕀 ( Record ks ) ) )
instance ( Act ( T ( ( Length ks ) ) ) ( ( Length ks ) )
, Semigroup ( T ( ( Length ks ) ) ) )
=> Act ( T ( Record ks ) ) ( Record ks ) where
@ -116,12 +126,34 @@ instance ( Torsor ( T ( ( Length ks ) ) ) ( ( Length ks ) )
=> Torsor ( T ( Record ks ) ) ( Record ks ) where
MkR g --> MkR a = T $ MkR $ unT $ g --> a
instance ( Act ( T ( 𝕀 ( Length ks ) ) ) ( 𝕀 ( Length ks ) )
, Semigroup ( T ( 𝕀 ( Length ks ) ) ) )
=> Act ( T ( 𝕀 ( Record ks ) ) ) ( 𝕀 ( Record ks ) ) where
T ( I ( Rounded ( MkR g_lo ) ) ( Rounded ( MkR g_hi ) ) )
I ( Rounded ( MkR a_lo ) ) ( Rounded ( MkR a_hi ) )
= case T ( I ( Rounded g_lo ) ( Rounded g_hi ) ) I ( Rounded a_lo ) ( Rounded a_hi ) of
I ( Rounded b_lo ) ( Rounded b_hi ) ->
I ( Rounded ( MkR b_lo ) ) ( Rounded ( MkR b_hi ) )
instance ( Torsor ( T ( 𝕀 ( Length ks ) ) ) ( 𝕀 ( Length ks ) )
, Group ( T ( 𝕀 ( Length ks ) ) ) )
=> Torsor ( T ( 𝕀 ( Record ks ) ) ) ( 𝕀 ( Record ks ) ) where
I ( Rounded ( MkR a_lo ) ) ( Rounded ( MkR a_hi ) )
--> I ( Rounded ( MkR b_lo ) ) ( Rounded ( MkR b_hi ) )
= case I ( Rounded a_lo ) ( Rounded a_hi ) --> I ( Rounded b_lo ) ( Rounded b_hi ) of
T ( I ( Rounded c_lo ) ( Rounded c_hi ) ) ->
T ( I ( Rounded ( MkR c_lo ) ) ( Rounded ( MkR c_hi ) ) )
deriving newtype
instance Representable r ( ( Length ks ) )
=> Representable r ( Record ks )
type instance D ( Record ks ) = D ( ( Length ks ) )
deriving newtype instance Diffy Double ( ( Length ks ) ) => Diffy Double ( Record ks )
deriving newtype instance Diffy Double ( ( Length ks ) )
=> Diffy Double ( Record ks )
deriving via 𝕀 ( Length ks )
instance Diffy ( 𝕀 Double ) ( 𝕀 ( Length ks ) )
=> Diffy ( 𝕀 Double ) ( 𝕀 ( Record ks ) )
--------------------------------------------------------------------------------
@ -148,23 +180,24 @@ intersect :: forall r1 r2 l1 l2
. ( Typeable r1, Typeable r2
, KnownSymbols r1, KnownSymbols r2
, l1 ~ Length r1, l2 ~ Length r2
, Representable Double ( l1 ), Representable Double ( l2 )
, Interpolatable ( Record r1 ), Diffy Double ( l2 )
, Representable Double ( l1 )
, Differentiable 'Point ( l2 )
, Differentiable 'Interval ( l2 )
)
=> Intersection r1 r2
intersect
-- Shortcut when the two rows are equal.
| Just Refl <- eqT @r1 @r2
, Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
= Intersection { project = id, inject = \ _ -> linear id }
= Intersection { project = id, inject = \ _ -> id }
| otherwise
= doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
let
project :: Record r1 -> Record r1r2
project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
inject :: Record r2 -> Record r1r2 ~> Record r2
inject = \ ( MkR r2 ) -> linear \ ( MkR r1r2 ) -> MkR $ injection ( find eqFin r2_idxs ) r1r2 r2
inject :: Record r2 -> Record r1r2 -> Record r2
inject = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( find eqFin r2_idxs ) r1r2 r2
in Intersection { project, inject }
data Intersection r1 r2 where
@ -172,12 +205,15 @@ data Intersection r1 r2 where
:: forall r1r2 r1 r2 l12
. ( l12 ~ Length r1r2
, KnownSymbols r1r2
, Representable Double ( l12 )
, Diffy Double ( l12 )
, Interpolatable ( Record r1r2 ) )
, Differentiable 'Point ( l12 )
, Differentiable 'Interval ( l12 )
)
=> { project :: Record r1 -> Record r1r2
, inject :: Record r2 -> Record r1r2 ~> Record r2
-- ^ project out fields present in both rows
-- (linear non-decreasing mapping)
, inject :: Record r2 -> Record r1r2 -> Record r2
-- ^ overrides the components of the first record with the second
-- (linear non-decreasing mapping in its second argument)
} -> Intersection r1 r2
{-# INLINE doIntersection #-}
@ -185,13 +221,13 @@ doIntersection
:: forall r1 r2 l1 l2 kont
. ( KnownSymbols r1, KnownSymbols r2
, l1 ~ Length r1, l2 ~ Length r2
, Representable Double ( l1 ), Representable Double ( l2 )
, Representable Double ( l1 )
, Representable Double ( l2 )
)
=> ( forall r1r2 l12.
( r1r2 ~ Intersect r1 r2, l12 ~ Length r1r2
, Representable Double ( l12 ), Diffy Double ( l12 )
, Interpolatable ( l12 )
, KnownSymbols r1r2, Representable Double ( ( Length r1r2 ) )
( r1r2 ~ Intersect r1 r2, KnownSymbols r1r2, l12 ~ Length r1r2
, Differentiable 'Point ( l12 )
, Differentiable 'Interval ( l12 )
)
=> Proxy# r1r2 -> Vec l12 ( Fin l1 ) -> Vec l12 ( Fin l2 ) -> kont )
-> kont

View file

@ -1,4 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
@ -36,14 +37,14 @@ import Data.Foldable
( for_ )
import Data.Functor.Identity
( Identity(..) )
import Data.Kind
( Type )
import Data.List.NonEmpty
( unzip )
import Data.Maybe
( fromMaybe, isJust, listToMaybe, mapMaybe )
import GHC.Exts
( newMutVar#, runRW# )
( newMutVar#, runRW#
, Proxy#, proxy#
)
import GHC.STRef
( STRef(..), readSTRef, writeSTRef )
import GHC.Generics
@ -182,18 +183,30 @@ type OutlineFn = 1 -> ( ( 2, T ( 2 ) ), ( 2, T ( 2 ) ) )
computeStrokeOutline ::
forall ( clo :: SplineType ) usedParams brushParams crvData ptData s
. ( KnownSplineType clo
, Interpolatable usedParams
, Diffy Double usedParams, Diffy Double brushParams
, HasType ( 2 ) ptData
, HasType ( CachedStroke s ) crvData
, NFData ptData, NFData crvData
-- Differentiability.
, Differentiable 'Point brushParams
, Differentiable 'Interval brushParams
, Interpolatable Double usedParams
, Interpolatable ( 𝕀 Double ) ( 𝕀 usedParams )
, Diffy Double usedParams
, Diffy ( 𝕀 Double ) ( 𝕀 usedParams )
-- Debugging.
, Show ptData, Show brushParams
)
=> FitParameters
-> ( ptData -> usedParams )
-> ( usedParams ~> brushParams )
-> ( brushParams ~> SplinePts Closed )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
-> ( forall i. Differentiable i brushParams
=> Proxy# i
-> ( forall a. a -> I i a )
-> I i brushParams ~> Spline Closed () ( I i ( 2 ) )
)
-> Spline clo crvData ptData
-> ST s
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
@ -303,7 +316,7 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
outlineFunction ptParams toBrushParams brushFn p0 crv :<| go ( openCurveEnd crv ) crvs
brushShape :: ptData -> SplinePts Closed
brushShape pt = fun brushFn $ fun toBrushParams $ ptParams pt
brushShape pt = fun ( brushFn @Point proxy# id ) $ toBrushParams $ ptParams pt
updateSpline :: ( T ( 2 ), T ( 2 ), T ( 2 ) ) -> ST s OutlineData
updateSpline ( lastTgt, lastTgtFwd, lastTgtBwd )
@ -415,36 +428,71 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
-- | Computes the forward and backward stroke outline functions for a single curve.
outlineFunction
:: forall usedParams brushParams crvData ptData
. ( Interpolatable usedParams
, Diffy Double usedParams, Diffy Double brushParams
, HasType ( 2 ) ptData
. ( HasType ( 2 ) ptData
-- Differentiability.
, Differentiable 'Point brushParams
, Differentiable 'Interval brushParams
, Interpolatable Double usedParams
, Interpolatable ( 𝕀 Double ) ( 𝕀 usedParams )
, Diffy Double usedParams
, Diffy ( 𝕀 Double ) ( 𝕀 usedParams )
-- Debugging.
, Show ptData, Show brushParams
)
=> ( ptData -> usedParams )
-> ( usedParams ~> brushParams )
-> ( brushParams ~> SplinePts Closed )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
-> ( forall i. Differentiable i brushParams
=> Proxy# i
-> ( forall a. a -> I i a )
-> I i brushParams ~> Spline Closed () ( I i ( 2 ) )
)
-> ptData
-> Curve Open crvData ptData
-> OutlineFn
outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
let
usedParams :: 1 ~> usedParams
path :: 1 ~> 2
( path, usedParams ) =
pathAndUsedParams :: forall i
. ( D ( I i ( 1 ) ) ~ D ( 1 )
, Coercible ( I i ( 1 ) ) ( I i Double )
, Module ( I i Double ) ( T ( I i ( 2 ) ) )
, Torsor ( T ( I i ( 2 ) ) ) ( I i ( 2 ) )
, Module ( I i Double ) ( T ( I i usedParams ) )
, Torsor ( T ( I i usedParams ) ) ( I i usedParams )
)
=> ( forall a. a -> I i a )
-> ( I i ( 1 ) ~> I i ( 2 ), I i ( 1 ) ~> I i usedParams )
pathAndUsedParams toI =
case crv of
LineTo { curveEnd = NextPoint sp1 }
| let seg = Segment sp0 sp1
-> ( line @Point ( fmap coords seg )
, line @Point ( fmap ptParams seg ) )
-> ( line @i ( fmap ( toI . coords ) seg )
, line @i ( fmap ( toI . ptParams ) seg ) )
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
| let bez2 = Quadratic.Bezier sp0 sp1 sp2
-> ( bezier2 @Point ( fmap coords bez2 )
, bezier2 @Point ( fmap ptParams bez2 ) )
-> ( bezier2 @i ( fmap ( toI . coords ) bez2 )
, bezier2 @i ( fmap ( toI . ptParams ) bez2 ) )
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
| let bez3 = Cubic.Bezier sp0 sp1 sp2 sp3
-> ( bezier3 @Point ( fmap coords bez3 )
, bezier3 @Point ( fmap ptParams bez3 ) )
-> ( bezier3 @i ( fmap ( toI . coords ) bez3 )
, bezier3 @i ( fmap ( toI . ptParams ) bez3 ) )
usedParams :: 1 ~> usedParams
path :: 1 ~> 2
( path, usedParams ) = pathAndUsedParams @Point id
{-
curvesI :: 𝕀 1 -> Seq ( 𝕀 1 -> StrokeDatum 'Interval )
curvesI = brushStrokeData @'Interval @brushParams
pathI
( usedParamsI `chainRule` linear ( nonDecreasing toBrushParams ) )
( brushFromParams @'Interval proxy# singleton )
usedParamsI :: 𝕀 1 ~> 𝕀 usedParams
pathI :: 𝕀 1 ~> 𝕀 2
( pathI, usedParamsI ) = pathAndUsedParams @'Interval singleton
-}
fwdBwd :: OutlineFn
fwdBwd t
@ -456,8 +504,8 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
curves :: Seq ( 1 -> StrokeDatum Point )
curves = brushStrokeData @Point @brushParams
path
( usedParams `chainRule` toBrushParams )
brushFromParams
( usedParams `chainRule` linear toBrushParams )
( brushFromParams @Point proxy# id )
t
fwdOffset = withTangent path'_t brush_t
@ -466,8 +514,8 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
D1 path_t path'_t _ = runD path t
D1 params_t _ _ = runD usedParams t
brush_t = value @Double @brushParams
$ runD brushFromParams
$ fun toBrushParams params_t
$ runD ( brushFromParams @Point proxy# id )
$ toBrushParams params_t
in fwdBwd
@ -1075,14 +1123,5 @@ data StrokeDatum i
}
deriving stock instance Show ( StrokeDatum Point )
deriving stock instance Show ( StrokeDatum Interval )
-- Handling points and intervals uniformly.
data Extent = Point | Interval
type I :: Extent -> Type -> Type
type family I i a where
I Point a = a
I Interval a = 𝕀 a
deriving stock instance Show ( StrokeDatum 'Point )
deriving stock instance Show ( StrokeDatum 'Interval )

View file

@ -1,7 +1,8 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnliftedNewtypes #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnliftedNewtypes #-}
module Math.Linear
( -- * Points and vectors
@ -10,14 +11,18 @@ module Math.Linear
-- * Points and vectors (second version)
, (..), T(.., V2, V3)
, Fin(..), eqFin, MFin(..)
, Dim, Representable(..), injection, projection
, Dim, Representable(..), ApRep(..)
, injection, projection
, Vec(..), (!), find
-- * Intervals
, 𝕀, 𝕀
, 𝕀, 𝕀, singleton, nonDecreasing
, Extent(..), I
) where
-- base
import Data.Coerce
( Coercible, coerce )
import Data.Kind
( Type, Constraint )
import Data.Monoid
@ -48,8 +53,12 @@ import Data.Group.Generics
( )
-- rounded-hw
import Numeric.Rounded.Hardware
( Rounded(..) )
import Numeric.Rounded.Hardware.Interval.NonEmpty
( Interval )
( Interval(..) )
import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as Interval
( sup, inf )
--------------------------------------------------------------------------------
@ -90,11 +99,36 @@ data instance 3 = 3 {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-#
deriving anyclass NFData
deriving stock ( Show, Eq, Ord )
deriving via ApRep ( Sum Double ) ( n )
instance Representable Double ( n ) => Semigroup ( T ( n ) )
deriving via ApRep ( Sum Double ) ( n )
instance Representable Double ( n ) => Monoid ( T ( n ) )
deriving via ApRep ( Sum Double ) ( n )
instance Representable Double ( n ) => Group ( T ( n ) )
deriving via ApRep Double ( n )
instance Representable Double ( n ) => Act ( T ( n ) ) ( n )
deriving via ApRep Double ( n )
instance Representable Double ( n ) => Torsor ( T ( n ) ) ( n )
-- | Tangent space to Euclidean space.
type T :: Type -> Type
newtype T e = T { unT :: e }
deriving stock ( Eq, Functor, Foldable, Traversable )
deriving newtype NFData -- newtype Show instance for debugging...
deriving newtype NFData
instance Semigroup ( T Double ) where
(<>) = coerce ( (+) @Double )
instance Monoid ( T Double ) where
mempty = T 0
instance Group ( T Double ) where
invert ( T x ) = T ( negate x )
instance Act ( T Double ) Double where
T u v = u + v
instance Torsor ( T Double ) Double where
a --> b = T ( b - a )
instance {-# OVERLAPPING #-} Show ( n ) => Show ( T ( n ) ) where
show ( T p ) = "V" ++ drop 1 ( show p )
@ -104,14 +138,6 @@ instance Applicative T where
pure = T
T f <*> T a = T ( f a )
instance Semigroup ( T ( 0 ) ) where { _ <> _ = T 0 }
instance Monoid ( T ( 0 ) ) where { mempty = T 0 }
instance Group ( T ( 0 ) ) where { invert _ = T 0 }
deriving via Sum Double instance Semigroup ( T ( 1 ) )
deriving via Sum Double instance Monoid ( T ( 1 ) )
deriving via Sum Double instance Group ( T ( 1 ) )
{-# COMPLETE V2 #-}
pattern V2 :: Double -> Double -> T ( 2 )
pattern V2 x y = T ( 2 x y )
@ -122,42 +148,6 @@ pattern V2 x y = T ( 2 x y )
pattern V3 :: Double -> Double -> Double -> T ( 3 )
pattern V3 x y z = T ( 3 x y z )
instance Semigroup ( T ( 2 ) ) where
T ( 2 x1 y1 ) <> T ( 2 x2 y2 ) =
T ( 2 ( x1 + x2 ) ( y1 + y2 ) )
instance Monoid ( T ( 2 ) ) where
mempty = T ( 2 0 0 )
instance Group ( T ( 2 ) ) where
invert ( T ( 2 x y ) ) = T ( 2 ( negate x ) ( negate y ) )
instance Semigroup ( T ( 3 ) ) where
T ( 3 x1 y1 z1 ) <> T ( 3 x2 y2 z2 ) =
T ( 3 ( x1 + x2 ) ( y1 + y2 ) ( z1 + z2 ) )
instance Monoid ( T ( 3 ) ) where
mempty = T ( 3 0 0 0 )
instance Group ( T ( 3 ) ) where
invert ( T ( 3 x y z ) ) = T ( 3 ( negate x ) ( negate y ) ( negate z ) )
instance Act ( T ( 0 ) ) ( 0 ) where
_ _ = 0
instance Torsor ( T ( 0 ) ) ( 0 ) where
_ --> _ = T 0
instance Act ( T ( 1 ) ) ( 1 ) where
T ( 1 t ) 1 a = 1 ( a + t )
instance Torsor ( T ( 1 ) ) ( 1 ) where
1 a --> 1 b = T ( 1 ( b - a ) )
instance Act ( T ( 2 ) ) ( 2 ) where
T ( 2 u v ) 2 x y = 2 ( x + u ) ( y + v )
instance Torsor ( T ( 2 ) ) ( 2 ) where
2 a1 b1 --> 2 a2 b2 = T ( 2 ( a2 - a1 ) ( b2 - b1 ) )
instance Act ( T ( 3 ) ) ( 3 ) where
T ( 3 u v w ) 3 x y z = 3 ( x + u ) ( y + v ) ( z + w)
instance Torsor ( T ( 3 ) ) ( 3 ) where
3 a1 b1 c1 --> 3 a2 b2 c2 = T ( 3 ( a2 - a1 ) ( b2 - b1 ) ( c2 - c1 ) )
--------------------------------------------------------------------------------
-- | 1, ..., n
@ -250,8 +240,88 @@ find eq v b = MFin ( go 1## v )
= go ( j `plusWord#` 1## ) as
go _ VZ = 0##
--------------------------------------------------------------------------------
-- Instances in terms of representable.
-- | A newtype to hang off instances for representable functors.
newtype ApRep r u = ApRep { unApRep :: u }
instance ( Representable r u, Coercible r m, Semigroup m ) => Semigroup ( ApRep m u ) where
ApRep a <> ApRep b = ApRep $ tabulate @r @u \ i ->
coerce $ (<>) @m ( coerce ( index @r @u a i ) ) ( coerce ( index @r @u b i ) )
{-# INLINE (<>) #-}
instance ( Representable r u, Coercible r m, Monoid m ) => Monoid ( ApRep m u ) where
mempty = ApRep $ tabulate @r @u \ _ -> coerce $ mempty @m
{-# INLINE mempty #-}
instance ( Representable r u, Coercible r m, Group m ) => Group ( ApRep m u ) where
invert ( ApRep a ) = ApRep $ tabulate @r @u \ i ->
coerce $ invert @m $ coerce ( index @r @u a i )
{-# INLINE invert #-}
instance ( Act ( T r ) r , Semigroup ( T u ), Representable r u ) => Act ( T u ) ( ApRep r u ) where
T g ApRep a = ApRep $ tabulate @r @u \ i ->
coerce $ () @(T r) @r ( coerce $ index @r @u g i ) ( coerce ( index @r @u a i ) )
{-# INLINE (•) #-}
instance ( Torsor ( T r ) r , Group ( T u ), Representable r u ) => Torsor ( T u ) ( ApRep r u ) where
ApRep a --> ApRep b = T $ tabulate @r @u \ i ->
coerce $ (-->) @(T r) @r ( coerce $ index @r @u a i ) ( coerce ( index @r @u b i ) )
{-# INLINE (-->) #-}
--------------------------------------------------------------------------------
-- Intervals.
type 𝕀 = Interval
type 𝕀 n = 𝕀 ( n )
-- Handling points and intervals uniformly.
data Extent = Point | Interval
type I :: Extent -> Type -> Type
type family I i a where
I 'Point a = a
I 'Interval a = 𝕀 a
singleton :: a -> 𝕀 a
singleton a = I ( Rounded a ) ( Rounded a )
-- | Turn a non-decreasing function into a function on intervals.
nonDecreasing :: ( a -> b ) -> 𝕀 a -> 𝕀 b
nonDecreasing f ( I ( Rounded lo ) ( Rounded hi ) ) =
I ( Rounded $ f lo ) ( Rounded $ f hi )
type instance Dim ( 𝕀 u ) = Dim u
instance Representable r u => Representable ( 𝕀 r ) ( 𝕀 u ) where
tabulate f =
let !lo = tabulate @r @u ( \ i -> getRounded $ Interval.inf ( f i ) )
!hi = tabulate @r @u ( \ i -> getRounded $ Interval.sup ( f i ) )
in I ( Rounded lo ) ( Rounded hi )
{-# INLINE tabulate #-}
index ( I ( Rounded lo ) ( Rounded hi ) ) i =
let !lo_i = index @r @u lo i
!hi_i = index @r @u hi i
in I ( Rounded lo_i ) ( Rounded hi_i )
{-# INLINE index #-}
deriving via ApRep ( Sum ( 𝕀 Double ) ) ( 𝕀 n )
instance Representable ( 𝕀 Double ) ( 𝕀 n ) => Semigroup ( T ( 𝕀 n ) )
deriving via ApRep ( Sum ( 𝕀 Double ) ) ( 𝕀 n )
instance Representable ( 𝕀 Double ) ( 𝕀 n ) => Monoid ( T ( 𝕀 n ) )
deriving via ApRep ( Sum ( 𝕀 Double ) ) ( 𝕀 n )
instance Representable ( 𝕀 Double ) ( 𝕀 n ) => Group ( T ( 𝕀 n ) )
deriving via Sum ( 𝕀 Double )
instance Semigroup ( T ( 𝕀 Double ) )
deriving via Sum ( 𝕀 Double )
instance Monoid ( T ( 𝕀 Double ) )
deriving via Sum ( 𝕀 Double )
instance Group ( T ( 𝕀 Double ) )
instance Act ( T ( 𝕀 Double ) ) ( 𝕀 Double ) where
T g a = coerce ( Sum g a )
instance Torsor ( T ( 𝕀 Double ) ) ( 𝕀 Double ) where
a --> b = T $ getSum ( a --> b )
deriving via ApRep ( 𝕀 Double ) ( 𝕀 n )
instance Representable ( 𝕀 Double ) ( 𝕀 n ) => Act ( T ( 𝕀 n ) ) ( 𝕀 n )
deriving via ApRep ( 𝕀 Double ) ( 𝕀 n )
instance Representable ( 𝕀 Double ) ( 𝕀 n ) => Torsor ( T ( 𝕀 n ) ) ( 𝕀 n )

View file

@ -16,8 +16,19 @@ import Data.Kind
import GHC.Generics
( Generic, Generic1(..), Generically1(..) )
-- acts
import Data.Act
( Torsor )
-- rounded-hw
import Numeric.Rounded.Hardware
( Rounded(..) )
import Numeric.Rounded.Hardware.Interval.NonEmpty
( Interval(..) )
-- MetaBrush
import Math.Module
( Module(..) )
import Math.Linear
--------------------------------------------------------------------------------
@ -66,7 +77,7 @@ data D3 v = D3 { v :: !v, dx, dy, dz :: !( T v ), ddx, dxdy, ddy, dxdz, dydz,
via Generically1 D3
deriving stock instance ( Show v, Show ( T v ) ) => Show ( D3 v )
instance Num ( D1 Double ) where
instance ( Module s ( T r ), Num r ) => Num ( D1 r ) where
(+) = liftA2 (+)
(-) = liftA2 (-)
negate = fmap negate
@ -81,7 +92,7 @@ instance Num ( D1 Double ) where
( T $ dx1 * v2 + v1 * dx2 )
( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 )
instance Num ( D2 Double ) where
instance ( Num r, Module s ( T r ) ) => Num ( D2 r ) where
(+) = liftA2 (+)
(-) = liftA2 (-)
negate = fmap negate
@ -100,7 +111,7 @@ instance Num ( D2 Double ) where
( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 )
instance Num ( D3 Double ) where
instance ( Module s ( T r ) , Num r ) => Num ( D3 r ) where
(+) = liftA2 (+)
(-) = liftA2 (-)
negate = fmap negate
@ -123,34 +134,34 @@ instance Num ( D3 Double ) where
( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2)
instance Module Double ( T v ) => Module ( D0 Double ) ( D0 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
origin = pure ( coerce $ origin @Double @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
instance ( Num ( D0 r ), Module r ( T v ) ) => Module ( D0 r ) ( D0 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
origin = pure ( coerce $ origin @r @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
instance Module Double ( T v ) => Module ( D1 Double ) ( D1 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
origin = pure ( coerce $ origin @Double @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
instance ( Num ( D1 r ), Module r ( T v ) ) => Module ( D1 r ) ( D1 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
origin = pure ( coerce $ origin @r @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
instance Module Double ( T v ) => Module ( D2 Double ) ( D2 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
origin = pure ( coerce $ origin @Double @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
instance ( Num ( D2 r ), Module r ( T v ) ) => Module ( D2 r ) ( D2 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
origin = pure ( coerce $ origin @r @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
instance Module Double ( T v ) => Module ( D3 Double ) ( D3 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
origin = pure ( coerce $ origin @Double @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
instance ( Num ( D3 r ), Module r ( T v ) ) => Module ( D3 r ) ( D3 v ) where
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
origin = pure ( coerce $ origin @r @( T v ) )
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
instance Fractional ( D1 Double ) where
instance ( Module s ( T r ), Fractional r ) => Fractional ( D1 r ) where
(/) = error "I haven't yet defined (/) for D1"
fromRational = konst @Double @( 1 ) . fromRational
instance Floating ( D1 Double ) where
instance ( Module s ( T r ), Floating r ) => Floating ( D1 r ) where
pi = konst @Double @( 1 ) pi
sin ( D1 v ( T dx ) ( T ddx ) )
= let !s = sin v
@ -162,10 +173,10 @@ instance Floating ( D1 Double ) where
!c = cos v
in D1 c ( T $ -s * dx ) ( T $ -2 * s * ddx - c * dx * dx )
instance Fractional ( D2 Double ) where
instance ( Module s ( T r ), Fractional r ) => Fractional ( D2 r ) where
(/) = error "I haven't yet defined (/) for D2"
fromRational = konst @Double @( 2 ) . fromRational
instance Floating ( D2 Double ) where
instance ( Module s ( T r ), Floating r ) => Floating ( D2 r ) where
pi = konst @Double @( 2 ) pi
sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
= let !s = sin v
@ -185,10 +196,10 @@ instance Floating ( D2 Double ) where
( T $ -2 * s * dxdy - 2 * c * dx * dy )
( T $ -2 * s * ddy - c * dy * dy )
instance Fractional ( D3 Double ) where
instance ( Module s ( T r ), Fractional r ) => Fractional ( D3 r ) where
(/) = error "I haven't yet defined (/) for D3"
fromRational = konst @Double @( 3 ) . fromRational
instance Floating ( D3 Double ) where
instance ( Module s ( T r ), Floating r ) => Floating ( D3 r ) where
pi = konst @Double @( 3 ) pi
sin ( D3 v ( T dx ) ( T dy ) ( T dz ) ( T ddx ) ( T dxdy ) ( T ddy ) ( T dxdz ) ( T dydz ) ( T ddz ) )
= let !s = sin v
@ -229,12 +240,12 @@ uncurryD ( D1 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) s0 =
type Diffy :: Type -> Type -> Constraint
class ( Traversable ( D v ), Module r ( T v ) ) => Diffy r v where
chain :: ( Module r ( T w ) ) => D ( 1 ) v -> D v w -> D ( 1 ) w
konst :: Module r ( T w ) => w -> D v w
konst :: Module s ( T w ) => w -> D v w
value :: D v w -> w
linear :: Module r ( T w ) => ( v -> w ) -> ( v ~> w )
linear :: Module s ( T w ) => ( v -> w ) -> ( v ~> w )
chainRule :: ( Diffy r v, Module r ( T w ) )
=> ( ( 1 ) ~> v ) -> ( v ~> w ) -> ( ( 1 ) ~> w )
chainRule :: ( Diffy r v, Module r ( T w ), D u ~ D ( 1 ) )
=> ( u ~> v ) -> ( v ~> w ) -> ( u ~> w )
chainRule ( D df ) ( D dg ) =
D \ x ->
case df x of
@ -310,3 +321,110 @@ instance Diffy Double ( 3 ) where
( T $ f ( 3 1 0 0 ) ) ( T $ f ( 3 0 1 0 ) ) ( T $ f ( 3 0 0 1 ) )
origin origin origin origin origin origin
{-# INLINE linear #-}
--------------------------------------------------------------------------------
-- TODO: avoid copying over code...
instance Diffy ( 𝕀 Double ) ( 𝕀 0 ) where
chain _ ( D0 w ) = D1 w origin origin
{-# INLINE chain #-}
konst k = D0 k
{-# INLINE konst #-}
value ( D0 w ) = w
{-# INLINE value #-}
linear f = D \ _ -> D0 ( f $ singleton 0 )
{-# INLINE linear #-}
instance Diffy ( 𝕀 Double ) ( 𝕀 1 ) where
chain ( D1 _ ( T ( I ( Rounded ( 1 x'_lo ) ) ( Rounded ( 1 x'_hi ) ) ) )
( T ( I ( Rounded ( 1 x''_lo ) ) ( Rounded ( 1 x''_hi ) ) ) ) )
( D1 v g_x g_xx )
= let
!x' = I ( Rounded x'_lo ) ( Rounded x'_hi )
!x'' = I ( Rounded x''_lo ) ( Rounded x''_hi )
in D1 v
( x' *^ g_x )
( x'' *^ g_x ^+^ ( x' * x' ) *^ g_xx )
{-# INLINE chain #-}
konst k = D1 k origin origin
{-# INLINE konst #-}
value ( D1 { v } ) = v
{-# INLINE value #-}
linear f = D \ u -> D1 ( f u ) ( T $ f u ) origin
{-# INLINE linear #-}
instance Diffy ( 𝕀 Double ) ( 𝕀 2 ) where
chain ( D1 _ ( T ( I ( Rounded ( 2 x'_lo y'_lo ) ) ( Rounded ( 2 x'_hi y'_hi ) ) ) )
( T ( I ( Rounded ( 2 x''_lo y''_lo ) ) ( Rounded ( 2 x''_hi y''_hi ) ) ) ) )
( D2 v g_x g_y g_xx g_xy g_yy )
= let
!x' = I ( Rounded x'_lo ) ( Rounded x'_hi )
!y' = I ( Rounded y'_lo ) ( Rounded y'_hi )
!x'' = I ( Rounded x''_lo ) ( Rounded x''_hi )
!y'' = I ( Rounded y''_lo ) ( Rounded y''_hi )
in D1 v
( x' *^ g_x ^+^ y' *^ g_y )
( x'' *^ g_x ^+^ y'' *^ g_y
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy
^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) )
{-# INLINE chain #-}
konst k = D2 k origin origin origin origin origin
{-# INLINE konst #-}
value ( D2 { v } ) = v
{-# INLINE value #-}
linear f = D \ u ->
D2 ( f u )
( T $ f ( singleton $ 2 1 0 ) ) ( T $ f ( singleton $ 2 0 1 ) )
origin origin origin
{-# INLINE linear #-}
instance Diffy ( 𝕀 Double ) ( 𝕀 3 ) where
chain ( D1 _ ( T ( I ( Rounded ( 3 x'_lo y'_lo z'_lo ) ) ( Rounded ( 3 x'_hi y'_hi z'_hi ) ) ) )
( T ( I ( Rounded ( 3 x''_lo y''_lo z''_lo ) ) ( Rounded ( 3 x''_hi y''_hi z''_hi ) ) ) ) )
( D3 v g_x g_y g_z g_xx g_xy g_yy g_xz g_yz g_zz )
= let
!x' = I ( Rounded x'_lo ) ( Rounded x'_hi )
!y' = I ( Rounded y'_lo ) ( Rounded y'_hi )
!z' = I ( Rounded z'_lo ) ( Rounded z'_hi )
!x'' = I ( Rounded x''_lo ) ( Rounded x''_hi )
!y'' = I ( Rounded y''_lo ) ( Rounded y''_hi )
!z'' = I ( Rounded z''_lo ) ( Rounded z''_hi )
in D1 v
( x' *^ g_x ^+^ y' *^ g_y ^+^ z' *^ g_z )
( x'' *^ g_x ^+^ y'' *^ g_y ^+^ z'' *^ g_z
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy ^+^ ( z' * z' ) *^ g_zz
^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) ^+^ ( x' * z' ) *^ g_xz ^+^ ( y' * z' ) *^ g_yz )
{-# INLINE chain #-}
konst k = D3 k origin origin origin origin origin origin origin origin origin
{-# INLINE konst #-}
value ( D3 { v } ) = v
{-# INLINE value #-}
linear f = D \ u ->
D3 ( f u )
( T $ f ( singleton $ 3 1 0 0 ) ) ( T $ f ( singleton $ 3 0 1 0 ) ) ( T $ f ( singleton $ 3 0 0 1 ) )
origin origin origin origin origin origin
{-# INLINE linear #-}
--------------------------------------------------------------------------------
type Differentiable :: Extent -> Type -> Constraint
class
( Diffy ( I i Double ) ( I i u )
, Module ( I i Double ) ( T ( I i Double ) )
, Torsor ( T ( I i u ) ) ( I i u )
, Module ( D ( I i u ) ( I i Double ) ) ( D ( I i u ) ( I i ( 2 ) ) )
, Representable ( I i Double ) ( I i u )
, Floating ( D ( I i u ) ( I i Double ) )
, Applicative ( D ( I i u ) )
) => Differentiable i u
instance
( Diffy ( I i Double ) ( I i u )
, Module ( I i Double ) ( T ( I i Double ) )
, Torsor ( T ( I i u ) ) ( I i u )
, Module ( D ( I i u ) ( I i Double ) ) ( D ( I i u ) ( I i ( 2 ) ) )
, Representable ( I i Double ) ( I i u )
, Floating ( D ( I i u ) ( I i Double ) )
, Applicative ( D ( I i u ) )
) => Differentiable i u

View file

@ -9,7 +9,6 @@ module Math.Module
, norm, squaredNorm, quadrance, distance
, proj, projC, closestPointOnSegment
, strictlyParallel, convexCombination
, 𝕀
)
where
@ -18,6 +17,8 @@ import Control.Applicative
( liftA2 )
import Control.Monad
( guard )
import Data.Coerce
( Coercible, coerce )
import Data.Kind
( Type, Constraint )
import Data.Monoid
@ -36,8 +37,6 @@ import Numeric.Rounded.Hardware
( Rounded(..) )
import Numeric.Rounded.Hardware.Interval.NonEmpty
( Interval(..) )
import Numeric.Rounded.Hardware.Class
( intervalAdd, intervalSub, intervalMul )
-- MetaBrush
import Math.Epsilon
@ -124,47 +123,42 @@ closestPointOnSegment c ( Segment p0 p1 )
--------------------------------------------------------------------------------
-- | A convenient constraint synonym for types that support interpolation.
type Interpolatable :: Type -> Constraint
class ( Torsor ( T u ) u, Module Double ( T u ) ) => Interpolatable u
instance ( Torsor ( T u ) u, Module Double ( T u ) ) => Interpolatable u
type Interpolatable :: Type -> Type -> Constraint
class ( Torsor ( T u ) u, Module r ( T u ) ) => Interpolatable r u
instance ( Torsor ( T u ) u, Module r ( T u ) ) => Interpolatable r u
--------------------------------------------------------------------------------
instance ( Representable r u, Coercible r m, Module r m ) => Module r ( ApRep m u ) where
origin = ApRep $ tabulate @r @u \ _ -> coerce $ origin @r @m
{-# INLINE origin #-}
ApRep a ^+^ ApRep b = ApRep $ tabulate @r @u \ i ->
coerce $ (^+^) @r @m ( coerce ( index @r @u a i ) ) ( coerce ( index @r @u b i ) )
{-# INLINE (^+^) #-}
ApRep a ^-^ ApRep b = ApRep $ tabulate @r @u \ i ->
coerce $ (^-^) @r @m ( coerce ( index @r @u a i ) ) ( coerce ( index @r @u b i ) )
{-# INLINE (^-^) #-}
k *^ ApRep a = ApRep $ tabulate @r @u \ i ->
coerce $ (*^) @r @m k ( coerce ( index @r @u a i ) )
{-# INLINE (*^) #-}
deriving via ( ApRep ( Sum Double ) ( n ) )
instance Representable Double ( n ) => Module Double ( T ( n ) )
instance Num a => Module a ( Sum a ) where
origin = Sum 0
(^+^) = (<>)
( Sum x ) ^-^ ( Sum y ) = Sum ( x - y )
Sum x ^-^ Sum y = Sum ( x - y )
c *^ ( Sum x ) = Sum ( c * x )
( Sum x ) ^* c = Sum ( x * c )
c *^ Sum x = Sum ( c * x )
Sum x ^* c = Sum ( x * c )
instance Num a => Inner a ( Sum a ) where
Sum a ^.^ Sum b = a * b
instance Module Double ( T ( 0 ) ) where
origin = T 0
_ ^+^ _ = T 0
_ ^-^ _ = T 0
_ *^ _ = T 0
deriving via Sum Double instance Module Double ( T Double )
deriving via Sum Double instance Module Double ( T ( 1 ) )
instance Module Double ( T ( 2 ) ) where
origin = mempty
(^+^) = (<>)
T ( 2 x1 y1 ) ^-^ T ( 2 x2 y2 ) =
T ( 2 ( x1 - x2 ) ( y1 - y2 ) )
k *^ ( T ( 2 a b ) ) = T ( 2 ( k * a ) ( k * b ) )
instance Module Double ( T ( 3 ) ) where
origin = mempty
(^+^) = (<>)
T ( 3 x1 y1 z1 ) ^-^ T ( 3 x2 y2 z2 ) =
T ( 3 ( x1 - x2 ) ( y1 - y2 ) ( z1 - z2 ) )
k *^ ( T ( 3 a b c ) ) = T ( 3 ( k * a ) ( k * b ) ( k * c ) )
instance Inner Double ( T ( 2 ) ) where
V2 x1 y1 ^.^ V2 x2 y2 = x1 * x2 + y1 * y2
@ -213,35 +207,21 @@ convexCombination v0 v1 u
--------------------------------------------------------------------------------
-- Interval arithmetic using rounded-hw library.
instance Module ( 𝕀 Double ) ( T ( 𝕀 2 ) ) where
origin = T ( I ( Rounded ( 2 0 0 ) ) ( Rounded ( 2 0 0 ) ) )
T ( I ( Rounded ( 2 x1_lo y1_lo ) ) ( Rounded ( 2 x1_hi y1_hi ) ) ) ^+^
T ( I ( Rounded ( 2 x2_lo y2_lo ) ) ( Rounded ( 2 x2_hi y2_hi ) ) )
= let !( Rounded x_lo, Rounded x_hi ) = intervalAdd ( Rounded x1_lo ) ( Rounded x1_hi ) ( Rounded x2_lo ) ( Rounded x2_hi )
!( Rounded y_lo, Rounded y_hi ) = intervalAdd ( Rounded y1_lo ) ( Rounded y1_hi ) ( Rounded y2_lo ) ( Rounded y2_hi )
in T ( I ( Rounded ( 2 x_lo y_lo ) ) ( Rounded ( 2 x_hi y_hi ) ) )
T ( I ( Rounded ( 2 x1_lo y1_lo ) ) ( Rounded ( 2 x1_hi y1_hi ) ) ) ^-^
T ( I ( Rounded ( 2 x2_lo y2_lo ) ) ( Rounded ( 2 x2_hi y2_hi ) ) )
= let !( Rounded x_lo, Rounded x_hi ) = intervalSub ( Rounded x1_lo ) ( Rounded x1_hi ) ( Rounded x2_lo ) ( Rounded x2_hi )
!( Rounded y_lo, Rounded y_hi ) = intervalSub ( Rounded y1_lo ) ( Rounded y1_hi ) ( Rounded y2_lo ) ( Rounded y2_hi )
in T ( I ( Rounded ( 2 x_lo y_lo ) ) ( Rounded ( 2 x_hi y_hi ) ) )
I ( Rounded k_lo ) ( Rounded k_hi ) *^ T ( I ( Rounded ( 2 x1_lo y1_lo ) ) ( Rounded ( 2 x1_hi y1_hi ) ) )
= let !( Rounded x_lo, Rounded x_hi ) = intervalMul ( Rounded k_lo ) ( Rounded k_hi ) ( Rounded x1_lo ) ( Rounded x1_hi )
!( Rounded y_lo, Rounded y_hi ) = intervalMul ( Rounded k_lo ) ( Rounded k_hi ) ( Rounded y1_lo ) ( Rounded y1_hi )
in T ( I ( Rounded ( 2 x_lo y_lo ) ) ( Rounded ( 2 x_hi y_hi ) ) )
deriving via Sum ( 𝕀 Double ) instance Module ( 𝕀 Double ) ( T ( 𝕀 Double ) )
deriving via ApRep ( Sum ( 𝕀 Double ) ) ( 𝕀 n )
instance Representable ( 𝕀 Double ) ( 𝕀 n ) => Module ( 𝕀 Double ) ( T ( 𝕀 n ) )
instance Inner ( 𝕀 Double ) ( T ( 𝕀 2 ) ) where
T ( I ( Rounded ( 2 x1_lo y1_lo ) ) ( Rounded ( 2 x1_hi y1_hi ) ) ) ^.^
T ( I ( Rounded ( 2 x2_lo y2_lo ) ) ( Rounded ( 2 x2_hi y2_hi ) ) )
= let !( x_lo, x_hi ) = intervalMul ( Rounded x1_lo ) ( Rounded x1_hi ) ( Rounded x2_lo ) ( Rounded x2_hi )
!( y_lo, y_hi ) = intervalMul ( Rounded y1_lo ) ( Rounded y1_hi ) ( Rounded y2_lo ) ( Rounded y2_hi )
!( z_lo, z_hi ) = intervalAdd x_lo x_hi y_lo y_hi
in I z_lo z_hi
= let !x1x2 = I ( Rounded x1_lo ) ( Rounded x1_hi ) * I ( Rounded x2_lo ) ( Rounded x2_hi )
!y1y2 = I ( Rounded y1_lo ) ( Rounded y1_hi ) * I ( Rounded y2_lo ) ( Rounded y2_hi )
in x1x2 + y1y2
instance Cross ( 𝕀 Double ) ( T ( 𝕀 2 ) ) where
T ( I ( Rounded ( 2 x1_lo y1_lo ) ) ( Rounded ( 2 x1_hi y1_hi ) ) ) `cross`
T ( I ( Rounded ( 2 x2_lo y2_lo ) ) ( Rounded ( 2 x2_hi y2_hi ) ) )
= let !( x_lo, x_hi ) = intervalMul ( Rounded x1_lo ) ( Rounded x1_hi ) ( Rounded y2_lo ) ( Rounded y2_hi )
!( y_lo, y_hi ) = intervalMul ( Rounded x2_lo ) ( Rounded x2_hi ) ( Rounded y1_lo ) ( Rounded y1_hi )
!( z_lo, z_hi ) = intervalSub x_lo x_hi y_lo y_hi
in I z_lo z_hi
= let !x1y2 = I ( Rounded x1_lo ) ( Rounded x1_hi ) * I ( Rounded y2_lo ) ( Rounded y2_hi )
!y2x1 = I ( Rounded x2_lo ) ( Rounded x2_hi ) * I ( Rounded y1_lo ) ( Rounded y1_hi )
in x1y2 - y2x1