mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
implement intervallic brushes
This commit is contained in:
sheaf
parent
09c1bdd948
commit
684550a795
|
|
@ -50,6 +50,8 @@ common common
|
||||||
^>= 0.3.1.0
|
^>= 0.3.1.0
|
||||||
, primitive
|
, primitive
|
||||||
^>= 0.7.1.0
|
^>= 0.7.1.0
|
||||||
|
, rounded-hw
|
||||||
|
^>= 0.3
|
||||||
, transformers
|
, transformers
|
||||||
^>= 0.5.6.2
|
^>= 0.5.6.2
|
||||||
|
|
||||||
|
|
@ -195,8 +197,6 @@ library splines
|
||||||
^>= 3.2.2.0
|
^>= 3.2.2.0
|
||||||
, prim-instances
|
, prim-instances
|
||||||
^>= 0.2
|
^>= 0.2
|
||||||
, rounded-hw
|
|
||||||
^>= 0.3
|
|
||||||
, vector
|
, vector
|
||||||
>= 0.12.1.2 && < 0.14
|
>= 0.12.1.2 && < 0.14
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,8 @@ import Data.Functor.Compose
|
||||||
( Compose(..) )
|
( Compose(..) )
|
||||||
import Data.Int
|
import Data.Int
|
||||||
( Int32 )
|
( Int32 )
|
||||||
|
import GHC.Exts
|
||||||
|
( proxy# )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic, Generic1, Generically1(..) )
|
( Generic, Generic1, Generically1(..) )
|
||||||
|
|
||||||
|
|
@ -72,13 +74,13 @@ import Math.Bezier.Stroke
|
||||||
, computeStrokeOutline
|
, computeStrokeOutline
|
||||||
)
|
)
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ(..), T(..) )
|
( ℝ(..), T(..), Extent(Point) )
|
||||||
import Math.Linear.Dual
|
import Math.Linear.Dual
|
||||||
( fun )
|
( fun )
|
||||||
import MetaBrush.Asset.Colours
|
import MetaBrush.Asset.Colours
|
||||||
( Colours, ColourRecord(..) )
|
( Colours, ColourRecord(..) )
|
||||||
import MetaBrush.Brush
|
import MetaBrush.Brush
|
||||||
( Brush(..) )
|
( Brush(..), WithParams(..) )
|
||||||
import MetaBrush.Context
|
import MetaBrush.Context
|
||||||
( Modifier(..)
|
( Modifier(..)
|
||||||
, HoldAction(..), PartialPath(..)
|
, HoldAction(..), PartialPath(..)
|
||||||
|
|
@ -285,7 +287,7 @@ strokeRenderData fitParams
|
||||||
, withParams = brushFn
|
, withParams = brushFn
|
||||||
} <- fn
|
} <- fn
|
||||||
-> -- This is the key place where we need to perform impedance matching
|
-> -- This is the key place where we need to perform impedance matching
|
||||||
-- between the collection of parameters supplied along a strong and
|
-- between the collection of parameters supplied along a stroke and
|
||||||
-- the collection of parameters expected by the brush.
|
-- the collection of parameters expected by the brush.
|
||||||
case intersect @pointFields @brushFields of
|
case intersect @pointFields @brushFields of
|
||||||
Intersection
|
Intersection
|
||||||
|
|
@ -303,7 +305,9 @@ strokeRenderData fitParams
|
||||||
StrokeWithOutlineRenderData
|
StrokeWithOutlineRenderData
|
||||||
{ strokeDataSpline = spline
|
{ strokeDataSpline = spline
|
||||||
, strokeOutlineData = ( outline, fitPts )
|
, strokeOutlineData = ( outline, fitPts )
|
||||||
, strokeBrushFunction = fun brushFn . fun embedUsedParams . toUsedParams
|
, strokeBrushFunction = fun ( brushFn @Point proxy# id )
|
||||||
|
. embedUsedParams
|
||||||
|
. toUsedParams
|
||||||
}
|
}
|
||||||
_ -> pure $
|
_ -> pure $
|
||||||
StrokeRenderData
|
StrokeRenderData
|
||||||
|
|
|
||||||
|
|
@ -98,7 +98,7 @@ type LocatedTrail' l = Diagrams.Located (Diagrams.Trail' l Linear.V2 Double)
|
||||||
data SomeSpline ptData where
|
data SomeSpline ptData where
|
||||||
SomeSpline :: KnownSplineType clo => Spline clo (CachedStroke RealWorld) ptData -> SomeSpline ptData
|
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
|
parseMetaFontPath pathText ptParams = do
|
||||||
locTrail <- Bi.first PathParseError $ MetaFont.fromString @LocatedTrail pathText
|
locTrail <- Bi.first PathParseError $ MetaFont.fromString @LocatedTrail pathText
|
||||||
let
|
let
|
||||||
|
|
@ -110,7 +110,7 @@ parseMetaFontPath pathText ptParams = do
|
||||||
SomeSpline <$> trailToSpline @Diagrams.Loop ( Diagrams.Loc { Diagrams.loc = loc, Diagrams.unLoc = trail' } ) ptParams
|
SomeSpline <$> trailToSpline @Diagrams.Loop ( Diagrams.Loc { Diagrams.loc = loc, Diagrams.unLoc = trail' } ) ptParams
|
||||||
|
|
||||||
trailToSpline :: forall l ptParams
|
trailToSpline :: forall l ptParams
|
||||||
. Interpolatable ptParams
|
. Interpolatable Double ptParams
|
||||||
=> LocatedTrail' l
|
=> LocatedTrail' l
|
||||||
-> [ptParams]
|
-> [ptParams]
|
||||||
-> Either MetaFontError (Spline (Openness l) (CachedStroke RealWorld) (PointData 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
|
go _ (_:_) [] = Left TooFewBrushParams
|
||||||
|
|
||||||
segmentToCurve :: forall c ptParams
|
segmentToCurve :: forall c ptParams
|
||||||
. Interpolatable ptParams
|
. Interpolatable Double ptParams
|
||||||
=> PointData ptParams -- ^ start point
|
=> PointData ptParams -- ^ start point
|
||||||
-> ptParams -- ^ parameters at end of curve
|
-> ptParams -- ^ parameters at end of curve
|
||||||
-> Diagrams.Segment c Linear.V2 Double
|
-> Diagrams.Segment c Linear.V2 Double
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,13 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module MetaBrush.Asset.Brushes where
|
module MetaBrush.Asset.Brushes where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import GHC.Exts
|
||||||
|
( Proxy# )
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
( fromList )
|
( fromList )
|
||||||
|
|
@ -20,14 +25,14 @@ import qualified Data.HashMap.Strict as HashMap
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Bezier.Spline
|
import Math.Bezier.Spline
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ(..), Fin(..) )
|
|
||||||
import Math.Linear.Dual
|
import Math.Linear.Dual
|
||||||
( D, type (~>)(..), var, konst )
|
( D, type (~>)(..), Differentiable, Diffy(konst), var )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
( Module((^+^), (*^)) )
|
( Module((^+^), (*^)) )
|
||||||
import MetaBrush.Brush
|
import MetaBrush.Brush
|
||||||
( Brush(..), SomeBrush(..) )
|
( Brush(..), SomeBrush(..), WithParams(..) )
|
||||||
import MetaBrush.Records
|
import MetaBrush.Records
|
||||||
|
( Record(MkR) )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
@ -65,51 +70,62 @@ ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Differentiable brushes.
|
-- 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 $
|
circleSpline p = sequenceA $
|
||||||
Spline { splineStart = p 1 0
|
Spline { splineStart = p 1 0
|
||||||
, splineCurves = ClosedCurves crvs lastCrv }
|
, splineCurves = ClosedCurves crvs lastCrv }
|
||||||
where
|
where
|
||||||
crvs = Seq.fromList
|
crvs = Seq.fromList
|
||||||
[ 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 -1 0) ) ()
|
||||||
, Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) ()
|
, Bezier3To ( p -1 -κ ) ( p -κ -1 ) ( NextPoint (p 0 -1) ) ()
|
||||||
]
|
]
|
||||||
lastCrv =
|
lastCrv =
|
||||||
Bezier3To (p κ -1) (p 1 -κ) BackToStart ()
|
Bezier3To ( p κ -1 ) ( p 1 -κ ) BackToStart ()
|
||||||
|
|
||||||
circleBrush :: Record CircleBrushFields ~> Spline 'Closed () ( ℝ 2 )
|
circleBrush :: forall i
|
||||||
circleBrush =
|
. ( 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 ->
|
D \ params ->
|
||||||
let r :: D ( Record CircleBrushFields ) Double
|
let r :: D ( I i ( Record CircleBrushFields ) ) ( I i Double )
|
||||||
r = runD ( var ( Fin 1## ) ) params
|
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 )
|
mkPt ( kon -> x ) ( kon -> y )
|
||||||
= ( x * r ) *^ e_x
|
= ( x * r ) *^ e_x
|
||||||
^+^ ( y * r ) *^ e_y
|
^+^ ( y * r ) *^ e_y
|
||||||
in circleSpline @( Record CircleBrushFields ) mkPt
|
in circleSpline @i @( Record CircleBrushFields ) @( ℝ 2 ) mkPt
|
||||||
where
|
where
|
||||||
e_x, e_y :: D ( Record CircleBrushFields ) ( ℝ 2 )
|
e_x, e_y :: D ( I i ( Record CircleBrushFields ) ) ( I i ( ℝ 2 ) )
|
||||||
e_x = pure $ ℝ2 1 0
|
e_x = pure $ mkI $ ℝ2 1 0
|
||||||
e_y = pure $ ℝ2 0 1
|
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 :: forall i
|
||||||
ellipseBrush =
|
. ( 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 ->
|
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
|
a = runD ( var ( Fin 1## ) ) params
|
||||||
b = runD ( var ( Fin 2## ) ) params
|
b = runD ( var ( Fin 2## ) ) params
|
||||||
phi = runD ( var ( Fin 3## ) ) 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 )
|
mkPt ( kon -> x ) ( kon -> y )
|
||||||
= ( x * a * cos phi - y * b * sin phi ) *^ e_x
|
= ( x * a * cos phi - y * b * sin phi ) *^ e_x
|
||||||
^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y
|
^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y
|
||||||
in circleSpline @( Record EllipseBrushFields ) mkPt
|
in circleSpline @i @( Record EllipseBrushFields ) @( ℝ 2 ) mkPt
|
||||||
where
|
where
|
||||||
e_x, e_y :: D ( Record EllipseBrushFields ) ( ℝ 2 )
|
e_x, e_y :: D ( I i ( Record EllipseBrushFields ) ) ( I i ( ℝ 2 ) )
|
||||||
e_x = pure $ ℝ2 1 0
|
e_x = pure $ mkI $ ℝ2 1 0
|
||||||
e_y = pure $ ℝ2 0 1
|
e_y = pure $ mkI $ ℝ2 0 1
|
||||||
|
|
||||||
kon = konst @Double @( Record EllipseBrushFields )
|
kon = konst @( I i Double ) @( I i ( Record EllipseBrushFields ) ) . mkI
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,8 @@
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module MetaBrush.Brush
|
module MetaBrush.Brush
|
||||||
( Brush(..), SomeBrush(..), BrushFunction
|
( WithParams(..)
|
||||||
|
, Brush(..), SomeBrush(..), BrushFunction
|
||||||
, PointFields, provePointFields, duplicates
|
, PointFields, provePointFields, duplicates
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
@ -39,32 +40,45 @@ import qualified Data.Text as Text
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ, Representable )
|
( ℝ, type I, Extent(Point, Interval) )
|
||||||
import Math.Linear.Dual
|
import Math.Linear.Dual
|
||||||
( Diffy )
|
( type (~>), Differentiable )
|
||||||
import Math.Module
|
|
||||||
( Interpolatable )
|
|
||||||
import Math.Bezier.Spline
|
import Math.Bezier.Spline
|
||||||
( SplineType(Closed), SplinePts)
|
( SplineType(Closed), Spline )
|
||||||
import MetaBrush.Records
|
import MetaBrush.Records
|
||||||
( KnownSymbols, Length, Record, WithParams )
|
( KnownSymbols, Length, Record )
|
||||||
import MetaBrush.Serialisable
|
import MetaBrush.Serialisable
|
||||||
( 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.
|
-- | A brush function: a function from a record of parameters to a closed spline.
|
||||||
type BrushFunction :: [ Symbol ] -> Type
|
type BrushFunction :: [ Symbol ] -> Type
|
||||||
type BrushFunction brushFields = WithParams brushFields ( SplinePts Closed )
|
type BrushFunction brushFields = WithParams brushFields ( Spline Closed () )
|
||||||
|
|
||||||
type Brush :: [ Symbol ] -> Type
|
type Brush :: [ Symbol ] -> Type
|
||||||
data Brush brushFields where
|
data Brush brushFields where
|
||||||
BrushData
|
BrushData
|
||||||
:: forall brushFields
|
:: forall brushFields
|
||||||
. ( KnownSymbols brushFields
|
. ( KnownSymbols brushFields, Typeable brushFields
|
||||||
, Representable Double ( ℝ ( Length brushFields) )
|
, Differentiable Point ( ℝ ( Length brushFields ) )
|
||||||
, Diffy Double ( ℝ ( Length brushFields) )
|
, Differentiable Interval ( ℝ ( Length brushFields ) )
|
||||||
, Typeable brushFields )
|
)
|
||||||
=> { brushName :: !Text
|
=> { brushName :: !Text
|
||||||
, brushFunction :: BrushFunction brushFields
|
, brushFunction :: BrushFunction brushFields
|
||||||
}
|
}
|
||||||
|
|
@ -97,16 +111,16 @@ class ( KnownSymbols pointFields, Typeable pointFields
|
||||||
, Serialisable ( Record pointFields )
|
, Serialisable ( Record pointFields )
|
||||||
, Show ( Record pointFields )
|
, Show ( Record pointFields )
|
||||||
, NFData ( Record pointFields )
|
, NFData ( Record pointFields )
|
||||||
, Interpolatable ( Record pointFields )
|
, Differentiable Point ( ℝ ( Length pointFields ) )
|
||||||
, Representable Double ( ℝ ( Length pointFields ) )
|
, Differentiable Interval ( ℝ ( Length pointFields ) )
|
||||||
)
|
)
|
||||||
=> PointFields pointFields where { }
|
=> PointFields pointFields where { }
|
||||||
instance ( KnownSymbols pointFields, Typeable pointFields
|
instance ( KnownSymbols pointFields, Typeable pointFields
|
||||||
, Serialisable ( Record pointFields )
|
, Serialisable ( Record pointFields )
|
||||||
, Show ( Record pointFields )
|
, Show ( Record pointFields )
|
||||||
, NFData ( Record pointFields )
|
, NFData ( Record pointFields )
|
||||||
, Interpolatable ( Record pointFields )
|
, Differentiable Point ( ℝ ( Length pointFields ) )
|
||||||
, Representable Double ( ℝ ( Length pointFields ) )
|
, Differentiable Interval ( ℝ ( Length pointFields ) )
|
||||||
)
|
)
|
||||||
=> PointFields pointFields where { }
|
=> PointFields pointFields where { }
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -85,7 +85,7 @@ subdivide c doc@( Document { zoomFactor } ) =
|
||||||
where
|
where
|
||||||
updateSpline
|
updateSpline
|
||||||
:: forall clo brushParams
|
:: forall clo brushParams
|
||||||
. ( KnownSplineType clo, Interpolatable brushParams )
|
. ( KnownSplineType clo, Interpolatable Double brushParams )
|
||||||
=> StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams )
|
=> StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams )
|
||||||
updateSpline spline@( Spline { splineStart } )
|
updateSpline spline@( Spline { splineStart } )
|
||||||
| not strokeVisible
|
| not strokeVisible
|
||||||
|
|
|
||||||
|
|
@ -41,6 +41,12 @@ import Control.DeepSeq
|
||||||
import Data.Group
|
import Data.Group
|
||||||
( Group(..) )
|
( Group(..) )
|
||||||
|
|
||||||
|
-- rounded-hw
|
||||||
|
import Numeric.Rounded.Hardware
|
||||||
|
( Rounded(..) )
|
||||||
|
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
||||||
|
( Interval(..) )
|
||||||
|
|
||||||
-- text
|
-- text
|
||||||
import Data.Text
|
import Data.Text
|
||||||
( Text )
|
( Text )
|
||||||
|
|
@ -50,18 +56,9 @@ import qualified Data.Text as Text
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
import Math.Linear.Dual
|
import Math.Linear.Dual
|
||||||
|
( type (~>)(..), D, Diffy, Differentiable )
|
||||||
import Math.Module
|
import Math.Module
|
||||||
|
( 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
|
|
||||||
}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
@ -107,6 +104,19 @@ deriving via ( T ( ℝ ( Length ks ) ) )
|
||||||
instance Module Double ( T ( ℝ ( Length ks ) ) )
|
instance Module Double ( T ( ℝ ( Length ks ) ) )
|
||||||
=> Module Double ( T ( Record 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 ) )
|
instance ( Act ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
|
||||||
, Semigroup ( T ( ℝ ( Length ks ) ) ) )
|
, Semigroup ( T ( ℝ ( Length ks ) ) ) )
|
||||||
=> Act ( T ( Record ks ) ) ( Record ks ) where
|
=> 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
|
=> Torsor ( T ( Record ks ) ) ( Record ks ) where
|
||||||
MkR g --> MkR a = T $ MkR $ unT $ g --> a
|
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
|
deriving newtype
|
||||||
instance Representable r ( ℝ ( Length ks ) )
|
instance Representable r ( ℝ ( Length ks ) )
|
||||||
=> Representable r ( Record ks )
|
=> Representable r ( Record ks )
|
||||||
|
|
||||||
type instance D ( Record ks ) = D ( ℝ ( Length 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
|
. ( Typeable r1, Typeable r2
|
||||||
, KnownSymbols r1, KnownSymbols r2
|
, KnownSymbols r1, KnownSymbols r2
|
||||||
, l1 ~ Length r1, l2 ~ Length r2
|
, l1 ~ Length r1, l2 ~ Length r2
|
||||||
, Representable Double ( ℝ l1 ), Representable Double ( ℝ l2 )
|
, Representable Double ( ℝ l1 )
|
||||||
, Interpolatable ( Record r1 ), Diffy Double ( ℝ l2 )
|
, Differentiable 'Point ( ℝ l2 )
|
||||||
|
, Differentiable 'Interval ( ℝ l2 )
|
||||||
)
|
)
|
||||||
=> Intersection r1 r2
|
=> Intersection r1 r2
|
||||||
intersect
|
intersect
|
||||||
-- Shortcut when the two rows are equal.
|
-- Shortcut when the two rows are equal.
|
||||||
| Just Refl <- eqT @r1 @r2
|
| Just Refl <- eqT @r1 @r2
|
||||||
, Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
|
, Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
|
||||||
= Intersection { project = id, inject = \ _ -> linear id }
|
= Intersection { project = id, inject = \ _ -> id }
|
||||||
| otherwise
|
| otherwise
|
||||||
= doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
|
= doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
|
||||||
let
|
let
|
||||||
project :: Record r1 -> Record r1r2
|
project :: Record r1 -> Record r1r2
|
||||||
project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
|
project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
|
||||||
|
|
||||||
inject :: Record r2 -> Record r1r2 ~> Record r2
|
inject :: Record r2 -> Record r1r2 -> Record r2
|
||||||
inject = \ ( MkR r2 ) -> linear \ ( MkR r1r2 ) -> MkR $ injection ( find eqFin r2_idxs ) r1r2 r2
|
inject = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( find eqFin r2_idxs ) r1r2 r2
|
||||||
in Intersection { project, inject }
|
in Intersection { project, inject }
|
||||||
|
|
||||||
data Intersection r1 r2 where
|
data Intersection r1 r2 where
|
||||||
|
|
@ -172,12 +205,15 @@ data Intersection r1 r2 where
|
||||||
:: forall r1r2 r1 r2 l12
|
:: forall r1r2 r1 r2 l12
|
||||||
. ( l12 ~ Length r1r2
|
. ( l12 ~ Length r1r2
|
||||||
, KnownSymbols r1r2
|
, KnownSymbols r1r2
|
||||||
, Representable Double ( ℝ l12 )
|
, Differentiable 'Point ( ℝ l12 )
|
||||||
, Diffy Double ( ℝ l12 )
|
, Differentiable 'Interval ( ℝ l12 )
|
||||||
, Interpolatable ( Record r1r2 ) )
|
)
|
||||||
=> { project :: Record r1 -> Record r1r2
|
=> { 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
|
-- ^ overrides the components of the first record with the second
|
||||||
|
-- (linear non-decreasing mapping in its second argument)
|
||||||
} -> Intersection r1 r2
|
} -> Intersection r1 r2
|
||||||
|
|
||||||
{-# INLINE doIntersection #-}
|
{-# INLINE doIntersection #-}
|
||||||
|
|
@ -185,13 +221,13 @@ doIntersection
|
||||||
:: forall r1 r2 l1 l2 kont
|
:: forall r1 r2 l1 l2 kont
|
||||||
. ( KnownSymbols r1, KnownSymbols r2
|
. ( KnownSymbols r1, KnownSymbols r2
|
||||||
, l1 ~ Length r1, l2 ~ Length r2
|
, l1 ~ Length r1, l2 ~ Length r2
|
||||||
, Representable Double ( ℝ l1 ), Representable Double ( ℝ l2 )
|
, Representable Double ( ℝ l1 )
|
||||||
|
, Representable Double ( ℝ l2 )
|
||||||
)
|
)
|
||||||
=> ( forall r1r2 l12.
|
=> ( forall r1r2 l12.
|
||||||
( r1r2 ~ Intersect r1 r2, l12 ~ Length r1r2
|
( r1r2 ~ Intersect r1 r2, KnownSymbols r1r2, l12 ~ Length r1r2
|
||||||
, Representable Double ( ℝ l12 ), Diffy Double ( ℝ l12 )
|
, Differentiable 'Point ( ℝ l12 )
|
||||||
, Interpolatable ( ℝ l12 )
|
, Differentiable 'Interval ( ℝ l12 )
|
||||||
, KnownSymbols r1r2, Representable Double ( ℝ ( Length r1r2 ) )
|
|
||||||
)
|
)
|
||||||
=> Proxy# r1r2 -> Vec l12 ( Fin l1 ) -> Vec l12 ( Fin l2 ) -> kont )
|
=> Proxy# r1r2 -> Vec l12 ( Fin l1 ) -> Vec l12 ( Fin l2 ) -> kont )
|
||||||
-> kont
|
-> kont
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
{-# LANGUAGE QuantifiedConstraints #-}
|
{-# LANGUAGE QuantifiedConstraints #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
@ -36,14 +37,14 @@ import Data.Foldable
|
||||||
( for_ )
|
( for_ )
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
( Identity(..) )
|
( Identity(..) )
|
||||||
import Data.Kind
|
|
||||||
( Type )
|
|
||||||
import Data.List.NonEmpty
|
import Data.List.NonEmpty
|
||||||
( unzip )
|
( unzip )
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( fromMaybe, isJust, listToMaybe, mapMaybe )
|
( fromMaybe, isJust, listToMaybe, mapMaybe )
|
||||||
import GHC.Exts
|
import GHC.Exts
|
||||||
( newMutVar#, runRW# )
|
( newMutVar#, runRW#
|
||||||
|
, Proxy#, proxy#
|
||||||
|
)
|
||||||
import GHC.STRef
|
import GHC.STRef
|
||||||
( STRef(..), readSTRef, writeSTRef )
|
( STRef(..), readSTRef, writeSTRef )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
|
|
@ -182,18 +183,30 @@ type OutlineFn = ℝ 1 -> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) )
|
||||||
computeStrokeOutline ::
|
computeStrokeOutline ::
|
||||||
forall ( clo :: SplineType ) usedParams brushParams crvData ptData s
|
forall ( clo :: SplineType ) usedParams brushParams crvData ptData s
|
||||||
. ( KnownSplineType clo
|
. ( KnownSplineType clo
|
||||||
, Interpolatable usedParams
|
|
||||||
, Diffy Double usedParams, Diffy Double brushParams
|
|
||||||
, HasType ( ℝ 2 ) ptData
|
, HasType ( ℝ 2 ) ptData
|
||||||
, HasType ( CachedStroke s ) crvData
|
, HasType ( CachedStroke s ) crvData
|
||||||
, NFData ptData, NFData 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.
|
-- Debugging.
|
||||||
, Show ptData, Show brushParams
|
, Show ptData, Show brushParams
|
||||||
|
|
||||||
)
|
)
|
||||||
=> FitParameters
|
=> FitParameters
|
||||||
-> ( ptData -> usedParams )
|
-> ( ptData -> usedParams )
|
||||||
-> ( usedParams ~> brushParams )
|
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
|
||||||
-> ( brushParams ~> SplinePts Closed )
|
-> ( 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
|
-> Spline clo crvData ptData
|
||||||
-> ST s
|
-> ST s
|
||||||
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
( 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
|
outlineFunction ptParams toBrushParams brushFn p0 crv :<| go ( openCurveEnd crv ) crvs
|
||||||
|
|
||||||
brushShape :: ptData -> SplinePts Closed
|
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 :: ( T ( ℝ 2 ), T ( ℝ 2 ), T ( ℝ 2 ) ) -> ST s OutlineData
|
||||||
updateSpline ( lastTgt, lastTgtFwd, lastTgtBwd )
|
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.
|
-- | Computes the forward and backward stroke outline functions for a single curve.
|
||||||
outlineFunction
|
outlineFunction
|
||||||
:: forall usedParams brushParams crvData ptData
|
:: forall usedParams brushParams crvData ptData
|
||||||
. ( Interpolatable usedParams
|
. ( HasType ( ℝ 2 ) ptData
|
||||||
, Diffy Double usedParams, Diffy Double brushParams
|
|
||||||
, HasType ( ℝ 2 ) ptData
|
-- Differentiability.
|
||||||
|
, Differentiable 'Point brushParams
|
||||||
|
, Differentiable 'Interval brushParams
|
||||||
|
, Interpolatable Double usedParams
|
||||||
|
, Interpolatable ( 𝕀 Double ) ( 𝕀 usedParams )
|
||||||
|
, Diffy Double usedParams
|
||||||
|
, Diffy ( 𝕀 Double ) ( 𝕀 usedParams )
|
||||||
|
|
||||||
-- Debugging.
|
-- Debugging.
|
||||||
, Show ptData, Show brushParams
|
, Show ptData, Show brushParams
|
||||||
)
|
)
|
||||||
=> ( ptData -> usedParams )
|
=> ( ptData -> usedParams )
|
||||||
-> ( usedParams ~> brushParams )
|
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
|
||||||
-> ( brushParams ~> SplinePts Closed )
|
-> ( forall i. Differentiable i brushParams
|
||||||
|
=> Proxy# i
|
||||||
|
-> ( forall a. a -> I i a )
|
||||||
|
-> I i brushParams ~> Spline Closed () ( I i ( ℝ 2 ) )
|
||||||
|
)
|
||||||
-> ptData
|
-> ptData
|
||||||
-> Curve Open crvData ptData
|
-> Curve Open crvData ptData
|
||||||
-> OutlineFn
|
-> OutlineFn
|
||||||
outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
||||||
let
|
let
|
||||||
usedParams :: ℝ 1 ~> usedParams
|
pathAndUsedParams :: forall i
|
||||||
path :: ℝ 1 ~> ℝ 2
|
. ( D ( I i ( ℝ 1 ) ) ~ D ( ℝ 1 )
|
||||||
( path, usedParams ) =
|
, 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
|
case crv of
|
||||||
LineTo { curveEnd = NextPoint sp1 }
|
LineTo { curveEnd = NextPoint sp1 }
|
||||||
| let seg = Segment sp0 sp1
|
| let seg = Segment sp0 sp1
|
||||||
-> ( line @Point ( fmap coords seg )
|
-> ( line @i ( fmap ( toI . coords ) seg )
|
||||||
, line @Point ( fmap ptParams seg ) )
|
, line @i ( fmap ( toI . ptParams ) seg ) )
|
||||||
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
|
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
|
||||||
| let bez2 = Quadratic.Bezier sp0 sp1 sp2
|
| let bez2 = Quadratic.Bezier sp0 sp1 sp2
|
||||||
-> ( bezier2 @Point ( fmap coords bez2 )
|
-> ( bezier2 @i ( fmap ( toI . coords ) bez2 )
|
||||||
, bezier2 @Point ( fmap ptParams bez2 ) )
|
, bezier2 @i ( fmap ( toI . ptParams ) bez2 ) )
|
||||||
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
|
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
|
||||||
| let bez3 = Cubic.Bezier sp0 sp1 sp2 sp3
|
| let bez3 = Cubic.Bezier sp0 sp1 sp2 sp3
|
||||||
-> ( bezier3 @Point ( fmap coords bez3 )
|
-> ( bezier3 @i ( fmap ( toI . coords ) bez3 )
|
||||||
, bezier3 @Point ( fmap ptParams 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 :: OutlineFn
|
||||||
fwdBwd t
|
fwdBwd t
|
||||||
|
|
@ -456,8 +504,8 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
||||||
curves :: Seq ( ℝ 1 -> StrokeDatum Point )
|
curves :: Seq ( ℝ 1 -> StrokeDatum Point )
|
||||||
curves = brushStrokeData @Point @brushParams
|
curves = brushStrokeData @Point @brushParams
|
||||||
path
|
path
|
||||||
( usedParams `chainRule` toBrushParams )
|
( usedParams `chainRule` linear toBrushParams )
|
||||||
brushFromParams
|
( brushFromParams @Point proxy# id )
|
||||||
t
|
t
|
||||||
|
|
||||||
fwdOffset = withTangent path'_t brush_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 path_t path'_t _ = runD path t
|
||||||
D1 params_t _ _ = runD usedParams t
|
D1 params_t _ _ = runD usedParams t
|
||||||
brush_t = value @Double @brushParams
|
brush_t = value @Double @brushParams
|
||||||
$ runD brushFromParams
|
$ runD ( brushFromParams @Point proxy# id )
|
||||||
$ fun toBrushParams params_t
|
$ toBrushParams params_t
|
||||||
|
|
||||||
in fwdBwd
|
in fwdBwd
|
||||||
|
|
||||||
|
|
@ -1075,14 +1123,5 @@ data StrokeDatum i
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
deriving stock instance Show ( StrokeDatum Point )
|
deriving stock instance Show ( StrokeDatum 'Point )
|
||||||
deriving stock instance Show ( StrokeDatum Interval )
|
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
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE UnliftedNewtypes #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# LANGUAGE UnliftedNewtypes #-}
|
||||||
|
|
||||||
module Math.Linear
|
module Math.Linear
|
||||||
( -- * Points and vectors
|
( -- * Points and vectors
|
||||||
|
|
@ -10,14 +11,18 @@ module Math.Linear
|
||||||
-- * Points and vectors (second version)
|
-- * Points and vectors (second version)
|
||||||
, ℝ(..), T(.., V2, V3)
|
, ℝ(..), T(.., V2, V3)
|
||||||
, Fin(..), eqFin, MFin(..)
|
, Fin(..), eqFin, MFin(..)
|
||||||
, Dim, Representable(..), injection, projection
|
, Dim, Representable(..), ApRep(..)
|
||||||
|
, injection, projection
|
||||||
, Vec(..), (!), find
|
, Vec(..), (!), find
|
||||||
|
|
||||||
-- * Intervals
|
-- * Intervals
|
||||||
, 𝕀, 𝕀ℝ
|
, 𝕀, 𝕀ℝ, singleton, nonDecreasing
|
||||||
|
, Extent(..), I
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Data.Coerce
|
||||||
|
( Coercible, coerce )
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
( Type, Constraint )
|
( Type, Constraint )
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
|
|
@ -48,8 +53,12 @@ import Data.Group.Generics
|
||||||
( )
|
( )
|
||||||
|
|
||||||
-- rounded-hw
|
-- rounded-hw
|
||||||
|
import Numeric.Rounded.Hardware
|
||||||
|
( Rounded(..) )
|
||||||
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
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 anyclass NFData
|
||||||
deriving stock ( Show, Eq, Ord )
|
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.
|
-- | Tangent space to Euclidean space.
|
||||||
type T :: Type -> Type
|
type T :: Type -> Type
|
||||||
newtype T e = T { unT :: e }
|
newtype T e = T { unT :: e }
|
||||||
deriving stock ( Eq, Functor, Foldable, Traversable )
|
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
|
instance {-# OVERLAPPING #-} Show ( ℝ n ) => Show ( T ( ℝ n ) ) where
|
||||||
show ( T p ) = "V" ++ drop 1 ( show p )
|
show ( T p ) = "V" ++ drop 1 ( show p )
|
||||||
|
|
@ -104,14 +138,6 @@ instance Applicative T where
|
||||||
pure = T
|
pure = T
|
||||||
T f <*> T a = T ( f a )
|
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 #-}
|
{-# COMPLETE V2 #-}
|
||||||
pattern V2 :: Double -> Double -> T ( ℝ 2 )
|
pattern V2 :: Double -> Double -> T ( ℝ 2 )
|
||||||
pattern V2 x y = T ( ℝ2 x y )
|
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 :: Double -> Double -> Double -> T ( ℝ 3 )
|
||||||
pattern V3 x y z = T ( ℝ3 x y z )
|
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
|
-- | 1, ..., n
|
||||||
|
|
@ -250,8 +240,88 @@ find eq v b = MFin ( go 1## v )
|
||||||
= go ( j `plusWord#` 1## ) as
|
= go ( j `plusWord#` 1## ) as
|
||||||
go _ VZ = 0##
|
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.
|
-- Intervals.
|
||||||
|
|
||||||
type 𝕀 = Interval
|
type 𝕀 = Interval
|
||||||
type 𝕀ℝ n = 𝕀 ( ℝ n )
|
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 )
|
||||||
|
|
|
||||||
|
|
@ -16,8 +16,19 @@ import Data.Kind
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic, Generic1(..), Generically1(..) )
|
( Generic, Generic1(..), Generically1(..) )
|
||||||
|
|
||||||
|
-- acts
|
||||||
|
import Data.Act
|
||||||
|
( Torsor )
|
||||||
|
|
||||||
|
-- rounded-hw
|
||||||
|
import Numeric.Rounded.Hardware
|
||||||
|
( Rounded(..) )
|
||||||
|
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
||||||
|
( Interval(..) )
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Module
|
import Math.Module
|
||||||
|
( Module(..) )
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -66,7 +77,7 @@ data Dℝ3 v = D3 { v :: !v, dx, dy, dz :: !( T v ), ddx, dxdy, ddy, dxdz, dydz,
|
||||||
via Generically1 Dℝ3
|
via Generically1 Dℝ3
|
||||||
deriving stock instance ( Show v, Show ( T v ) ) => Show ( Dℝ3 v )
|
deriving stock instance ( Show v, Show ( T v ) ) => Show ( Dℝ3 v )
|
||||||
|
|
||||||
instance Num ( Dℝ1 Double ) where
|
instance ( Module s ( T r ), Num r ) => Num ( Dℝ1 r ) where
|
||||||
(+) = liftA2 (+)
|
(+) = liftA2 (+)
|
||||||
(-) = liftA2 (-)
|
(-) = liftA2 (-)
|
||||||
negate = fmap negate
|
negate = fmap negate
|
||||||
|
|
@ -81,7 +92,7 @@ instance Num ( Dℝ1 Double ) where
|
||||||
( T $ dx1 * v2 + v1 * dx2 )
|
( T $ dx1 * v2 + v1 * dx2 )
|
||||||
( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 )
|
( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 )
|
||||||
|
|
||||||
instance Num ( Dℝ2 Double ) where
|
instance ( Num r, Module s ( T r ) ) => Num ( Dℝ2 r ) where
|
||||||
(+) = liftA2 (+)
|
(+) = liftA2 (+)
|
||||||
(-) = liftA2 (-)
|
(-) = liftA2 (-)
|
||||||
negate = fmap negate
|
negate = fmap negate
|
||||||
|
|
@ -100,7 +111,7 @@ instance Num ( Dℝ2 Double ) where
|
||||||
( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 )
|
( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 )
|
||||||
|
|
||||||
|
|
||||||
instance Num ( Dℝ3 Double ) where
|
instance ( Module s ( T r ) , Num r ) => Num ( Dℝ3 r ) where
|
||||||
(+) = liftA2 (+)
|
(+) = liftA2 (+)
|
||||||
(-) = liftA2 (-)
|
(-) = liftA2 (-)
|
||||||
negate = fmap negate
|
negate = fmap negate
|
||||||
|
|
@ -123,34 +134,34 @@ instance Num ( Dℝ3 Double ) where
|
||||||
( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2)
|
( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2)
|
||||||
|
|
||||||
|
|
||||||
instance Module Double ( T v ) => Module ( Dℝ0 Double ) ( Dℝ0 v ) where
|
instance ( Num ( Dℝ0 r ), Module r ( T v ) ) => Module ( Dℝ0 r ) ( Dℝ0 v ) where
|
||||||
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
|
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
|
||||||
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
|
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
|
||||||
origin = pure ( coerce $ origin @Double @( T v ) )
|
origin = pure ( coerce $ origin @r @( T v ) )
|
||||||
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
|
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
|
||||||
|
|
||||||
instance Module Double ( T v ) => Module ( Dℝ1 Double ) ( Dℝ1 v ) where
|
instance ( Num ( Dℝ1 r ), Module r ( T v ) ) => Module ( Dℝ1 r ) ( Dℝ1 v ) where
|
||||||
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
|
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
|
||||||
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
|
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
|
||||||
origin = pure ( coerce $ origin @Double @( T v ) )
|
origin = pure ( coerce $ origin @r @( T v ) )
|
||||||
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
|
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
|
||||||
|
|
||||||
instance Module Double ( T v ) => Module ( Dℝ2 Double ) ( Dℝ2 v ) where
|
instance ( Num ( Dℝ2 r ), Module r ( T v ) ) => Module ( Dℝ2 r ) ( Dℝ2 v ) where
|
||||||
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
|
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
|
||||||
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
|
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
|
||||||
origin = pure ( coerce $ origin @Double @( T v ) )
|
origin = pure ( coerce $ origin @r @( T v ) )
|
||||||
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
|
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
|
||||||
|
|
||||||
instance Module Double ( T v ) => Module ( Dℝ3 Double ) ( Dℝ3 v ) where
|
instance ( Num ( Dℝ3 r ), Module r ( T v ) ) => Module ( Dℝ3 r ) ( Dℝ3 v ) where
|
||||||
(^+^) = liftA2 ( coerce $ (^+^) @Double @( T v ) )
|
(^+^) = liftA2 ( coerce $ (^+^) @r @( T v ) )
|
||||||
(^-^) = liftA2 ( coerce $ (^-^) @Double @( T v ) )
|
(^-^) = liftA2 ( coerce $ (^-^) @r @( T v ) )
|
||||||
origin = pure ( coerce $ origin @Double @( T v ) )
|
origin = pure ( coerce $ origin @r @( T v ) )
|
||||||
(*^) = liftA2 ( coerce $ (*^) @Double @( T v ) )
|
(*^) = liftA2 ( coerce $ (*^) @r @( T v ) )
|
||||||
|
|
||||||
instance Fractional ( Dℝ1 Double ) where
|
instance ( Module s ( T r ), Fractional r ) => Fractional ( Dℝ1 r ) where
|
||||||
(/) = error "I haven't yet defined (/) for Dℝ1"
|
(/) = error "I haven't yet defined (/) for Dℝ1"
|
||||||
fromRational = konst @Double @( ℝ 1 ) . fromRational
|
fromRational = konst @Double @( ℝ 1 ) . fromRational
|
||||||
instance Floating ( Dℝ1 Double ) where
|
instance ( Module s ( T r ), Floating r ) => Floating ( Dℝ1 r ) where
|
||||||
pi = konst @Double @( ℝ 1 ) pi
|
pi = konst @Double @( ℝ 1 ) pi
|
||||||
sin ( D1 v ( T dx ) ( T ddx ) )
|
sin ( D1 v ( T dx ) ( T ddx ) )
|
||||||
= let !s = sin v
|
= let !s = sin v
|
||||||
|
|
@ -162,10 +173,10 @@ instance Floating ( Dℝ1 Double ) where
|
||||||
!c = cos v
|
!c = cos v
|
||||||
in D1 c ( T $ -s * dx ) ( T $ -2 * s * ddx - c * dx * dx )
|
in D1 c ( T $ -s * dx ) ( T $ -2 * s * ddx - c * dx * dx )
|
||||||
|
|
||||||
instance Fractional ( Dℝ2 Double ) where
|
instance ( Module s ( T r ), Fractional r ) => Fractional ( Dℝ2 r ) where
|
||||||
(/) = error "I haven't yet defined (/) for Dℝ2"
|
(/) = error "I haven't yet defined (/) for Dℝ2"
|
||||||
fromRational = konst @Double @( ℝ 2 ) . fromRational
|
fromRational = konst @Double @( ℝ 2 ) . fromRational
|
||||||
instance Floating ( Dℝ2 Double ) where
|
instance ( Module s ( T r ), Floating r ) => Floating ( Dℝ2 r ) where
|
||||||
pi = konst @Double @( ℝ 2 ) pi
|
pi = konst @Double @( ℝ 2 ) pi
|
||||||
sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
|
sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
|
||||||
= let !s = sin v
|
= let !s = sin v
|
||||||
|
|
@ -185,10 +196,10 @@ instance Floating ( Dℝ2 Double ) where
|
||||||
( T $ -2 * s * dxdy - 2 * c * dx * dy )
|
( T $ -2 * s * dxdy - 2 * c * dx * dy )
|
||||||
( T $ -2 * s * ddy - c * dy * dy )
|
( T $ -2 * s * ddy - c * dy * dy )
|
||||||
|
|
||||||
instance Fractional ( Dℝ3 Double ) where
|
instance ( Module s ( T r ), Fractional r ) => Fractional ( Dℝ3 r ) where
|
||||||
(/) = error "I haven't yet defined (/) for Dℝ3"
|
(/) = error "I haven't yet defined (/) for Dℝ3"
|
||||||
fromRational = konst @Double @( ℝ 3 ) . fromRational
|
fromRational = konst @Double @( ℝ 3 ) . fromRational
|
||||||
instance Floating ( Dℝ3 Double ) where
|
instance ( Module s ( T r ), Floating r ) => Floating ( Dℝ3 r ) where
|
||||||
pi = konst @Double @( ℝ 3 ) pi
|
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 ) )
|
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
|
= 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
|
type Diffy :: Type -> Type -> Constraint
|
||||||
class ( Traversable ( D v ), Module r ( T v ) ) => Diffy r v where
|
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
|
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
|
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 ) )
|
chainRule :: ( Diffy r v, Module r ( T w ), D u ~ D ( ℝ 1 ) )
|
||||||
=> ( ( ℝ 1 ) ~> v ) -> ( v ~> w ) -> ( ( ℝ 1 ) ~> w )
|
=> ( u ~> v ) -> ( v ~> w ) -> ( u ~> w )
|
||||||
chainRule ( D df ) ( D dg ) =
|
chainRule ( D df ) ( D dg ) =
|
||||||
D \ x ->
|
D \ x ->
|
||||||
case df x of
|
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 ) )
|
( T $ f ( ℝ3 1 0 0 ) ) ( T $ f ( ℝ3 0 1 0 ) ) ( T $ f ( ℝ3 0 0 1 ) )
|
||||||
origin origin origin origin origin origin
|
origin origin origin origin origin origin
|
||||||
{-# INLINE linear #-}
|
{-# 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
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,6 @@ module Math.Module
|
||||||
, norm, squaredNorm, quadrance, distance
|
, norm, squaredNorm, quadrance, distance
|
||||||
, proj, projC, closestPointOnSegment
|
, proj, projC, closestPointOnSegment
|
||||||
, strictlyParallel, convexCombination
|
, strictlyParallel, convexCombination
|
||||||
, 𝕀
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -18,6 +17,8 @@ import Control.Applicative
|
||||||
( liftA2 )
|
( liftA2 )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( guard )
|
( guard )
|
||||||
|
import Data.Coerce
|
||||||
|
( Coercible, coerce )
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
( Type, Constraint )
|
( Type, Constraint )
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
|
|
@ -36,8 +37,6 @@ import Numeric.Rounded.Hardware
|
||||||
( Rounded(..) )
|
( Rounded(..) )
|
||||||
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
||||||
( Interval(..) )
|
( Interval(..) )
|
||||||
import Numeric.Rounded.Hardware.Class
|
|
||||||
( intervalAdd, intervalSub, intervalMul )
|
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import Math.Epsilon
|
import Math.Epsilon
|
||||||
|
|
@ -124,47 +123,42 @@ closestPointOnSegment c ( Segment p0 p1 )
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | A convenient constraint synonym for types that support interpolation.
|
-- | A convenient constraint synonym for types that support interpolation.
|
||||||
type Interpolatable :: Type -> Constraint
|
type Interpolatable :: Type -> Type -> Constraint
|
||||||
class ( Torsor ( T u ) u, Module Double ( T u ) ) => Interpolatable u
|
class ( Torsor ( T u ) u, Module r ( T u ) ) => Interpolatable r u
|
||||||
instance ( Torsor ( T u ) u, Module Double ( T u ) ) => Interpolatable 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
|
instance Num a => Module a ( Sum a ) where
|
||||||
|
|
||||||
origin = Sum 0
|
origin = Sum 0
|
||||||
|
|
||||||
(^+^) = (<>)
|
(^+^) = (<>)
|
||||||
( Sum x ) ^-^ ( Sum y ) = Sum ( x - y )
|
Sum x ^-^ Sum y = Sum ( x - y )
|
||||||
|
|
||||||
c *^ ( Sum x ) = Sum ( c * x )
|
c *^ Sum x = Sum ( c * x )
|
||||||
( Sum x ) ^* c = Sum ( x * c )
|
Sum x ^* c = Sum ( x * c )
|
||||||
|
|
||||||
instance Num a => Inner a ( Sum a ) where
|
instance Num a => Inner a ( Sum a ) where
|
||||||
Sum a ^.^ Sum b = a * b
|
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 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
|
instance Inner Double ( T ( ℝ 2 ) ) where
|
||||||
V2 x1 y1 ^.^ V2 x2 y2 = x1 * x2 + y1 * y2
|
V2 x1 y1 ^.^ V2 x2 y2 = x1 * x2 + y1 * y2
|
||||||
|
|
@ -213,35 +207,21 @@ convexCombination v0 v1 u
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Interval arithmetic using rounded-hw library.
|
-- Interval arithmetic using rounded-hw library.
|
||||||
|
|
||||||
instance Module ( 𝕀 Double ) ( T ( 𝕀ℝ 2 ) ) where
|
deriving via Sum ( 𝕀 Double ) instance Module ( 𝕀 Double ) ( T ( 𝕀 Double ) )
|
||||||
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 ) ) ) ^+^
|
deriving via ApRep ( Sum ( 𝕀 Double ) ) ( 𝕀ℝ n )
|
||||||
T ( I ( Rounded ( ℝ2 x2_lo y2_lo ) ) ( Rounded ( ℝ2 x2_hi y2_hi ) ) )
|
instance Representable ( 𝕀 Double ) ( 𝕀ℝ n ) => Module ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
||||||
= 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 ) ) )
|
|
||||||
|
|
||||||
instance Inner ( 𝕀 Double ) ( T ( 𝕀ℝ 2 ) ) where
|
instance Inner ( 𝕀 Double ) ( T ( 𝕀ℝ 2 ) ) where
|
||||||
T ( I ( Rounded ( ℝ2 x1_lo y1_lo ) ) ( Rounded ( ℝ2 x1_hi y1_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 ) ) )
|
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 )
|
= let !x1x2 = I ( Rounded x1_lo ) ( Rounded x1_hi ) * I ( Rounded x2_lo ) ( Rounded x2_hi )
|
||||||
!( y_lo, y_hi ) = intervalMul ( Rounded y1_lo ) ( Rounded y1_hi ) ( Rounded y2_lo ) ( Rounded y2_hi )
|
!y1y2 = I ( Rounded y1_lo ) ( Rounded y1_hi ) * I ( Rounded y2_lo ) ( Rounded y2_hi )
|
||||||
!( z_lo, z_hi ) = intervalAdd x_lo x_hi y_lo y_hi
|
in x1x2 + y1y2
|
||||||
in I z_lo z_hi
|
|
||||||
|
|
||||||
instance Cross ( 𝕀 Double ) ( T ( 𝕀ℝ 2 ) ) where
|
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 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 ) ) )
|
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 )
|
= let !x1y2 = I ( Rounded x1_lo ) ( Rounded x1_hi ) * I ( Rounded y2_lo ) ( Rounded y2_hi )
|
||||||
!( y_lo, y_hi ) = intervalMul ( Rounded x2_lo ) ( Rounded x2_hi ) ( Rounded y1_lo ) ( Rounded y1_hi )
|
!y2x1 = I ( Rounded x2_lo ) ( Rounded x2_hi ) * I ( Rounded y1_lo ) ( Rounded y1_hi )
|
||||||
!( z_lo, z_hi ) = intervalSub x_lo x_hi y_lo y_hi
|
in x1y2 - y2x1
|
||||||
in I z_lo z_hi
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue