mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
improve show instances
This commit is contained in:
sheaf
parent
25d738b252
commit
6945aac704
|
|
@ -27,12 +27,6 @@ allow-newer:
|
|||
waargonaut:semigroups, waargonaut:text,
|
||||
waargonaut:vector, waargonaut:witherable,
|
||||
|
||||
-- eigen
|
||||
--source-repository-package
|
||||
-- type: git
|
||||
-- location: https://github.com/chessai/eigen
|
||||
-- tag: 8fff32a43df743c8c83428a86dd566a0936a4fba
|
||||
|
||||
-- records-sop
|
||||
source-repository-package
|
||||
type: git
|
||||
|
|
@ -43,11 +37,11 @@ source-repository-package
|
|||
-- GHC 9.4 --
|
||||
-------------
|
||||
|
||||
-- hw-balancedparens
|
||||
-- eigen
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/sheaf/hw-balancedparens
|
||||
tag: 747e4ce2145b436dd352814b71a68fc41fe63e6f
|
||||
location: https://github.com/chessai/eigen
|
||||
tag: 1790fdf9138970dde0dbabf8b270698145a4a88c
|
||||
|
||||
-------------
|
||||
-- GHC 9.6 --
|
||||
|
|
|
|||
|
|
@ -200,11 +200,11 @@ runApplication application = do
|
|||
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
||||
fitParametersTVar <- STM.newTVarIO @FitParameters
|
||||
( FitParameters
|
||||
{ maxSubdiv = 1 --2 --3 -- 6
|
||||
, nbSegments = 2 --3 --6 -- 12
|
||||
{ maxSubdiv = 5 --2 --3 -- 6
|
||||
, nbSegments = 3 --3 --6 -- 12
|
||||
, dist_tol = 0.1 -- 5e-3
|
||||
, t_tol = 0.1 -- 1e-4
|
||||
, maxIters = 1 -- 100
|
||||
, maxIters = 5 -- 100
|
||||
}
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -41,12 +41,6 @@ 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 )
|
||||
|
|
@ -130,19 +124,19 @@ instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
|
|||
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 ) )
|
||||
T ( 𝕀 ( MkR g_lo ) ( MkR g_hi ) )
|
||||
• 𝕀 ( MkR a_lo ) ( MkR a_hi )
|
||||
= case T ( 𝕀 g_lo g_hi ) • 𝕀 a_lo a_hi of
|
||||
𝕀 b_lo b_hi ->
|
||||
𝕀 ( MkR b_lo ) ( 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 ) ) )
|
||||
𝕀 ( MkR a_lo ) ( MkR a_hi )
|
||||
--> 𝕀 ( MkR b_lo ) ( MkR b_hi )
|
||||
= case 𝕀 a_lo a_hi --> 𝕀 b_lo b_hi of
|
||||
T ( 𝕀 c_lo c_hi ) ->
|
||||
T ( 𝕀 ( MkR c_lo ) ( MkR c_hi ) )
|
||||
|
||||
type instance RepDim ( Record ks ) = Length ks
|
||||
deriving newtype
|
||||
|
|
|
|||
|
|
@ -85,8 +85,6 @@ import qualified Control.Parallel.Strategies as Strats
|
|||
-- rounded-hw
|
||||
import Numeric.Rounded.Hardware
|
||||
( Rounded(..) )
|
||||
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
||||
( Interval(I) )
|
||||
import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as Interval
|
||||
|
||||
-- transformers
|
||||
|
|
@ -539,11 +537,11 @@ outlineFunction ptParams toBrushParams brushFromParams sp0 crv =
|
|||
|
||||
bisSols = bisection 0.0001 curvesI
|
||||
|
||||
in --trace
|
||||
-- ( unlines $
|
||||
-- ( "bisectionMethod: #(possible zeroes) = " ++ show ( length bisSols ) ) :
|
||||
-- "" :
|
||||
-- map show bisSols )
|
||||
in trace
|
||||
( unlines $
|
||||
( "bisectionMethod: #(possible zeroes) = " ++ show ( length bisSols ) ) :
|
||||
"" :
|
||||
map show bisSols )
|
||||
fwdBwd
|
||||
|
||||
-----------------------------------
|
||||
|
|
@ -1178,9 +1176,9 @@ bisection minWidth eqs = bisect initialCands [] []
|
|||
| otherwise
|
||||
= bisect cands toTry sols
|
||||
|
||||
bisect ( cand@( t@( I ( Rounded ( ℝ1 t_lo ) ) ( Rounded ( ℝ1 t_hi ) ) )
|
||||
bisect ( cand@( t@( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_hi ) )
|
||||
, i
|
||||
, s@( I ( Rounded ( ℝ1 s_lo ) ) ( Rounded ( ℝ1 s_hi ) ) )
|
||||
, s@( 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_hi ) )
|
||||
, _, _
|
||||
) : cands )
|
||||
toTry
|
||||
|
|
@ -1195,37 +1193,37 @@ bisection minWidth eqs = bisect initialCands [] []
|
|||
= let newToTry
|
||||
| t_hi - t_lo > s_hi - s_lo
|
||||
, let t_mid = 0.5 * ( t_lo + t_hi )
|
||||
= ( I ( Rounded ( ℝ1 t_lo ) ) ( Rounded ( ℝ1 t_mid ) ), i, s )
|
||||
: ( I ( Rounded ( ℝ1 t_mid ) ) ( Rounded ( ℝ1 t_hi ) ), i, s )
|
||||
= ( 𝕀 ( ℝ1 t_lo ) ( ℝ1 t_mid ), i, s )
|
||||
: ( 𝕀 ( ℝ1 t_mid ) ( ℝ1 t_hi ), i, s )
|
||||
: toTry
|
||||
| let s_mid = 0.5 * ( s_lo + s_hi )
|
||||
= ( t, i, I ( Rounded ( ℝ1 s_lo ) ) ( Rounded ( ℝ1 s_mid ) ) )
|
||||
: ( t, i, I ( Rounded ( ℝ1 s_mid ) ) ( Rounded ( ℝ1 s_hi ) ) )
|
||||
= ( t, i, 𝕀 ( ℝ1 s_lo ) ( ℝ1 s_mid ) )
|
||||
: ( t, i, 𝕀 ( ℝ1 s_mid ) ( ℝ1 s_hi ) )
|
||||
: toTry
|
||||
in bisect cands newToTry sols
|
||||
|
||||
initialCands =
|
||||
getCands
|
||||
( I ( Rounded $ ℝ1 0 ) ( Rounded $ ℝ1 1 ) )
|
||||
( I ( Rounded $ ℝ1 0 ) ( Rounded $ ℝ1 1 ) )
|
||||
( 𝕀 ( ℝ1 0 ) ( ℝ1 1 ) )
|
||||
( 𝕀 ( ℝ1 0 ) ( ℝ1 1 ) )
|
||||
|
||||
getCands t s =
|
||||
[ (t, i, s, ee, 𝛿E𝛿sdcdt )
|
||||
| let !eqs_t = eqs t
|
||||
, ( eq_t, i ) <- zip ( toList eqs_t ) ( [0,1..] :: [Int] )
|
||||
, let !( StrokeDatum { ee, 𝛿E𝛿sdcdt = T 𝛿E𝛿sdcdt } ) = eq_t s
|
||||
, Interval.inf ee < 0 && Interval.sup ee > 0
|
||||
, cmpℝ2 (<) ( getRounded ( Interval.inf 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
&& cmpℝ2 (>) ( getRounded ( Interval.sup 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
, Interval.inf ( ival ee ) < 0 && Interval.sup ( ival ee ) > 0
|
||||
, cmpℝ2 (<) ( getRounded ( Interval.inf $ ival 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
&& cmpℝ2 (>) ( getRounded ( Interval.sup $ ival 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
]
|
||||
|
||||
isCand :: 𝕀ℝ 1 -> Int -> 𝕀ℝ 1 -> Maybe ( 𝕀 Double, 𝕀ℝ 2 )
|
||||
isCand t i s = case ( ( eqs t ) `Seq.index` i ) s of
|
||||
StrokeDatum { ee, 𝛿E𝛿sdcdt = T 𝛿E𝛿sdcdt } ->
|
||||
do guard $
|
||||
Interval.inf ee < 0 && Interval.sup ee > 0
|
||||
&& cmpℝ2 (<) ( getRounded ( Interval.inf 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
&& cmpℝ2 (>) ( getRounded ( Interval.sup 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
Interval.inf ( ival ee ) < 0 && Interval.sup ( ival ee ) > 0
|
||||
&& cmpℝ2 (<) ( getRounded ( Interval.inf $ ival 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
&& cmpℝ2 (>) ( getRounded ( Interval.sup $ ival 𝛿E𝛿sdcdt ) ) ( ℝ2 0 0 )
|
||||
return ( ee, 𝛿E𝛿sdcdt )
|
||||
|
||||
cmpℝ2 :: ( Double -> Double -> Bool ) -> ℝ 2 -> ℝ 2 -> Bool
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Math.Interval
|
||||
( 𝕀, 𝕀ℝ
|
||||
( 𝕀(..), 𝕀ℝ
|
||||
, Extent(..), type I
|
||||
, singleton, nonDecreasing
|
||||
)
|
||||
|
|
@ -32,18 +32,12 @@ import Data.Group
|
|||
import Data.Group.Generics
|
||||
( )
|
||||
|
||||
-- rounded-hw
|
||||
import Numeric.Rounded.Hardware
|
||||
( Rounded(..) )
|
||||
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
||||
( Interval(..) )
|
||||
|
||||
-- splines
|
||||
import Math.Algebra.Dual
|
||||
import Math.Algebra.Dual.Internal
|
||||
( chainRuleQ )
|
||||
import Math.Interval.Internal
|
||||
( type 𝕀 )
|
||||
( 𝕀(..) )
|
||||
import Math.Linear
|
||||
( ℝ(..), T(..)
|
||||
, RepresentableQ(..)
|
||||
|
|
@ -67,12 +61,11 @@ type family I i a where
|
|||
I 'Interval a = 𝕀 a
|
||||
|
||||
singleton :: a -> 𝕀 a
|
||||
singleton a = I ( Rounded a ) ( Rounded a )
|
||||
singleton a = 𝕀 a 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 )
|
||||
nonDecreasing f ( 𝕀 lo hi ) = 𝕀 ( f lo ) ( f hi )
|
||||
|
||||
|
||||
deriving via ViaAbelianGroup ( T ( 𝕀 Double ) )
|
||||
|
|
@ -120,17 +113,17 @@ instance Module ( 𝕀 Double ) ( T ( 𝕀ℝ 4 ) ) where
|
|||
k *^ T a = T $$( tabulateQ \ i -> [|| unT $ k *^ T $$( indexQ [|| a ||] i ) ||] )
|
||||
|
||||
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 !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 )
|
||||
T ( 𝕀 ( ℝ2 x1_lo y1_lo ) ( ℝ2 x1_hi y1_hi ) ) ^.^
|
||||
T ( 𝕀 ( ℝ2 x2_lo y2_lo ) ( ℝ2 x2_hi y2_hi ) )
|
||||
= let !x1x2 = 𝕀 x1_lo x1_hi * 𝕀 x2_lo x2_hi
|
||||
!y1y2 = 𝕀 y1_lo y1_hi * 𝕀 y2_lo 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 !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 )
|
||||
T ( 𝕀 ( ℝ2 x1_lo y1_lo ) ( ℝ2 x1_hi y1_hi ) ) `cross`
|
||||
T ( 𝕀 ( ℝ2 x2_lo y2_lo ) ( ℝ2 x2_hi y2_hi ) )
|
||||
= let !x1y2 = 𝕀 x1_lo x1_hi * 𝕀 y2_lo y2_hi
|
||||
!y2x1 = 𝕀 x2_lo x2_hi * 𝕀 y1_lo y1_hi
|
||||
in x1y2 - y2x1
|
||||
|
||||
deriving via ViaModule ( 𝕀 Double ) ( T ( 𝕀ℝ n ) )
|
||||
|
|
|
|||
|
|
@ -5,17 +5,23 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Math.Interval.Internal
|
||||
( type 𝕀 )
|
||||
( 𝕀(.., 𝕀) )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Prelude hiding ( Num(..), Fractional(..), Floating(..), (^) )
|
||||
import qualified Prelude
|
||||
import Data.Monoid
|
||||
( Sum(..) )
|
||||
import GHC.Show
|
||||
( showCommaSpace )
|
||||
|
||||
-- rounded-hw
|
||||
import Numeric.Rounded.Hardware
|
||||
( Rounded(..) )
|
||||
import Numeric.Rounded.Hardware.Interval.NonEmpty
|
||||
( Interval )
|
||||
import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as Interval
|
||||
( Interval(..) )
|
||||
import qualified Numeric.Rounded.Hardware.Interval.NonEmpty as Interval
|
||||
( sup, inf, powInt )
|
||||
|
|
@ -32,7 +38,19 @@ import Math.Ring
|
|||
--------------------------------------------------------------------------------
|
||||
-- Intervals.
|
||||
|
||||
type 𝕀 = Interval
|
||||
newtype 𝕀 a = MkI { ival :: Interval a }
|
||||
deriving newtype ( Prelude.Num, Prelude.Fractional, Prelude.Floating )
|
||||
|
||||
{-# COMPLETE 𝕀 #-}
|
||||
pattern 𝕀 :: a -> a -> 𝕀 a
|
||||
pattern 𝕀 x y = MkI ( Interval.I ( Rounded x ) ( Rounded y ) )
|
||||
instance Show a => Show ( 𝕀 a ) where
|
||||
showsPrec _ ( 𝕀 x y )
|
||||
= showString "["
|
||||
. showsPrec 0 x
|
||||
. showCommaSpace
|
||||
. showsPrec 0 y
|
||||
. showString "]"
|
||||
|
||||
deriving via ViaPrelude ( 𝕀 Double )
|
||||
instance AbelianGroup ( 𝕀 Double )
|
||||
|
|
@ -40,8 +58,8 @@ deriving via ViaPrelude ( 𝕀 Double )
|
|||
instance AbelianGroup ( T ( 𝕀 Double ) )
|
||||
|
||||
instance Ring ( 𝕀 Double ) where
|
||||
(*) = (Prelude.*)
|
||||
x ^ n = Interval.powInt x ( Prelude.fromIntegral n )
|
||||
MkI i1 * MkI i2 = MkI $ i1 Prelude.* i2
|
||||
MkI x ^ n = MkI $ Interval.powInt x ( Prelude.fromIntegral n )
|
||||
-- This is very important, as x^2 is not the same as x * x
|
||||
-- in interval arithmetic. This ensures we don't
|
||||
-- accidentally use (^) from Prelude.
|
||||
|
|
@ -55,28 +73,28 @@ deriving via ViaPrelude ( 𝕀 Double )
|
|||
type instance RepDim ( 𝕀 u ) = RepDim u
|
||||
instance RepresentableQ r u => RepresentableQ ( 𝕀 r ) ( 𝕀 u ) where
|
||||
tabulateQ f =
|
||||
let !lo = tabulateQ @r @u ( \ i -> [|| getRounded $ Interval.inf $$( f i ) ||] )
|
||||
!hi = tabulateQ @r @u ( \ i -> [|| getRounded $ Interval.sup $$( f i ) ||] )
|
||||
in [|| I ( Rounded $$lo ) ( Rounded $$hi ) ||]
|
||||
let !lo = tabulateQ @r @u ( \ i -> [|| getRounded $ Interval.inf $ ival $$( f i ) ||] )
|
||||
!hi = tabulateQ @r @u ( \ i -> [|| getRounded $ Interval.sup $ ival $$( f i ) ||] )
|
||||
in [|| 𝕀 $$lo $$hi ||]
|
||||
|
||||
indexQ d i =
|
||||
[|| case $$d of
|
||||
I ( Rounded lo ) ( Rounded hi ) ->
|
||||
𝕀 lo hi ->
|
||||
let !lo_i = $$( indexQ @r @u [|| lo ||] i )
|
||||
!hi_i = $$( indexQ @r @u [|| hi ||] i )
|
||||
in I ( Rounded lo_i ) ( Rounded hi_i )
|
||||
in 𝕀 lo_i hi_i
|
||||
||]
|
||||
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 )
|
||||
let !lo = tabulate @r @u ( \ i -> getRounded $ Interval.inf $ ival ( f i ) )
|
||||
!hi = tabulate @r @u ( \ i -> getRounded $ Interval.sup $ ival ( f i ) )
|
||||
in 𝕀 lo hi
|
||||
|
||||
index d i =
|
||||
case d of
|
||||
I ( Rounded lo ) ( Rounded hi ) ->
|
||||
𝕀 lo hi ->
|
||||
let !lo_i = index @r @u lo i
|
||||
!hi_i = index @r @u hi i
|
||||
in I ( Rounded lo_i ) ( Rounded hi_i )
|
||||
in 𝕀 lo_i hi_i
|
||||
|
||||
deriving via Sum ( 𝕀 Double ) instance Module ( 𝕀 Double ) ( T ( 𝕀 Double ) )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ module Math.Linear
|
|||
Segment(..), Mat22(..)
|
||||
|
||||
-- * Points and vectors (second version)
|
||||
, ℝ(..), T(.., V2, V3)
|
||||
, ℝ(..), T(.., V2, V3, V4)
|
||||
, Fin(..), MFin(..)
|
||||
, RepDim, RepresentableQ(..)
|
||||
, Representable(..), injection, projection
|
||||
|
|
@ -24,6 +24,8 @@ import Data.Kind
|
|||
( Type )
|
||||
import GHC.Generics
|
||||
( Generic, Generic1, Generically(..), Generically1(..) )
|
||||
import GHC.Show
|
||||
( showSpace )
|
||||
import GHC.TypeNats
|
||||
( Nat, type (+) )
|
||||
|
||||
|
|
@ -85,9 +87,14 @@ instance Act ( T Double ) Double where
|
|||
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 )
|
||||
deriving stock instance Show v => Show ( T v )
|
||||
instance {-# OVERLAPPING #-} Show ( ℝ n ) => Show ( T ( ℝ n ) ) where
|
||||
show ( T p ) = "V" ++ drop 1 ( show p )
|
||||
instance {-# INCOHERENT #-} Show v => Show ( T v ) where
|
||||
showsPrec p ( T v )
|
||||
= showParen ( p >= 11 )
|
||||
$ showString "T"
|
||||
. showSpace
|
||||
. showsPrec 0 v
|
||||
|
||||
instance Applicative T where
|
||||
pure = T
|
||||
|
|
@ -96,13 +103,15 @@ instance Applicative T where
|
|||
{-# COMPLETE V2 #-}
|
||||
pattern V2 :: Double -> Double -> T ( ℝ 2 )
|
||||
pattern V2 x y = T ( ℝ2 x y )
|
||||
--instance Show (T (ℝ 2)) where
|
||||
-- showsPrec i (T (ℝ2 x y)) = showsPrec i (V x y)
|
||||
|
||||
{-# COMPLETE V3 #-}
|
||||
pattern V3 :: Double -> Double -> Double -> T ( ℝ 3 )
|
||||
pattern V3 x y z = T ( ℝ3 x y z )
|
||||
|
||||
{-# COMPLETE V4 #-}
|
||||
pattern V4 :: Double -> Double -> Double -> Double -> T ( ℝ 4 )
|
||||
pattern V4 x y z w = T ( ℝ4 x y z w )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
infixr 5 `VS`
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module Math.Linear.Internal
|
||||
( ℝ(..)
|
||||
, Fin(..), MFin(..)
|
||||
|
|
@ -14,8 +13,12 @@ module Math.Linear.Internal
|
|||
-- base
|
||||
import Data.Kind
|
||||
( Type, Constraint )
|
||||
import Data.List
|
||||
( intersperse )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
import GHC.Show
|
||||
( showSpace )
|
||||
import GHC.TypeNats
|
||||
( Nat )
|
||||
|
||||
|
|
@ -38,19 +41,51 @@ data instance ℝ 0 = ℝ0
|
|||
deriving anyclass NFData
|
||||
newtype instance ℝ 1 = ℝ1 { unℝ1 :: Double }
|
||||
deriving stock ( Generic )
|
||||
deriving newtype ( Show, Eq, Ord, NFData )
|
||||
deriving newtype ( Eq, Ord, NFData )
|
||||
data instance ℝ 2 = ℝ2 { _ℝ2_x, _ℝ2_y :: {-# UNPACK #-} !Double }
|
||||
deriving stock Generic
|
||||
deriving anyclass NFData
|
||||
deriving stock ( Show, Eq, Ord )
|
||||
deriving stock ( Eq, Ord )
|
||||
data instance ℝ 3 = ℝ3 { _ℝ3_x, _ℝ3_y, _ℝ3_z :: {-# UNPACK #-} !Double }
|
||||
deriving stock Generic
|
||||
deriving anyclass NFData
|
||||
deriving stock ( Show, Eq, Ord )
|
||||
deriving stock ( Eq, Ord )
|
||||
data instance ℝ 4 = ℝ4 { _ℝ4_x, _ℝ4_y, _ℝ4_z, _ℝ4_w :: {-# UNPACK #-} !Double }
|
||||
deriving stock Generic
|
||||
deriving anyclass NFData
|
||||
deriving stock ( Show, Eq, Ord )
|
||||
deriving stock ( Eq, Ord )
|
||||
|
||||
instance Show ( ℝ 1 ) where
|
||||
showsPrec p ( ℝ1 x )
|
||||
= showParen ( p >= 11 )
|
||||
$ showString "ℝ1"
|
||||
. foldr (.) id ( showSpace : intersperse showSpace coords )
|
||||
where
|
||||
coords = map ( showsPrec 0 ) [ x ]
|
||||
|
||||
instance Show ( ℝ 2 ) where
|
||||
showsPrec p ( ℝ2 x y )
|
||||
= showParen ( p >= 11 )
|
||||
$ showString "ℝ2"
|
||||
. foldr (.) id ( showSpace : intersperse showSpace coords )
|
||||
where
|
||||
coords = map ( showsPrec 0 ) [ x, y ]
|
||||
|
||||
instance Show ( ℝ 3 ) where
|
||||
showsPrec p ( ℝ3 x y z )
|
||||
= showParen ( p >= 11 )
|
||||
$ showString "ℝ3"
|
||||
. foldr (.) id ( showSpace : intersperse showSpace coords )
|
||||
where
|
||||
coords = map ( showsPrec 0 ) [ x, y, z ]
|
||||
|
||||
instance Show ( ℝ 4 ) where
|
||||
showsPrec p ( ℝ4 x y z w )
|
||||
= showParen ( p >= 11 )
|
||||
$ showString "ℝ4"
|
||||
. foldr (.) id ( showSpace : intersperse showSpace coords )
|
||||
where
|
||||
coords = map ( showsPrec 0 ) [ x, y, z, w ]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue