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
|
||||
, 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 { }
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 Dℝ3 v = D3 { v :: !v, dx, dy, dz :: !( T v ), ddx, dxdy, ddy, dxdz, dydz,
|
|||
via Generically1 Dℝ3
|
||||
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 (-)
|
||||
negate = fmap negate
|
||||
|
|
@ -81,7 +92,7 @@ instance Num ( Dℝ1 Double ) where
|
|||
( T $ dx1 * v2 + v1 * dx2 )
|
||||
( 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 (-)
|
||||
negate = fmap negate
|
||||
|
|
@ -100,7 +111,7 @@ instance Num ( Dℝ2 Double ) where
|
|||
( 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 (-)
|
||||
negate = fmap negate
|
||||
|
|
@ -123,34 +134,34 @@ instance Num ( Dℝ3 Double ) where
|
|||
( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2)
|
||||
|
||||
|
||||
instance Module Double ( T v ) => Module ( Dℝ0 Double ) ( Dℝ0 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 ( Dℝ0 r ), Module r ( T v ) ) => Module ( Dℝ0 r ) ( Dℝ0 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 ( Dℝ1 Double ) ( Dℝ1 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 ( Dℝ1 r ), Module r ( T v ) ) => Module ( Dℝ1 r ) ( Dℝ1 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 ( Dℝ2 Double ) ( Dℝ2 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 ( Dℝ2 r ), Module r ( T v ) ) => Module ( Dℝ2 r ) ( Dℝ2 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 ( Dℝ3 Double ) ( Dℝ3 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 ( Dℝ3 r ), Module r ( T v ) ) => Module ( Dℝ3 r ) ( Dℝ3 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 ( 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"
|
||||
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
|
||||
sin ( D1 v ( T dx ) ( T ddx ) )
|
||||
= let !s = sin v
|
||||
|
|
@ -162,10 +173,10 @@ instance Floating ( Dℝ1 Double ) where
|
|||
!c = cos v
|
||||
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"
|
||||
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
|
||||
sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
|
||||
= 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 * 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"
|
||||
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
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue