diff --git a/bench/misc.hs b/bench/misc.hs --- a/bench/misc.hs +++ b/bench/misc.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -18,23 +17,30 @@ main :: IO () main = do putStrLn "Hello world!" - print (Dn @3 :* Dn @2 :* (D :: Dim ('[] :: [Nat]))) + print (D @3 :* D @2 :* U) - print (fromList [vec2 1 0, vec2 2 3, vec2 3 4, vec2 5 6] :: DataFrame Int '[N 2, XN 2]) - print (fromList [vec4 1 0 2 11, vec4 2 22 3 0, vec4 3 4 0 0] :: DataFrame Double '[N 4, XN 2]) - print (fromList [vec2 0 0, vec2 2 22, vec2 2 22] :: DataFrame Float '[N 2, XN 2]) - print (fromList [0, 1, 3, 5, 7] :: DataFrame Float '[XN 2]) - print (fromList [9, 13, 2] :: DataFrame Float '[N 5, N 2, XN 2]) - print $ vec2 1 1 %* mat22 (vec2 1 1) (vec2 2 (3 :: Float)) + print (fromList D [vec2 1 0, vec2 2 3, vec2 3 4, vec2 5 6] + :: Maybe (DataFrame Int '[N 2, XN 2])) + print (fromList D [vec4 1 0 2 11, vec4 2 22 3 0, vec4 3 4 0 0] + :: Maybe (DataFrame Double '[N 4, XN 0])) + print (fromList D [vec2 0 0, vec2 2 22, vec2 2 22] + :: Maybe (DataFrame Float '[N 2, XN 4])) + print $ fromList (D @3) [0 :: Scf, 1, 3, 5, 7] + print ( fromList D [9, 13, 2] + :: Maybe (DataFrame Float '[N 5, N 2, XN 2])) + print $ vec2 1 1 %* mat22 1 (vec2 2 (3 :: Float)) print (toList (42 :: DataFrame Int '[4,3,2])) -- Seems like I have to specify known dimension explicitly, -- because the inference process within the pattern match -- cannot escape the case expression. -- On the other hand, if I type wrong dimension it will throw a nice type-level error. - () <- case fromList [10, 100, 1000] :: DataFrame Double '[N 4, N 2, XN 2] of - -- Amazing inference! - -- m :: KnownNat k => DataFrame '[4,2,k] - SomeDataFrame m -> print $ vec4 1 2.25 3 0.162 %* m + () <- case fromList D [10, 100, 1000] :: Maybe (DataFrame Double '[N 4, N 2, XN 2]) of + Just (XFrame m) + | KnownDims <- dims `inSpaceOf` m + -- Amazing inference! + -- m :: KnownNat k => DataFrame '[4,2,k] + -> print $ vec4 1 2.25 3 0.162 %* m + Nothing -> print "Failed to construct a DataFrame!" putStrLn "Constructing larger matrices" let x :: DataFrame Double '[2,5,4] x = transpose ( (56707.4 <::> 73558.41 <+:> 47950.074 <+:> 83394.61 <+:> 25611.629 ) @@ -62,7 +68,7 @@ -- For example, we can do tensor produt of every sub-tensor. putStrLn "\nConversions between element types and frame sizes." print $ iwmap @Int @'[2,2] @'[7] @_ - (\(i:!Z) v -> fromScalar . (scalar i +) . round + (\(Idx i:*U) v -> fromScalar . (scalar (fromIntegral i) +) . round $ vec3 0.02 (-0.01) 0.001 %* v ) y @@ -77,8 +83,8 @@ print rVec -- Updating existing frames - print $ update (2:!Z) (scalar 777) rVec - print $ update (2:!3:!Z) (vec2 999 999) x + print $ update (2:*U) (scalar 777) rVec + print $ update (2:*3:*U) (vec2 999 999) x let matX = iwgen (scalar . fromEnum) :: DataFrame Int '[2,5,4] matY = iwgen (scalar . fromEnum) :: DataFrame Int '[5,4] @@ -91,7 +97,7 @@ -- Working with mutable frames print $ ST.runST $ do sdf <- ST.thawDataFrame matY - ST.writeDataFrame sdf (1:!1:!Z) 900101 - ST.writeDataFrame sdf (3:!3:!Z) 900303 - ST.writeDataFrame sdf (5:!3:!Z) 900503 + ST.writeDataFrame sdf (1:*1:*U) 900101 + ST.writeDataFrame sdf (3:*3:*U) 900303 + ST.writeDataFrame sdf (5:*3:*U) 900503 ST.unsafeFreezeDataFrame sdf diff --git a/bench/subspacefolds.hs b/bench/subspacefolds.hs --- a/bench/subspacefolds.hs +++ b/bench/subspacefolds.hs @@ -48,7 +48,7 @@ putStrLn "\nRunning a ewfoldl on vector5 elements..." let rezEwv1 = ewfoldl @Float @'[Head DList] @(Tail DList) - (\a x -> return $! fromMaybe 2 a + fromMaybe 0 a / (1 + iwgen @_ @'[] (\(i:!Z) -> (i+1):!Z !. x )) ) + (\a x -> return $! fromMaybe 2 a + fromMaybe 0 a / (1 + iwgen @_ @'[] (\(Idx i:*U) -> Idx (i+1) :* U !. x )) ) (Just (3 :: DataFrame Float '[5])) df t6 <- rezEwv1 `seq` getCurrentTime seq t6 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t6 t5) @@ -56,7 +56,7 @@ putStrLn "\nRunning a ewfoldr on vector3 elements..." let rezEwv2 = ewfoldr @Float @'[Head DList] @(Tail DList) - (\x a -> return $! fromMaybe 2 a + fromMaybe 1 a / (1 + iwgen @_ @'[] (\(i:!Z) -> (i+1):!Z !. x ))) + (\x a -> return $! fromMaybe 2 a + fromMaybe 1 a / (1 + iwgen @_ @'[] (\(Idx i:*U) -> Idx (i+1):* U !. x ))) (Just (3 :: DataFrame Float '[3])) df t7 <- rezEwv2 `seq` getCurrentTime seq t7 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t7 t6) @@ -74,4 +74,4 @@ putStrLn "Checking indexes" - print $ 2:!1:!1:!3:!1:!Z !. df + print $ 2:*1:*1:*3:*1:*U !. df diff --git a/bench/tuple.hs b/bench/tuple.hs deleted file mode 100644 --- a/bench/tuple.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Main (main) where - -import Data.Time.Clock -import Numeric.Semigroup -import Numeric.Tuple - - -main :: IO () -main = do - let n = 10000000 :: Int - one = 1 :: Int - bench "MaxTup0Fold" $ - fromTuple $ foldMap' (const T0) [1..n] - bench "MaxFold" $ - foldMap' Max [1..n] - bench "MaxTupFold" $ - foldMap' (T1 <$> Max) [1..n] - bench "MaxSumFold" $ - fromTuple $ foldMap' (T2 <$> Max <*> Sum) [1..n] - bench "MaxSumMinFold" $ - fromTuple $ foldMap' (T3 <$> Max <*> Sum <*> Min) [1..n] - bench "MaxSumMinMinMaxFold" $ - fromTuple $ foldMap' (T4 <$> Max <*> Sum <*> Min <*> minMax) [1..n] - bench "MaxSumMinMinMaxAllFold" $ - fromTuple $ foldMap' (T5 <$> Max - <*> Sum . (`mod` 19) - <*> Min . (`mod` 23) - <*> minMax - <*> (All . (>0)) - ) [1..n] - bench "MaxSumMinMinMaxAllCountFold" $ - fromTuple $ foldMap' (T6 <$> Max - <*> Sum . (`mod` 19) - <*> Min . (`mod` 23) - <*> minMax - <*> (All . (>0)) - <*> (Sum . const one) - ) [1..n] - bench "MaxSumMinMinMaxAllCountProdFold" $ - fromTuple $ foldMap' (T7 <$> Max - <*> Sum . (`mod` 19) - <*> Min . (`mod` 23) - <*> minMax - <*> (All . (>0)) - <*> (Sum . const one) - <*> Product . (+1) . (*(-2)) . (`mod` 2) - ) [1..n] - - - - -bench :: Show a => String -> a -> IO () -bench bname v = do - t0 <- getCurrentTime - t1 <- t0 `seq` v `seq` putStrLn ("Evaluated " <> bname <> ":") >> print v >> getCurrentTime - seq t1 putStrLn $ "Execution time: " <> show (diffUTCTime t1 t0) - putStrLn "" diff --git a/easytensor.cabal b/easytensor.cabal --- a/easytensor.cabal +++ b/easytensor.cabal @@ -1,6 +1,6 @@ name: easytensor -version: 0.4.0.0 -cabal-version: >=1.20 +version: 1.0.0.0 +cabal-version: >=1.22 build-type: Simple license: BSD3 license-file: LICENSE @@ -15,8 +15,6 @@ Allows ad-hoc replacement with fixed low-dimensionality vectors and matrices without changing user interface. category: Math, Geometry author: Artem Chirkin -extra-source-files: - src-base/Numeric/Array/Family/Array.h source-repository head type: git @@ -35,74 +33,46 @@ if flag(unsafeindices) cpp-options: -DUNSAFE_INDICES exposed-modules: - Numeric.Commons Numeric.DataFrame Numeric.DataFrame.IO Numeric.DataFrame.ST Numeric.Matrix + Numeric.Matrix.Class Numeric.Vector Numeric.Scalar Numeric.Quaternion Numeric.Semigroup - Numeric.Tuple + Numeric.PrimBytes + Numeric.DataFrame.Type + Numeric.DataFrame.Family + Numeric.DataFrame.Shape + Numeric.DataFrame.SubSpace + Numeric.DataFrame.Contraction + Numeric.DataFrame.Internal.Mutable + Numeric.DataFrame.Internal.Array + Numeric.DataFrame.Internal.Array.Class + Numeric.DataFrame.Internal.Array.Family + Numeric.DataFrame.Internal.Array.Family.ArrayBase + Numeric.DataFrame.Internal.Array.Family.ScalarBase + Numeric.DataFrame.Internal.Array.Family.FloatX2 + Numeric.DataFrame.Internal.Array.Family.FloatX3 + Numeric.DataFrame.Internal.Array.Family.FloatX4 + Numeric.DataFrame.Internal.Array.Family.DoubleX2 + Numeric.DataFrame.Internal.Array.Family.DoubleX3 + Numeric.DataFrame.Internal.Array.Family.DoubleX4 + Numeric.DataFrame.Internal.Array.PrimOps build-depends: - base >=4.9 && <5, - ghc-prim >=0.5, - dimensions -any - if impl(ghcjs) - build-depends: - ghcjs-base >= 0.2.0.0 + base >=4.10 && <5, + dimensions >=1.0.0.0 default-language: Haskell2010 hs-source-dirs: src - if impl(ghcjs) - hs-source-dirs: src-ghcjs - else - hs-source-dirs: src-base other-modules: - Numeric.Array.Family - Numeric.Array.ElementWise - Numeric.Array - Numeric.DataFrame.SubSpace - Numeric.DataFrame.Contraction - Numeric.DataFrame.Mutable - Numeric.DataFrame.Type - Numeric.DataFrame.Inference - Numeric.DataFrame.Shape - Numeric.Matrix.Class - Numeric.Matrix.Mat44d - Numeric.Matrix.Mat44f Numeric.Quaternion.Class Numeric.Quaternion.QDouble Numeric.Quaternion.QFloat - if impl(ghcjs) - other-modules: - Numeric.Array.Family.ArrayT - else - other-modules: - Numeric.Array.Family.ArrayF - Numeric.Array.Family.ArrayD - Numeric.Array.Family.ArrayI - Numeric.Array.Family.ArrayI8 - Numeric.Array.Family.ArrayI16 - Numeric.Array.Family.ArrayI32 - Numeric.Array.Family.ArrayI64 - Numeric.Array.Family.ArrayW - Numeric.Array.Family.ArrayW8 - Numeric.Array.Family.ArrayW16 - Numeric.Array.Family.ArrayW32 - Numeric.Array.Family.ArrayW64 - Numeric.Array.Family.FloatX2 - Numeric.Array.Family.FloatX3 - Numeric.Array.Family.FloatX4 - Numeric.Array.Family.DoubleX2 - Numeric.Array.Family.DoubleX3 - Numeric.Array.Family.DoubleX4 - js-sources: - src-ghcjs/Numeric/Array/Family/ArrayT.js - src-ghcjs/Numeric/Quaternion/Quaternion.js - src-ghcjs/Numeric/Matrix/Mat44.js - ghc-options: -Wall -fwarn-tabs -fwarn-unused-do-bind -fwarn-monomorphism-restriction -O2 + ghc-options: -Wall -fwarn-tabs -fwarn-unused-do-bind -fwarn-monomorphism-restriction + test-suite et-test type: exitcode-stdio-1.0 @@ -111,10 +81,11 @@ Numeric.DataFrame.Arbitraries Numeric.DataFrame.SubSpaceTest Numeric.DataFrame.BasicTest + Numeric.MatrixTest Numeric.QuaternionTest build-depends: base -any, - Cabal >=1.20, + Cabal -any, QuickCheck -any, easytensor -any, dimensions -any @@ -123,7 +94,6 @@ ghc-options: -Wall -fwarn-tabs -O2 - benchmark et-bench-misc type: exitcode-stdio-1.0 @@ -137,24 +107,10 @@ ghc-options: -Wall -fwarn-tabs -O2 - benchmark et-bench-spfolds type: exitcode-stdio-1.0 main-is: subspacefolds.hs - build-depends: - base -any, - easytensor -any, - dimensions -any, - time -any - default-language: Haskell2010 - hs-source-dirs: bench - ghc-options: -Wall -fwarn-tabs -O2 - -benchmark et-tuple - - type: exitcode-stdio-1.0 - main-is: tuple.hs build-depends: base -any, easytensor -any, diff --git a/src-base/Numeric/Array.hs b/src-base/Numeric/Array.hs deleted file mode 100644 --- a/src-base/Numeric/Array.hs +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- Low-level implementations of data frames --- ------------------------------------------------------------------------------ - -module Numeric.Array - ( module Numeric.Array.Family - ) where - -import Numeric.Array.Family -import Numeric.Array.Family.ArrayD () -import Numeric.Array.Family.ArrayF () -import Numeric.Array.Family.ArrayI () -import Numeric.Array.Family.ArrayI8 () -import Numeric.Array.Family.ArrayI16 () -import Numeric.Array.Family.ArrayI32 () -import Numeric.Array.Family.ArrayI64 () -import Numeric.Array.Family.ArrayW () -import Numeric.Array.Family.ArrayW8 () -import Numeric.Array.Family.ArrayW16 () -import Numeric.Array.Family.ArrayW32 () -import Numeric.Array.Family.ArrayW64 () - -import Numeric.Array.Family.FloatX2 () -import Numeric.Array.Family.FloatX3 () -import Numeric.Array.Family.FloatX4 () - -import Numeric.Array.Family.DoubleX2 () -import Numeric.Array.Family.DoubleX3 () -import Numeric.Array.Family.DoubleX4 () diff --git a/src-base/Numeric/Array/Family.hs b/src-base/Numeric/Array/Family.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE StandaloneDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family - ( Array - , ArrayF (..), ArrayD (..) - , ArrayI (..), ArrayI8 (..), ArrayI16 (..), ArrayI32 (..), ArrayI64 (..) - , ArrayW (..), ArrayW8 (..), ArrayW16 (..), ArrayW32 (..), ArrayW64 (..) - , Scalar (..) - , FloatX2 (..), FloatX3 (..), FloatX4 (..) - , DoubleX2 (..), DoubleX3 (..), DoubleX4 (..) - , ArrayInstanceInference, ElemType (..), ArraySize (..) - , ElemTypeInference (..), ArraySizeInference (..), ArrayInstanceEvidence - , getArrayInstance, ArrayInstance (..), inferArrayInstance - ) where - -#include "MachDeps.h" - -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Type.Equality ((:~:) (..)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Prim ( ByteArray#, Double#, Float# -#if WORD_SIZE_IN_BITS < 64 - , Int64#, Word64# -#endif - , Int#, Word#, unsafeCoerce#) -import GHC.Exts (RuntimeRep(..)) - -import Numeric.Array.ElementWise -import Numeric.Commons -import Numeric.TypeLits -import Numeric.Dimensions - --- | Full collection of n-order arrays -type family Array t (ds :: [Nat]) = v | v -> t ds where - Array t '[] = Scalar t - Array Float '[2] = FloatX2 - Array Float '[3] = FloatX3 - Array Float '[4] = FloatX4 - Array Double '[2] = DoubleX2 - Array Double '[3] = DoubleX3 - Array Double '[4] = DoubleX4 - Array Float (d ': ds) = ArrayF (d ': ds) - Array Double (d ': ds) = ArrayD (d ': ds) - Array Int (d ': ds) = ArrayI (d ': ds) - Array Int8 (d ': ds) = ArrayI8 (d ': ds) - Array Int16 (d ': ds) = ArrayI16 (d ': ds) - Array Int32 (d ': ds) = ArrayI32 (d ': ds) - Array Int64 (d ': ds) = ArrayI64 (d ': ds) - Array Word (d ': ds) = ArrayW (d ': ds) - Array Word8 (d ': ds) = ArrayW8 (d ': ds) - Array Word16 (d ': ds) = ArrayW16 (d ': ds) - Array Word32 (d ': ds) = ArrayW32 (d ': ds) - Array Word64 (d ': ds) = ArrayW64 (d ': ds) - - --- | Specialize scalar type without any arrays -newtype Scalar t = Scalar { _unScalar :: t } - deriving ( Enum, Eq, Integral - , Num, Fractional, Floating, Ord, Read, Real, RealFrac, RealFloat) -instance Show t => Show (Scalar t) where - show (Scalar t) = "{ " ++ show t ++ " }" - -deriving instance {-# OVERLAPPABLE #-} Bounded t => Bounded (Scalar t) -instance {-# OVERLAPPING #-} Bounded (Scalar Double) where - maxBound = Scalar inftyD - minBound = Scalar $ negate inftyD -instance {-# OVERLAPPING #-} Bounded (Scalar Float) where - maxBound = Scalar inftyF - minBound = Scalar $ negate inftyF -inftyD :: Double -inftyD = read "Infinity" -inftyF :: Float -inftyF = read "Infinity" - -type instance ElemRep (Scalar Float ) = 'FloatRep -type instance ElemRep (Scalar Double) = 'DoubleRep -type instance ElemRep (Scalar Int ) = 'IntRep -type instance ElemRep (Scalar Int8 ) = 'IntRep -type instance ElemRep (Scalar Int16 ) = 'IntRep -type instance ElemRep (Scalar Int32 ) = 'IntRep -#if WORD_SIZE_IN_BITS < 64 -type instance ElemRep (Scalar Int64 ) = 'Int64Rep -#else -type instance ElemRep (Scalar Int64 ) = 'IntRep -#endif -type instance ElemRep (Scalar Word ) = 'WordRep -type instance ElemRep (Scalar Word8 ) = 'WordRep -type instance ElemRep (Scalar Word16) = 'WordRep -type instance ElemRep (Scalar Word32) = 'WordRep -#if WORD_SIZE_IN_BITS < 64 -type instance ElemRep (Scalar Word64) = 'Word64Rep -#else -type instance ElemRep (Scalar Word64) = 'WordRep -#endif - -type instance ElemPrim (Scalar Float ) = Float# -type instance ElemPrim (Scalar Double) = Double# -type instance ElemPrim (Scalar Int ) = Int# -type instance ElemPrim (Scalar Int8 ) = Int# -type instance ElemPrim (Scalar Int16 ) = Int# -type instance ElemPrim (Scalar Int32 ) = Int# -#if WORD_SIZE_IN_BITS < 64 -type instance ElemPrim (Scalar Int64 ) = Int64# -#else -type instance ElemPrim (Scalar Int64 ) = Int# -#endif -type instance ElemPrim (Scalar Word ) = Word# -type instance ElemPrim (Scalar Word8 ) = Word# -type instance ElemPrim (Scalar Word16) = Word# -type instance ElemPrim (Scalar Word32) = Word# -#if WORD_SIZE_IN_BITS < 64 -type instance ElemPrim (Scalar Word64) = Word64# -#else -type instance ElemPrim (Scalar Word64) = Word# -#endif - -deriving instance PrimBytes (Scalar Float) -deriving instance PrimBytes (Scalar Double) -deriving instance PrimBytes (Scalar Int) -deriving instance PrimBytes (Scalar Int8) -deriving instance PrimBytes (Scalar Int16) -deriving instance PrimBytes (Scalar Int32) -deriving instance PrimBytes (Scalar Int64) -deriving instance PrimBytes (Scalar Word) -deriving instance PrimBytes (Scalar Word8) -deriving instance PrimBytes (Scalar Word16) -deriving instance PrimBytes (Scalar Word32) -deriving instance PrimBytes (Scalar Word64) - --- | Indexing over scalars is trivial... -instance ElementWise (Idx ('[] :: [Nat])) t (Scalar t) where - indexOffset# x _ = _unScalar x - (!) x _ = _unScalar x - {-# INLINE (!) #-} - ewmap f = Scalar . f Z . _unScalar - {-# INLINE ewmap #-} - ewgen f = Scalar $ f Z - {-# INLINE ewgen #-} - ewgenA f = Scalar <$> f Z - {-# INLINE ewgenA #-} - ewfoldl f x0 = f Z x0 . _unScalar - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f Z (_unScalar x) x0 - {-# INLINE ewfoldr #-} - elementWise f = fmap Scalar . f . _unScalar - {-# INLINE elementWise #-} - indexWise f = fmap Scalar . f Z . _unScalar - {-# INLINE indexWise #-} - broadcast = Scalar - {-# INLINE broadcast #-} - update _ x _ = Scalar x - {-# INLINE update #-} - - --- * Array implementations. --- All array implementations have the same structure: --- Array[Type] (element offset :: Int#) (element length :: Int#) --- (content :: ByteArray#) --- All types can also be instantiated with a single scalar value. - - -data ArrayF (ds :: [Nat]) = ArrayF# Int# Int# ByteArray# - | FromScalarF# Float# -data ArrayD (ds :: [Nat]) = ArrayD# Int# Int# ByteArray# - | FromScalarD# Double# -data ArrayI (ds :: [Nat]) = ArrayI# Int# Int# ByteArray# - | FromScalarI# Int# -data ArrayI8 (ds :: [Nat]) = ArrayI8# Int# Int# ByteArray# - | FromScalarI8# Int# -data ArrayI16 (ds :: [Nat]) = ArrayI16# Int# Int# ByteArray# - | FromScalarI16# Int# -data ArrayI32 (ds :: [Nat]) = ArrayI32# Int# Int# ByteArray# - | FromScalarI32# Int# -#if WORD_SIZE_IN_BITS < 64 -data ArrayI64 (ds :: [Nat]) = ArrayI64# Int# Int# ByteArray# - | FromScalarI64# Int64# -#else -data ArrayI64 (ds :: [Nat]) = ArrayI64# Int# Int# ByteArray# - | FromScalarI64# Int# -#endif -data ArrayW (ds :: [Nat]) = ArrayW# Int# Int# ByteArray# - | FromScalarW# Word# -data ArrayW8 (ds :: [Nat]) = ArrayW8# Int# Int# ByteArray# - | FromScalarW8# Word# -data ArrayW16 (ds :: [Nat]) = ArrayW16# Int# Int# ByteArray# - | FromScalarW16# Word# -data ArrayW32 (ds :: [Nat]) = ArrayW32# Int# Int# ByteArray# - | FromScalarW32# Word# -#if WORD_SIZE_IN_BITS < 64 -data ArrayW64 (ds :: [Nat]) = ArrayW64# Int# Int# ByteArray# - | FromScalarW64# Word64# -#else -data ArrayW64 (ds :: [Nat]) = ArrayW64# Int# Int# ByteArray# - | FromScalarW64# Word# -#endif - --- * Specialized types --- More efficient data types for small fixed-size tensors -data FloatX2 = FloatX2# Float# Float# -data FloatX3 = FloatX3# Float# Float# Float# -data FloatX4 = FloatX4# Float# Float# Float# Float# - -data DoubleX2 = DoubleX2# Double# Double# -data DoubleX3 = DoubleX3# Double# Double# Double# -data DoubleX4 = DoubleX4# Double# Double# Double# Double# - --- * Recovering type instances at runtime --- A combination of `ElemType t` and `ArraySize ds` should --- define an instance of `Array t ds` unambiguously. - - --- | Keep information about the element type instance. --- --- Warning! This part of the code is platform and flag dependent. -data ElemType t - = t ~ Float => ETFloat - | t ~ Double => ETDouble - | t ~ Int => ETInt - | t ~ Int8 => ETInt8 - | t ~ Int16 => ETInt16 - | t ~ Int32 => ETInt32 - | t ~ Int64 => ETInt64 - | t ~ Word => ETWord - | t ~ Word8 => ETWord8 - | t ~ Word16 => ETWord16 - | t ~ Word32 => ETWord32 - | t ~ Word64 => ETWord64 - --- | Keep information about the array dimensionality --- --- Warning! This part of the code is platform and flag dependent. -data ArraySize (ds :: [Nat]) - = ds ~ '[] => ASScalar - | ds ~ '[2] => ASX2 - | ds ~ '[3] => ASX3 - | ds ~ '[4] => ASX4 - | forall n . (ds ~ '[n], 5 <= n) => ASXN - | forall n1 n2 ns . ds ~ (n1 ': n2 ': ns) => ASArray - --- | Keep information about the instance behind Array family --- --- Warning! This part of the code is platform and flag dependent. -data ArrayInstance t (ds :: [Nat]) - = ( Array t ds ~ Scalar t, ds ~ '[]) => AIScalar - | forall n ns . ( Array t ds ~ ArrayF ds, ds ~ (n ': ns), t ~ Float ) => AIArrayF - | forall n ns . ( Array t ds ~ ArrayD ds, ds ~ (n ': ns), t ~ Double) => AIArrayD - | forall n ns . ( Array t ds ~ ArrayI ds, ds ~ (n ': ns), t ~ Int ) => AIArrayI - | forall n ns . ( Array t ds ~ ArrayI8 ds, ds ~ (n ': ns), t ~ Int8 ) => AIArrayI8 - | forall n ns . ( Array t ds ~ ArrayI16 ds, ds ~ (n ': ns), t ~ Int16 ) => AIArrayI16 - | forall n ns . ( Array t ds ~ ArrayI32 ds, ds ~ (n ': ns), t ~ Int32 ) => AIArrayI32 - | forall n ns . ( Array t ds ~ ArrayI64 ds, ds ~ (n ': ns), t ~ Int64 ) => AIArrayI64 - | forall n ns . ( Array t ds ~ ArrayW ds, ds ~ (n ': ns), t ~ Word ) => AIArrayW - | forall n ns . ( Array t ds ~ ArrayW8 ds, ds ~ (n ': ns), t ~ Word8 ) => AIArrayW8 - | forall n ns . ( Array t ds ~ ArrayW16 ds, ds ~ (n ': ns), t ~ Word16) => AIArrayW16 - | forall n ns . ( Array t ds ~ ArrayW32 ds, ds ~ (n ': ns), t ~ Word32) => AIArrayW32 - | forall n ns . ( Array t ds ~ ArrayW64 ds, ds ~ (n ': ns), t ~ Word64) => AIArrayW64 - | ( Array t ds ~ FloatX2, ds ~ '[2], t ~ Float) => AIFloatX2 - | ( Array t ds ~ FloatX3, ds ~ '[3], t ~ Float) => AIFloatX3 - | ( Array t ds ~ FloatX4, ds ~ '[4], t ~ Float) => AIFloatX4 - | ( Array t ds ~ DoubleX2, ds ~ '[2], t ~ Double) => AIDoubleX2 - | ( Array t ds ~ DoubleX3, ds ~ '[3], t ~ Double) => AIDoubleX3 - | ( Array t ds ~ DoubleX4, ds ~ '[4], t ~ Double) => AIDoubleX4 - --- | A singleton type used to prove that the given Array family instance --- has a known instance -type ArrayInstanceEvidence t (ds :: [Nat]) - = Evidence (ArrayInstanceInference t ds) - - -class ElemTypeInference t where - -- | Pattern match against result to get specific element type - elemTypeInstance :: ElemType t - -class ArraySizeInference ds where - -- | Pattern match agains result to get actual array dimensionality - arraySizeInstance :: ArraySize ds - inferSnocArrayInstance :: (ElemTypeInference t, KnownDim z) - => p t ds -> q z -> ArrayInstanceEvidence t (ds +: z) - inferConsArrayInstance :: (ElemTypeInference t, KnownDim z) - => q z -> p t ds -> ArrayInstanceEvidence t (z :+ ds) - inferInitArrayInstance :: ElemTypeInference t - => p t ds -> ArrayInstanceEvidence t (Init ds) - - --- | Use this typeclass constraint in libraries functions if there is a need --- to select an instance of Array famility at runtime. --- Combination of `elemTypeInstance` and `arraySizeInstance` allows --- to bring into typechecker's scope any specific typeclass instance -type ArrayInstanceInference t ds = (ElemTypeInference t, ArraySizeInference ds) - - - -instance ElemTypeInference Float where - elemTypeInstance = ETFloat -instance ElemTypeInference Double where - elemTypeInstance = ETDouble -instance ElemTypeInference Int where - elemTypeInstance = ETInt -instance ElemTypeInference Int8 where - elemTypeInstance = ETInt8 -instance ElemTypeInference Int16 where - elemTypeInstance = ETInt16 -instance ElemTypeInference Int32 where - elemTypeInstance = ETInt32 -instance ElemTypeInference Int64 where - elemTypeInstance = ETInt64 -instance ElemTypeInference Word where - elemTypeInstance = ETWord -instance ElemTypeInference Word8 where - elemTypeInstance = ETWord8 -instance ElemTypeInference Word16 where - elemTypeInstance = ETWord16 -instance ElemTypeInference Word32 where - elemTypeInstance = ETWord32 -instance ElemTypeInference Word64 where - elemTypeInstance = ETWord64 - -instance ArraySizeInference '[] where - arraySizeInstance = ASScalar - {-# INLINE arraySizeInstance #-} - inferSnocArrayInstance _ _ = Evidence - {-# INLINE inferSnocArrayInstance #-} - inferConsArrayInstance _ _ = Evidence - {-# INLINE inferConsArrayInstance #-} - inferInitArrayInstance _ = error "Init -- empty type-level list" - {-# INLINE inferInitArrayInstance #-} - -instance KnownDim d => ArraySizeInference '[d] where - arraySizeInstance = case dimVal' @d of - 0 -> unsafeCoerce# ASScalar - 1 -> unsafeCoerce# ASScalar - 2 -> unsafeCoerce# ASX2 - 3 -> unsafeCoerce# ASX3 - 4 -> unsafeCoerce# ASX4 - _ -> case (unsafeCoerce# Refl :: (5 <=? d) :~: 'True) of Refl -> ASXN - {-# INLINE arraySizeInstance #-} - inferSnocArrayInstance _ _ = Evidence - {-# INLINE inferSnocArrayInstance #-} - inferConsArrayInstance _ _ = Evidence - {-# INLINE inferConsArrayInstance #-} - inferInitArrayInstance _ = Evidence - {-# INLINE inferInitArrayInstance #-} - -instance KnownDim d1 => ArraySizeInference '[d1, d2] where - arraySizeInstance = ASArray - {-# INLINE arraySizeInstance #-} - inferSnocArrayInstance _ _ = Evidence - {-# INLINE inferSnocArrayInstance #-} - inferConsArrayInstance _ _ = Evidence - {-# INLINE inferConsArrayInstance #-} - inferInitArrayInstance _ = Evidence - {-# INLINE inferInitArrayInstance #-} - - -instance ArraySizeInference (d1 ': d2 ': d3 ': ds) where - arraySizeInstance = ASArray - {-# INLINE arraySizeInstance #-} - -- I know that for dimensionality > 2 all instances are the same. - -- Hence this dirty hack should work. - -- I have to change this when I have customized N*M instances - inferSnocArrayInstance p q = unsafeCoerce# (inferConsArrayInstance q p) - {-# INLINE inferSnocArrayInstance #-} - inferConsArrayInstance _ _ = Evidence - {-# INLINE inferConsArrayInstance #-} - -- I know that for dimensionality > 2 all instances are the same. - -- Hence this dirty hack should work. - -- I have to change this when I have customized N*M instances - inferInitArrayInstance p = unsafeCoerce# (inferConsArrayInstance (Proxy @3) p) - {-# INLINE inferInitArrayInstance #-} - - - -getArrayInstance :: forall t (ds :: [Nat]) - . ArrayInstanceInference t ds - => ArrayInstance t ds -getArrayInstance = case (elemTypeInstance @t, arraySizeInstance @ds) of - (ETFloat , ASScalar) -> AIScalar - (ETDouble , ASScalar) -> AIScalar - (ETInt , ASScalar) -> AIScalar - (ETInt8 , ASScalar) -> AIScalar - (ETInt16 , ASScalar) -> AIScalar - (ETInt32 , ASScalar) -> AIScalar - (ETInt64 , ASScalar) -> AIScalar - (ETWord , ASScalar) -> AIScalar - (ETWord8 , ASScalar) -> AIScalar - (ETWord16 , ASScalar) -> AIScalar - (ETWord32 , ASScalar) -> AIScalar - (ETWord64 , ASScalar) -> AIScalar - - (ETFloat , ASX2) -> AIFloatX2 - (ETDouble , ASX2) -> AIDoubleX2 - (ETInt , ASX2) -> AIArrayI - (ETInt8 , ASX2) -> AIArrayI8 - (ETInt16 , ASX2) -> AIArrayI16 - (ETInt32 , ASX2) -> AIArrayI32 - (ETInt64 , ASX2) -> AIArrayI64 - (ETWord , ASX2) -> AIArrayW - (ETWord8 , ASX2) -> AIArrayW8 - (ETWord16 , ASX2) -> AIArrayW16 - (ETWord32 , ASX2) -> AIArrayW32 - (ETWord64 , ASX2) -> AIArrayW64 - - (ETFloat , ASX3) -> AIFloatX3 - (ETDouble , ASX3) -> AIDoubleX3 - (ETInt , ASX3) -> AIArrayI - (ETInt8 , ASX3) -> AIArrayI8 - (ETInt16 , ASX3) -> AIArrayI16 - (ETInt32 , ASX3) -> AIArrayI32 - (ETInt64 , ASX3) -> AIArrayI64 - (ETWord , ASX3) -> AIArrayW - (ETWord8 , ASX3) -> AIArrayW8 - (ETWord16 , ASX3) -> AIArrayW16 - (ETWord32 , ASX3) -> AIArrayW32 - (ETWord64 , ASX3) -> AIArrayW64 - - (ETFloat , ASX4) -> AIFloatX4 - (ETDouble , ASX4) -> AIDoubleX4 - (ETInt , ASX4) -> AIArrayI - (ETInt8 , ASX4) -> AIArrayI8 - (ETInt16 , ASX4) -> AIArrayI16 - (ETInt32 , ASX4) -> AIArrayI32 - (ETInt64 , ASX4) -> AIArrayI64 - (ETWord , ASX4) -> AIArrayW - (ETWord8 , ASX4) -> AIArrayW8 - (ETWord16 , ASX4) -> AIArrayW16 - (ETWord32 , ASX4) -> AIArrayW32 - (ETWord64 , ASX4) -> AIArrayW64 - - (ETFloat , ASXN) -> unsafeCoerce# (AIArrayF :: ArrayInstance Float '[5]) - (ETDouble , ASXN) -> unsafeCoerce# (AIArrayD :: ArrayInstance Double '[5]) - (ETInt , ASXN) -> AIArrayI - (ETInt8 , ASXN) -> AIArrayI8 - (ETInt16 , ASXN) -> AIArrayI16 - (ETInt32 , ASXN) -> AIArrayI32 - (ETInt64 , ASXN) -> AIArrayI64 - (ETWord , ASXN) -> AIArrayW - (ETWord8 , ASXN) -> AIArrayW8 - (ETWord16 , ASXN) -> AIArrayW16 - (ETWord32 , ASXN) -> AIArrayW32 - (ETWord64 , ASXN) -> AIArrayW64 - - (ETFloat , ASArray) -> AIArrayF - (ETDouble , ASArray) -> AIArrayD - (ETInt , ASArray) -> AIArrayI - (ETInt8 , ASArray) -> AIArrayI8 - (ETInt16 , ASArray) -> AIArrayI16 - (ETInt32 , ASArray) -> AIArrayI32 - (ETInt64 , ASArray) -> AIArrayI64 - (ETWord , ASArray) -> AIArrayW - (ETWord8 , ASArray) -> AIArrayW8 - (ETWord16 , ASArray) -> AIArrayW16 - (ETWord32 , ASArray) -> AIArrayW32 - (ETWord64 , ASArray) -> AIArrayW64 - --- | Given element type instance and proper dimension list, --- infer a corresponding array instance -inferArrayInstance :: forall t ds - . ( FiniteList ds - , KnownDims ds - , ElemTypeInference t - ) - => ArrayInstanceEvidence t ds -inferArrayInstance = case tList @_ @ds of - TLEmpty -> Evidence - TLCons _ TLEmpty -> Evidence - TLCons _ (TLCons _ TLEmpty) -> Evidence - TLCons _ (TLCons _ (TLCons _ _)) -> Evidence - - -_suppressHlintUnboxedTuplesWarning :: () -> (# (), () #) -_suppressHlintUnboxedTuplesWarning = undefined diff --git a/src-base/Numeric/Array/Family/Array.h b/src-base/Numeric/Array/Family/Array.h deleted file mode 100644 --- a/src-base/Numeric/Array/Family/Array.h +++ /dev/null @@ -1,308 +0,0 @@ - --------------------------------------------------------------------------------- --- * Utility functions --------------------------------------------------------------------------------- - --- | Do something in a loop for int i from 0 to n -loop1# :: Int# -> (Int# -> State# s -> State# s) -> State# s -> State# s -loop1# n f = loop0 0# - where - loop0 i s | isTrue# (i ==# n) = s - | otherwise = case f i s of s1 -> loop0 (i +# 1#) s1 -{-# INLINE loop1# #-} - - --- | Do something in a loop for int i from 0 to n -loop1a# :: Int# -> (Int# -> a -> a) -> a -> a -loop1a# n f = loop0 0# - where - loop0 i s | isTrue# (i ==# n) = s - | otherwise = s `seq` case f i s of s1 -> s1 `seq` loop0 (i +# 1#) s1 -{-# INLINE loop1a# #-} - - --- | Treat a single number as an array -broadcastArray :: EL_TYPE_BOXED -> ARR_TYPE ds -broadcastArray (EL_CONSTR x) = ARR_FROMSCALAR x -{-# INLINE broadcastArray #-} - --- | Accumulates only idempotent operations! --- Being applied to FromScalars, executes only once! -accumV2 :: (EL_TYPE_PRIM-> EL_TYPE_PRIM -> a -> a) - -> ARR_TYPE ds -> ARR_TYPE ds -> a -> a -accumV2 f (ARR_FROMSCALAR a) - (ARR_FROMSCALAR b) = f a b -accumV2 f (ARR_CONSTR offset n a) - (ARR_FROMSCALAR b) = loop1a# n - (\i -> f (INDEX_ARRAY a (offset +# i)) b) -accumV2 f (ARR_FROMSCALAR a) - (ARR_CONSTR offset n b) = loop1a# n - (\i -> f a (INDEX_ARRAY b (offset +# i))) -accumV2 f (ARR_CONSTR offsetA n a) - (ARR_CONSTR offsetB _ b) = loop1a# n - (\i -> f (INDEX_ARRAY a (offsetA +# i)) - (INDEX_ARRAY b (offsetB +# i)) - ) - -mapV :: (EL_TYPE_PRIM -> EL_TYPE_PRIM) -> ARR_TYPE ds -> ARR_TYPE ds -mapV f (ARR_FROMSCALAR x) = ARR_FROMSCALAR (f x) -mapV f (ARR_CONSTR offset n a) = case runRW# - ( \s0 -> case newByteArray# (n *# EL_SIZE) s0 of - (# s1, marr #) -> case loop1# n - (\i ss -> case f (INDEX_ARRAY a (offset +# i)) of - r -> WRITE_ARRAY marr i r ss - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> ARR_CONSTR 0# n r -{-# INLINE mapV #-} - -zipV :: (EL_TYPE_PRIM -> EL_TYPE_PRIM -> EL_TYPE_PRIM) - -> ARR_TYPE ds -> ARR_TYPE ds -> ARR_TYPE ds -zipV f (ARR_FROMSCALAR a) - (ARR_FROMSCALAR b) = ARR_FROMSCALAR (f a b) -zipV f x (ARR_FROMSCALAR b) = mapV (`f` b) x -zipV f (ARR_FROMSCALAR a) y = mapV (f a) y -zipV f (ARR_CONSTR offsetA n a) - (ARR_CONSTR offsetB _ b) = case runRW# - ( \s0 -> case newByteArray# (n *# EL_SIZE ) s0 of - (# s1, marr #) -> case loop1# n - (\i ss -> case f (INDEX_ARRAY a (offsetA +# i)) - (INDEX_ARRAY b (offsetB +# i)) of - r -> WRITE_ARRAY marr i r ss - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> ARR_CONSTR 0# n r -{-# INLINE zipV #-} - - - --------------------------------------------------------------------------------- --- * Instances --------------------------------------------------------------------------------- - - - - -wr :: ARR_TYPE (ds :: [Nat]) -> Int# -> Int# - -> (MutableByteArray# RealWorld -> State# RealWorld -> State# RealWorld) - -> ARR_TYPE ds -wr _ bs n ff = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case ff marr s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> ARR_CONSTR 0# n r -{-# INLINE wr #-} - -data ArrayUpdate# (f :: * -> *) s - = AU# Int# !(f (MutableByteArray# s -> State# s -> State# s)) - -instance Dimensions ds => ElementWise (Idx ds) EL_TYPE_BOXED (ARR_TYPE (ds :: [Nat])) where - indexOffset# (ARR_CONSTR off _ a) j = EL_CONSTR (INDEX_ARRAY a (off +# j)) - indexOffset# (ARR_FROMSCALAR x) _ = EL_CONSTR x - {-# INLINE indexOffset# #-} - (!) (ARR_CONSTR off _ a) i - = case fromEnum i of I# j -> EL_CONSTR (INDEX_ARRAY a (off +# j)) - (!) (ARR_FROMSCALAR x) _ = EL_CONSTR x - {-# INLINE (!) #-} - - broadcast (EL_CONSTR x) = ARR_FROMSCALAR x - {-# INLINE broadcast #-} - - ewmap f x@(ARR_CONSTR offset n arr) = case runRW# - (\s0 -> case newByteArray# (n *# EL_SIZE) s0 of - (# s1, marr #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off s -> case f ii (EL_CONSTR (INDEX_ARRAY arr (offset +# off))) of - (EL_CONSTR r) -> WRITE_ARRAY marr off r s - ) 0# 1# s1 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, r #) -> ARR_CONSTR 0# n r - ewmap f x@(ARR_FROMSCALAR scalVal) = case runRW# - (\s0 -> case newByteArray# (n *# EL_SIZE) s0 of - (# s1, marr #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off s -> case f ii (EL_CONSTR scalVal) of - (EL_CONSTR r) -> WRITE_ARRAY marr off r s - ) 0# 1# s1 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, r #) -> ARR_CONSTR 0# n r - where - n = case totalDim x of I# d -> d - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case newByteArray# (n *# EL_SIZE) s0 of - (# s1, marr #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off s -> case f ii of - (EL_CONSTR r) -> WRITE_ARRAY marr off r s - ) 0# 1# s1 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, r #) -> ARR_CONSTR 0# n r - where - x = undefined :: ARR_TYPE ds - n = case totalDim x of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f - = case foldDimIdx (dim `inSpaceOf` x) g (AU# 0# (pure (\_ s -> s))) of - AU# _ ff -> wr x bs n <$> ff - where - g ds (AU# i ff) = AU# ( i +# 1# ) - $ (\(EL_CONSTR z) u a s -> WRITE_ARRAY a i z (u a s)) - <$> f ds <*> ff - x = undefined :: ARR_TYPE ds - n = case totalDim x of I# d -> d - bs = n *# EL_SIZE - - ewfoldr f v0 x@(ARR_CONSTR offset _ arr) - = foldDimReverse (dim `inSpaceOf` x) - (\ii off -> f ii (EL_CONSTR (INDEX_ARRAY arr off))) offset 1# v0 - ewfoldr f v0 x@(ARR_FROMSCALAR scalVal) = foldDimReverseIdx (dim `inSpaceOf` x) - (\ii -> f ii (EL_CONSTR scalVal)) v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x@(ARR_CONSTR offset _ arr) - = foldDim (dim `inSpaceOf` x) - (\ii off v -> f ii v (EL_CONSTR (INDEX_ARRAY arr off))) offset 1# v0 - ewfoldl f v0 x@(ARR_FROMSCALAR scalVal) = foldDimIdx (dim `inSpaceOf` x) - (\ii v -> f ii v (EL_CONSTR scalVal)) v0 - {-# INLINE ewfoldl #-} - - indexWise f x@(ARR_CONSTR offset n arr) - = case foldDimIdx (dim `inSpaceOf` x) g (AU# 0# (pure (\_ s -> s))) of - AU# _ ff -> wr x bs n <$> ff - where - g ds (AU# i ff) = AU# ( i +# 1# ) - $ (\(EL_CONSTR z) u a s -> WRITE_ARRAY a i z (u a s)) - <$> f ds (EL_CONSTR (INDEX_ARRAY arr (offset +# i))) <*> ff - bs = n *# EL_SIZE - - indexWise f x@(ARR_FROMSCALAR scalVal) - = case foldDimIdx (dim `inSpaceOf` x) g (AU# 0# (pure (\_ s -> s))) of - AU# _ ff -> wr x bs n <$> ff - where - n = case totalDim x of I# d -> d - g ds (AU# i ff) = AU# ( i +# 1# ) - $ (\(EL_CONSTR z) u a s -> WRITE_ARRAY a i z (u a s)) - <$> f ds (EL_CONSTR scalVal) <*> ff - bs = n *# EL_SIZE - - - elementWise f x@(ARR_CONSTR offset n arr) = - wr x bs n <$> loop1a# n g (pure (\_ s -> s)) - where - g i ff = (\(EL_CONSTR z) u a s -> WRITE_ARRAY a i z (u a s)) - <$> f (EL_CONSTR (INDEX_ARRAY arr (offset +# i))) <*> ff - bs = n *# EL_SIZE - elementWise f x@(ARR_FROMSCALAR scalVal) = - wr x bs n <$> loop1a# n g (pure (\_ s -> s)) - where - fa = f (EL_CONSTR scalVal) - n = case totalDim x of I# d -> d - g i ff = (\(EL_CONSTR z) u a s -> WRITE_ARRAY a i z (u a s)) - <$> fa <*> ff - bs = n *# EL_SIZE - - update ei (EL_CONSTR y) (ARR_CONSTR off len arr) - | I# i <- fromEnum ei - = case runRW# - ( \s0 -> case newByteArray# ( len *# EL_SIZE ) s0 of - (# s1, marr #) -> case copyByteArray# arr (off *# EL_SIZE) marr 0# (len *# EL_SIZE) s1 of - s2 -> case WRITE_ARRAY marr i y s2 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, r #) -> ARR_CONSTR 0# len r - - - update ei (EL_CONSTR y) x@(ARR_FROMSCALAR scalVal) - | I# i <- fromEnum ei - , I# len <- totalDim x - = case runRW# - ( \s0 -> case newByteArray# ( len *# EL_SIZE ) s0 of - (# s1, marr #) -> case loop1# len (\j -> WRITE_ARRAY marr j scalVal) s1 of - s2 -> case WRITE_ARRAY marr i y s2 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, r #) -> ARR_CONSTR 0# len r - -instance Dimensions ds - => Show (ARR_TYPE (ds :: [Nat])) where - show x = case dim @ds of - D -> "{ " ++ show (x ! Z) ++ " }" - Dn :* D -> ('{' :) . drop 1 $ - foldr (\i s -> ", " ++ show (x ! i) ++ s) " }" - [minBound .. maxBound] - (Dn :: Dim (n :: Nat)) :* (Dn :: Dim (m :: Nat)) :* (_ :: Dim (dss :: [Nat])) -> - case inferDropNDimensions @2 @ds of - Evidence -> - let loopInner :: Idx dss -> Idx '[n,m] -> String - loopInner ods (n:!m:!_) = ('{' :) . drop 2 $ - foldr (\i ss -> '\n': - foldr (\j s -> - ", " ++ show (x ! (i :! j :! ods)) ++ s - ) ss [1..m] - ) " }" [1..n] - loopOuter :: Idx dss -> String -> String - loopOuter Z s = "\n" ++ loopInner Z maxBound ++ s - loopOuter ds s = "\n(i j" ++ drop 3 (show ds) ++ "):\n" - ++ loopInner ds maxBound ++ s - in drop 1 $ foldr loopOuter "" [minBound..maxBound] - -instance Eq (ARR_TYPE ds) where - a == b = accumV2 (\x y r -> r && isTrue# (OP_EQ x y)) a b True - {-# INLINE (==) #-} - a /= b = accumV2 (\x y r -> r || isTrue# (OP_NE x y)) a b False - {-# INLINE (/=) #-} - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord (ARR_TYPE ds) where - a > b = accumV2 (\x y r -> r && isTrue# (OP_GT x y)) a b True - {-# INLINE (>) #-} - a < b = accumV2 (\x y r -> r && isTrue# (OP_LT x y)) a b True - {-# INLINE (<) #-} - a >= b = accumV2 (\x y r -> r && isTrue# (OP_GE x y)) a b True - {-# INLINE (>=) #-} - a <= b = accumV2 (\x y r -> r && isTrue# (OP_LE x y)) a b True - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare a b = accumV2 (\x y r -> r `mappend` - if isTrue# (OP_GT x y) - then GT - else if isTrue# (OP_LT x y) - then LT - else EQ - ) a b EQ - {-# INLINE compare #-} - -- | Element-wise minimum - min = zipV (\x y -> if isTrue# (OP_GT x y) then y else x) - {-# INLINE min #-} - -- | Element-wise maximum - max = zipV (\x y -> if isTrue# (OP_GT x y) then x else y) - {-# INLINE max #-} - - -type instance ElemRep (ARR_TYPE ds) = EL_RUNTIME_REP -type instance ElemPrim (ARR_TYPE ds) = EL_TYPE_PRIM -instance Dimensions ds => PrimBytes (ARR_TYPE ds) where - toBytes (ARR_CONSTR off size a) = (# off, size, a #) - toBytes (ARR_FROMSCALAR x) = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case loop1# n - (\i -> WRITE_ARRAY marr i x - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> (# 0#, n, r #) - where - n = case totalDim (undefined :: ArrayF ds) of I# d -> d - bs = n *# EL_SIZE - {-# INLINE toBytes #-} - fromBytes (# off, size, a #) = ARR_CONSTR off size a - {-# INLINE fromBytes #-} - byteSize x = case totalDim x of - I# d -> EL_SIZE *# d - {-# INLINE byteSize #-} - byteAlign _ = EL_ALIGNMENT - {-# INLINE byteAlign #-} - elementByteSize _ = EL_SIZE - {-# INLINE elementByteSize #-} - ix i (ARR_CONSTR off _ a) = INDEX_ARRAY a (off +# i) - ix _ (ARR_FROMSCALAR x) = x - {-# INLINE ix #-} diff --git a/src-base/Numeric/Array/Family/ArrayD.hs b/src-base/Numeric/Array/Family/ArrayD.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayD.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayD --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayD () where - - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Double (..), Int (..), - RuntimeRep (..), isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions -import Numeric.Dimensions.Traverse -import Numeric.TypeLits -import Numeric.Matrix.Class - - -#include "MachDeps.h" -#define ARR_TYPE ArrayD -#define ARR_FROMSCALAR FromScalarD# -#define ARR_CONSTR ArrayD# -#define EL_TYPE_BOXED Double -#define EL_TYPE_PRIM Double# -#define EL_RUNTIME_REP 'DoubleRep -#define EL_CONSTR D# -#define EL_SIZE SIZEOF_HSDOUBLE# -#define EL_ALIGNMENT ALIGNMENT_HSDOUBLE# -#define EL_ZERO 0.0## -#define EL_ONE 1.0## -#define EL_MINUS_ONE -1.0## -#define INDEX_ARRAY indexDoubleArray# -#define WRITE_ARRAY writeDoubleArray# -#define OP_EQ (==##) -#define OP_NE (/=##) -#define OP_GT (>##) -#define OP_GE (>=##) -#define OP_LT (<##) -#define OP_LE (<=##) -#define OP_PLUS (+##) -#define OP_MINUS (-##) -#define OP_TIMES (*##) -#define OP_NEGATE negateDouble# -#include "Array.h" - -instance Bounded (ArrayD ds) where - maxBound = broadcastArray infty - minBound = broadcastArray $ negate infty - -infty :: Double -infty = read "Infinity" - -instance Num (ArrayD ds) where - (+) = zipV (+##) - {-# INLINE (+) #-} - (-) = zipV (-##) - {-# INLINE (-) #-} - (*) = zipV (*##) - {-# INLINE (*) #-} - negate = mapV negateDouble# - {-# INLINE negate #-} - abs = mapV (\x -> if isTrue# (x >=## 0.0##) - then x - else negateDouble# x - ) - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (x >## 0.0##) - then 1.0## - else if isTrue# (x <## 0.0##) - then -1.0## - else 0.0## - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional (ArrayD ds) where - (/) = zipV (/##) - {-# INLINE (/) #-} - recip = mapV (1.0## /##) - {-# INLINE recip #-} - fromRational = broadcastArray . fromRational - {-# INLINE fromRational #-} - - -instance Floating (ArrayD ds) where - pi = broadcastArray pi - {-# INLINE pi #-} - exp = mapV expDouble# - {-# INLINE exp #-} - log = mapV logDouble# - {-# INLINE log #-} - sqrt = mapV sqrtDouble# - {-# INLINE sqrt #-} - sin = mapV sinDouble# - {-# INLINE sin #-} - cos = mapV cosDouble# - {-# INLINE cos #-} - tan = mapV tanDouble# - {-# INLINE tan #-} - asin = mapV asinDouble# - {-# INLINE asin #-} - acos = mapV acosDouble# - {-# INLINE acos #-} - atan = mapV atanDouble# - {-# INLINE atan #-} - sinh = mapV sinDouble# - {-# INLINE sinh #-} - cosh = mapV coshDouble# - {-# INLINE cosh #-} - tanh = mapV tanhDouble# - {-# INLINE tanh #-} - (**) = zipV (**##) - {-# INLINE (**) #-} - - logBase = zipV (\x y -> logDouble# y /## logDouble# x) - {-# INLINE logBase #-} - asinh = mapV (\x -> logDouble# (x +## - sqrtDouble# (1.0## +## x *## x))) - {-# INLINE asinh #-} - acosh = mapV (\x -> case x +## 1.0## of - y -> logDouble# ( x +## y *## - sqrtDouble# ((x -## 1.0##) /## y) - ) - ) - {-# INLINE acosh #-} - atanh = mapV (\x -> 0.5## *## - logDouble# ((1.0## +## x) /## (1.0## -## x))) - {-# INLINE atanh #-} - - -instance (KnownNat n, KnownNat m, ArrayD '[n,m] ~ Array Double '[n,m], 2 <= n, 2 <= m) - => MatrixCalculus Double n m where - transpose (KnownDataFrame (ArrayD# offs nm arr)) = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case loop2# n m - (\i j s' -> writeDoubleArray# marr (j +# m *# i) - (indexDoubleArray# arr (offs +# j *# n +# i)) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, nm, r #) - where - n = case fromInteger $ natVal (Proxy @n) of I# np -> np - m = case fromInteger $ natVal (Proxy @m) of I# mp -> mp - bs = n *# m *# EL_SIZE - transpose (KnownDataFrame (FromScalarD# x)) = unsafeCoerce# $ FromScalarD# x - -instance ( KnownDim n, ArrayD '[n,n] ~ Array Double '[n,n] ) - => SquareMatrixCalculus Double n where - eye = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case loop1# n - (\j s' -> writeDoubleArray# marr (j *# n1) 1.0## s' - ) (setByteArray# marr 0# bs 0# s1) of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# n, r #) - where - n1 = n +# 1# - n = case dimVal' @n of I# np -> np - bs = n *# n *# EL_SIZE - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar (D# v))) = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case loop1# n - (\j s' -> writeDoubleArray# marr (j *# n1) v s' - ) (setByteArray# marr 0# bs 0# s1) of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# n, r #) - where - n1 = n +# 1# - n = case dimVal' @n of I# np -> np - bs = n *# n *# EL_SIZE - {-# INLINE diag #-} - - - det (KnownDataFrame (ArrayD# off nsqr arr)) = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, mat #) -> case newByteArray# - (n *# EL_SIZE) - (copyByteArray# arr offb mat 0# bs s1) of - (# s2, vec #) -> - let f i x s | isTrue# (i >=# n) = (# s, x #) - | otherwise = - let !(# s' , j #) = maxInRowRem# n n i mat s - !(# s'', x' #) = if isTrue# (i /=# j) - then (# swapCols# n i j vec mat s' - , negateDouble# x #) - else (# s', x #) - !(# s''', y #) = clearRowEnd# n n i mat s'' - in if isTrue# (0.0## ==## y) - then (# s''', 0.0## #) - else f (i +# 1#) (x' *## y) s''' - in f 0# 1.0## s2 - ) of (# _, r #) -> KnownDataFrame (Scalar (D# r)) - where - n = case dimVal' @n of I# np -> np - offb = off *# EL_SIZE - bs = nsqr *# EL_SIZE - det (KnownDataFrame (FromScalarD# _)) = 0 - {-# INLINE det #-} - - - - trace (KnownDataFrame (ArrayD# off nsqr a)) = KnownDataFrame (Scalar (D# (loop' 0# 0.0##))) - where - n1 = n +# 1# - n = case dimVal' @n of I# np -> np - loop' i acc | isTrue# (i ># nsqr) = acc - | otherwise = loop' (i +# n1) - (indexDoubleArray# a (off +# i) +## acc) - trace (KnownDataFrame (FromScalarD# x)) = KnownDataFrame (Scalar (D# (x *## n))) - where - n = case fromIntegral (dimVal' @n) of D# np -> np - {-# INLINE trace #-} - - - -instance (KnownNat n, ArrayD '[n,n] ~ Array Double '[n,n], 2 <= n) => MatrixInverse Double n where - inverse (KnownDataFrame (ArrayD# offs nsqr arr)) = case runRW# - ( \s0 -> case newByteArray# (bs *# 2#) s0 of - (# s1, mat #) -> case newByteArray# (vs *# 2#) - -- copy original matrix to the top of an augmented matrix - (loop1# n (\i s -> writeDoubleArray# mat - (i *# nn +# i +# n) 1.0## - (copyByteArray# arr (offb +# i *# vs) - mat (2# *# i *# vs) vs s)) - (setByteArray# mat 0# (bs *# 2#) 0# s1) - ) of - (# s2, vec #) -> - let f i s | isTrue# (i >=# n) = s - | otherwise = - let !(# s' , j #) = maxInRowRem# nn n i mat s - s'' = if isTrue# (i /=# j) then swapCols# nn i j vec mat s' - else s' - !(# s''', _ #) = clearRowAll# nn n i mat s'' - in f (i +# 1#) s''' - in unsafeFreezeByteArray# mat - ( shrinkMutableByteArray# mat bs - (-- copy inverse matrix from the augmented part - loop1# n (\i s -> - copyMutableByteArray# mat - (2# *# i *# vs +# vs) - mat (i *# vs) vs s) - (f 0# s2) - ) - ) - ) of (# _, r #) -> KnownDataFrame (ArrayD# 0# nsqr r) - where - nn = 2# *# n - n = case fromInteger $ natVal (Proxy @n) of I# np -> np - vs = n *# EL_SIZE - bs = n *# n *# EL_SIZE - offb = offs *# EL_SIZE - inverse (KnownDataFrame (FromScalarD# _)) = error "Cannot take inverse of a degenerate matrix" - - ------------------------------------------------------------------------------ --- Helpers ------------------------------------------------------------------------------ - --- #ifndef UNSAFE_INDICES --- | isTrue# ( (i ># dim# _x) --- `orI#` (i <=# 0#) --- ) = error $ "Bad index " ++ --- show (I# i) ++ " for " ++ show (dim _x) ++ "D vector" --- | otherwise --- #endif - - --- | Swap columns i and j. Does not check if i or j is larger than matrix width m -swapCols# :: Int# -- n - -> Int# -- ith column to swap - -> Int# -- jth column to swap - -> MutableByteArray# s -- buffer byte array of length of n elems - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> State# s -- next state -swapCols# n i j vec mat s0 = - -- copy ith column to bugger vec - case copyMutableByteArray# mat (i *# bs) vec 0# bs s0 of - s1 -> case copyMutableByteArray# mat (j *# bs) mat (i *# bs) bs s1 of - s2 -> copyMutableByteArray# vec 0# mat (j *# bs) bs s2 - where - bs = n *# EL_SIZE - --- | Starting from i-th row and i+1-th column, substract a multiple of i-th column from i+1 .. m columns, --- such that there are only zeroes in i-th row and i+1..m columns elements. -clearRowEnd# :: Int# -- n - -> Int# -- m - -> Int# -- ith column to remove from all others - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> (# State# s, Double# #) -- next state and a diagonal element -clearRowEnd# n m i mat s0 = (# loop' (i +# 1#) s1, y' #) - where - y0 = (n +# 1#) *# i +# 1# -- first element in source column - !(# s1, y' #) = readDoubleArray# mat ((n +# 1#) *# i) s0 -- diagonal element, must be non-zero - yrc = 1.0## /## y' - n' = n -# i -# 1# - loop' k s | isTrue# (k >=# m) = s - | otherwise = loop' (k +# 1#) - ( let x0 = k *# n +# i - !(# s', a' #) = readDoubleArray# mat x0 s - s'' = writeDoubleArray# mat x0 0.0## s' - a = a' *## yrc - in multNRem# n' (x0 +# 1#) y0 a mat s'' - ) - --- | Substract a multiple of i-th column from 0 .. i-1 and i+1 .. m columns, --- such that there are only zeroes in i-th row everywhere except i-th column --- Assuming that elements in 0..i-1 columnts and in i-th row are zeroes, so they do not affect other columns. --- After all columns updated, divide i-th row by its diagonal element, so (i,i) element has 1. -clearRowAll# :: Int# -- n - -> Int# -- m - -> Int# -- ith column to remove from all others - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> (# State# s, Double# #) -- next state and a diagonal element -clearRowAll# n m i mat s0 = (# divLoop (i +# 1#) - (writeDoubleArray# mat ((n +# 1#) *# i) 1.0## - (loop' 0# i (loop' (i +# 1#) m s1))), y' #) - where - y0 = (n +# 1#) *# i +# 1# -- first element in source column - !(# s1, y' #) = readDoubleArray# mat ((n +# 1#) *# i) s0 -- diagonal element, must be non-zero - yrc = 1.0## /## y' - n' = n -# i -# 1# - loop' k km s | isTrue# (k >=# km) = s - | otherwise = loop' (k +# 1#) km - ( let x0 = k *# n +# i - !(# s', a' #) = readDoubleArray# mat x0 s - s'' = writeDoubleArray# mat x0 0.0## s' - a = a' *## yrc - in multNRem# n' (x0 +# 1#) y0 a mat s'' - ) - divLoop k s | isTrue# (k >=# n) = s - | otherwise = divLoop (k +# 1#) - ( let x0 = n *# i +# k - !(# s', x #) = readDoubleArray# mat x0 s - in writeDoubleArray# mat x0 (x *## yrc) s' - ) - - --- | Remove a multiple of one row from another one. --- do: xi = xi - yi*a -multNRem# :: Int# -- n - nr of elements to go through - -> Int# -- start idx of x (update) - -> Int# -- start idx of y (read) - -> Double# -- multiplier a - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> State# s -- next state -multNRem# 0# _ _ _ _ s = s -multNRem# n x0 y0 a mat s = multNRem# (n -# 1#) (x0 +# 1#) (y0 +# 1#) a mat - ( case readDoubleArray# mat y0 s of - (# s1, y #) -> case readDoubleArray# mat x0 s1 of - (# s2, x #) -> writeDoubleArray# mat x0 (x -## y *## a) s2 - ) - - - --- | Gives index of maximum (absolute) element in i-th row, starting from i-th element only. --- If i >= m then returns i. -maxInRowRem# :: Int# -- n - -> Int# -- m - -> Int# -- ith column to start to search for and a row to look in - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> (# State# s, Int# #) -- next state -maxInRowRem# n m i mat s0 = loop' i (abs# v) i s1 - where - !(# s1, v #) = readDoubleArray# mat ((n +# 1#) *# i) s0 - abs# x = if isTrue# (x >=## 0.0##) then x else negateDouble# x - loop' ok ov k s | isTrue# (k >=# m) = (# s, ok #) - | otherwise = case readDoubleArray# mat (n *# k +# i) s of - (# s', v' #) -> if isTrue# (abs# v' >## ov) - then loop' k (abs# v') (k +# 1#) s' - else loop' ok ov (k +# 1#) s' - --- | Do something in a loop for int i from 0 to n-1 and j from 0 to m-1 -loop2# :: Int# -> Int# -> (Int# -> Int#-> State# s -> State# s) - -> State# s -> State# s -loop2# n m f = loop0 0# 0# - where - loop0 i j s | isTrue# (j ==# m) = s - | isTrue# (i ==# n) = loop0 0# (j +# 1#) s - | otherwise = case f i j s of s1 -> loop0 (i +# 1#) j s1 -{-# INLINE loop2# #-} diff --git a/src-base/Numeric/Array/Family/ArrayF.hs b/src-base/Numeric/Array/Family/ArrayF.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayF.hs +++ /dev/null @@ -1,418 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayF --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayF () where - - - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Float (..), Int (..), - RuntimeRep (..), isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions -import Numeric.Dimensions.Traverse -import Numeric.TypeLits -import Numeric.Matrix.Class - -#include "MachDeps.h" -#define ARR_TYPE ArrayF -#define ARR_FROMSCALAR FromScalarF# -#define ARR_CONSTR ArrayF# -#define EL_TYPE_BOXED Float -#define EL_TYPE_PRIM Float# -#define EL_RUNTIME_REP 'FloatRep -#define EL_CONSTR F# -#define EL_SIZE SIZEOF_HSFLOAT# -#define EL_ALIGNMENT ALIGNMENT_HSFLOAT# -#define EL_ZERO 0.0# -#define EL_ONE 1.0# -#define EL_MINUS_ONE -1.0# -#define INDEX_ARRAY indexFloatArray# -#define WRITE_ARRAY writeFloatArray# -#define OP_EQ eqFloat# -#define OP_NE neFloat# -#define OP_GT gtFloat# -#define OP_GE geFloat# -#define OP_LT ltFloat# -#define OP_LE leFloat# -#define OP_PLUS plusFloat# -#define OP_MINUS minusFloat# -#define OP_TIMES timesFloat# -#define OP_NEGATE negateFloat# -#include "Array.h" - -instance Bounded (ArrayF ds) where - maxBound = broadcastArray infty - minBound = broadcastArray $ negate infty - -infty :: Float -infty = read "Infinity" - -instance Num (ArrayF ds) where - (+) = zipV plusFloat# - {-# INLINE (+) #-} - (-) = zipV minusFloat# - {-# INLINE (-) #-} - (*) = zipV timesFloat# - {-# INLINE (*) #-} - negate = mapV negateFloat# - {-# INLINE negate #-} - abs = mapV (\x -> if isTrue# (geFloat# x 0.0#) - then x - else negateFloat# x - ) - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (gtFloat# x 0.0#) - then 1.0# - else if isTrue# (ltFloat# x 0.0#) - then -1.0# - else 0.0# - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional (ArrayF ds) where - (/) = zipV divideFloat# - {-# INLINE (/) #-} - recip = mapV (divideFloat# 1.0#) - {-# INLINE recip #-} - fromRational = broadcastArray . fromRational - {-# INLINE fromRational #-} - - - -instance Floating (ArrayF ds) where - pi = broadcastArray pi - {-# INLINE pi #-} - exp = mapV expFloat# - {-# INLINE exp #-} - log = mapV logFloat# - {-# INLINE log #-} - sqrt = mapV sqrtFloat# - {-# INLINE sqrt #-} - sin = mapV sinFloat# - {-# INLINE sin #-} - cos = mapV cosFloat# - {-# INLINE cos #-} - tan = mapV tanFloat# - {-# INLINE tan #-} - asin = mapV asinFloat# - {-# INLINE asin #-} - acos = mapV acosFloat# - {-# INLINE acos #-} - atan = mapV atanFloat# - {-# INLINE atan #-} - sinh = mapV sinFloat# - {-# INLINE sinh #-} - cosh = mapV coshFloat# - {-# INLINE cosh #-} - tanh = mapV tanhFloat# - {-# INLINE tanh #-} - (**) = zipV powerFloat# - {-# INLINE (**) #-} - - logBase = zipV (\x y -> logFloat# y `divideFloat#` logFloat# x) - {-# INLINE logBase #-} - asinh = mapV (\x -> logFloat# (x `plusFloat#` - sqrtFloat# (1.0# `plusFloat#` timesFloat# x x))) - {-# INLINE asinh #-} - acosh = mapV (\x -> case plusFloat# x 1.0# of - y -> logFloat# ( x `plusFloat#` timesFloat# y - (sqrtFloat# (minusFloat# x 1.0# `divideFloat#` y)) - ) - ) - {-# INLINE acosh #-} - atanh = mapV (\x -> 0.5# `timesFloat#` - logFloat# (plusFloat# 1.0# x `divideFloat#` minusFloat# 1.0# x)) - {-# INLINE atanh #-} - - - - -instance (KnownDim n, KnownDim m, ArrayF '[n,m] ~ Array Float '[n,m], 2 <= n, 2 <= m) - => MatrixCalculus Float n m where - transpose (KnownDataFrame (ArrayF# offs nm arr)) = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case loop2# n m - (\i j s' -> writeFloatArray# marr (j +# m *# i) - (indexFloatArray# arr (offs +# j *# n +# i)) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, nm, r #) - where - n = case dimVal' @n of I# np -> np - m = case dimVal' @m of I# mp -> mp - bs = n *# m *# SIZEOF_HSFLOAT# - transpose (KnownDataFrame (FromScalarF# x)) = unsafeCoerce# $ FromScalarF# x - -instance ( KnownDim n, ArrayF '[n,n] ~ Array Float '[n,n] ) - => SquareMatrixCalculus Float n where - eye = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case loop1# n - (\j s' -> writeFloatArray# marr (j *# n1) 1.0# s' - ) (setByteArray# marr 0# bs 0# s1) of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# n, r #) - where - n1 = n +# 1# - n = case dimVal' @n of I# np -> np - bs = n *# n *# SIZEOF_HSFLOAT# - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar (F# v))) = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> case loop1# n - (\j s' -> writeFloatArray# marr (j *# n1) v s' - ) (setByteArray# marr 0# bs 0# s1) of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# n, r #) - where - n1 = n +# 1# - n = case dimVal' @n of I# np -> np - bs = n *# n *# SIZEOF_HSFLOAT# - {-# INLINE diag #-} - - - det (KnownDataFrame (ArrayF# off nsqr arr)) = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, mat #) -> case newByteArray# - (n *# SIZEOF_HSFLOAT#) - (copyByteArray# arr offb mat 0# bs s1) of - (# s2, vec #) -> - let f i x s | isTrue# (i >=# n) = (# s, x #) - | otherwise = - let !(# s' , j #) = maxInRowRem# n n i mat s - !(# s'', x' #) = if isTrue# (i /=# j) - then (# swapCols# n i j vec mat s' - , negateFloat# x #) - else (# s', x #) - !(# s''', y #) = clearRowEnd# n n i mat s'' - in if isTrue# (eqFloat# 0.0# y) - then (# s''', 0.0# #) - else f (i +# 1#) (timesFloat# x' y) s''' - in f 0# 1.0# s2 - ) of (# _, r #) -> KnownDataFrame (Scalar (F# r)) - where - n = case dimVal' @n of I# np -> np - offb = off *# SIZEOF_HSFLOAT# - bs = nsqr *# SIZEOF_HSFLOAT# - det (KnownDataFrame (FromScalarF# _)) = 0 - {-# INLINE det #-} - - - - trace (KnownDataFrame (ArrayF# off nsqr a)) = KnownDataFrame (Scalar (F# (loop' 0# 0.0#))) - where - n1 = n +# 1# - n = case dimVal' @n of I# np -> np - loop' i acc | isTrue# (i ># nsqr) = acc - | otherwise = loop' (i +# n1) - (indexFloatArray# a (off +# i) `plusFloat#` acc) - trace (KnownDataFrame (FromScalarF# x)) = KnownDataFrame (Scalar (F# (x `timesFloat#` n))) - where - n = case fromIntegral (dimVal' @n) of F# np -> np - {-# INLINE trace #-} - - - -instance (KnownNat n, ArrayF '[n,n] ~ Array Float '[n,n], 2 <= n) => MatrixInverse Float n where - inverse (KnownDataFrame (ArrayF# offs nsqr arr)) = case runRW# - ( \s0 -> case newByteArray# (bs *# 2#) s0 of - (# s1, mat #) -> case newByteArray# (vs *# 2#) - -- copy original matrix to the top of an augmented matrix - (loop1# n (\i s -> writeFloatArray# mat - (i *# nn +# i +# n) 1.0# - (copyByteArray# arr (offb +# i *# vs) - mat (2# *# i *# vs) vs s)) - (setByteArray# mat 0# (bs *# 2#) 0# s1) - ) of - (# s2, vec #) -> - let f i s | isTrue# (i >=# n) = s - | otherwise = - let !(# s' , j #) = maxInRowRem# nn n i mat s - s'' = if isTrue# (i /=# j) then swapCols# nn i j vec mat s' - else s' - !(# s''', _ #) = clearRowAll# nn n i mat s'' - in f (i +# 1#) s''' - in unsafeFreezeByteArray# mat - ( shrinkMutableByteArray# mat bs - (-- copy inverse matrix from the augmented part - loop1# n (\i s -> - copyMutableByteArray# mat - (2# *# i *# vs +# vs) - mat (i *# vs) vs s) - (f 0# s2) - ) - ) - ) of (# _, r #) -> KnownDataFrame (ArrayF# 0# nsqr r) - where - nn = 2# *# n - n = case dimVal' @n of I# np -> np - vs = n *# SIZEOF_HSFLOAT# - bs = n *# n *# SIZEOF_HSFLOAT# - offb = offs *# SIZEOF_HSFLOAT# - inverse (KnownDataFrame (FromScalarF# _)) = error "Cannot take inverse of a degenerate matrix" - - ------------------------------------------------------------------------------ --- Helpers ------------------------------------------------------------------------------ - --- #ifndef UNSAFE_INDICES --- | isTrue# ( (i ># dim# _x) --- `orI#` (i <=# 0#) --- ) = error $ "Bad index " ++ --- show (I# i) ++ " for " ++ show (dim _x) ++ "D vector" --- | otherwise --- #endif - - --- | Swap columns i and j. Does not check if i or j is larger than matrix width m -swapCols# :: Int# -- n - -> Int# -- ith column to swap - -> Int# -- jth column to swap - -> MutableByteArray# s -- buffer byte array of length of n elems - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> State# s -- next state -swapCols# n i j vec mat s0 = - -- copy ith column to bugger vec - case copyMutableByteArray# mat (i *# bs) vec 0# bs s0 of - s1 -> case copyMutableByteArray# mat (j *# bs) mat (i *# bs) bs s1 of - s2 -> copyMutableByteArray# vec 0# mat (j *# bs) bs s2 - where - bs = n *# SIZEOF_HSFLOAT# - --- | Starting from i-th row and i+1-th column, substract a multiple of i-th column from i+1 .. m columns, --- such that there are only zeroes in i-th row and i+1..m columns elements. -clearRowEnd# :: Int# -- n - -> Int# -- m - -> Int# -- ith column to remove from all others - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> (# State# s, Float# #) -- next state and a diagonal element -clearRowEnd# n m i mat s0 = (# loop' (i +# 1#) s1, y' #) - where - y0 = (n +# 1#) *# i +# 1# -- first element in source column - !(# s1, y' #) = readFloatArray# mat ((n +# 1#) *# i) s0 -- diagonal element, must be non-zero - yrc = 1.0# `divideFloat#` y' - n' = n -# i -# 1# - loop' k s | isTrue# (k >=# m) = s - | otherwise = loop' (k +# 1#) - ( let x0 = k *# n +# i - !(# s', a' #) = readFloatArray# mat x0 s - s'' = writeFloatArray# mat x0 0.0# s' - a = a' `timesFloat#` yrc - in multNRem# n' (x0 +# 1#) y0 a mat s'' - ) - --- | Substract a multiple of i-th column from 0 .. i-1 and i+1 .. m columns, --- such that there are only zeroes in i-th row everywhere except i-th column --- Assuming that elements in 0..i-1 columnts and in i-th row are zeroes, so they do not affect other columns. --- After all columns updated, divide i-th row by its diagonal element, so (i,i) element has 1. -clearRowAll# :: Int# -- n - -> Int# -- m - -> Int# -- ith column to remove from all others - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> (# State# s, Float# #) -- next state and a diagonal element -clearRowAll# n m i mat s0 = (# divLoop (i +# 1#) - (writeFloatArray# mat ((n +# 1#) *# i) 1.0# - (loop' 0# i (loop' (i +# 1#) m s1))), y' #) - where - y0 = (n +# 1#) *# i +# 1# -- first element in source column - !(# s1, y' #) = readFloatArray# mat ((n +# 1#) *# i) s0 -- diagonal element, must be non-zero - yrc = 1.0# `divideFloat#` y' - n' = n -# i -# 1# - loop' k km s | isTrue# (k >=# km) = s - | otherwise = loop' (k +# 1#) km - ( let x0 = k *# n +# i - !(# s', a' #) = readFloatArray# mat x0 s - s'' = writeFloatArray# mat x0 0.0# s' - a = a' `timesFloat#` yrc - in multNRem# n' (x0 +# 1#) y0 a mat s'' - ) - divLoop k s | isTrue# (k >=# n) = s - | otherwise = divLoop (k +# 1#) - ( let x0 = n *# i +# k - !(# s', x #) = readFloatArray# mat x0 s - in writeFloatArray# mat x0 (timesFloat# x yrc) s' - ) - - --- | Remove a multiple of one row from another one. --- do: xi = xi - yi*a -multNRem# :: Int# -- n - nr of elements to go through - -> Int# -- start idx of x (update) - -> Int# -- start idx of y (read) - -> Float# -- multiplier a - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> State# s -- next state -multNRem# 0# _ _ _ _ s = s -multNRem# n x0 y0 a mat s = multNRem# (n -# 1#) (x0 +# 1#) (y0 +# 1#) a mat - ( case readFloatArray# mat y0 s of - (# s1, y #) -> case readFloatArray# mat x0 s1 of - (# s2, x #) -> writeFloatArray# mat x0 (x `minusFloat#` timesFloat# y a) s2 - ) - - - --- | Gives index of maximum (absolute) element in i-th row, starting from i-th element only. --- If i >= m then returns i. -maxInRowRem# :: Int# -- n - -> Int# -- m - -> Int# -- ith column to start to search for and a row to look in - -> MutableByteArray# s -- byte array of matrix - -> State# s -- previous state - -> (# State# s, Int# #) -- next state -maxInRowRem# n m i mat s0 = loop' i (abs# v) i s1 - where - !(# s1, v #) = readFloatArray# mat ((n +# 1#) *# i) s0 - abs# x = if isTrue# (x `geFloat#` 0.0#) then x else negateFloat# x - loop' ok ov k s | isTrue# (k >=# m) = (# s, ok #) - | otherwise = case readFloatArray# mat (n *# k +# i) s of - (# s', v' #) -> if isTrue# (abs# v' `gtFloat#` ov) - then loop' k (abs# v') (k +# 1#) s' - else loop' ok ov (k +# 1#) s' - --- | Do something in a loop for int i from 0 to n-1 and j from 0 to m-1 -loop2# :: Int# -> Int# -> (Int# -> Int#-> State# s -> State# s) - -> State# s -> State# s -loop2# n m f = loop0 0# 0# - where - loop0 i j s | isTrue# (j ==# m) = s - | isTrue# (i ==# n) = loop0 0# (j +# 1#) s - | otherwise = case f i j s of s1 -> loop0 (i +# 1#) j s1 -{-# INLINE loop2# #-} diff --git a/src-base/Numeric/Array/Family/ArrayI.hs b/src-base/Numeric/Array/Family/ArrayI.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayI.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayI --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayI () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayI -#define ARR_FROMSCALAR FromScalarI# -#define ARR_CONSTR ArrayI# -#define EL_TYPE_BOXED Int -#define EL_TYPE_PRIM Int# -#define EL_RUNTIME_REP 'IntRep -#define EL_CONSTR I# -#define EL_SIZE SIZEOF_HSINT# -#define EL_ALIGNMENT ALIGNMENT_HSINT# -#define EL_ZERO 0# -#define EL_ONE 1# -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexIntArray# -#define WRITE_ARRAY writeIntArray# -#define OP_EQ (==#) -#define OP_NE (/=#) -#define OP_GT (>#) -#define OP_GE (>=#) -#define OP_LT (<#) -#define OP_LE (<=#) -#define OP_PLUS (+#) -#define OP_MINUS (-#) -#define OP_TIMES (*#) -#define OP_NEGATE negateInt# -#include "Array.h" - - -instance Num (ArrayI ds) where - (+) = zipV (+#) - {-# INLINE (+) #-} - (-) = zipV (-#) - {-# INLINE (-) #-} - (*) = zipV (*#) - {-# INLINE (*) #-} - negate = mapV negateInt# - {-# INLINE negate #-} - abs = mapV (\x -> if isTrue# (x >=# 0#) - then x - else negateInt# x - ) - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (x ># 0#) - then 1# - else if isTrue# (x <# 0#) - then -1# - else 0# - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - -instance Bounded (ArrayI ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayI16.hs b/src-base/Numeric/Array/Family/ArrayI16.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayI16.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayI16 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayI16 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Int (Int16 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayI16 -#define ARR_FROMSCALAR FromScalarI16# -#define ARR_CONSTR ArrayI16# -#define EL_TYPE_BOXED Int16 -#define EL_TYPE_PRIM Int# -#define EL_RUNTIME_REP 'IntRep -#define EL_CONSTR I16# -#define EL_SIZE SIZEOF_INT16# -#define EL_ALIGNMENT ALIGNMENT_INT16# -#define EL_ZERO 0# -#define EL_ONE 1# -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexInt16Array# -#define WRITE_ARRAY writeInt16Array# -#define OP_EQ (==#) -#define OP_NE (/=#) -#define OP_GT (>#) -#define OP_GE (>=#) -#define OP_LT (<#) -#define OP_LE (<=#) -#define OP_PLUS (+#) -#define OP_MINUS (-#) -#define OP_TIMES (*#) -#define OP_NEGATE negateInt# -#include "Array.h" - - -instance Num (ArrayI16 ds) where - (+) = zipV (+#) - {-# INLINE (+) #-} - (-) = zipV (-#) - {-# INLINE (-) #-} - (*) = zipV (*#) - {-# INLINE (*) #-} - negate = mapV negateInt# - {-# INLINE negate #-} - abs = mapV (\x -> if isTrue# (x >=# 0#) - then x - else negateInt# x - ) - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (x ># 0#) - then 1# - else if isTrue# (x <# 0#) - then -1# - else 0# - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - -instance Bounded (ArrayI16 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayI32.hs b/src-base/Numeric/Array/Family/ArrayI32.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayI32.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayI32 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayI32 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Int (Int32 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayI32 -#define ARR_FROMSCALAR FromScalarI32# -#define ARR_CONSTR ArrayI32# -#define EL_TYPE_BOXED Int32 -#define EL_TYPE_PRIM Int# -#define EL_RUNTIME_REP 'IntRep -#define EL_CONSTR I32# -#define EL_SIZE SIZEOF_INT32# -#define EL_ALIGNMENT ALIGNMENT_INT32# -#define EL_ZERO 0# -#define EL_ONE 1# -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexInt32Array# -#define WRITE_ARRAY writeInt32Array# -#define OP_EQ (==#) -#define OP_NE (/=#) -#define OP_GT (>#) -#define OP_GE (>=#) -#define OP_LT (<#) -#define OP_LE (<=#) -#define OP_PLUS (+#) -#define OP_MINUS (-#) -#define OP_TIMES (*#) -#define OP_NEGATE negateInt# -#include "Array.h" - - -instance Num (ArrayI32 ds) where - (+) = zipV (+#) - {-# INLINE (+) #-} - (-) = zipV (-#) - {-# INLINE (-) #-} - (*) = zipV (*#) - {-# INLINE (*) #-} - negate = mapV negateInt# - {-# INLINE negate #-} - abs = mapV (\x -> if isTrue# (x >=# 0#) - then x - else negateInt# x - ) - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (x ># 0#) - then 1# - else if isTrue# (x <# 0#) - then -1# - else 0# - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - -instance Bounded (ArrayI32 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayI64.hs b/src-base/Numeric/Array/Family/ArrayI64.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayI64.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayI64 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayI64 () where - -#include "MachDeps.h" -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Int (Int64 (..)) -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - - -#if SIZEOF_HSWORD < 8 -#define ARR_TYPE ArrayI64 -#define ARR_FROMSCALAR FromScalarI64# -#define ARR_CONSTR ArrayI64# -#define EL_TYPE_BOXED Int64 -#define EL_TYPE_PRIM Int64# -#define EL_RUNTIME_REP 'Int64Rep -#define EL_CONSTR I64# -#define EL_SIZE SIZEOF_INT64# -#define EL_ALIGNMENT ALIGNMENT_INT64# -#define EL_ZERO (intToInt64# 0#) -#define EL_ONE (intToInt64# 1#) -#define EL_MINUS_ONE (intToInt64# (-1#)) -#define INDEX_ARRAY indexInt64Array# -#define WRITE_ARRAY writeInt64Array# -#define OP_EQ (eqInt64#) -#define OP_NE (neInt64#) -#define OP_GT (gtInt64#) -#define OP_GE (geInt64#) -#define OP_LT (ltInt64#) -#define OP_LE (leInt64#) -#define OP_PLUS (plusInt64#) -#define OP_MINUS (minusInt64#) -#define OP_TIMES (timesInt64#) -#define OP_NEGATE negateInt64# -#else -#define ARR_TYPE ArrayI64 -#define ARR_FROMSCALAR FromScalarI64# -#define ARR_CONSTR ArrayI64# -#define EL_TYPE_BOXED Int64 -#define EL_TYPE_PRIM Int# -#define EL_RUNTIME_REP 'IntRep -#define EL_CONSTR I64# -#define EL_SIZE SIZEOF_INT64# -#define EL_ALIGNMENT ALIGNMENT_INT64# -#define EL_ZERO 0# -#define EL_ONE 1# -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexInt64Array# -#define WRITE_ARRAY writeInt64Array# -#define OP_EQ (==#) -#define OP_NE (/=#) -#define OP_GT (>#) -#define OP_GE (>=#) -#define OP_LT (<#) -#define OP_LE (<=#) -#define OP_PLUS (+#) -#define OP_MINUS (-#) -#define OP_TIMES (*#) -#define OP_NEGATE negateInt# -#endif -#include "Array.h" - - -instance Num (ArrayI64 ds) where - (+) = zipV OP_PLUS - {-# INLINE (+) #-} - (-) = zipV OP_MINUS - {-# INLINE (-) #-} - (*) = zipV OP_TIMES - {-# INLINE (*) #-} - negate = mapV OP_NEGATE - {-# INLINE negate #-} - abs = mapV (\x -> if isTrue# (OP_GE x EL_ZERO) - then x - else OP_NEGATE x - ) - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (OP_GT x EL_ZERO) - then EL_ONE - else if isTrue# (OP_LT x EL_ZERO) - then EL_MINUS_ONE - else EL_ZERO - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - -instance Bounded (ArrayI64 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayI8.hs b/src-base/Numeric/Array/Family/ArrayI8.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayI8.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayI8 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayI8 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Int (Int8 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayI8 -#define ARR_FROMSCALAR FromScalarI8# -#define ARR_CONSTR ArrayI8# -#define EL_TYPE_BOXED Int8 -#define EL_TYPE_PRIM Int# -#define EL_RUNTIME_REP 'IntRep -#define EL_CONSTR I8# -#define EL_SIZE SIZEOF_INT8# -#define EL_ALIGNMENT ALIGNMENT_INT8# -#define EL_ZERO 0# -#define EL_ONE 1# -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexInt8Array# -#define WRITE_ARRAY writeInt8Array# -#define OP_EQ (==#) -#define OP_NE (/=#) -#define OP_GT (>#) -#define OP_GE (>=#) -#define OP_LT (<#) -#define OP_LE (<=#) -#define OP_PLUS (+#) -#define OP_MINUS (-#) -#define OP_TIMES (*#) -#define OP_NEGATE negateInt# -#include "Array.h" - - -instance Num (ArrayI8 ds) where - (+) = zipV (+#) - {-# INLINE (+) #-} - (-) = zipV (-#) - {-# INLINE (-) #-} - (*) = zipV (*#) - {-# INLINE (*) #-} - negate = mapV negateInt# - {-# INLINE negate #-} - abs = mapV (\x -> if isTrue# (x >=# 0#) - then x - else negateInt# x - ) - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (x ># 0#) - then 1# - else if isTrue# (x <# 0#) - then -1# - else 0# - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - -instance Bounded (ArrayI8 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayW.hs b/src-base/Numeric/Array/Family/ArrayW.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayW.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayW --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayW () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Word (..), Int (..), RuntimeRep (..), isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayW -#define ARR_FROMSCALAR FromScalarW# -#define ARR_CONSTR ArrayW# -#define EL_TYPE_BOXED Word -#define EL_TYPE_PRIM Word# -#define EL_RUNTIME_REP 'WordRep -#define EL_CONSTR W# -#define EL_SIZE SIZEOF_HSWORD# -#define EL_ALIGNMENT ALIGNMENT_HSWORD# -#define EL_ZERO 0## -#define EL_ONE 1## -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexWordArray# -#define WRITE_ARRAY writeWordArray# -#define OP_EQ eqWord# -#define OP_NE neWord# -#define OP_GT gtWord# -#define OP_GE geWord# -#define OP_LT ltWord# -#define OP_LE leWord# -#define OP_PLUS plusWord# -#define OP_MINUS minusWord# -#define OP_TIMES timesWord# -#include "Array.h" - -instance Num (ArrayW ds) where - (+) = zipV plusWord# - {-# INLINE (+) #-} - (-) = zipV minusWord# - {-# INLINE (-) #-} - (*) = zipV timesWord# - {-# INLINE (*) #-} - negate = mapV (\x -> int2Word# (negateInt# (word2Int# x))) - {-# INLINE negate #-} - abs = id - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (gtWord# x 0##) - then 1## - else 0## - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - - -instance Bounded (ArrayW ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayW16.hs b/src-base/Numeric/Array/Family/ArrayW16.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayW16.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayW16 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayW16 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Word (Word16 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayW16 -#define ARR_FROMSCALAR FromScalarW16# -#define ARR_CONSTR ArrayW16# -#define EL_TYPE_BOXED Word16 -#define EL_TYPE_PRIM Word# -#define EL_RUNTIME_REP 'WordRep -#define EL_CONSTR W16# -#define EL_SIZE SIZEOF_WORD16# -#define EL_ALIGNMENT ALIGNMENT_WORD16# -#define EL_ZERO 0## -#define EL_ONE 1## -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexWord16Array# -#define WRITE_ARRAY writeWord16Array# -#define OP_EQ eqWord# -#define OP_NE neWord# -#define OP_GT gtWord# -#define OP_GE geWord# -#define OP_LT ltWord# -#define OP_LE leWord# -#define OP_PLUS plusWord# -#define OP_MINUS minusWord# -#define OP_TIMES timesWord# -#include "Array.h" - -instance Num (ArrayW16 ds) where - (+) = zipV plusWord# - {-# INLINE (+) #-} - (-) = zipV minusWord# - {-# INLINE (-) #-} - (*) = zipV timesWord# - {-# INLINE (*) #-} - negate = mapV (\x -> int2Word# (negateInt# (word2Int# x))) - {-# INLINE negate #-} - abs = id - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (gtWord# x 0##) - then 1## - else 0## - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - - -instance Bounded (ArrayW16 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayW32.hs b/src-base/Numeric/Array/Family/ArrayW32.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayW32.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayW32 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayW32 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Word (Word32 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayW32 -#define ARR_FROMSCALAR FromScalarW32# -#define ARR_CONSTR ArrayW32# -#define EL_TYPE_BOXED Word32 -#define EL_TYPE_PRIM Word# -#define EL_RUNTIME_REP 'WordRep -#define EL_CONSTR W32# -#define EL_SIZE SIZEOF_WORD32# -#define EL_ALIGNMENT ALIGNMENT_WORD32# -#define EL_ZERO 0## -#define EL_ONE 1## -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexWord32Array# -#define WRITE_ARRAY writeWord32Array# -#define OP_EQ eqWord# -#define OP_NE neWord# -#define OP_GT gtWord# -#define OP_GE geWord# -#define OP_LT ltWord# -#define OP_LE leWord# -#define OP_PLUS plusWord# -#define OP_MINUS minusWord# -#define OP_TIMES timesWord# -#include "Array.h" - -instance Num (ArrayW32 ds) where - (+) = zipV plusWord# - {-# INLINE (+) #-} - (-) = zipV minusWord# - {-# INLINE (-) #-} - (*) = zipV timesWord# - {-# INLINE (*) #-} - negate = mapV (\x -> int2Word# (negateInt# (word2Int# x))) - {-# INLINE negate #-} - abs = id - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (gtWord# x 0##) - then 1## - else 0## - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - - -instance Bounded (ArrayW32 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayW64.hs b/src-base/Numeric/Array/Family/ArrayW64.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayW64.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayW64 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayW64 () where - -#include "MachDeps.h" -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Word (Word64 (..)) -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - -#if SIZEOF_HSWORD < 8 - -plusWord64#, minusWord64#, timesWord64# - :: Word64# -> Word64# -> Word64# -plusWord64# x y = int64ToWord64# (word64ToInt64# x `plusInt64#` word64ToInt64# y) -minusWord64# x y = int64ToWord64# (word64ToInt64# x `minusInt64#` word64ToInt64# y) -timesWord64# x y = int64ToWord64# (word64ToInt64# x `timesInt64#` word64ToInt64# y) - - -#define ARR_TYPE ArrayW64 -#define ARR_FROMSCALAR FromScalarW64# -#define ARR_CONSTR ArrayW64# -#define EL_TYPE_BOXED Word64 -#define EL_TYPE_PRIM Word64# -#define EL_RUNTIME_REP 'Word64Rep -#define EL_CONSTR W64# -#define EL_SIZE SIZEOF_WORD64# -#define EL_ALIGNMENT ALIGNMENT_WORD64# -#define EL_ZERO (wordToWord64# 0##) -#define EL_ONE (wordToWord64# 1##) -#define INDEX_ARRAY indexWord64Array# -#define WRITE_ARRAY writeWord64Array# -#define OP_EQ (eqWord64#) -#define OP_NE (neWord64#) -#define OP_GT (gtWord64#) -#define OP_GE (geWord64#) -#define OP_LT (ltWord64#) -#define OP_LE (leWord64#) -#define OP_PLUS (plusWord64#) -#define OP_MINUS (minusWord64#) -#define OP_TIMES (timesWord64#) -#else -#define ARR_TYPE ArrayW64 -#define ARR_FROMSCALAR FromScalarW64# -#define ARR_CONSTR ArrayW64# -#define EL_TYPE_BOXED Word64 -#define EL_TYPE_PRIM Word# -#define EL_RUNTIME_REP 'WordRep -#define EL_CONSTR W64# -#define EL_SIZE SIZEOF_WORD64# -#define EL_ALIGNMENT ALIGNMENT_WORD64# -#define EL_ZERO 0## -#define EL_ONE 1## -#define INDEX_ARRAY indexWord64Array# -#define WRITE_ARRAY writeWord64Array# -#define OP_EQ eqWord# -#define OP_NE neWord# -#define OP_GT gtWord# -#define OP_GE geWord# -#define OP_LT ltWord# -#define OP_LE leWord# -#define OP_PLUS plusWord# -#define OP_MINUS minusWord# -#define OP_TIMES timesWord# -#endif -#include "Array.h" - -instance Num (ArrayW64 ds) where - (+) = zipV OP_PLUS - {-# INLINE (+) #-} - (-) = zipV OP_MINUS - {-# INLINE (-) #-} - (*) = zipV OP_TIMES - {-# INLINE (*) #-} -#if SIZEOF_HSWORD < 8 - negate = mapV (\x -> int64ToWord64# (negateInt64# (word64ToInt64# x))) -#else - negate = mapV (\x -> int2Word# (negateInt# (word2Int# x))) -#endif - {-# INLINE negate #-} - abs = id - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (OP_GT x EL_ZERO) - then EL_ONE - else EL_ZERO - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - - -instance Bounded (ArrayW64 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/ArrayW8.hs b/src-base/Numeric/Array/Family/ArrayW8.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/ArrayW8.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.ArrayW8 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayW8 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Word (Word8 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#define ARR_TYPE ArrayW8 -#define ARR_FROMSCALAR FromScalarW8# -#define ARR_CONSTR ArrayW8# -#define EL_TYPE_BOXED Word8 -#define EL_TYPE_PRIM Word# -#define EL_RUNTIME_REP 'WordRep -#define EL_CONSTR W8# -#define EL_SIZE SIZEOF_WORD8# -#define EL_ALIGNMENT ALIGNMENT_WORD8# -#define EL_ZERO 0## -#define EL_ONE 1## -#define EL_MINUS_ONE -1# -#define INDEX_ARRAY indexWord8Array# -#define WRITE_ARRAY writeWord8Array# -#define OP_EQ eqWord# -#define OP_NE neWord# -#define OP_GT gtWord# -#define OP_GE geWord# -#define OP_LT ltWord# -#define OP_LE leWord# -#define OP_PLUS plusWord# -#define OP_MINUS minusWord# -#define OP_TIMES timesWord# -#include "Array.h" - -instance Num (ArrayW8 ds) where - (+) = zipV plusWord# - {-# INLINE (+) #-} - (-) = zipV minusWord# - {-# INLINE (-) #-} - (*) = zipV timesWord# - {-# INLINE (*) #-} - negate = mapV (\x -> int2Word# (negateInt# (word2Int# x))) - {-# INLINE negate #-} - abs = id - {-# INLINE abs #-} - signum = mapV (\x -> if isTrue# (gtWord# x 0##) - then 1## - else 0## - ) - {-# INLINE signum #-} - fromInteger = broadcastArray . fromInteger - {-# INLINE fromInteger #-} - - -instance Bounded (ArrayW8 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src-base/Numeric/Array/Family/DoubleX2.hs b/src-base/Numeric/Array/Family/DoubleX2.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/DoubleX2.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.DoubleX2 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.DoubleX2 () where - - -#include "MachDeps.h" - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Double (..), RuntimeRep (..), - isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions - - -instance Bounded DoubleX2 where - maxBound = case infty of D# x -> DoubleX2# x x - minBound = case negate infty of D# x -> DoubleX2# x x - -infty :: Double -infty = read "Infinity" - - - -instance Show DoubleX2 where - show (DoubleX2# a1 a2) = "{ " ++ show (D# a1) - ++ ", " ++ show (D# a2) - ++ " }" - - - -instance Eq DoubleX2 where - DoubleX2# a1 a2 == DoubleX2# b1 b2 = isTrue# ( (a1 ==## b1) - `andI#` (a2 ==## b2) - ) - {-# INLINE (==) #-} - DoubleX2# a1 a2 /= DoubleX2# b1 b2 = isTrue# ( (a1 /=## b1) - `orI#` (a2 /=## b2) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord DoubleX2 where - DoubleX2# a1 a2 > DoubleX2# b1 b2 = isTrue# ( (a1 >## b1) - `andI#` (a2 >## b2) - ) - {-# INLINE (>) #-} - DoubleX2# a1 a2 < DoubleX2# b1 b2 = isTrue# ( (a1 <## b1) - `andI#` (a2 <## b2) - ) - {-# INLINE (<) #-} - DoubleX2# a1 a2 >= DoubleX2# b1 b2 = isTrue# ( (a1 >=## b1) - `andI#` (a2 >=## b2) - ) - {-# INLINE (>=) #-} - DoubleX2# a1 a2 <= DoubleX2# b1 b2 = isTrue# ( (a1 <=## b1) - `andI#` (a2 <=## b2) - ) - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare (DoubleX2# a1 a2) (DoubleX2# b1 b2) - | isTrue# (a1 >## b1) = GT - | isTrue# (a1 <## b1) = LT - | isTrue# (a2 >## b2) = GT - | isTrue# (a2 <## b2) = LT - | otherwise = EQ - {-# INLINE compare #-} - -- | Element-wise minimum - min (DoubleX2# a1 a2) (DoubleX2# b1 b2) = - DoubleX2# (if isTrue# (a1 >## b1) then b1 else a1) - (if isTrue# (a2 >## b2) then b2 else a2) - {-# INLINE min #-} - -- | Element-wise maximum - max (DoubleX2# a1 a2) (DoubleX2# b1 b2) = - DoubleX2# (if isTrue# (a1 >## b1) then a1 else b1) - (if isTrue# (a2 >## b2) then a2 else b2) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num DoubleX2 where - DoubleX2# a1 a2 + DoubleX2# b1 b2 - = DoubleX2# ((+##) a1 b1) ((+##) a2 b2) - {-# INLINE (+) #-} - DoubleX2# a1 a2 - DoubleX2# b1 b2 - = DoubleX2# ((-##) a1 b1) ((-##) a2 b2) - {-# INLINE (-) #-} - DoubleX2# a1 a2 * DoubleX2# b1 b2 - = DoubleX2# ((*##) a1 b1) ((*##) a2 b2) - {-# INLINE (*) #-} - negate (DoubleX2# a1 a2) - = DoubleX2# (negateDouble# a1) (negateDouble# a2) - {-# INLINE negate #-} - abs (DoubleX2# a1 a2) - = DoubleX2# (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) - (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) - {-# INLINE abs #-} - signum (DoubleX2# a1 a2) - = DoubleX2# (if isTrue# (a1 >## 0.0##) - then 1.0## - else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a2 >## 0.0##) - then 1.0## - else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of D# x -> DoubleX2# x x - {-# INLINE fromInteger #-} - - - -instance Fractional DoubleX2 where - DoubleX2# a1 a2 / DoubleX2# b1 b2 = DoubleX2# ((/##) a1 b1) - ((/##) a2 b2) - {-# INLINE (/) #-} - recip (DoubleX2# a1 a2) = DoubleX2# ((/##) 1.0## a1) - ((/##) 1.0## a2) - {-# INLINE recip #-} - fromRational r = case fromRational r of D# x -> DoubleX2# x x - {-# INLINE fromRational #-} - - - -instance Floating DoubleX2 where - pi = DoubleX2# 3.141592653589793238## 3.141592653589793238## - {-# INLINE pi #-} - exp (DoubleX2# a1 a2) = DoubleX2# (expDouble# a1) - (expDouble# a2) - {-# INLINE exp #-} - log (DoubleX2# a1 a2) = DoubleX2# (logDouble# a1) - (logDouble# a2) - {-# INLINE log #-} - sqrt (DoubleX2# a1 a2) = DoubleX2# (sqrtDouble# a1) - (sqrtDouble# a2) - {-# INLINE sqrt #-} - sin (DoubleX2# a1 a2) = DoubleX2# (sinDouble# a1) - (sinDouble# a2) - {-# INLINE sin #-} - cos (DoubleX2# a1 a2) = DoubleX2# (cosDouble# a1) - (cosDouble# a2) - {-# INLINE cos #-} - tan (DoubleX2# a1 a2) = DoubleX2# (tanDouble# a1) - (tanDouble# a2) - {-# INLINE tan #-} - asin (DoubleX2# a1 a2) = DoubleX2# (asinDouble# a1) - (asinDouble# a2) - {-# INLINE asin #-} - acos (DoubleX2# a1 a2) = DoubleX2# (acosDouble# a1) - (acosDouble# a2) - {-# INLINE acos #-} - atan (DoubleX2# a1 a2) = DoubleX2# (atanDouble# a1) - (atanDouble# a2) - {-# INLINE atan #-} - sinh (DoubleX2# a1 a2) = DoubleX2# (sinDouble# a1) - (sinDouble# a2) - {-# INLINE sinh #-} - cosh (DoubleX2# a1 a2) = DoubleX2# (coshDouble# a1) - (coshDouble# a2) - {-# INLINE cosh #-} - tanh (DoubleX2# a1 a2) = DoubleX2# (tanhDouble# a1) - (tanhDouble# a2) - {-# INLINE tanh #-} - DoubleX2# a1 a2 ** DoubleX2# b1 b2 = DoubleX2# ((**##) a1 b1) - ((**##) a2 b2) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - - - -type instance ElemRep DoubleX2 = 'DoubleRep -type instance ElemPrim DoubleX2 = Double# -instance PrimBytes DoubleX2 where - toBytes (DoubleX2# a1 a2) = case runRW# - ( \s0 -> case newByteArray# (SIZEOF_HSDOUBLE# *# 2#) s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of - s2 -> case writeDoubleArray# marr 1# a2 s2 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, a #) -> (# 0#, 2#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = DoubleX2# - (indexDoubleArray# arr off) - (indexDoubleArray# arr (off +# 1#)) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_HSDOUBLE# *# 2# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSDOUBLE# - {-# INLINE byteAlign #-} - elementByteSize _ = SIZEOF_HSDOUBLE# - {-# INLINE elementByteSize #-} - ix 0# (DoubleX2# a1 _) = a1 - ix 1# (DoubleX2# _ a2) = a2 - ix _ _ = undefined - {-# INLINE ix #-} - - -instance ElementWise (Idx '[2]) Double DoubleX2 where - indexOffset# (DoubleX2# a1 _) 0# = D# a1 - indexOffset# (DoubleX2# _ a2) 1# = D# a2 - indexOffset# _ _ = undefined - {-# INLINE indexOffset# #-} - - (!) (DoubleX2# a1 _) ( 1 :! Z) = D# a1 - (!) (DoubleX2# _ a2) ( 2 :! Z) = D# a2 - (!) _ ( _ :! Z) = undefined - {-# INLINE (!) #-} - - broadcast (D# x) = DoubleX2# x x - {-# INLINE broadcast #-} - - ewmap f (DoubleX2# x y) = case (f (1:!Z) (D# x), f (2:!Z) (D# y)) of - (D# r1, D# r2) -> DoubleX2# r1 r2 - {-# INLINE ewmap #-} - - ewgen f = case (f (1:!Z), f (2:!Z)) of (D# r1, D# r2) -> DoubleX2# r1 r2 - {-# INLINE ewgen #-} - - ewgenA f = (\(D# r1) (D# r2) -> DoubleX2# r1 r2) <$> f (1:!Z) <*> f (2:!Z) - {-# INLINE ewgenA #-} - - ewfoldl f x0 (DoubleX2# x y) = f (2:!Z) (f (1:!Z) x0 (D# x)) (D# y) - {-# INLINE ewfoldl #-} - - ewfoldr f x0 (DoubleX2# x y) = f (1:!Z) (D# x) (f (2:!Z) (D# y) x0) - {-# INLINE ewfoldr #-} - - elementWise f (DoubleX2# x y) = (\(D# a) (D# b) -> DoubleX2# a b) - <$> f (D# x) <*> f (D# y) - {-# INLINE elementWise #-} - - indexWise f (DoubleX2# x y) = (\(D# a) (D# b) -> DoubleX2# a b) - <$> f (1:!Z) (D# x) <*> f (2:!Z) (D# y) - {-# INLINE indexWise #-} - - update (1 :! Z) (D# q) (DoubleX2# _ y) = DoubleX2# q y - update (2 :! Z) (D# q) (DoubleX2# x _) = DoubleX2# x q - update (_ :! Z) _ x = x - {-# INLINE update #-} diff --git a/src-base/Numeric/Array/Family/DoubleX3.hs b/src-base/Numeric/Array/Family/DoubleX3.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/DoubleX3.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.DoubleX3 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.DoubleX3 () where - - -#include "MachDeps.h" - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Double (..), RuntimeRep (..), - isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions - - -instance Bounded DoubleX3 where - maxBound = case infty of D# x -> DoubleX3# x x x - minBound = case negate infty of D# x -> DoubleX3# x x x - -infty :: Double -infty = read "Infinity" - - -instance Show DoubleX3 where - show (DoubleX3# a1 a2 a3) = "{ " ++ show (D# a1) - ++ ", " ++ show (D# a2) - ++ ", " ++ show (D# a3) - ++ " }" - - - -instance Eq DoubleX3 where - DoubleX3# a1 a2 a3 == DoubleX3# b1 b2 b3 = isTrue# ( (a1 ==## b1) - `andI#` (a2 ==## b2) - `andI#` (a3 ==## b3) - ) - {-# INLINE (==) #-} - DoubleX3# a1 a2 a3 /= DoubleX3# b1 b2 b3 = isTrue# ( (a1 /=## b1) - `orI#` (a2 /=## b2) - `orI#` (a3 /=## b3) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord DoubleX3 where - DoubleX3# a1 a2 a3 > DoubleX3# b1 b2 b3 = isTrue# ( (a1 >## b1) - `andI#` (a2 >## b2) - `andI#` (a3 >## b3) - ) - {-# INLINE (>) #-} - DoubleX3# a1 a2 a3 < DoubleX3# b1 b2 b3 = isTrue# ( (a1 <## b1) - `andI#` (a2 <## b2) - `andI#` (a3 <## b3) - ) - {-# INLINE (<) #-} - DoubleX3# a1 a2 a3 >= DoubleX3# b1 b2 b3 = isTrue# ( (a1 >=## b1) - `andI#` (a2 >=## b2) - `andI#` (a3 >=## b3) - ) - {-# INLINE (>=) #-} - DoubleX3# a1 a2 a3 <= DoubleX3# b1 b2 b3 = isTrue# ( (a1 <=## b1) - `andI#` (a2 <=## b2) - `andI#` (a3 <=## b3) - ) - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) - | isTrue# (a1 >## b1) = GT - | isTrue# (a1 <## b1) = LT - | isTrue# (a2 >## b2) = GT - | isTrue# (a2 <## b2) = LT - | isTrue# (a3 >## b3) = GT - | isTrue# (a3 <## b3) = LT - | otherwise = EQ - {-# INLINE compare #-} - -- | Element-wise minimum - min (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) = - DoubleX3# (if isTrue# (a1 >## b1) then b1 else a1) - (if isTrue# (a2 >## b2) then b2 else a2) - (if isTrue# (a3 >## b3) then b3 else a3) - {-# INLINE min #-} - -- | Element-wise maximum - max (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) = - DoubleX3# (if isTrue# (a1 >## b1) then a1 else b1) - (if isTrue# (a2 >## b2) then a2 else b2) - (if isTrue# (a3 >## b3) then a3 else b3) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num DoubleX3 where - DoubleX3# a1 a2 a3 + DoubleX3# b1 b2 b3 - = DoubleX3# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) - {-# INLINE (+) #-} - DoubleX3# a1 a2 a3 - DoubleX3# b1 b2 b3 - = DoubleX3# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) - {-# INLINE (-) #-} - DoubleX3# a1 a2 a3 * DoubleX3# b1 b2 b3 - = DoubleX3# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) - {-# INLINE (*) #-} - negate (DoubleX3# a1 a2 a3) - = DoubleX3# (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) - {-# INLINE negate #-} - abs (DoubleX3# a1 a2 a3) - = DoubleX3# (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) - (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) - (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) - {-# INLINE abs #-} - signum (DoubleX3# a1 a2 a3) - = DoubleX3# (if isTrue# (a1 >## 0.0##) - then 1.0## - else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a2 >## 0.0##) - then 1.0## - else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a3 >## 0.0##) - then 1.0## - else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of D# x -> DoubleX3# x x x - {-# INLINE fromInteger #-} - - - -instance Fractional DoubleX3 where - DoubleX3# a1 a2 a3 / DoubleX3# b1 b2 b3 = DoubleX3# ((/##) a1 b1) - ((/##) a2 b2) - ((/##) a3 b3) - {-# INLINE (/) #-} - recip (DoubleX3# a1 a2 a3) = DoubleX3# ((/##) 1.0## a1) - ((/##) 1.0## a2) - ((/##) 1.0## a3) - {-# INLINE recip #-} - fromRational r = case fromRational r of D# x -> DoubleX3# x x x - {-# INLINE fromRational #-} - - - -instance Floating DoubleX3 where - pi = DoubleX3# 3.141592653589793238## 3.141592653589793238## 3.141592653589793238## - {-# INLINE pi #-} - exp (DoubleX3# a1 a2 a3) = DoubleX3# (expDouble# a1) - (expDouble# a2) - (expDouble# a3) - {-# INLINE exp #-} - log (DoubleX3# a1 a2 a3) = DoubleX3# (logDouble# a1) - (logDouble# a2) - (logDouble# a3) - {-# INLINE log #-} - sqrt (DoubleX3# a1 a2 a3) = DoubleX3# (sqrtDouble# a1) - (sqrtDouble# a2) - (sqrtDouble# a3) - {-# INLINE sqrt #-} - sin (DoubleX3# a1 a2 a3) = DoubleX3# (sinDouble# a1) - (sinDouble# a2) - (sinDouble# a3) - {-# INLINE sin #-} - cos (DoubleX3# a1 a2 a3) = DoubleX3# (cosDouble# a1) - (cosDouble# a2) - (cosDouble# a3) - {-# INLINE cos #-} - tan (DoubleX3# a1 a2 a3) = DoubleX3# (tanDouble# a1) - (tanDouble# a2) - (tanDouble# a3) - {-# INLINE tan #-} - asin (DoubleX3# a1 a2 a3) = DoubleX3# (asinDouble# a1) - (asinDouble# a2) - (asinDouble# a3) - {-# INLINE asin #-} - acos (DoubleX3# a1 a2 a3) = DoubleX3# (acosDouble# a1) - (acosDouble# a2) - (acosDouble# a3) - {-# INLINE acos #-} - atan (DoubleX3# a1 a2 a3) = DoubleX3# (atanDouble# a1) - (atanDouble# a2) - (atanDouble# a3) - {-# INLINE atan #-} - sinh (DoubleX3# a1 a2 a3) = DoubleX3# (sinDouble# a1) - (sinDouble# a2) - (sinDouble# a3) - {-# INLINE sinh #-} - cosh (DoubleX3# a1 a2 a3) = DoubleX3# (coshDouble# a1) - (coshDouble# a2) - (coshDouble# a3) - {-# INLINE cosh #-} - tanh (DoubleX3# a1 a2 a3) = DoubleX3# (tanhDouble# a1) - (tanhDouble# a2) - (tanhDouble# a3) - {-# INLINE tanh #-} - DoubleX3# a1 a2 a3 ** DoubleX3# b1 b2 b3 = DoubleX3# ((**##) a1 b1) - ((**##) a2 b2) - ((**##) a3 b3) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - - - -type instance ElemRep DoubleX3 = 'DoubleRep -type instance ElemPrim DoubleX3 = Double# -instance PrimBytes DoubleX3 where - toBytes (DoubleX3# a1 a2 a3) = case runRW# - ( \s0 -> case newByteArray# (SIZEOF_HSDOUBLE# *# 3#) s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of - s2 -> case writeDoubleArray# marr 1# a2 s2 of - s3 -> case writeDoubleArray# marr 2# a3 s3 of - s4 -> unsafeFreezeByteArray# marr s4 - ) of (# _, a #) -> (# 0#, 3#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = DoubleX3# - (indexDoubleArray# arr off) - (indexDoubleArray# arr (off +# 1#)) - (indexDoubleArray# arr (off +# 2#)) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_HSDOUBLE# *# 3# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSDOUBLE# - {-# INLINE byteAlign #-} - elementByteSize _ = SIZEOF_HSDOUBLE# - {-# INLINE elementByteSize #-} - ix 0# (DoubleX3# a1 _ _) = a1 - ix 1# (DoubleX3# _ a2 _) = a2 - ix 2# (DoubleX3# _ _ a3) = a3 - ix _ _ = undefined - {-# INLINE ix #-} - - -instance ElementWise (Idx '[3]) Double DoubleX3 where - indexOffset# (DoubleX3# a1 _ _) 0# = D# a1 - indexOffset# (DoubleX3# _ a2 _) 1# = D# a2 - indexOffset# (DoubleX3# _ _ a3) 2# = D# a3 - indexOffset# _ _ = undefined - {-# INLINE indexOffset# #-} - - (!) (DoubleX3# a1 _ _) ( 1 :! Z) = D# a1 - (!) (DoubleX3# _ a2 _) ( 2 :! Z) = D# a2 - (!) (DoubleX3# _ _ a3) ( 3 :! Z) = D# a3 - (!) _ ( _ :! Z) = undefined - {-# INLINE (!) #-} - - broadcast (D# x) = DoubleX3# x x x - {-# INLINE broadcast #-} - - ewmap f (DoubleX3# x y z) = case (f (1:!Z) (D# x), f (2:!Z) (D# y), f (3:!Z) (D# z)) of - (D# r1, D# r2, D# r3) -> DoubleX3# r1 r2 r3 - {-# INLINE ewmap #-} - - ewgen f = case (f (1:!Z), f (2:!Z), f (3:!Z)) of (D# r1, D# r2, D# r3) -> DoubleX3# r1 r2 r3 - {-# INLINE ewgen #-} - - ewgenA f = (\(D# r1) (D# r2) (D# r3) -> DoubleX3# r1 r2 r3) - <$> f (1:!Z) <*> f (2:!Z) <*> f (3:!Z) - {-# INLINE ewgenA #-} - - ewfoldl f x0 (DoubleX3# x y z) = f (3:!Z) (f (2:!Z) (f (1:!Z) x0 (D# x)) (D# y)) (D# z) - {-# INLINE ewfoldl #-} - - ewfoldr f x0 (DoubleX3# x y z) = f (1:!Z) (D# x) (f (2:!Z) (D# y) (f (3:!Z) (D# z) x0)) - {-# INLINE ewfoldr #-} - - elementWise f (DoubleX3# x y z) = (\(D# a) (D# b) (D# c) -> DoubleX3# a b c) - <$> f (D# x) <*> f (D# y) <*> f (D# z) - {-# INLINE elementWise #-} - - indexWise f (DoubleX3# x y z) = (\(D# a) (D# b) (D# c) -> DoubleX3# a b c) - <$> f (1:!Z) (D# x) <*> f (2:!Z) (D# y) <*> f (3:!Z) (D# z) - {-# INLINE indexWise #-} - - update (1 :! Z) (D# q) (DoubleX3# _ y z) = DoubleX3# q y z - update (2 :! Z) (D# q) (DoubleX3# x _ z) = DoubleX3# x q z - update (3 :! Z) (D# q) (DoubleX3# x y _) = DoubleX3# x y q - update (_ :! Z) _ x = x - {-# INLINE update #-} diff --git a/src-base/Numeric/Array/Family/DoubleX4.hs b/src-base/Numeric/Array/Family/DoubleX4.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/DoubleX4.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.DoubleX4 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.DoubleX4 () where - - -#include "MachDeps.h" - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Double (..), RuntimeRep (..), - isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions - - -instance Bounded DoubleX4 where - maxBound = case infty of D# x -> DoubleX4# x x x x - minBound = case negate infty of D# x -> DoubleX4# x x x x - -infty :: Double -infty = read "Infinity" - - -instance Show DoubleX4 where - show (DoubleX4# a1 a2 a3 a4) = "{ " ++ show (D# a1) - ++ ", " ++ show (D# a2) - ++ ", " ++ show (D# a3) - ++ ", " ++ show (D# a4) - ++ " }" - - - -instance Eq DoubleX4 where - DoubleX4# a1 a2 a3 a4 == DoubleX4# b1 b2 b3 b4 = isTrue# ( (a1 ==## b1) - `andI#` (a2 ==## b2) - `andI#` (a3 ==## b3) - `andI#` (a4 ==## b4) - ) - {-# INLINE (==) #-} - DoubleX4# a1 a2 a3 a4 /= DoubleX4# b1 b2 b3 b4 = isTrue# ( (a1 /=## b1) - `orI#` (a2 /=## b2) - `orI#` (a3 /=## b3) - `orI#` (a4 /=## b4) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord DoubleX4 where - DoubleX4# a1 a2 a3 a4 > DoubleX4# b1 b2 b3 b4 = isTrue# ( (a1 >## b1) - `andI#` (a2 >## b2) - `andI#` (a3 >## b3) - `andI#` (a4 >## b4) - ) - {-# INLINE (>) #-} - DoubleX4# a1 a2 a3 a4 < DoubleX4# b1 b2 b3 b4 = isTrue# ( (a1 <## b1) - `andI#` (a2 <## b2) - `andI#` (a3 <## b3) - `andI#` (a4 <## b4) - ) - {-# INLINE (<) #-} - DoubleX4# a1 a2 a3 a4 >= DoubleX4# b1 b2 b3 b4 = isTrue# ( (a1 >=## b1) - `andI#` (a2 >=## b2) - `andI#` (a3 >=## b3) - `andI#` (a4 >=## b4) - ) - {-# INLINE (>=) #-} - DoubleX4# a1 a2 a3 a4 <= DoubleX4# b1 b2 b3 b4 = isTrue# ( (a1 <=## b1) - `andI#` (a2 <=## b2) - `andI#` (a3 <=## b3) - `andI#` (a4 <=## b4) - ) - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) - | isTrue# (a1 >## b1) = GT - | isTrue# (a1 <## b1) = LT - | isTrue# (a2 >## b2) = GT - | isTrue# (a2 <## b2) = LT - | isTrue# (a3 >## b3) = GT - | isTrue# (a3 <## b3) = LT - | isTrue# (a4 >## b4) = GT - | isTrue# (a4 <## b4) = LT - | otherwise = EQ - {-# INLINE compare #-} - -- | Element-wise minimum - min (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) = - DoubleX4# (if isTrue# (a1 >## b1) then b1 else a1) - (if isTrue# (a2 >## b2) then b2 else a2) - (if isTrue# (a3 >## b3) then b3 else a3) - (if isTrue# (a4 >## b4) then b4 else a4) - {-# INLINE min #-} - -- | Element-wise maximum - max (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) = - DoubleX4# (if isTrue# (a1 >## b1) then a1 else b1) - (if isTrue# (a2 >## b2) then a2 else b2) - (if isTrue# (a3 >## b3) then a3 else b3) - (if isTrue# (a4 >## b4) then a4 else b4) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num DoubleX4 where - DoubleX4# a1 a2 a3 a4 + DoubleX4# b1 b2 b3 b4 - = DoubleX4# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) ((+##) a4 b4) - {-# INLINE (+) #-} - DoubleX4# a1 a2 a3 a4 - DoubleX4# b1 b2 b3 b4 - = DoubleX4# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) ((-##) a4 b4) - {-# INLINE (-) #-} - DoubleX4# a1 a2 a3 a4 * DoubleX4# b1 b2 b3 b4 - = DoubleX4# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) ((*##) a4 b4) - {-# INLINE (*) #-} - negate (DoubleX4# a1 a2 a3 a4) - = DoubleX4# (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) (negateDouble# a4) - {-# INLINE negate #-} - abs (DoubleX4# a1 a2 a3 a4) - = DoubleX4# (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) - (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) - (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) - (if isTrue# (a4 >=## 0.0##) then a4 else negateDouble# a4) - {-# INLINE abs #-} - signum (DoubleX4# a1 a2 a3 a4) - = DoubleX4# (if isTrue# (a1 >## 0.0##) - then 1.0## - else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a2 >## 0.0##) - then 1.0## - else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a3 >## 0.0##) - then 1.0## - else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a4 >## 0.0##) - then 1.0## - else if isTrue# (a4 <## 0.0##) then -1.0## else 0.0## ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of D# x -> DoubleX4# x x x x - {-# INLINE fromInteger #-} - - - -instance Fractional DoubleX4 where - DoubleX4# a1 a2 a3 a4 / DoubleX4# b1 b2 b3 b4 = DoubleX4# ((/##) a1 b1) - ((/##) a2 b2) - ((/##) a3 b3) - ((/##) a4 b4) - {-# INLINE (/) #-} - recip (DoubleX4# a1 a2 a3 a4) = DoubleX4# ((/##) 1.0## a1) - ((/##) 1.0## a2) - ((/##) 1.0## a3) - ((/##) 1.0## a4) - {-# INLINE recip #-} - fromRational r = case fromRational r of D# x -> DoubleX4# x x x x - {-# INLINE fromRational #-} - - - -instance Floating DoubleX4 where - pi = DoubleX4# 3.141592653589793238## 3.141592653589793238## 3.141592653589793238## 3.141592653589793238## - {-# INLINE pi #-} - exp (DoubleX4# a1 a2 a3 a4) = DoubleX4# (expDouble# a1) - (expDouble# a2) - (expDouble# a3) - (expDouble# a4) - {-# INLINE exp #-} - log (DoubleX4# a1 a2 a3 a4) = DoubleX4# (logDouble# a1) - (logDouble# a2) - (logDouble# a3) - (logDouble# a4) - {-# INLINE log #-} - sqrt (DoubleX4# a1 a2 a3 a4) = DoubleX4# (sqrtDouble# a1) - (sqrtDouble# a2) - (sqrtDouble# a3) - (sqrtDouble# a4) - {-# INLINE sqrt #-} - sin (DoubleX4# a1 a2 a3 a4) = DoubleX4# (sinDouble# a1) - (sinDouble# a2) - (sinDouble# a3) - (sinDouble# a4) - {-# INLINE sin #-} - cos (DoubleX4# a1 a2 a3 a4) = DoubleX4# (cosDouble# a1) - (cosDouble# a2) - (cosDouble# a3) - (cosDouble# a4) - {-# INLINE cos #-} - tan (DoubleX4# a1 a2 a3 a4) = DoubleX4# (tanDouble# a1) - (tanDouble# a2) - (tanDouble# a3) - (tanDouble# a4) - {-# INLINE tan #-} - asin (DoubleX4# a1 a2 a3 a4) = DoubleX4# (asinDouble# a1) - (asinDouble# a2) - (asinDouble# a3) - (asinDouble# a4) - {-# INLINE asin #-} - acos (DoubleX4# a1 a2 a3 a4) = DoubleX4# (acosDouble# a1) - (acosDouble# a2) - (acosDouble# a3) - (acosDouble# a4) - {-# INLINE acos #-} - atan (DoubleX4# a1 a2 a3 a4) = DoubleX4# (atanDouble# a1) - (atanDouble# a2) - (atanDouble# a3) - (atanDouble# a4) - {-# INLINE atan #-} - sinh (DoubleX4# a1 a2 a3 a4) = DoubleX4# (sinDouble# a1) - (sinDouble# a2) - (sinDouble# a3) - (sinDouble# a4) - {-# INLINE sinh #-} - cosh (DoubleX4# a1 a2 a3 a4) = DoubleX4# (coshDouble# a1) - (coshDouble# a2) - (coshDouble# a3) - (coshDouble# a4) - {-# INLINE cosh #-} - tanh (DoubleX4# a1 a2 a3 a4) = DoubleX4# (tanhDouble# a1) - (tanhDouble# a2) - (tanhDouble# a3) - (tanhDouble# a4) - {-# INLINE tanh #-} - DoubleX4# a1 a2 a3 a4 ** DoubleX4# b1 b2 b3 b4 = DoubleX4# ((**##) a1 b1) - ((**##) a2 b2) - ((**##) a3 b3) - ((**##) a4 b4) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - - - -type instance ElemRep DoubleX4 = 'DoubleRep -type instance ElemPrim DoubleX4 = Double# -instance PrimBytes DoubleX4 where - toBytes (DoubleX4# a1 a2 a3 a4) = case runRW# - ( \s0 -> case newByteArray# (SIZEOF_HSDOUBLE# *# 3#) s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of - s2 -> case writeDoubleArray# marr 1# a2 s2 of - s3 -> case writeDoubleArray# marr 2# a3 s3 of - s4 -> case writeDoubleArray# marr 3# a4 s4 of - s5 -> unsafeFreezeByteArray# marr s5 - ) of (# _, a #) -> (# 0#, 4#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = DoubleX4# - (indexDoubleArray# arr off) - (indexDoubleArray# arr (off +# 1#)) - (indexDoubleArray# arr (off +# 2#)) - (indexDoubleArray# arr (off +# 3#)) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_HSDOUBLE# *# 4# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSDOUBLE# - {-# INLINE byteAlign #-} - elementByteSize _ = SIZEOF_HSDOUBLE# - {-# INLINE elementByteSize #-} - ix 0# (DoubleX4# a1 _ _ _) = a1 - ix 1# (DoubleX4# _ a2 _ _) = a2 - ix 2# (DoubleX4# _ _ a3 _) = a3 - ix 3# (DoubleX4# _ _ _ a4) = a4 - ix _ _ = undefined - {-# INLINE ix #-} - - -instance ElementWise (Idx '[4]) Double DoubleX4 where - indexOffset# (DoubleX4# a1 _ _ _) 0# = D# a1 - indexOffset# (DoubleX4# _ a2 _ _) 1# = D# a2 - indexOffset# (DoubleX4# _ _ a3 _) 2# = D# a3 - indexOffset# (DoubleX4# _ _ _ a4) 3# = D# a4 - indexOffset# _ _ = undefined - {-# INLINE indexOffset# #-} - - (!) (DoubleX4# a1 _ _ _) ( 1 :! Z) = D# a1 - (!) (DoubleX4# _ a2 _ _) ( 2 :! Z) = D# a2 - (!) (DoubleX4# _ _ a3 _) ( 3 :! Z) = D# a3 - (!) (DoubleX4# _ _ _ a4) ( 4 :! Z) = D# a4 - (!) _ ( _ :! Z) = undefined - {-# INLINE (!) #-} - - broadcast (D# x) = DoubleX4# x x x x - {-# INLINE broadcast #-} - - ewmap f (DoubleX4# x y z w) = case (f (1:!Z) (D# x), f (2:!Z) (D# y), f (3:!Z) (D# z), f (3:!Z) (D# w)) of - (D# r1, D# r2, D# r3, D# r4) -> DoubleX4# r1 r2 r3 r4 - {-# INLINE ewmap #-} - - ewgen f = case (f (1:!Z), f (2:!Z), f (3:!Z), f (4:!Z)) of (D# r1, D# r2, D# r3, D# r4) -> DoubleX4# r1 r2 r3 r4 - {-# INLINE ewgen #-} - - ewgenA f = (\(D# a) (D# b) (D# c) (D# d) -> DoubleX4# a b c d) - <$> f (1:!Z) <*> f (2:!Z) <*> f (3:!Z) <*> f (4:!Z) - {-# INLINE ewgenA #-} - - ewfoldl f x0 (DoubleX4# x y z w) = f (4:!Z) (f (3:!Z) (f (2:!Z) (f (1:!Z) x0 (D# x)) (D# y)) (D# z)) (D# w) - {-# INLINE ewfoldl #-} - - ewfoldr f x0 (DoubleX4# x y z w) = f (1:!Z) (D# x) (f (2:!Z) (D# y) (f (3:!Z) (D# z) (f (4:!Z) (D# w) x0))) - {-# INLINE ewfoldr #-} - - elementWise f (DoubleX4# x y z w) = (\(D# a) (D# b) (D# c) (D# d) -> DoubleX4# a b c d) - <$> f (D# x) <*> f (D# y) <*> f (D# z) <*> f (D# w) - {-# INLINE elementWise #-} - - indexWise f (DoubleX4# x y z w) = (\(D# a) (D# b) (D# c) (D# d) -> DoubleX4# a b c d) - <$> f (1:!Z) (D# x) <*> f (2:!Z) (D# y) <*> f (3:!Z) (D# z) <*> f (4:!Z) (D# w) - {-# INLINE indexWise #-} - - update (1 :! Z) (D# q) (DoubleX4# _ y z w) = DoubleX4# q y z w - update (2 :! Z) (D# q) (DoubleX4# x _ z w) = DoubleX4# x q z w - update (3 :! Z) (D# q) (DoubleX4# x y _ w) = DoubleX4# x y q w - update (4 :! Z) (D# q) (DoubleX4# x y z _) = DoubleX4# x y z q - update (_ :! Z) _ x = x - {-# INLINE update #-} diff --git a/src-base/Numeric/Array/Family/FloatX2.hs b/src-base/Numeric/Array/Family/FloatX2.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/FloatX2.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.FloatX2 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.FloatX2 () where - - -#include "MachDeps.h" - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Float (..), RuntimeRep (..), - isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions - - -instance Bounded FloatX2 where - maxBound = case infty of F# x -> FloatX2# x x - minBound = case negate infty of F# x -> FloatX2# x x - -infty :: Float -infty = read "Infinity" - - -instance Show FloatX2 where - show (FloatX2# a1 a2) = "{ " ++ show (F# a1) - ++ ", " ++ show (F# a2) - ++ " }" - - - -instance Eq FloatX2 where - FloatX2# a1 a2 == FloatX2# b1 b2 = isTrue# ( (a1 `eqFloat#` b1) - `andI#` (a2 `eqFloat#` b2) - ) - {-# INLINE (==) #-} - FloatX2# a1 a2 /= FloatX2# b1 b2 = isTrue# ( (a1 `neFloat#` b1) - `orI#` (a2 `neFloat#` b2) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord FloatX2 where - FloatX2# a1 a2 > FloatX2# b1 b2 = isTrue# ( (a1 `gtFloat#` b1) - `andI#` (a2 `gtFloat#` b2) - ) - {-# INLINE (>) #-} - FloatX2# a1 a2 < FloatX2# b1 b2 = isTrue# ( (a1 `ltFloat#` b1) - `andI#` (a2 `ltFloat#` b2) - ) - {-# INLINE (<) #-} - FloatX2# a1 a2 >= FloatX2# b1 b2 = isTrue# ( (a1 `geFloat#` b1) - `andI#` (a2 `geFloat#` b2) - ) - {-# INLINE (>=) #-} - FloatX2# a1 a2 <= FloatX2# b1 b2 = isTrue# ( (a1 `leFloat#` b1) - `andI#` (a2 `leFloat#` b2) - ) - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare (FloatX2# a1 a2) (FloatX2# b1 b2) - | isTrue# (a1 `gtFloat#` b1) = GT - | isTrue# (a1 `ltFloat#` b1) = LT - | isTrue# (a2 `gtFloat#` b2) = GT - | isTrue# (a2 `ltFloat#` b2) = LT - | otherwise = EQ - {-# INLINE compare #-} - -- | Element-wise minimum - min (FloatX2# a1 a2) (FloatX2# b1 b2) = - FloatX2# (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) - (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) - {-# INLINE min #-} - -- | Element-wise maximum - max (FloatX2# a1 a2) (FloatX2# b1 b2) = - FloatX2# (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) - (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num FloatX2 where - FloatX2# a1 a2 + FloatX2# b1 b2 - = FloatX2# (plusFloat# a1 b1) (plusFloat# a2 b2) - {-# INLINE (+) #-} - FloatX2# a1 a2 - FloatX2# b1 b2 - = FloatX2# (minusFloat# a1 b1) (minusFloat# a2 b2) - {-# INLINE (-) #-} - FloatX2# a1 a2 * FloatX2# b1 b2 - = FloatX2# (timesFloat# a1 b1) (timesFloat# a2 b2) - {-# INLINE (*) #-} - negate (FloatX2# a1 a2) - = FloatX2# (negateFloat# a1) (negateFloat# a2) - {-# INLINE negate #-} - abs (FloatX2# a1 a2) - = FloatX2# (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) - (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) - {-# INLINE abs #-} - signum (FloatX2# a1 a2) - = FloatX2# (if isTrue# (a1 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a2 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of F# x -> FloatX2# x x - {-# INLINE fromInteger #-} - - - -instance Fractional FloatX2 where - FloatX2# a1 a2 / FloatX2# b1 b2 = FloatX2# (divideFloat# a1 b1) - (divideFloat# a2 b2) - {-# INLINE (/) #-} - recip (FloatX2# a1 a2) = FloatX2# (divideFloat# 1.0# a1) - (divideFloat# 1.0# a2) - {-# INLINE recip #-} - fromRational r = case fromRational r of F# x -> FloatX2# x x - {-# INLINE fromRational #-} - - - -instance Floating FloatX2 where - pi = FloatX2# 3.141592653589793238# 3.141592653589793238# - {-# INLINE pi #-} - exp (FloatX2# a1 a2) = FloatX2# (expFloat# a1) - (expFloat# a2) - {-# INLINE exp #-} - log (FloatX2# a1 a2) = FloatX2# (logFloat# a1) - (logFloat# a2) - {-# INLINE log #-} - sqrt (FloatX2# a1 a2) = FloatX2# (sqrtFloat# a1) - (sqrtFloat# a2) - {-# INLINE sqrt #-} - sin (FloatX2# a1 a2) = FloatX2# (sinFloat# a1) - (sinFloat# a2) - {-# INLINE sin #-} - cos (FloatX2# a1 a2) = FloatX2# (cosFloat# a1) - (cosFloat# a2) - {-# INLINE cos #-} - tan (FloatX2# a1 a2) = FloatX2# (tanFloat# a1) - (tanFloat# a2) - {-# INLINE tan #-} - asin (FloatX2# a1 a2) = FloatX2# (asinFloat# a1) - (asinFloat# a2) - {-# INLINE asin #-} - acos (FloatX2# a1 a2) = FloatX2# (acosFloat# a1) - (acosFloat# a2) - {-# INLINE acos #-} - atan (FloatX2# a1 a2) = FloatX2# (atanFloat# a1) - (atanFloat# a2) - {-# INLINE atan #-} - sinh (FloatX2# a1 a2) = FloatX2# (sinFloat# a1) - (sinFloat# a2) - {-# INLINE sinh #-} - cosh (FloatX2# a1 a2) = FloatX2# (coshFloat# a1) - (coshFloat# a2) - {-# INLINE cosh #-} - tanh (FloatX2# a1 a2) = FloatX2# (tanhFloat# a1) - (tanhFloat# a2) - {-# INLINE tanh #-} - FloatX2# a1 a2 ** FloatX2# b1 b2 = FloatX2# (powerFloat# a1 b1) - (powerFloat# a2 b2) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - - - --- log1p (FloatX2# a1 a2) = case ( log1p (F# a1), log1p (F# a2) ) of --- (F# x1, F# x2) -> FloatX2# x1 x2 --- expm1 (FloatX2# a1 a2) = case ( expm1 (F# a1), expm1 (F# a2) ) of --- (F# x1, F# x2) -> FloatX2# x1 x2 --- --- log1mexp a --- | a <= log 2 = log (negate (expm1Float a)) --- | otherwise = log1p (negate (exp a)) --- {-# INLINE log1mexp #-} --- log1pexp a --- | a <= 18 = log1p (exp a) --- | a <= 100 = a + exp (negate a) --- | otherwise = a --- {-# INLINE log1pexp #-} - - - --- instance VectorCalculus Float 2 FloatX2 where --- broadcastVec (F# x) = FloatX2# x x --- {-# INLINE broadcastVec #-} --- FloatX2# a1 a2 .*. FloatX2# b1 b2 = case timesFloat# a1 b1 --- `plusFloat#` timesFloat# a2 b2 of --- x -> FloatX2# x x --- {-# INLINE (.*.) #-} --- FloatX2# a1 a2 `dot` FloatX2# b1 b2 = F# ( timesFloat# a1 b1 --- `plusFloat#` timesFloat# a2 b2 --- ) --- {-# INLINE dot #-} --- indexVec 1 (FloatX2# a1 _) = F# a1 --- indexVec 2 (FloatX2# _ a2) = F# a2 --- indexVec i _ = error $ "Bad index " ++ show i ++ " for 2D vector" --- {-# INLINE indexVec #-} --- normL1 v = case abs v of --- FloatX2# a1 a2 -> F# (a1 `plusFloat#` a2) --- {-# INLINE normL1 #-} --- normL2 v = sqrt $ dot v v --- {-# INLINE normL2 #-} --- normLPInf (FloatX2# a1 a2) --- = F# (if isTrue# (a1 `gtFloat#` a2) then a1 else a2) --- {-# INLINE normLPInf #-} --- normLNInf (FloatX2# a1 a2) --- = F# (if isTrue# (a1 `gtFloat#` a2) then a2 else a1) --- {-# INLINE normLNInf #-} --- normLP n (FloatX2# a1 a2) = case realToFrac n of --- F# x -> F# ( powerFloat# (divideFloat# 1.0# x) --- ( powerFloat# a1 x --- `plusFloat#` powerFloat# a2 x --- ) --- ) --- {-# INLINE normLP #-} --- dim _ = 2 --- {-# INLINE dim #-} --- --- --- --- --- instance Vector2D Float where --- vec2 (F# x) (F# y) = FloatX2# x y --- {-# INLINE vec2 #-} --- det2 (FloatX2# a1 a2) (FloatX2# b1 b2) --- = F# (timesFloat# a1 b2 `minusFloat#` timesFloat# a2 b1) --- {-# INLINE det2 #-} - -type instance ElemRep FloatX2 = 'FloatRep -type instance ElemPrim FloatX2 = Float# -instance PrimBytes FloatX2 where - toBytes (FloatX2# a1 a2) = case runRW# - ( \s0 -> case newByteArray# (SIZEOF_HSFLOAT# *# 2#) s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of - s2 -> case writeFloatArray# marr 1# a2 s2 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, a #) -> (# 0#, 2#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = FloatX2# - (indexFloatArray# arr off) - (indexFloatArray# arr (off +# 1#)) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_HSFLOAT# *# 2# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSFLOAT# - {-# INLINE byteAlign #-} - elementByteSize _ = SIZEOF_HSFLOAT# - {-# INLINE elementByteSize #-} - ix 0# (FloatX2# a1 _) = a1 - ix 1# (FloatX2# _ a2) = a2 - ix _ _ = undefined - {-# INLINE ix #-} - - -instance ElementWise (Idx '[2]) Float FloatX2 where - indexOffset# (FloatX2# a1 _) 0# = F# a1 - indexOffset# (FloatX2# _ a2) 1# = F# a2 - indexOffset# _ _ = undefined - {-# INLINE indexOffset# #-} - - (!) (FloatX2# a1 _) ( 1 :! Z) = F# a1 - (!) (FloatX2# _ a2) ( 2 :! Z) = F# a2 - (!) _ ( _ :! Z) = undefined - {-# INLINE (!) #-} - - broadcast (F# x) = FloatX2# x x - {-# INLINE broadcast #-} - - ewmap f (FloatX2# x y) = case (f (1:!Z) (F# x), f (2:!Z) (F# y)) of - (F# r1, F# r2) -> FloatX2# r1 r2 - {-# INLINE ewmap #-} - - ewgen f = case (f (1:!Z), f (2:!Z)) of (F# r1, F# r2) -> FloatX2# r1 r2 - {-# INLINE ewgen #-} - - ewgenA f = (\(F# r1) (F# r2) -> FloatX2# r1 r2) <$> f (1:!Z) <*> f (2:!Z) - {-# INLINE ewgenA #-} - - ewfoldl f x0 (FloatX2# x y) = f (2:!Z) (f (1:!Z) x0 (F# x)) (F# y) - {-# INLINE ewfoldl #-} - - ewfoldr f x0 (FloatX2# x y) = f (1:!Z) (F# x) (f (2:!Z) (F# y) x0) - {-# INLINE ewfoldr #-} - - elementWise f (FloatX2# x y) = (\(F# a) (F# b) -> FloatX2# a b) - <$> f (F# x) <*> f (F# y) - {-# INLINE elementWise #-} - - indexWise f (FloatX2# x y) = (\(F# a) (F# b) -> FloatX2# a b) - <$> f (1:!Z) (F# x) <*> f (2:!Z) (F# y) - {-# INLINE indexWise #-} - - update (1 :! Z) (F# q) (FloatX2# _ y) = FloatX2# q y - update (2 :! Z) (F# q) (FloatX2# x _) = FloatX2# x q - update (_ :! Z) _ x = x - {-# INLINE update #-} diff --git a/src-base/Numeric/Array/Family/FloatX3.hs b/src-base/Numeric/Array/Family/FloatX3.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/FloatX3.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.FloatX3 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.FloatX3 () where - - -#include "MachDeps.h" - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Float (..), RuntimeRep (..), - isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions - -instance Bounded FloatX3 where - maxBound = case infty of F# x -> FloatX3# x x x - minBound = case negate infty of F# x -> FloatX3# x x x - -infty :: Float -infty = read "Infinity" - - - -instance Show FloatX3 where - show (FloatX3# a1 a2 a3) = "{ " ++ show (F# a1) - ++ ", " ++ show (F# a2) - ++ ", " ++ show (F# a3) - ++ " }" - - - -instance Eq FloatX3 where - FloatX3# a1 a2 a3 == FloatX3# b1 b2 b3 = isTrue# ( (a1 `eqFloat#` b1) - `andI#` (a2 `eqFloat#` b2) - `andI#` (a3 `eqFloat#` b3) - ) - {-# INLINE (==) #-} - FloatX3# a1 a2 a3 /= FloatX3# b1 b2 b3 = isTrue# ( (a1 `neFloat#` b1) - `orI#` (a2 `neFloat#` b2) - `orI#` (a3 `neFloat#` b3) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord FloatX3 where - FloatX3# a1 a2 a3 > FloatX3# b1 b2 b3 = isTrue# ( (a1 `gtFloat#` b1) - `andI#` (a2 `gtFloat#` b2) - `andI#` (a3 `gtFloat#` b3) - ) - {-# INLINE (>) #-} - FloatX3# a1 a2 a3 < FloatX3# b1 b2 b3 = isTrue# ( (a1 `ltFloat#` b1) - `andI#` (a2 `ltFloat#` b2) - `andI#` (a3 `ltFloat#` b3) - ) - {-# INLINE (<) #-} - FloatX3# a1 a2 a3 >= FloatX3# b1 b2 b3 = isTrue# ( (a1 `geFloat#` b1) - `andI#` (a2 `geFloat#` b2) - `andI#` (a3 `geFloat#` b3) - ) - {-# INLINE (>=) #-} - FloatX3# a1 a2 a3 <= FloatX3# b1 b2 b3 = isTrue# ( (a1 `leFloat#` b1) - `andI#` (a2 `leFloat#` b2) - `andI#` (a3 `leFloat#` b3) - ) - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) - | isTrue# (a1 `gtFloat#` b1) = GT - | isTrue# (a1 `ltFloat#` b1) = LT - | isTrue# (a2 `gtFloat#` b2) = GT - | isTrue# (a2 `ltFloat#` b2) = LT - | isTrue# (a3 `gtFloat#` b3) = GT - | isTrue# (a3 `ltFloat#` b3) = LT - | otherwise = EQ - {-# INLINE compare #-} - -- | Element-wise minimum - min (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) = - FloatX3# (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) - (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) - (if isTrue# (a3 `gtFloat#` b3) then b3 else a3) - {-# INLINE min #-} - -- | Element-wise maximum - max (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) = - FloatX3# (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) - (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) - (if isTrue# (a3 `gtFloat#` b3) then a3 else b3) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num FloatX3 where - FloatX3# a1 a2 a3 + FloatX3# b1 b2 b3 - = FloatX3# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) - {-# INLINE (+) #-} - FloatX3# a1 a2 a3 - FloatX3# b1 b2 b3 - = FloatX3# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) - {-# INLINE (-) #-} - FloatX3# a1 a2 a3 * FloatX3# b1 b2 b3 - = FloatX3# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) - {-# INLINE (*) #-} - negate (FloatX3# a1 a2 a3) - = FloatX3# (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) - {-# INLINE negate #-} - abs (FloatX3# a1 a2 a3) - = FloatX3# (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) - (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) - (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) - {-# INLINE abs #-} - signum (FloatX3# a1 a2 a3) - = FloatX3# (if isTrue# (a1 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a2 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a3 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of F# x -> FloatX3# x x x - {-# INLINE fromInteger #-} - - - -instance Fractional FloatX3 where - FloatX3# a1 a2 a3 / FloatX3# b1 b2 b3 = FloatX3# (divideFloat# a1 b1) - (divideFloat# a2 b2) - (divideFloat# a3 b3) - {-# INLINE (/) #-} - recip (FloatX3# a1 a2 a3) = FloatX3# (divideFloat# 1.0# a1) - (divideFloat# 1.0# a2) - (divideFloat# 1.0# a3) - {-# INLINE recip #-} - fromRational r = case fromRational r of F# x -> FloatX3# x x x - {-# INLINE fromRational #-} - - - -instance Floating FloatX3 where - pi = FloatX3# 3.141592653589793238# 3.141592653589793238# 3.141592653589793238# - {-# INLINE pi #-} - exp (FloatX3# a1 a2 a3) = FloatX3# (expFloat# a1) - (expFloat# a2) - (expFloat# a3) - {-# INLINE exp #-} - log (FloatX3# a1 a2 a3) = FloatX3# (logFloat# a1) - (logFloat# a2) - (logFloat# a3) - {-# INLINE log #-} - sqrt (FloatX3# a1 a2 a3) = FloatX3# (sqrtFloat# a1) - (sqrtFloat# a2) - (sqrtFloat# a3) - {-# INLINE sqrt #-} - sin (FloatX3# a1 a2 a3) = FloatX3# (sinFloat# a1) - (sinFloat# a2) - (sinFloat# a3) - {-# INLINE sin #-} - cos (FloatX3# a1 a2 a3) = FloatX3# (cosFloat# a1) - (cosFloat# a2) - (cosFloat# a3) - {-# INLINE cos #-} - tan (FloatX3# a1 a2 a3) = FloatX3# (tanFloat# a1) - (tanFloat# a2) - (tanFloat# a3) - {-# INLINE tan #-} - asin (FloatX3# a1 a2 a3) = FloatX3# (asinFloat# a1) - (asinFloat# a2) - (asinFloat# a3) - {-# INLINE asin #-} - acos (FloatX3# a1 a2 a3) = FloatX3# (acosFloat# a1) - (acosFloat# a2) - (acosFloat# a3) - {-# INLINE acos #-} - atan (FloatX3# a1 a2 a3) = FloatX3# (atanFloat# a1) - (atanFloat# a2) - (atanFloat# a3) - {-# INLINE atan #-} - sinh (FloatX3# a1 a2 a3) = FloatX3# (sinFloat# a1) - (sinFloat# a2) - (sinFloat# a3) - {-# INLINE sinh #-} - cosh (FloatX3# a1 a2 a3) = FloatX3# (coshFloat# a1) - (coshFloat# a2) - (coshFloat# a3) - {-# INLINE cosh #-} - tanh (FloatX3# a1 a2 a3) = FloatX3# (tanhFloat# a1) - (tanhFloat# a2) - (tanhFloat# a3) - {-# INLINE tanh #-} - FloatX3# a1 a2 a3 ** FloatX3# b1 b2 b3 = FloatX3# (powerFloat# a1 b1) - (powerFloat# a2 b2) - (powerFloat# a3 b3) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - - - -type instance ElemRep FloatX3 = 'FloatRep -type instance ElemPrim FloatX3 = Float# -instance PrimBytes FloatX3 where - toBytes (FloatX3# a1 a2 a3) = case runRW# - ( \s0 -> case newByteArray# (SIZEOF_HSFLOAT# *# 3#) s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of - s2 -> case writeFloatArray# marr 1# a2 s2 of - s3 -> case writeFloatArray# marr 2# a3 s3 of - s4 -> unsafeFreezeByteArray# marr s4 - ) of (# _, a #) -> (# 0#, 3#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = FloatX3# - (indexFloatArray# arr off) - (indexFloatArray# arr (off +# 1#)) - (indexFloatArray# arr (off +# 2#)) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_HSFLOAT# *# 3# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSFLOAT# - {-# INLINE byteAlign #-} - elementByteSize _ = SIZEOF_HSFLOAT# - {-# INLINE elementByteSize #-} - ix 0# (FloatX3# a1 _ _) = a1 - ix 1# (FloatX3# _ a2 _) = a2 - ix 2# (FloatX3# _ _ a3) = a3 - ix _ _ = undefined - {-# INLINE ix #-} - - -instance ElementWise (Idx '[3]) Float FloatX3 where - indexOffset# (FloatX3# a1 _ _) 0# = F# a1 - indexOffset# (FloatX3# _ a2 _) 1# = F# a2 - indexOffset# (FloatX3# _ _ a3) 2# = F# a3 - indexOffset# _ _ = undefined - {-# INLINE indexOffset# #-} - - (!) (FloatX3# a1 _ _) ( 1 :! Z) = F# a1 - (!) (FloatX3# _ a2 _) ( 2 :! Z) = F# a2 - (!) (FloatX3# _ _ a3) ( 3 :! Z) = F# a3 - (!) _ ( _ :! Z) = undefined - {-# INLINE (!) #-} - - broadcast (F# x) = FloatX3# x x x - {-# INLINE broadcast #-} - - ewmap f (FloatX3# x y z) = case (f (1:!Z) (F# x), f (2:!Z) (F# y), f (3:!Z) (F# z)) of - (F# r1, F# r2, F# r3) -> FloatX3# r1 r2 r3 - {-# INLINE ewmap #-} - - ewgen f = case (f (1:!Z), f (2:!Z), f (3:!Z)) of (F# r1, F# r2, F# r3) -> FloatX3# r1 r2 r3 - {-# INLINE ewgen #-} - - ewgenA f = (\(F# r1) (F# r2) (F# r3) -> FloatX3# r1 r2 r3) - <$> f (1:!Z) <*> f (2:!Z) <*> f (3:!Z) - {-# INLINE ewgenA #-} - - ewfoldl f x0 (FloatX3# x y z) = f (3:!Z) (f (2:!Z) (f (1:!Z) x0 (F# x)) (F# y)) (F# z) - {-# INLINE ewfoldl #-} - - ewfoldr f x0 (FloatX3# x y z) = f (1:!Z) (F# x) (f (2:!Z) (F# y) (f (3:!Z) (F# z) x0)) - {-# INLINE ewfoldr #-} - - elementWise f (FloatX3# x y z) = (\(F# a) (F# b) (F# c) -> FloatX3# a b c) - <$> f (F# x) <*> f (F# y) <*> f (F# z) - {-# INLINE elementWise #-} - - indexWise f (FloatX3# x y z) = (\(F# a) (F# b) (F# c) -> FloatX3# a b c) - <$> f (1:!Z) (F# x) <*> f (2:!Z) (F# y) <*> f (3:!Z) (F# z) - {-# INLINE indexWise #-} - - update (1 :! Z) (F# q) (FloatX3# _ y z) = FloatX3# q y z - update (2 :! Z) (F# q) (FloatX3# x _ z) = FloatX3# x q z - update (3 :! Z) (F# q) (FloatX3# x y _) = FloatX3# x y q - update (_ :! Z) _ x = x - {-# INLINE update #-} diff --git a/src-base/Numeric/Array/Family/FloatX4.hs b/src-base/Numeric/Array/Family/FloatX4.hs deleted file mode 100644 --- a/src-base/Numeric/Array/Family/FloatX4.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family.FloatX4 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.FloatX4 () where - - -#include "MachDeps.h" - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Float (..), RuntimeRep (..), - isTrue#) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions - - -instance Bounded FloatX4 where - maxBound = case infty of F# x -> FloatX4# x x x x - minBound = case negate infty of F# x -> FloatX4# x x x x - -infty :: Float -infty = read "Infinity" - - -instance Show FloatX4 where - show (FloatX4# a1 a2 a3 a4) = "{ " ++ show (F# a1) - ++ ", " ++ show (F# a2) - ++ ", " ++ show (F# a3) - ++ ", " ++ show (F# a4) - ++ " }" - - - -instance Eq FloatX4 where - FloatX4# a1 a2 a3 a4 == FloatX4# b1 b2 b3 b4 = isTrue# ( (a1 `eqFloat#` b1) - `andI#` (a2 `eqFloat#` b2) - `andI#` (a3 `eqFloat#` b3) - `andI#` (a4 `eqFloat#` b4) - ) - {-# INLINE (==) #-} - FloatX4# a1 a2 a3 a4 /= FloatX4# b1 b2 b3 b4 = isTrue# ( (a1 `neFloat#` b1) - `orI#` (a2 `neFloat#` b2) - `orI#` (a3 `neFloat#` b3) - `orI#` (a4 `neFloat#` b4) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord FloatX4 where - FloatX4# a1 a2 a3 a4 > FloatX4# b1 b2 b3 b4 = isTrue# ( (a1 `gtFloat#` b1) - `andI#` (a2 `gtFloat#` b2) - `andI#` (a3 `gtFloat#` b3) - `andI#` (a4 `gtFloat#` b4) - ) - {-# INLINE (>) #-} - FloatX4# a1 a2 a3 a4 < FloatX4# b1 b2 b3 b4 = isTrue# ( (a1 `ltFloat#` b1) - `andI#` (a2 `ltFloat#` b2) - `andI#` (a3 `ltFloat#` b3) - `andI#` (a4 `ltFloat#` b4) - ) - {-# INLINE (<) #-} - FloatX4# a1 a2 a3 a4 >= FloatX4# b1 b2 b3 b4 = isTrue# ( (a1 `geFloat#` b1) - `andI#` (a2 `geFloat#` b2) - `andI#` (a3 `geFloat#` b3) - `andI#` (a4 `geFloat#` b4) - ) - {-# INLINE (>=) #-} - FloatX4# a1 a2 a3 a4 <= FloatX4# b1 b2 b3 b4 = isTrue# ( (a1 `leFloat#` b1) - `andI#` (a2 `leFloat#` b2) - `andI#` (a3 `leFloat#` b3) - `andI#` (a4 `leFloat#` b4) - ) - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) - | isTrue# (a1 `gtFloat#` b1) = GT - | isTrue# (a1 `ltFloat#` b1) = LT - | isTrue# (a2 `gtFloat#` b2) = GT - | isTrue# (a2 `ltFloat#` b2) = LT - | isTrue# (a3 `gtFloat#` b3) = GT - | isTrue# (a3 `ltFloat#` b3) = LT - | isTrue# (a4 `gtFloat#` b4) = GT - | isTrue# (a4 `ltFloat#` b4) = LT - | otherwise = EQ - {-# INLINE compare #-} - -- | Element-wise minimum - min (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) = - FloatX4# (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) - (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) - (if isTrue# (a3 `gtFloat#` b3) then b3 else a3) - (if isTrue# (a4 `gtFloat#` b4) then b4 else a4) - {-# INLINE min #-} - -- | Element-wise maximum - max (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) = - FloatX4# (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) - (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) - (if isTrue# (a3 `gtFloat#` b3) then a3 else b3) - (if isTrue# (a4 `gtFloat#` b4) then a4 else b4) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num FloatX4 where - FloatX4# a1 a2 a3 a4 + FloatX4# b1 b2 b3 b4 - = FloatX4# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) (plusFloat# a4 b4) - {-# INLINE (+) #-} - FloatX4# a1 a2 a3 a4 - FloatX4# b1 b2 b3 b4 - = FloatX4# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) (minusFloat# a4 b4) - {-# INLINE (-) #-} - FloatX4# a1 a2 a3 a4 * FloatX4# b1 b2 b3 b4 - = FloatX4# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) (timesFloat# a4 b4) - {-# INLINE (*) #-} - negate (FloatX4# a1 a2 a3 a4) - = FloatX4# (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) (negateFloat# a4) - {-# INLINE negate #-} - abs (FloatX4# a1 a2 a3 a4) - = FloatX4# (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) - (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) - (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) - (if isTrue# (a4 `geFloat#` 0.0#) then a4 else negateFloat# a4) - {-# INLINE abs #-} - signum (FloatX4# a1 a2 a3 a4) - = FloatX4# (if isTrue# (a1 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a2 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a3 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a4 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a4 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of F# x -> FloatX4# x x x x - {-# INLINE fromInteger #-} - - - -instance Fractional FloatX4 where - FloatX4# a1 a2 a3 a4 / FloatX4# b1 b2 b3 b4 = FloatX4# (divideFloat# a1 b1) - (divideFloat# a2 b2) - (divideFloat# a3 b3) - (divideFloat# a4 b4) - {-# INLINE (/) #-} - recip (FloatX4# a1 a2 a3 a4) = FloatX4# (divideFloat# 1.0# a1) - (divideFloat# 1.0# a2) - (divideFloat# 1.0# a3) - (divideFloat# 1.0# a4) - {-# INLINE recip #-} - fromRational r = case fromRational r of F# x -> FloatX4# x x x x - {-# INLINE fromRational #-} - - - -instance Floating FloatX4 where - pi = FloatX4# 3.141592653589793238# 3.141592653589793238# 3.141592653589793238# 3.141592653589793238# - {-# INLINE pi #-} - exp (FloatX4# a1 a2 a3 a4) = FloatX4# (expFloat# a1) - (expFloat# a2) - (expFloat# a3) - (expFloat# a4) - {-# INLINE exp #-} - log (FloatX4# a1 a2 a3 a4) = FloatX4# (logFloat# a1) - (logFloat# a2) - (logFloat# a3) - (logFloat# a4) - {-# INLINE log #-} - sqrt (FloatX4# a1 a2 a3 a4) = FloatX4# (sqrtFloat# a1) - (sqrtFloat# a2) - (sqrtFloat# a3) - (sqrtFloat# a4) - {-# INLINE sqrt #-} - sin (FloatX4# a1 a2 a3 a4) = FloatX4# (sinFloat# a1) - (sinFloat# a2) - (sinFloat# a3) - (sinFloat# a4) - {-# INLINE sin #-} - cos (FloatX4# a1 a2 a3 a4) = FloatX4# (cosFloat# a1) - (cosFloat# a2) - (cosFloat# a3) - (cosFloat# a4) - {-# INLINE cos #-} - tan (FloatX4# a1 a2 a3 a4) = FloatX4# (tanFloat# a1) - (tanFloat# a2) - (tanFloat# a3) - (tanFloat# a4) - {-# INLINE tan #-} - asin (FloatX4# a1 a2 a3 a4) = FloatX4# (asinFloat# a1) - (asinFloat# a2) - (asinFloat# a3) - (asinFloat# a4) - {-# INLINE asin #-} - acos (FloatX4# a1 a2 a3 a4) = FloatX4# (acosFloat# a1) - (acosFloat# a2) - (acosFloat# a3) - (acosFloat# a4) - {-# INLINE acos #-} - atan (FloatX4# a1 a2 a3 a4) = FloatX4# (atanFloat# a1) - (atanFloat# a2) - (atanFloat# a3) - (atanFloat# a4) - {-# INLINE atan #-} - sinh (FloatX4# a1 a2 a3 a4) = FloatX4# (sinFloat# a1) - (sinFloat# a2) - (sinFloat# a3) - (sinFloat# a4) - {-# INLINE sinh #-} - cosh (FloatX4# a1 a2 a3 a4) = FloatX4# (coshFloat# a1) - (coshFloat# a2) - (coshFloat# a3) - (coshFloat# a4) - {-# INLINE cosh #-} - tanh (FloatX4# a1 a2 a3 a4) = FloatX4# (tanhFloat# a1) - (tanhFloat# a2) - (tanhFloat# a3) - (tanhFloat# a4) - {-# INLINE tanh #-} - FloatX4# a1 a2 a3 a4 ** FloatX4# b1 b2 b3 b4 = FloatX4# (powerFloat# a1 b1) - (powerFloat# a2 b2) - (powerFloat# a3 b3) - (powerFloat# a4 b4) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - - - -type instance ElemRep FloatX4 = 'FloatRep -type instance ElemPrim FloatX4 = Float# -instance PrimBytes FloatX4 where - toBytes (FloatX4# a1 a2 a3 a4) = case runRW# - ( \s0 -> case newByteArray# (SIZEOF_HSFLOAT# *# 3#) s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of - s2 -> case writeFloatArray# marr 1# a2 s2 of - s3 -> case writeFloatArray# marr 2# a3 s3 of - s4 -> case writeFloatArray# marr 3# a4 s4 of - s5 -> unsafeFreezeByteArray# marr s5 - ) of (# _, a #) -> (# 0#, 4#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = FloatX4# - (indexFloatArray# arr off) - (indexFloatArray# arr (off +# 1#)) - (indexFloatArray# arr (off +# 2#)) - (indexFloatArray# arr (off +# 3#)) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_HSFLOAT# *# 4# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSFLOAT# - {-# INLINE byteAlign #-} - elementByteSize _ = SIZEOF_HSFLOAT# - {-# INLINE elementByteSize #-} - ix 0# (FloatX4# a1 _ _ _) = a1 - ix 1# (FloatX4# _ a2 _ _) = a2 - ix 2# (FloatX4# _ _ a3 _) = a3 - ix 3# (FloatX4# _ _ _ a4) = a4 - ix _ _ = undefined - {-# INLINE ix #-} - - -instance ElementWise (Idx '[4]) Float FloatX4 where - indexOffset# (FloatX4# a1 _ _ _) 0# = F# a1 - indexOffset# (FloatX4# _ a2 _ _) 1# = F# a2 - indexOffset# (FloatX4# _ _ a3 _) 2# = F# a3 - indexOffset# (FloatX4# _ _ _ a4) 3# = F# a4 - indexOffset# _ _ = undefined - {-# INLINE indexOffset# #-} - - (!) (FloatX4# a1 _ _ _) ( 1 :! Z) = F# a1 - (!) (FloatX4# _ a2 _ _) ( 2 :! Z) = F# a2 - (!) (FloatX4# _ _ a3 _) ( 3 :! Z) = F# a3 - (!) (FloatX4# _ _ _ a4) ( 4 :! Z) = F# a4 - (!) _ ( _ :! Z) = undefined - {-# INLINE (!) #-} - - broadcast (F# x) = FloatX4# x x x x - {-# INLINE broadcast #-} - - ewmap f (FloatX4# x y z w) = case (f (1:!Z) (F# x), f (2:!Z) (F# y), f (3:!Z) (F# z), f (3:!Z) (F# w)) of - (F# r1, F# r2, F# r3, F# r4) -> FloatX4# r1 r2 r3 r4 - {-# INLINE ewmap #-} - - ewgen f = case (f (1:!Z), f (2:!Z), f (3:!Z), f (4:!Z)) of (F# r1, F# r2, F# r3, F# r4) -> FloatX4# r1 r2 r3 r4 - {-# INLINE ewgen #-} - - ewgenA f = (\(F# a) (F# b) (F# c) (F# d) -> FloatX4# a b c d) - <$> f (1:!Z) <*> f (2:!Z) <*> f (3:!Z) <*> f (4:!Z) - {-# INLINE ewgenA #-} - - ewfoldl f x0 (FloatX4# x y z w) = f (4:!Z) (f (3:!Z) (f (2:!Z) (f (1:!Z) x0 (F# x)) (F# y)) (F# z)) (F# w) - {-# INLINE ewfoldl #-} - - ewfoldr f x0 (FloatX4# x y z w) = f (1:!Z) (F# x) (f (2:!Z) (F# y) (f (3:!Z) (F# z) (f (4:!Z) (F# w) x0))) - {-# INLINE ewfoldr #-} - - elementWise f (FloatX4# x y z w) = (\(F# a) (F# b) (F# c) (F# d) -> FloatX4# a b c d) - <$> f (F# x) <*> f (F# y) <*> f (F# z) <*> f (F# w) - {-# INLINE elementWise #-} - - indexWise f (FloatX4# x y z w) = (\(F# a) (F# b) (F# c) (F# d) -> FloatX4# a b c d) - <$> f (1:!Z) (F# x) <*> f (2:!Z) (F# y) <*> f (3:!Z) (F# z) <*> f (4:!Z) (F# w) - {-# INLINE indexWise #-} - - update (1 :! Z) (F# q) (FloatX4# _ y z w) = FloatX4# q y z w - update (2 :! Z) (F# q) (FloatX4# x _ z w) = FloatX4# x q z w - update (3 :! Z) (F# q) (FloatX4# x y _ w) = FloatX4# x y q w - update (4 :! Z) (F# q) (FloatX4# x y z _) = FloatX4# x y z q - update (_ :! Z) _ x = x - {-# INLINE update #-} diff --git a/src-base/Numeric/DataFrame/Contraction.hs b/src-base/Numeric/DataFrame/Contraction.hs deleted file mode 100644 --- a/src-base/Numeric/DataFrame/Contraction.hs +++ /dev/null @@ -1,576 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE InstanceSigs #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Contraction --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- This modules provides generalization of a matrix product: --- tensor-like contraction. --- For matrices and vectors this is a normal matrix*matrix or vector*matrix or matrix*vector product, --- for larger dimensions it calculates the scalar product of "adjacent" dimesnions of a tensor. --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Contraction - ( Contraction (..), (%*) - ) where - -#include "MachDeps.h" - -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import Data.Type.Equality ((:~:) (..)) -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), Type, - Word (..), isTrue#) -import Unsafe.Coerce (unsafeCoerce) - -import Numeric.Array.Family -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions -import Numeric.TypeLits - - - -class ConcatList as bs asbs - => Contraction (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) - | asbs as -> bs, asbs bs -> as, as bs -> asbs where - -- | Generalization of a matrix product: take scalar product over one dimension - -- and, thus, concatenate other dimesnions - contract :: ( KnownDim m - , PrimBytes (DataFrame t (as +: m)) - , PrimBytes (DataFrame t (m :+ bs)) - , PrimBytes (DataFrame t asbs) - ) - => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs - --- | Tensor contraction. --- In particular: --- 1. matrix-matrix product --- 2. matrix-vector or vector-matrix product --- 3. dot product of two vectors. -(%*) :: ( ConcatList as bs (as ++ bs) - , Contraction t as bs asbs - , KnownDim m - , PrimBytes (DataFrame t (as +: m)) - , PrimBytes (DataFrame t (m :+ bs)) - , PrimBytes (DataFrame t (as ++ bs)) - ) => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t (as ++ bs) -(%*) = contract -{-# INLINE (%*) #-} -infixl 7 %* - - --------------------------------------------------------------------------------- - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Float as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Float (m : bs) ) :~: 'FloatRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Float (m : bs) ) :~: Float# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Float (as +: m)) :~: 'FloatRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Float (as +: m)) :~: Float# - = prodF n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Double as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Double (m : bs) ) :~: 'DoubleRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Double (m : bs) ) :~: Double# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Double (as +: m)) :~: 'DoubleRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Double (as +: m)) :~: Double# - = prodD n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Int as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int (m : bs) ) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int (m : bs) ) :~: Int# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int (as +: m)) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int (as +: m)) :~: Int# - = prodI n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Int8 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int8 (m : bs) ) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int8 (m : bs) ) :~: Int# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int8 (as +: m)) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int8 (as +: m)) :~: Int# - = prodI8 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Int16 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int16 (m : bs) ) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int16 (m : bs) ) :~: Int# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int16 (as +: m)) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int16 (as +: m)) :~: Int# - = prodI16 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Int32 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int32 (m : bs) ) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int32 (m : bs) ) :~: Int# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int32 (as +: m)) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int32 (as +: m)) :~: Int# - = prodI32 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Int64 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) -#if WORD_SIZE_IN_BITS < 64 - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int64 (m : bs) ) :~: 'Int64Rep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int64 (m : bs) ) :~: Int64# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int64 (as +: m)) :~: 'Int64Rep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int64 (as +: m)) :~: Int64# -#else - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int64 (m : bs) ) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int64 (m : bs) ) :~: Int# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Int64 (as +: m)) :~: 'IntRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Int64 (as +: m)) :~: Int# -#endif - = prodI64 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - - - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Word as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word (m : bs) ) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word (m : bs) ) :~: Word# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word (as +: m)) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word (as +: m)) :~: Word# - = prodW n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Word8 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word8 (m : bs) ) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word8 (m : bs) ) :~: Word# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word8 (as +: m)) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word8 (as +: m)) :~: Word# - = prodW8 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Word16 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word16 (m : bs) ) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word16 (m : bs) ) :~: Word# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word16 (as +: m)) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word16 (as +: m)) :~: Word# - = prodW16 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Word32 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word32 (m : bs) ) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word32 (m : bs) ) :~: Word# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word32 (as +: m)) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word32 (as +: m)) :~: Word# - = prodW32 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - -instance ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - ) => Contraction Word64 as bs asbs where - contract x y - | (pm :: Proxy m) <- getM y - , I# m <- intNatVal pm - , I# n <- totalDim (Proxy @as) - , I# k <- totalDim (Proxy @bs) -#if WORD_SIZE_IN_BITS < 64 - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word64 (m : bs) ) :~: 'Word64Rep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word64 (m : bs) ) :~: Word64# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word64 (as +: m)) :~: 'Word64Rep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word64 (as +: m)) :~: Word64# -#else - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word64 (m : bs) ) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word64 (m : bs) ) :~: Word# - , Refl <- unsafeCoerce Refl :: ElemRep (Array Word64 (as +: m)) :~: 'WordRep - , Refl <- unsafeCoerce Refl :: ElemPrim (Array Word64 (as +: m)) :~: Word# -#endif - = prodW64 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - - -prodF :: (PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Float#, ElemRep a ~ 'FloatRep - , ElemPrim b ~ Float#, ElemRep b ~ 'FloatRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodF n m k x y = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r `plusFloat#` timesFloat# (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeFloatArray# marr (i +# n *# j) (loop' i j 0# 0.0#) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodF #-} - -prodD :: (PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Double#, ElemRep a ~ 'DoubleRep - , ElemPrim b ~ Double#, ElemRep b ~ 'DoubleRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodD n m k x y= case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r +## (*##) (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeDoubleArray# marr (i +# n *# j) (loop' i j 0# 0.0##) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodD #-} - -prodI :: (PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Int#, ElemRep a ~ 'IntRep - , ElemPrim b ~ Int#, ElemRep b ~ 'IntRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodI n m k x y= case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r +# (*#) (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeIntArray# marr (i +# n *# j) (loop' i j 0# 0#) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodI #-} - -prodI8 :: (PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Int#, ElemRep a ~ 'IntRep - , ElemPrim b ~ Int#, ElemRep b ~ 'IntRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodI8 n m k x y= case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r +# (*#) (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeInt8Array# marr (i +# n *# j) (loop' i j 0# 0#) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodI8 #-} - - -prodI16 :: ( PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Int#, ElemRep a ~ 'IntRep - , ElemPrim b ~ Int#, ElemRep b ~ 'IntRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodI16 n m k x y= case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r +# (*#) (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeInt16Array# marr (i +# n *# j) (loop' i j 0# 0#) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodI16 #-} - - -prodI32 :: ( PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Int#, ElemRep a ~ 'IntRep - , ElemPrim b ~ Int#, ElemRep b ~ 'IntRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodI32 n m k x y= case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r +# (*#) (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeInt32Array# marr (i +# n *# j) (loop' i j 0# 0#) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodI32 #-} - - -prodI64 :: ( PrimBytes a, PrimBytes b, PrimBytes c -#if WORD_SIZE_IN_BITS < 64 - , ElemPrim a ~ Int64#, ElemRep a ~ 'Int64Rep - , ElemPrim b ~ Int64#, ElemRep b ~ 'Int64Rep -#else - , ElemPrim a ~ Int#, ElemRep a ~ 'IntRep - , ElemPrim b ~ Int#, ElemRep b ~ 'IntRep -#endif - ) => Int# -> Int# -> Int# -> a -> b -> c -#if WORD_SIZE_IN_BITS < 64 -prodI64 = undefined -#else -prodI64 n m k x y= case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r +# (*#) (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeInt64Array# marr (i +# n *# j) (loop' i j 0# 0#) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodI64 #-} -#endif - -prodW :: ( PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Word#, ElemRep a ~ 'WordRep - , ElemPrim b ~ Word#, ElemRep b ~ 'WordRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodW n m k x y = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r `plusWord#` timesWord# (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeWordArray# marr (i +# n *# j) (loop' i j 0# 0##) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodW #-} - -prodW8 :: ( PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Word#, ElemRep a ~ 'WordRep - , ElemPrim b ~ Word#, ElemRep b ~ 'WordRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodW8 n m k x y = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r `plusWord#` timesWord# (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeWord8Array# marr (i +# n *# j) (loop' i j 0# 0##) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodW8 #-} - - -prodW16 :: ( PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Word#, ElemRep a ~ 'WordRep - , ElemPrim b ~ Word#, ElemRep b ~ 'WordRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodW16 n m k x y = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r `plusWord#` timesWord# (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeWord16Array# marr (i +# n *# j) (loop' i j 0# 0##) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodW16 #-} - -prodW32 :: ( PrimBytes a, PrimBytes b, PrimBytes c - , ElemPrim a ~ Word#, ElemRep a ~ 'WordRep - , ElemPrim b ~ Word#, ElemRep b ~ 'WordRep - ) => Int# -> Int# -> Int# -> a -> b -> c -prodW32 n m k x y = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r `plusWord#` timesWord# (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeWord32Array# marr (i +# n *# j) (loop' i j 0# 0##) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodW32 #-} - -prodW64 :: ( PrimBytes a, PrimBytes b, PrimBytes c -#if WORD_SIZE_IN_BITS < 64 - , ElemPrim a ~ Word64#, ElemRep a ~ 'Word64Rep - , ElemPrim b ~ Word64#, ElemRep b ~ 'Word64Rep -#else - , ElemPrim a ~ Word#, ElemRep a ~ 'WordRep - , ElemPrim b ~ Word#, ElemRep b ~ 'WordRep -#endif - ) => Int# -> Int# -> Int# -> a -> b -> c -#if WORD_SIZE_IN_BITS < 64 -prodW64 = undefined -#else -prodW64 n m k x y = case runRW# - ( \s0 -> case newByteArray# bs s0 of - (# s1, marr #) -> - let loop' i j l r | isTrue# (l ==# m) = r - | otherwise = loop' i j (l +# 1#) (r `plusWord#` timesWord# (ix (i +# n *# l) x) - (ix (l +# m *# j) y)) - in case loop2# n k - (\i j s' -> writeWord64Array# marr (i +# n *# j) (loop' i j 0# 0##) s' - ) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, n *# k, r #) - where - bs = n *# k *# elementByteSize x -{-# INLINE prodW64 #-} -#endif - --- | Do something in a loop for int i from 0 to n-1 and j from 0 to m-1 -loop2# :: Int# -> Int# -> (Int# -> Int#-> State# s -> State# s) -> State# s -> State# s -loop2# n m f = loop' 0# 0# - where - loop' i j s | isTrue# (j ==# m) = s - | isTrue# (i ==# n) = loop' 0# (j +# 1#) s - | otherwise = case f i j s of s1 -> loop' (i +# 1#) j s1 -{-# INLINE loop2# #-} diff --git a/src-base/Numeric/DataFrame/Inference.hs b/src-base/Numeric/DataFrame/Inference.hs deleted file mode 100644 --- a/src-base/Numeric/DataFrame/Inference.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Inference --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- The module provides data types and functions to infer typeclasses at runtime. --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Inference - ( PrimBytesEvidence, inferPrimBytes - , ElementWiseEvidence, inferElementWise - , NumericFrameEvidence, inferNumericFrame - ) where - -import Numeric.Array -import Numeric.Array.ElementWise -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions - - --- | Evidence for PrimBytes class -type PrimBytesEvidence t (ds :: [Nat]) - = Evidence (PrimBytes (DataFrame t ds)) - --- | Evidence for ElementWise class -type ElementWiseEvidence t (ds :: [Nat]) - = Evidence (ElementWise (Idx ds) t (DataFrame t ds)) - --- | Allow all common operations on available data frames -type NumericFrameEvidence t (ds :: [Nat]) - = Evidence ( NumericFrame t ds) - -inferPrimBytes :: forall t (ds :: [Nat]) - . ( ArrayInstanceInference t ds - , Dimensions ds - ) - => PrimBytesEvidence t ds -inferPrimBytes = case getArrayInstance @t @ds of - AIScalar -> case elemTypeInstance @t of - ETFloat -> Evidence - ETDouble -> Evidence - ETInt -> Evidence - ETInt8 -> Evidence - ETInt16 -> Evidence - ETInt32 -> Evidence - ETInt64 -> Evidence - ETWord -> Evidence - ETWord8 -> Evidence - ETWord16 -> Evidence - ETWord32 -> Evidence - ETWord64 -> Evidence - AIArrayF -> Evidence - AIArrayD -> Evidence - AIArrayI -> Evidence - AIArrayI8 -> Evidence - AIArrayI16 -> Evidence - AIArrayI32 -> Evidence - AIArrayI64 -> Evidence - AIArrayW -> Evidence - AIArrayW8 -> Evidence - AIArrayW16 -> Evidence - AIArrayW32 -> Evidence - AIArrayW64 -> Evidence - AIFloatX2 -> Evidence - AIFloatX3 -> Evidence - AIFloatX4 -> Evidence - AIDoubleX2 -> Evidence - AIDoubleX3 -> Evidence - AIDoubleX4 -> Evidence - -inferElementWise :: forall t (ds :: [Nat]) - . ( ArrayInstanceInference t ds - , Dimensions ds - ) - => ElementWiseEvidence t ds -inferElementWise = case getArrayInstance @t @ds of - AIScalar -> Evidence - AIArrayF -> Evidence - AIArrayD -> Evidence - AIArrayI -> Evidence - AIArrayI8 -> Evidence - AIArrayI16 -> Evidence - AIArrayI32 -> Evidence - AIArrayI64 -> Evidence - AIArrayW -> Evidence - AIArrayW8 -> Evidence - AIArrayW16 -> Evidence - AIArrayW32 -> Evidence - AIArrayW64 -> Evidence - AIFloatX2 -> Evidence - AIFloatX3 -> Evidence - AIFloatX4 -> Evidence - AIDoubleX2 -> Evidence - AIDoubleX3 -> Evidence - AIDoubleX4 -> Evidence - - -inferNumericFrame :: forall t (ds :: [Nat]) - . ( ArrayInstanceInference t ds - , Dimensions ds - ) - => NumericFrameEvidence t ds -inferNumericFrame - | Evidence <- inferDimKnownDims @ds +!+ inferDimFiniteList @ds - = case getArrayInstance @t @ds of - AIFloatX2 -> Evidence - AIFloatX3 -> Evidence - AIFloatX4 -> Evidence - AIDoubleX2 -> Evidence - AIDoubleX3 -> Evidence - AIDoubleX4 -> Evidence - AIScalar -> case elemTypeInstance @t of - ETFloat -> Evidence - ETDouble -> Evidence - ETInt -> Evidence - ETInt8 -> Evidence - ETInt16 -> Evidence - ETInt32 -> Evidence - ETInt64 -> Evidence - ETWord -> Evidence - ETWord8 -> Evidence - ETWord16 -> Evidence - ETWord32 -> Evidence - ETWord64 -> Evidence - AIArrayF -> Evidence - AIArrayD -> Evidence - AIArrayI -> Evidence - AIArrayI8 -> Evidence - AIArrayI16 -> Evidence - AIArrayI32 -> Evidence - AIArrayI64 -> Evidence - AIArrayW -> Evidence - AIArrayW8 -> Evidence - AIArrayW16 -> Evidence - AIArrayW32 -> Evidence - AIArrayW64 -> Evidence diff --git a/src-base/Numeric/DataFrame/Mutable.hs b/src-base/Numeric/DataFrame/Mutable.hs deleted file mode 100644 --- a/src-base/Numeric/DataFrame/Mutable.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Mutable --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- Interfrace to perform primitive stateful operations on mutable frames. --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Mutable - ( MutableFrame (..), MDataFrame () - , newDataFrame#, copyDataFrame#, copyMDataFrame#, unsafeFreezeDataFrame# - , freezeDataFrame#, thawDataFrame# - , writeDataFrame#, readDataFrame# - ) where - - -import GHC.Int (Int16 (..), Int32 (..), Int64 (..), - Int8 (..)) -import GHC.Prim -import GHC.Types (Double (..), Float (..), Int (..), - Word (..)) -import GHC.Word (Word16 (..), Word32 (..), Word64 (..), - Word8 (..)) - -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions -import Numeric.TypeLits - - --- | Mutable DataFrame type -data MDataFrame s t (ns :: [Nat]) = MDataFrame# Int# Int# (MutableByteArray# s) - --- | Create a new mutable DataFrame. -newDataFrame# :: forall t (ns :: [Nat]) s - . ( PrimBytes t, Dimensions ns) - => State# s -> (# State# s, MDataFrame s t ns #) -newDataFrame# s0 - | elS <- elementByteSize (undefined :: t) - , I# n <- totalDim (Proxy @ns) - , (# s1, mba #) <- newByteArray# (n *# elS) s0 - = (# s1, MDataFrame# 0# n mba #) -{-# INLINE newDataFrame# #-} - --- | Copy one DataFrame into another mutable DataFrame at specified position. -copyDataFrame# :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) s - . ( PrimBytes (DataFrame t (as +: b')) - , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) - ) - => DataFrame t (as +: b') -> Idx (b :+ bs) -> MDataFrame s t asbs -> State# s -> (# State# s, () #) -copyDataFrame# df ei (MDataFrame# offM _ arrM) s - | (# offA, lenA, arrA #) <- toBytes df - , elS <- elementByteSize df - , I# i <- fromEnum ei - = (# copyByteArray# arrA (offA *# elS) arrM ((offM +# i) *# elS) (lenA *# elS) s, () #) -{-# INLINE copyDataFrame# #-} - --- | Copy one mutable DataFrame into another mutable DataFrame at specified position. -copyMDataFrame# :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) s - . ( PrimBytes t - , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) - ) - => MDataFrame s t (as +: b') -> Idx (b :+ bs) -> MDataFrame s t asbs -> State# s -> (# State# s, () #) -copyMDataFrame# (MDataFrame# offA lenA arrA) ei (MDataFrame# offM _ arrM) s - | elS <- elementByteSize (undefined :: t) - , I# i <- fromEnum ei - = (# copyMutableByteArray# arrA (offA *# elS) arrM ((offM +# i) *# elS) (lenA *# elS) s, () #) -{-# INLINE copyMDataFrame# #-} - --- | Make a mutable DataFrame immutable, without copying. -unsafeFreezeDataFrame# :: forall t (ns :: [Nat]) s - . PrimBytes (DataFrame t ns) - => MDataFrame s t ns -> State# s -> (# State# s, DataFrame t ns #) -unsafeFreezeDataFrame# (MDataFrame# offM lenM arrM) s1 - | (# s2, arrA #) <- unsafeFreezeByteArray# arrM s1 - = (# s2, fromBytes (# offM, lenM, arrA #) #) -{-# INLINE unsafeFreezeDataFrame# #-} - --- | Copy content of a mutable DataFrame into a new immutable DataFrame. -freezeDataFrame# :: forall t (ns :: [Nat]) s - . PrimBytes (DataFrame t ns) - => MDataFrame s t ns -> State# s -> (# State# s, DataFrame t ns #) -freezeDataFrame# (MDataFrame# offM n arrM) s0 - | elS <- elementByteSize (undefined :: DataFrame t ns) - , (# s1, mba #) <- newByteArray# (n *# elS) s0 - , s2 <- copyMutableByteArray# arrM (offM *# elS) mba 0# (n *# elS) s1 - , (# s3, arrA #) <- unsafeFreezeByteArray# mba s2 - = (# s3, fromBytes (# 0#, n, arrA #) #) -{-# INLINE freezeDataFrame# #-} - --- | Create a new mutable DataFrame and copy content of immutable one in there. -thawDataFrame# :: forall t (ns :: [Nat]) s - . PrimBytes (DataFrame t ns) - => DataFrame t ns -> State# s -> (# State# s, MDataFrame s t ns #) -thawDataFrame# df s0 - | elS <- elementByteSize (undefined :: DataFrame t ns) - , (# offA, n, arrA #) <- toBytes df - , (# s1, arrM #) <- newByteArray# (n *# elS) s0 - , s2 <- copyByteArray# arrA (offA *# elS) arrM 0# (n *# elS) s1 - = (# s2, MDataFrame# 0# n arrM #) -{-# INLINE thawDataFrame# #-} - --- | Write a single element at the specified index -writeDataFrame# :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => MDataFrame s t ns -> Idx ns -> t -> State# s -> (# State# s, () #) -writeDataFrame# mdf ei x s | I# i <- fromEnum ei = (# writeDataFrameOff# mdf i x s, () #) -{-# INLINE writeDataFrame# #-} - --- | Read a single element at the specified index -readDataFrame# :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => MDataFrame s t ns -> Idx ns -> State# s -> (# State# s, t #) -readDataFrame# mdf ei | I# i <- fromEnum ei = readDataFrameOff# mdf i -{-# INLINE readDataFrame# #-} - -class MutableFrame t (ns :: [Nat]) where - -- | Write a single element at the specified element offset - writeDataFrameOff# :: MDataFrame s t ns -> Int# -> t -> State# s -> State# s - -- | Read a single element at the specified element offset - readDataFrameOff# :: MDataFrame s t ns -> Int# -> State# s -> (# State# s, t #) - -instance MutableFrame Float (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (F# x) = writeFloatArray# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readFloatArray# arr (off +# i) s0 = (# s1, F# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Double (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (D# x) = writeDoubleArray# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readDoubleArray# arr (off +# i) s0 = (# s1, D# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (I# x) = writeIntArray# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readIntArray# arr (off +# i) s0 = (# s1, I# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int8 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (I8# x) = writeInt8Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readInt8Array# arr (off +# i) s0 = (# s1, I8# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int16 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (I16# x) = writeInt16Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readInt16Array# arr (off +# i) s0 = (# s1, I16# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int32 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (I32# x) = writeInt32Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readInt32Array# arr (off +# i) s0 = (# s1, I32# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int64 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (I64# x) = writeInt64Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readInt64Array# arr (off +# i) s0 = (# s1, I64# r #) - {-# INLINE readDataFrameOff# #-} - - -instance MutableFrame Word (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (W# x) = writeWordArray# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readWordArray# arr (off +# i) s0 = (# s1, W# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word8 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (W8# x) = writeWord8Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readWord8Array# arr (off +# i) s0 = (# s1, W8# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word16 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (W16# x) = writeWord16Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readWord16Array# arr (off +# i) s0 = (# s1, W16# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word32 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (W32# x) = writeWord32Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readWord32Array# arr (off +# i) s0 = (# s1, W32# r #) - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word64 (ns :: [Nat]) where - writeDataFrameOff# (MDataFrame# off _ arr) i (W64# x) = writeWord64Array# arr (off +# i) x - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# (MDataFrame# off _ arr) i s0 - | (# s1, r #) <- readWord64Array# arr (off +# i) s0 = (# s1, W64# r #) - {-# INLINE readDataFrameOff# #-} diff --git a/src-base/Numeric/Matrix/Mat44d.hs b/src-base/Numeric/Matrix/Mat44d.hs deleted file mode 100644 --- a/src-base/Numeric/Matrix/Mat44d.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Matrix.Mat44d () where - - -import Numeric.Matrix.Class - -notYet :: a -notYet = error "Sorry, this function is not implemented for current platform yet." - -instance HomTransform4 Double where - translate4 = notYet - {-# INLINE translate4 #-} - translate3 = notYet - {-# INLINE translate3 #-} - rotateX = notYet - {-# INLINE rotateX #-} - rotateY = notYet - {-# INLINE rotateY #-} - rotateZ = notYet - {-# INLINE rotateZ #-} - rotate = notYet - {-# INLINE rotate #-} - rotateEuler = notYet - {-# INLINE rotateEuler #-} - lookAt = notYet - {-# INLINE lookAt #-} - perspective = notYet - {-# INLINE perspective #-} - orthogonal = notYet - {-# INLINE orthogonal #-} - toHomPoint = notYet - {-# INLINE toHomPoint #-} - toHomVector = notYet - {-# INLINE toHomVector #-} - fromHom = notYet - {-# INLINE fromHom #-} - diff --git a/src-base/Numeric/Matrix/Mat44f.hs b/src-base/Numeric/Matrix/Mat44f.hs deleted file mode 100644 --- a/src-base/Numeric/Matrix/Mat44f.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Matrix.Mat44f () where - - -import Numeric.Matrix.Class - -notYet :: a -notYet = error "Sorry, this function is not implemented for current platform yet." - -instance HomTransform4 Float where - translate4 = notYet - {-# INLINE translate4 #-} - translate3 = notYet - {-# INLINE translate3 #-} - rotateX = notYet - {-# INLINE rotateX #-} - rotateY = notYet - {-# INLINE rotateY #-} - rotateZ = notYet - {-# INLINE rotateZ #-} - rotate = notYet - {-# INLINE rotate #-} - rotateEuler = notYet - {-# INLINE rotateEuler #-} - lookAt = notYet - {-# INLINE lookAt #-} - perspective = notYet - {-# INLINE perspective #-} - orthogonal = notYet - {-# INLINE orthogonal #-} - toHomPoint = notYet - {-# INLINE toHomPoint #-} - toHomVector = notYet - {-# INLINE toHomVector #-} - fromHom = notYet - {-# INLINE fromHom #-} - diff --git a/src-base/Numeric/Quaternion/QDouble.hs b/src-base/Numeric/Quaternion/QDouble.hs deleted file mode 100644 --- a/src-base/Numeric/Quaternion/QDouble.hs +++ /dev/null @@ -1,542 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Quaternion.QDouble - ( QDouble, Quater (..) - ) where - -import GHC.Exts -import Data.Coerce (coerce) - -import Numeric.Array -import Numeric.DataFrame.Type -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Scalar -import Numeric.Vector -import Numeric.Matrix -import qualified Numeric.DataFrame.ST as ST -import qualified Numeric.Dimensions.Traverse.ST as ST -import qualified Control.Monad.ST as ST - -import Numeric.Quaternion.Class - - -type QDouble = Quater Double - -instance Quaternion Double where - newtype Quater Double = QDouble DoubleX4 - {-# INLINE packQ #-} - packQ (D# x) (D# y) (D# z) (D# w) = QDouble (DoubleX4# x y z w) - {-# INLINE unpackQ #-} - unpackQ (QDouble (DoubleX4# x y z w)) = (D# x, D# y, D# z, D# w) - {-# INLINE fromVecNum #-} - fromVecNum (KnownDataFrame (DoubleX3# x y z)) (D# w) = QDouble (DoubleX4# x y z w) - {-# INLINE fromVec4 #-} - fromVec4 = coerce - {-# INLINE toVec4 #-} - toVec4 = coerce - {-# INLINE square #-} - square q = D# (qdot q) - {-# INLINE im #-} - im (QDouble (DoubleX4# x y z _)) = QDouble (DoubleX4# x y z 0.0##) - {-# INLINE re #-} - re (QDouble (DoubleX4# _ _ _ w)) = QDouble (DoubleX4# 0.0## 0.0## 0.0## w) - {-# INLINE imVec #-} - imVec (QDouble (DoubleX4# x y z _)) = KnownDataFrame (DoubleX3# x y z) - {-# INLINE taker #-} - taker (QDouble (DoubleX4# _ _ _ w)) = D# w - {-# INLINE takei #-} - takei (QDouble (DoubleX4# x _ _ _)) = D# x - {-# INLINE takej #-} - takej (QDouble (DoubleX4# _ y _ _)) = D# y - {-# INLINE takek #-} - takek (QDouble (DoubleX4# _ _ z _)) = D# z - {-# INLINE conjugate #-} - conjugate (QDouble (DoubleX4# x y z w)) = QDouble (DoubleX4# - (negateDouble# x) - (negateDouble# y) - (negateDouble# z) w) - {-# INLINE rotScale #-} - rotScale (QDouble (DoubleX4# i j k t)) - (KnownDataFrame (DoubleX3# x y z)) - = let l = t*##t -## i*##i -## j*##j -## k*##k - d = 2.0## *## ( i*##x +## j*##y +## k*##z) - t2 = t *## 2.0## - in KnownDataFrame - ( DoubleX3# - (l*##x +## d*##i +## t2 *## (z*##j -## y*##k)) - (l*##y +## d*##j +## t2 *## (x*##k -## z*##i)) - (l*##z +## d*##k +## t2 *## (y*##i -## x*##j)) - ) - {-# INLINE getRotScale #-} - getRotScale _ (KnownDataFrame (DoubleX3# 0.0## 0.0## 0.0##)) - = QDouble (DoubleX4# 0.0## 0.0## 0.0## 0.0##) - getRotScale (KnownDataFrame (DoubleX3# 0.0## 0.0## 0.0##)) _ - = case infty of D# x -> QDouble (DoubleX4# x x x x) - getRotScale a@(KnownDataFrame (DoubleX3# a1 a2 a3)) - b@(KnownDataFrame (DoubleX3# b1 b2 b3)) - = let ma = sqrtDouble# (a1*##a1 +## a2*##a2 +## a3*##a3) - mb = sqrtDouble# (b1*##b1 +## b2*##b2 +## b3*##b3) - d = a1*##b1 +## a2*##b2 +## a3*##b3 - c = sqrtDouble# (ma*##mb +## d) - ma2 = ma *## sqrtDouble# 2.0## - r = 1.0## /## (ma2 *## c) - in case cross a b of - KnownDataFrame (DoubleX3# 0.0## 0.0## 0.0##) -> - if isTrue# (d >## 0.0##) - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# (mb /## ma))) - -- Shall we move result from k to i component? - else QDouble (DoubleX4# 0.0## 0.0## (sqrtDouble# (mb /## ma)) 0.0##) - KnownDataFrame (DoubleX3# t1 t2 t3) -> QDouble - ( DoubleX4# - (t1 *## r) - (t2 *## r) - (t3 *## r) - (c /## ma2) - ) - {-# INLINE axisRotation #-} - axisRotation (KnownDataFrame (DoubleX3# 0.0## 0.0## 0.0##)) _ - = QDouble (DoubleX4# 0.0## 0.0## 0.0## 1.0##) - axisRotation (KnownDataFrame (DoubleX3# x y z)) (D# a) - = let c = cosDouble# (a *## 0.5##) - s = sinDouble# (a *## 0.5##) - /## sqrtDouble# (x*##x +## y*##y +## z*##z) - in QDouble - ( DoubleX4# - (x *## s) - (y *## s) - (z *## s) - c - ) - {-# INLINE qArg #-} - qArg (QDouble (DoubleX4# x y z w)) - = case atan2 (D# (sqrtDouble# (x*##x +## y*##y +## z*##z))) - (D# w) of - D# a -> D# (a *## 2.0##) - {-# INLINE fromMatrix33 #-} - fromMatrix33 m - = let d = - ( ix 0# m *## ( ix 4# m *## ix 8# m -## ix 5# m *## ix 7# m ) - -## ix 1# m *## ( ix 3# m *## ix 8# m -## ix 5# m *## ix 6# m ) - +## ix 2# m *## ( ix 3# m *## ix 7# m -## ix 4# m *## ix 6# m ) - ) **## 0.33333333333333333333333333333333## - in QDouble - ( DoubleX4# - (sqrtDouble# (max# 0.0## (d +## ix 0# m -## ix 4# m -## ix 8# m )) *## sign# (ix 5# m -## ix 7# m) *## 0.5##) - (sqrtDouble# (max# 0.0## (d -## ix 0# m +## ix 4# m -## ix 8# m )) *## sign# (ix 6# m -## ix 2# m) *## 0.5##) - (sqrtDouble# (max# 0.0## (d -## ix 0# m -## ix 4# m +## ix 8# m )) *## sign# (ix 1# m -## ix 3# m) *## 0.5##) - (sqrtDouble# (max# 0.0## (d +## ix 0# m +## ix 4# m +## ix 8# m )) *## 0.5##) - ) - {-# INLINE fromMatrix44 #-} - fromMatrix44 m - = let d = - ( ix 0# m *## ( ix 5# m *## ix 10# m -## ix 6# m *## ix 9# m ) - -## ix 1# m *## ( ix 4# m *## ix 10# m -## ix 6# m *## ix 8# m ) - +## ix 2# m *## ( ix 4# m *## ix 9# m -## ix 5# m *## ix 8# m ) - ) **## 0.33333333333333333333333333333333## - c = 0.5## /## ix 15# m - in QDouble - ( DoubleX4# - (sqrtDouble# (max# 0.0## (d +## ix 0# m -## ix 5# m -## ix 10# m )) *## sign# (ix 6# m -## ix 9# m) *## c) - (sqrtDouble# (max# 0.0## (d -## ix 0# m +## ix 5# m -## ix 10# m )) *## sign# (ix 8# m -## ix 2# m) *## c) - (sqrtDouble# (max# 0.0## (d -## ix 0# m -## ix 5# m +## ix 10# m )) *## sign# (ix 1# m -## ix 4# m) *## c) - (sqrtDouble# (max# 0.0## (d +## ix 0# m +## ix 5# m +## ix 10# m )) *## c) - ) - {-# INLINE toMatrix33 #-} - toMatrix33 (QDouble (DoubleX4# 0.0## 0.0## 0.0## w)) = diag (scalar (D# (w *## w))) - toMatrix33 (QDouble (DoubleX4# x' y' z' w')) = - let x = scalar (D# x') - y = scalar (D# y') - z = scalar (D# z') - w = scalar (D# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) - ST.unsafeFreezeDataFrame df - {-# INLINE toMatrix44 #-} - toMatrix44 (QDouble (DoubleX4# 0.0## 0.0## 0.0## w)) = ST.runST $ do - df <- ST.newDataFrame - ST.overDimOff_ (dim :: Dim '[4,4]) (\i -> ST.writeDataFrameOff df (I# i) 0) 0# 1# - let w2 = scalar (D# (w *## w)) - ST.writeDataFrameOff df 0 w2 - ST.writeDataFrameOff df 5 w2 - ST.writeDataFrameOff df 10 w2 - ST.writeDataFrameOff df 15 1 - ST.unsafeFreezeDataFrame df - toMatrix44 (QDouble (DoubleX4# x' y' z' w')) = - let x = scalar (D# x') - y = scalar (D# y') - z = scalar (D# z') - w = scalar (D# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 0 - ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 7 0 - ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) - ST.writeDataFrameOff df 11 0 - ST.writeDataFrameOff df 12 0 - ST.writeDataFrameOff df 13 0 - ST.writeDataFrameOff df 14 0 - ST.writeDataFrameOff df 15 1 - ST.unsafeFreezeDataFrame df - -qdot :: QDouble -> Double# -qdot (QDouble (DoubleX4# x y z w)) = (x *## x) +## - (y *## y) +## - (z *## z) +## - (w *## w) -{-# INLINE qdot #-} - -infty :: Double -infty = read "Infinity" - -max# :: Double# -> Double# -> Double# -max# a b | isTrue# (a >## b) = a - | otherwise = b -{-# INLINE max# #-} - -sign# :: Double# -> Double# -sign# a | isTrue# (a >## 0.0##) = 1.0## - | isTrue# (a <## 0.0##) = negateDouble# 1.0## - | otherwise = 0.0## -{-# INLINE sign# #-} - --------------------------------------------------------------------------- --- Num --------------------------------------------------------------------------- - -instance Num QDouble where - QDouble a + QDouble b - = QDouble (a + b) - {-# INLINE (+) #-} - QDouble a - QDouble b - = QDouble (a - b) - {-# INLINE (-) #-} - QDouble (DoubleX4# a1 a2 a3 a4) * QDouble (DoubleX4# b1 b2 b3 b4) - = QDouble - ( DoubleX4# - ((a4 *## b1) +## - (a1 *## b4) +## - (a2 *## b3) -## - (a3 *## b2) - ) - ((a4 *## b2) -## - (a1 *## b3) +## - (a2 *## b4) +## - (a3 *## b1) - ) - ((a4 *## b3) +## - (a1 *## b2) -## - (a2 *## b1) +## - (a3 *## b4) - ) - ((a4 *## b4) -## - (a1 *## b1) -## - (a2 *## b2) -## - (a3 *## b3) - ) - ) - {-# INLINE (*) #-} - negate (QDouble a) = QDouble (negate a) - {-# INLINE negate #-} - abs q = QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# (qdot q))) - {-# INLINE abs #-} - signum q@(QDouble (DoubleX4# x y z w)) - = case qdot q of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## 0.0##) - qd -> case 1.0## /## sqrtDouble# qd of - s -> QDouble - ( DoubleX4# - (x *## s) - (y *## s) - (z *## s) - (w *## s) - ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of - D# x -> QDouble (DoubleX4# 0.0## 0.0## 0.0## x) - {-# INLINE fromInteger #-} - - - --------------------------------------------------------------------------- --- Fractional --------------------------------------------------------------------------- - -instance Fractional QDouble where - {-# INLINE recip #-} - recip q@(QDouble (DoubleX4# x y z w)) = case -1.0## /## qdot q of - c -> QDouble - ( DoubleX4# - (x *## c) - (y *## c) - (z *## c) - (negateDouble# (w *## c)) - ) - {-# INLINE (/) #-} - a / b = a * recip b - {-# INLINE fromRational #-} - fromRational q = case fromRational q of - D# x -> QDouble (DoubleX4# 0.0## 0.0## 0.0## x) - --------------------------------------------------------------------------- --- Doubleing --------------------------------------------------------------------------- - -instance Floating QDouble where - {-# INLINE pi #-} - pi = QDouble (DoubleX4# 0.0## 0.0## 0.0## - 3.141592653589793##) - {-# INLINE exp #-} - exp (QDouble (DoubleX4# x y z w)) - = case (# (x *## x) +## - (y *## y) +## - (z *## z) - , expDouble# w - #) of - (# 0.0##, et #) -> QDouble (DoubleX4# 0.0## 0.0## 0.0## et) - (# mv2, et #) -> case sqrtDouble# mv2 of - mv -> case et *## sinDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (et *## cosDouble# mv) - ) - {-# INLINE log #-} - log (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> if isTrue# (w >=## 0.0##) - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (logDouble# w)) - else QDouble (DoubleX4# 3.141592653589793## 0.0## 0.0## - (logDouble# (negateDouble# w))) - mv2 -> case (# sqrtDouble# (mv2 +## (w *## w)) - , sqrtDouble# mv2 - #) of - (# mq, mv #) -> case atan2 (D# mv) (D# w) / D# mv of - D# l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (logDouble# mq) - ) - {-# INLINE sqrt #-} - sqrt (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> if isTrue# (w >=## 0.0##) - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# w)) - else QDouble (DoubleX4# (sqrtDouble# (negateDouble# w)) 0.0## 0.0## 0.0##) - mv2 -> - let mq = sqrtDouble# (mv2 +## w *## w) - l2 = sqrtDouble# mq - tq = w /## (mq *## 2.0##) - sina = sqrtDouble# (0.5## -## tq) *## l2 /## sqrtDouble# mv2 - in QDouble - ( DoubleX4# - (x *## sina) - (y *## sina) - (z *## sina) - (sqrtDouble# (0.5## +## tq) *## l2) - ) - {-# INLINE sin #-} - sin (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (sinDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case cosDouble# w *## sinhDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (sinDouble# w *## coshDouble# mv) - ) - {-# INLINE cos #-} - cos (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (cosDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case sinDouble# w *## sinhDouble# mv - /## negateDouble# mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (cosDouble# w *## coshDouble# mv) - ) - {-# INLINE tan #-} - tan (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (tanDouble# w)) - mv2 -> - let mv = sqrtDouble# mv2 - chv = coshDouble# mv - shv = sinhDouble# mv - ct = cosDouble# w - st = sinDouble# w - cq = 1.0## /## - ( (ct *## ct *## chv *## chv) - +## - (st *## st *## shv *## shv) - ) - l = chv *## shv *## cq - /## mv - in QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (ct *## st *## cq) - ) - {-# INLINE sinh #-} - sinh (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (sinhDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case coshDouble# w *## sinDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (sinhDouble# w *## cosDouble# mv) - ) - {-# INLINE cosh #-} - cosh (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (coshDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case sinhDouble# w *## sinDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (coshDouble# w *## cosDouble# mv) - ) - {-# INLINE tanh #-} - tanh (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (tanhDouble# w)) - mv2 -> - let mv = sqrtDouble# mv2 - cv = cosDouble# mv - sv = sinDouble# mv - cht = coshDouble# w - sht = sinhDouble# w - cq = 1.0## /## - ( (cht *## cht *## cv *## cv) - +## - (sht *## sht *## sv *## sv) - ) - l = cv *## sv *## cq - /## mv - in QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (cht *## sht *## cq) - ) - {-# INLINE asin #-} - asin q = -i * log (i*q + sqrt (1 - q*q)) - where - i = case signum . im $ q of - 0 -> QDouble (DoubleX4# 1.0## 0.0## 0.0## 0.0##) - i' -> i' - {-# INLINE acos #-} - acos q = pi/2 - asin q - {-# INLINE atan #-} - atan q@(QDouble (DoubleX4# _ _ _ w)) - = if square imq == 0 - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (atanDouble# w)) - else i / 2 * log ( (i + q) / (i - q) ) - where - i = signum imq - imq = im q - {-# INLINE asinh #-} - asinh q = log (q + sqrt (q*q + 1)) - {-# INLINE acosh #-} - acosh q = log (q + sqrt (q*q - 1)) - {-# INLINE atanh #-} - atanh q = 0.5 * log ((1+q)/(1-q)) - --------------------------------------------------------------------------- --- Eq --------------------------------------------------------------------------- - -instance Eq QDouble where - {-# INLINE (==) #-} - QDouble a == QDouble b = a == b - {-# INLINE (/=) #-} - QDouble a /= QDouble b = a /= b - - - --------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------- - -instance Show QDouble where - show (QDouble (DoubleX4# x y z w)) = - show (D# w) ++ ss x ++ "i" - ++ ss y ++ "j" - ++ ss z ++ "k" - where - ss a# = case D# a# of - a -> if a >= 0 then " + " ++ show a - else " - " ++ show (negate a) diff --git a/src-base/Numeric/Quaternion/QFloat.hs b/src-base/Numeric/Quaternion/QFloat.hs deleted file mode 100644 --- a/src-base/Numeric/Quaternion/QFloat.hs +++ /dev/null @@ -1,562 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Quaternion.QFloat - ( QFloat, Quater (..) - ) where - -import GHC.Exts -import Data.Coerce (coerce) - -import Numeric.Array -import Numeric.DataFrame.Type -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Scalar -import Numeric.Vector -import Numeric.Matrix -import qualified Numeric.DataFrame.ST as ST -import qualified Numeric.Dimensions.Traverse.ST as ST -import qualified Control.Monad.ST as ST - -import Numeric.Quaternion.Class - - -type QFloat = Quater Float - -instance Quaternion Float where - newtype Quater Float = QFloat FloatX4 - {-# INLINE packQ #-} - packQ (F# x) (F# y) (F# z) (F# w) = QFloat (FloatX4# x y z w) - {-# INLINE unpackQ #-} - unpackQ (QFloat (FloatX4# x y z w)) = (F# x, F# y, F# z, F# w) - {-# INLINE fromVecNum #-} - fromVecNum (KnownDataFrame (FloatX3# x y z)) (F# w) = QFloat (FloatX4# x y z w) - {-# INLINE fromVec4 #-} - fromVec4 = coerce - {-# INLINE toVec4 #-} - toVec4 = coerce - {-# INLINE square #-} - square q = F# (qdot q) - {-# INLINE im #-} - im (QFloat (FloatX4# x y z _)) = QFloat (FloatX4# x y z 0.0#) - {-# INLINE re #-} - re (QFloat (FloatX4# _ _ _ w)) = QFloat (FloatX4# 0.0# 0.0# 0.0# w) - {-# INLINE imVec #-} - imVec (QFloat (FloatX4# x y z _)) = KnownDataFrame (FloatX3# x y z) - {-# INLINE taker #-} - taker (QFloat (FloatX4# _ _ _ w)) = F# w - {-# INLINE takei #-} - takei (QFloat (FloatX4# x _ _ _)) = F# x - {-# INLINE takej #-} - takej (QFloat (FloatX4# _ y _ _)) = F# y - {-# INLINE takek #-} - takek (QFloat (FloatX4# _ _ z _)) = F# z - {-# INLINE conjugate #-} - conjugate (QFloat (FloatX4# x y z w)) = QFloat (FloatX4# - (negateFloat# x) - (negateFloat# y) - (negateFloat# z) w) - {-# INLINE rotScale #-} - rotScale (QFloat (FloatX4# i j k t)) - (KnownDataFrame (FloatX3# x y z)) - = let l = t*%t -% i*%i -% j*%j -% k*%k - d = 2.0# *% ( i*%x +% j*%y +% k*%z) - t2 = t *% 2.0# - in KnownDataFrame - ( FloatX3# - (l*%x +% d*%i +% t2 *% (z*%j -% y*%k)) - (l*%y +% d*%j +% t2 *% (x*%k -% z*%i)) - (l*%z +% d*%k +% t2 *% (y*%i -% x*%j)) - ) - {-# INLINE getRotScale #-} - getRotScale _ (KnownDataFrame (FloatX3# 0.0# 0.0# 0.0#)) - = QFloat (FloatX4# 0.0# 0.0# 0.0# 0.0#) - getRotScale (KnownDataFrame (FloatX3# 0.0# 0.0# 0.0#)) _ - = case infty of F# x -> QFloat (FloatX4# x x x x) - getRotScale a@(KnownDataFrame (FloatX3# a1 a2 a3)) - b@(KnownDataFrame (FloatX3# b1 b2 b3)) - = let ma = sqrtFloat# (a1*%a1 +% a2*%a2 +% a3*%a3) - mb = sqrtFloat# (b1*%b1 +% b2*%b2 +% b3*%b3) - d = a1*%b1 +% a2*%b2 +% a3*%b3 - c = sqrtFloat# (ma*%mb +% d) - ma2 = ma *% sqrtFloat# 2.0# - r = 1.0# /% (ma2 *% c) - in case cross a b of - KnownDataFrame (FloatX3# 0.0# 0.0# 0.0#) -> - if isTrue# (gtFloat# d 0.0#) - then QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# (mb /% ma))) - -- Shall we move result from k to i component? - else QFloat (FloatX4# 0.0# 0.0# (sqrtFloat# (mb /% ma)) 0.0#) - KnownDataFrame (FloatX3# t1 t2 t3) -> QFloat - ( FloatX4# - (t1 *% r) - (t2 *% r) - (t3 *% r) - (c /% ma2) - ) - {-# INLINE axisRotation #-} - axisRotation (KnownDataFrame (FloatX3# 0.0# 0.0# 0.0#)) _ - = QFloat (FloatX4# 0.0# 0.0# 0.0# 1.0#) - axisRotation (KnownDataFrame (FloatX3# x y z)) (F# a) - = let c = cosFloat# (a *% 0.5#) - s = sinFloat# (a *% 0.5#) - /% sqrtFloat# (x*%x +% y*%y +% z*%z) - in QFloat - ( FloatX4# - (x *% s) - (y *% s) - (z *% s) - c - ) - {-# INLINE qArg #-} - qArg (QFloat (FloatX4# x y z w)) - = case atan2 (F# (sqrtFloat# (x*%x +% y*%y +% z*%z))) - (F# w) of - F# a -> F# (a *% 2.0#) - {-# INLINE fromMatrix33 #-} - fromMatrix33 m - = let d = powerFloat# - ( ix 0# m *% ( ix 4# m *% ix 8# m -% ix 5# m *% ix 7# m ) - -% ix 1# m *% ( ix 3# m *% ix 8# m -% ix 5# m *% ix 6# m ) - +% ix 2# m *% ( ix 3# m *% ix 7# m -% ix 4# m *% ix 6# m ) - ) 0.33333333333333333333333333333333# - in QFloat - ( FloatX4# - (sqrtFloat# (max# 0.0# (d +% ix 0# m -% ix 4# m -% ix 8# m )) *% sign# (ix 5# m -% ix 7# m) *% 0.5#) - (sqrtFloat# (max# 0.0# (d -% ix 0# m +% ix 4# m -% ix 8# m )) *% sign# (ix 6# m -% ix 2# m) *% 0.5#) - (sqrtFloat# (max# 0.0# (d -% ix 0# m -% ix 4# m +% ix 8# m )) *% sign# (ix 1# m -% ix 3# m) *% 0.5#) - (sqrtFloat# (max# 0.0# (d +% ix 0# m +% ix 4# m +% ix 8# m )) *% 0.5#) - ) - {-# INLINE fromMatrix44 #-} - fromMatrix44 m - = let d = powerFloat# - ( ix 0# m *% ( ix 5# m *% ix 10# m -% ix 6# m *% ix 9# m ) - -% ix 1# m *% ( ix 4# m *% ix 10# m -% ix 6# m *% ix 8# m ) - +% ix 2# m *% ( ix 4# m *% ix 9# m -% ix 5# m *% ix 8# m ) - ) 0.33333333333333333333333333333333# - c = 0.5# /% ix 15# m - in QFloat - ( FloatX4# - (sqrtFloat# (max# 0.0# (d +% ix 0# m -% ix 5# m -% ix 10# m )) *% sign# (ix 6# m -% ix 9# m) *% c) - (sqrtFloat# (max# 0.0# (d -% ix 0# m +% ix 5# m -% ix 10# m )) *% sign# (ix 8# m -% ix 2# m) *% c) - (sqrtFloat# (max# 0.0# (d -% ix 0# m -% ix 5# m +% ix 10# m )) *% sign# (ix 1# m -% ix 4# m) *% c) - (sqrtFloat# (max# 0.0# (d +% ix 0# m +% ix 5# m +% ix 10# m )) *% c) - ) - {-# INLINE toMatrix33 #-} - toMatrix33 (QFloat (FloatX4# 0.0# 0.0# 0.0# w)) = diag (scalar (F# (w *% w))) - toMatrix33 (QFloat (FloatX4# x' y' z' w')) = - let x = scalar (F# x') - y = scalar (F# y') - z = scalar (F# z') - w = scalar (F# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) - ST.unsafeFreezeDataFrame df - {-# INLINE toMatrix44 #-} - toMatrix44 (QFloat (FloatX4# 0.0# 0.0# 0.0# w)) = ST.runST $ do - df <- ST.newDataFrame - ST.overDimOff_ (dim :: Dim '[4,4]) (\i -> ST.writeDataFrameOff df (I# i) 0) 0# 1# - let w2 = scalar (F# (w *% w)) - ST.writeDataFrameOff df 0 w2 - ST.writeDataFrameOff df 5 w2 - ST.writeDataFrameOff df 10 w2 - ST.writeDataFrameOff df 15 1 - ST.unsafeFreezeDataFrame df - toMatrix44 (QFloat (FloatX4# x' y' z' w')) = - let x = scalar (F# x') - y = scalar (F# y') - z = scalar (F# z') - w = scalar (F# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 0 - ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 7 0 - ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) - ST.writeDataFrameOff df 11 0 - ST.writeDataFrameOff df 12 0 - ST.writeDataFrameOff df 13 0 - ST.writeDataFrameOff df 14 0 - ST.writeDataFrameOff df 15 1 - ST.unsafeFreezeDataFrame df - -qdot :: QFloat -> Float# -qdot (QFloat (FloatX4# x y z w)) = (x *% x) +% - (y *% y) +% - (z *% z) +% - (w *% w) -{-# INLINE qdot #-} - -(*%) :: Float# -> Float# -> Float# -(*%) = timesFloat# -{-# INLINE (*%) #-} -infixl 7 *% - -(-%) :: Float# -> Float# -> Float# -(-%) = minusFloat# -{-# INLINE (-%) #-} -infixl 6 -% - -(+%) :: Float# -> Float# -> Float# -(+%) = plusFloat# -{-# INLINE (+%) #-} -infixl 6 +% - -(/%) :: Float# -> Float# -> Float# -(/%) = divideFloat# -{-# INLINE (/%) #-} -infixl 7 /% - -infty :: Float -infty = read "Infinity" - -max# :: Float# -> Float# -> Float# -max# a b | isTrue# (gtFloat# a b) = a - | otherwise = b -{-# INLINE max# #-} - -sign# :: Float# -> Float# -sign# a | isTrue# (gtFloat# a 0.0#) = 1.0# - | isTrue# (ltFloat# a 0.0#) = negateFloat# 1.0# - | otherwise = 0.0# -{-# INLINE sign# #-} - --------------------------------------------------------------------------- --- Num --------------------------------------------------------------------------- - -instance Num QFloat where - QFloat a + QFloat b - = QFloat (a + b) - {-# INLINE (+) #-} - QFloat a - QFloat b - = QFloat (a - b) - {-# INLINE (-) #-} - QFloat (FloatX4# a1 a2 a3 a4) * QFloat (FloatX4# b1 b2 b3 b4) - = QFloat - ( FloatX4# - ((a4 *% b1) +% - (a1 *% b4) +% - (a2 *% b3) -% - (a3 *% b2) - ) - ((a4 *% b2) -% - (a1 *% b3) +% - (a2 *% b4) +% - (a3 *% b1) - ) - ((a4 *% b3) +% - (a1 *% b2) -% - (a2 *% b1) +% - (a3 *% b4) - ) - ((a4 *% b4) -% - (a1 *% b1) -% - (a2 *% b2) -% - (a3 *% b3) - ) - ) - {-# INLINE (*) #-} - negate (QFloat a) = QFloat (negate a) - {-# INLINE negate #-} - abs q = QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# (qdot q))) - {-# INLINE abs #-} - signum q@(QFloat (FloatX4# x y z w)) - = case qdot q of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# 0.0#) - qd -> case 1.0# /% sqrtFloat# qd of - s -> QFloat - ( FloatX4# - (x *% s) - (y *% s) - (z *% s) - (w *% s) - ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of - F# x -> QFloat (FloatX4# 0.0# 0.0# 0.0# x) - {-# INLINE fromInteger #-} - - - --------------------------------------------------------------------------- --- Fractional --------------------------------------------------------------------------- - -instance Fractional QFloat where - {-# INLINE recip #-} - recip q@(QFloat (FloatX4# x y z w)) = case -1.0# /% qdot q of - c -> QFloat - ( FloatX4# - (x *% c) - (y *% c) - (z *% c) - (negateFloat# (w *% c)) - ) - {-# INLINE (/) #-} - a / b = a * recip b - {-# INLINE fromRational #-} - fromRational q = case fromRational q of - F# x -> QFloat (FloatX4# 0.0# 0.0# 0.0# x) - --------------------------------------------------------------------------- --- Floating --------------------------------------------------------------------------- - -instance Floating QFloat where - {-# INLINE pi #-} - pi = QFloat (FloatX4# 0.0# 0.0# 0.0# - 3.141592653589793#) - {-# INLINE exp #-} - exp (QFloat (FloatX4# x y z w)) - = case (# (x *% x) +% - (y *% y) +% - (z *% z) - , expFloat# w - #) of - (# 0.0#, et #) -> QFloat (FloatX4# 0.0# 0.0# 0.0# et) - (# mv2, et #) -> case sqrtFloat# mv2 of - mv -> case et *% sinFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (et *% cosFloat# mv) - ) - {-# INLINE log #-} - log (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> if isTrue# (w `geFloat#` 0.0#) - then QFloat (FloatX4# 0.0# 0.0# 0.0# (logFloat# w)) - else QFloat (FloatX4# 3.141592653589793# 0.0# 0.0# - (logFloat# (negateFloat# w))) - mv2 -> case (# sqrtFloat# (mv2 +% (w *% w)) - , sqrtFloat# mv2 - #) of - (# mq, mv #) -> case atan2 (F# mv) (F# w) / F# mv of - F# l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (logFloat# mq) - ) - {-# INLINE sqrt #-} - sqrt (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> if isTrue# (w `geFloat#` 0.0#) - then QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# w)) - else QFloat (FloatX4# (sqrtFloat# (negateFloat# w)) 0.0# 0.0# 0.0#) - mv2 -> - let mq = sqrtFloat# (mv2 +% w *% w) - l2 = sqrtFloat# mq - tq = w /% (mq *% 2.0#) - sina = sqrtFloat# (0.5# -% tq) *% l2 /% sqrtFloat# mv2 - in QFloat - ( FloatX4# - (x *% sina) - (y *% sina) - (z *% sina) - (sqrtFloat# (0.5# +% tq) *% l2) - ) - {-# INLINE sin #-} - sin (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (sinFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case cosFloat# w *% sinhFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (sinFloat# w *% coshFloat# mv) - ) - {-# INLINE cos #-} - cos (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (cosFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case sinFloat# w *% sinhFloat# mv - /% negateFloat# mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (cosFloat# w *% coshFloat# mv) - ) - {-# INLINE tan #-} - tan (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (tanFloat# w)) - mv2 -> - let mv = sqrtFloat# mv2 - chv = coshFloat# mv - shv = sinhFloat# mv - ct = cosFloat# w - st = sinFloat# w - cq = 1.0# /% - ( (ct *% ct *% chv *% chv) - +% - (st *% st *% shv *% shv) - ) - l = chv *% shv *% cq - /% mv - in QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (ct *% st *% cq) - ) - {-# INLINE sinh #-} - sinh (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (sinhFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case coshFloat# w *% sinFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (sinhFloat# w *% cosFloat# mv) - ) - {-# INLINE cosh #-} - cosh (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (coshFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case sinhFloat# w *% sinFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (coshFloat# w *% cosFloat# mv) - ) - {-# INLINE tanh #-} - tanh (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (tanhFloat# w)) - mv2 -> - let mv = sqrtFloat# mv2 - cv = cosFloat# mv - sv = sinFloat# mv - cht = coshFloat# w - sht = sinhFloat# w - cq = 1.0# /% - ( (cht *% cht *% cv *% cv) - +% - (sht *% sht *% sv *% sv) - ) - l = cv *% sv *% cq - /% mv - in QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (cht *% sht *% cq) - ) - {-# INLINE asin #-} - asin q = -i * log (i*q + sqrt (1 - q*q)) - where - i = case signum . im $ q of - 0 -> QFloat (FloatX4# 1.0# 0.0# 0.0# 0.0#) - i' -> i' - {-# INLINE acos #-} - acos q = pi/2 - asin q - {-# INLINE atan #-} - atan q@(QFloat (FloatX4# _ _ _ w)) - = if square imq == 0 - then QFloat (FloatX4# 0.0# 0.0# 0.0# (atanFloat# w)) - else i / 2 * log ( (i + q) / (i - q) ) - where - i = signum imq - imq = im q - {-# INLINE asinh #-} - asinh q = log (q + sqrt (q*q + 1)) - {-# INLINE acosh #-} - acosh q = log (q + sqrt (q*q - 1)) - {-# INLINE atanh #-} - atanh q = 0.5 * log ((1+q)/(1-q)) - --------------------------------------------------------------------------- --- Eq --------------------------------------------------------------------------- - -instance Eq QFloat where - {-# INLINE (==) #-} - QFloat a == QFloat b = a == b - {-# INLINE (/=) #-} - QFloat a /= QFloat b = a /= b - - - --------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------- - -instance Show QFloat where - show (QFloat (FloatX4# x y z w)) = - show (F# w) ++ ss x ++ "i" - ++ ss y ++ "j" - ++ ss z ++ "k" - where - ss a# = case F# a# of - a -> if a >= 0 then " + " ++ show a - else " - " ++ show (negate a) diff --git a/src-ghcjs/Numeric/Array.hs b/src-ghcjs/Numeric/Array.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/Array.hs +++ /dev/null @@ -1,18 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- Low-level implementations of data frames --- ------------------------------------------------------------------------------ - -module Numeric.Array - ( module Numeric.Array.Family - ) where - -import Numeric.Array.Family -import Numeric.Array.Family.ArrayT () diff --git a/src-ghcjs/Numeric/Array/Family.hs b/src-ghcjs/Numeric/Array/Family.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/Array/Family.hs +++ /dev/null @@ -1,360 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE UnliftedFFITypes #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.Family --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family - ( Array - , ArrayT (..), MutableArrayT (..), Scalar (..), Word8Clamped (..) - , ArrayInstanceInference, ElemType (..), ArraySize (..) - , ElemTypeInference (..), ArraySizeInference (..), ArrayInstanceEvidence - , getArrayInstance, ArrayInstance (..), inferArrayInstance - ) where - - -import Data.Int (Int16, Int32, Int8) -import Data.Type.Equality ((:~:) (..)) -import Data.Word (Word16, Word32, Word8) -import GHC.Prim (Double#, Float#, Int#, - Word#, unsafeCoerce#, ByteArray#) -import GHC.Types (Int (..)) -import GHCJS.Types - -import Numeric.Array.ElementWise -import Numeric.Commons -import Numeric.TypeLits -import Numeric.Dimensions - --- | Full collection of n-order arrays -type family Array t (ds :: [Nat]) = v | v -> t ds where - Array t '[] = Scalar t - Array t (d ': ds) = ArrayT t (d ': ds) - - --- | Specialize scalar type without any arrays -newtype Scalar t = Scalar { _unScalar :: t } - deriving ( Enum, Eq, Integral - , Num, Fractional, Floating, Ord, Read, Real, RealFrac, RealFloat, IsJSVal) -instance Show t => Show (Scalar t) where - show (Scalar t) = "{ " ++ show t ++ " }" - -deriving instance {-# OVERLAPPABLE #-} Bounded t => Bounded (Scalar t) -instance {-# OVERLAPPING #-} Bounded (Scalar Double) where - maxBound = Scalar inftyD - minBound = Scalar $ negate inftyD -instance {-# OVERLAPPING #-} Bounded (Scalar Float) where - maxBound = Scalar inftyF - minBound = Scalar $ negate inftyF -inftyD :: Double -inftyD = read "Infinity" -inftyF :: Float -inftyF = read "Infinity" - - --- | Support for Uint8ClampedArray in JS. --- This is backed by an ordinary Int type, but clamped to range 0..255 when used in an array -newtype Word8Clamped = Clamped { _fromClamped :: Int } deriving - (Ord,Num,Eq,Enum,Integral,Real,Show) -- ,Data,Ix,FiniteBits,Bits,Storable) -instance Bounded Word8Clamped where - maxBound = 255 - {-# INLINE maxBound #-} - minBound = 0 - {-# INLINE minBound #-} -type instance ElemRep Word8Clamped = ElemRep Int -type instance ElemPrim Word8Clamped = Int# -instance PrimBytes Word8Clamped where - toBytes v = (# 0#, 1#, js_wrapWord8Clamped v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapWord8Clamped arr off - {-# INLINE fromBytes #-} - byteSize _ = 1# - {-# INLINE byteSize #-} - byteAlign _ = 1# - {-# INLINE byteAlign #-} - elementByteSize _ = 1# - {-# INLINE elementByteSize #-} - ix _ (Clamped (I# x)) = x - {-# INLINE ix #-} -foreign import javascript unsafe "h$wrapBuffer((new Uint8ClampedArray([$1])).buffer)" js_wrapWord8Clamped :: Word8Clamped -> ByteArray# -foreign import javascript unsafe "($1.uc || new Uint8ClampedArray($1.buf))[$2]" js_unwrapWord8Clamped :: ByteArray# -> Int# -> Word8Clamped - -instance ElementWise (Idx ('[] :: [Nat])) Word8Clamped Word8Clamped where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f Z - {-# INLINE ewmap #-} - ewgen f = f Z - {-# INLINE ewgen #-} - ewgenA f = f Z - {-# INLINE ewgenA #-} - ewfoldl f x0 = f Z x0 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f Z x x0 - {-# INLINE ewfoldr #-} - elementWise f = f - {-# INLINE elementWise #-} - indexWise f = f Z - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ x _ = x - {-# INLINE update #-} - - -type instance ElemRep (Scalar t) = ElemRep t -type instance ElemPrim (Scalar Float ) = Float# -type instance ElemPrim (Scalar Double) = Double# -type instance ElemPrim (Scalar Int ) = Int# -type instance ElemPrim (Scalar Int8 ) = Int# -type instance ElemPrim (Scalar Int16 ) = Int# -type instance ElemPrim (Scalar Int32 ) = Int# -type instance ElemPrim (Scalar Word ) = Word# -type instance ElemPrim (Scalar Word8 ) = Word# -type instance ElemPrim (Scalar Word16) = Word# -type instance ElemPrim (Scalar Word32) = Word# -type instance ElemPrim (Scalar Word8Clamped) = Int# - -deriving instance PrimBytes (Scalar Float) -deriving instance PrimBytes (Scalar Double) -deriving instance PrimBytes (Scalar Int) -deriving instance PrimBytes (Scalar Int8) -deriving instance PrimBytes (Scalar Int16) -deriving instance PrimBytes (Scalar Int32) -deriving instance PrimBytes (Scalar Word) -deriving instance PrimBytes (Scalar Word8) -deriving instance PrimBytes (Scalar Word16) -deriving instance PrimBytes (Scalar Word32) -deriving instance PrimBytes (Scalar Word8Clamped) - --- | Indexing over scalars is trivial... -instance ElementWise (Idx ('[] :: [Nat])) t (Scalar t) where - indexOffset# x _ = _unScalar x - {-# INLINE indexOffset# #-} - (!) x _ = _unScalar x - {-# INLINE (!) #-} - ewmap f = Scalar . f Z . _unScalar - {-# INLINE ewmap #-} - ewgen f = Scalar $ f Z - {-# INLINE ewgen #-} - ewgenA f = Scalar <$> f Z - {-# INLINE ewgenA #-} - ewfoldl f x0 = f Z x0 . _unScalar - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f Z (_unScalar x) x0 - {-# INLINE ewfoldr #-} - elementWise f = fmap Scalar . f . _unScalar - {-# INLINE elementWise #-} - indexWise f = fmap Scalar . f Z . _unScalar - {-# INLINE indexWise #-} - broadcast = Scalar - {-# INLINE broadcast #-} - update _ x _ = Scalar x - {-# INLINE update #-} - - -newtype ArrayT t (ds :: [Nat]) = ArrayT JSVal -instance IsJSVal (ArrayT t ds) -newtype MutableArrayT s t (ds :: [Nat]) = MutableArrayT JSVal -instance IsJSVal (MutableArrayT s t ds) - - --- * Recovering type instances at runtime --- A combination of `ElemType t` and `ArraySize ds` should --- define an instance of `Array t ds` unambiguously. - - --- | Keep information about the element type instance --- --- Warning! This part of the code is platform and flag dependent. -data ElemType t - = t ~ Float => ETFloat - | t ~ Double => ETDouble - | t ~ Int => ETInt - | t ~ Int8 => ETInt8 - | t ~ Int16 => ETInt16 - | t ~ Int32 => ETInt32 - | t ~ Word => ETWord - | t ~ Word8 => ETWord8 - | t ~ Word16 => ETWord16 - | t ~ Word32 => ETWord32 - | t ~ Word8Clamped => ETWord8C - --- | Keep information about the array dimensionality --- --- Warning! This part of the code is platform and flag dependent. -data ArraySize (ds :: [Nat]) - = ds ~ '[] => ASScalar - | forall n ns . ds ~ (n ': ns) => ASArray - --- | Keep information about the instance behind Array family --- --- Warning! This part of the code is platform and flag dependent. -data ArrayInstance t (ds :: [Nat]) - = ( Array t ds ~ Scalar t, ds ~ '[]) => AIScalar - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Float ) => AIArrayF - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Double) => AIArrayD - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Int ) => AIArrayI - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Int8 ) => AIArrayI8 - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Int16 ) => AIArrayI16 - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Int32 ) => AIArrayI32 - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Word ) => AIArrayW - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Word8 ) => AIArrayW8 - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Word16) => AIArrayW16 - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Word32) => AIArrayW32 - | forall n ns . ( Array t ds ~ ArrayT t ds, ds ~ (n ': ns), t ~ Word8Clamped) => AIArrayW8C - --- | A singleton type used to prove that the given Array family instance --- has a known instance -type ArrayInstanceEvidence t (ds :: [Nat]) - = Evidence (ArrayInstanceInference t ds) - - -class ElemTypeInference t where - -- | Pattern match against result to get specific element type - elemTypeInstance :: ElemType t - -class ArraySizeInference ds where - -- | Pattern match agains result to get actual array dimensionality - arraySizeInstance :: ArraySize ds - inferSnocArrayInstance :: (ElemTypeInference t, KnownDim z) - => p t ds -> q z -> ArrayInstanceEvidence t (ds +: z) - inferConsArrayInstance :: (ElemTypeInference t, KnownDim z) - => q z -> p t ds -> ArrayInstanceEvidence t (z :+ ds) - inferInitArrayInstance :: ElemTypeInference t - => p t ds -> ArrayInstanceEvidence t (Init ds) - - --- | Use this typeclass constraint in libraries functions if there is a need --- to select an instance of Array famility at runtime. --- Combination of `elemTypeInstance` and `arraySizeInstance` allows --- to bring into typechecker's scope any specific typeclass instance -type ArrayInstanceInference t ds = (ElemTypeInference t, ArraySizeInference ds) - - - -instance ElemTypeInference Float where - elemTypeInstance = ETFloat -instance ElemTypeInference Double where - elemTypeInstance = ETDouble -instance ElemTypeInference Int where - elemTypeInstance = ETInt -instance ElemTypeInference Int8 where - elemTypeInstance = ETInt8 -instance ElemTypeInference Int16 where - elemTypeInstance = ETInt16 -instance ElemTypeInference Int32 where - elemTypeInstance = ETInt32 -instance ElemTypeInference Word where - elemTypeInstance = ETWord -instance ElemTypeInference Word8 where - elemTypeInstance = ETWord8 -instance ElemTypeInference Word16 where - elemTypeInstance = ETWord16 -instance ElemTypeInference Word32 where - elemTypeInstance = ETWord32 -instance ElemTypeInference Word8Clamped where - elemTypeInstance = ETWord8C - -instance ArraySizeInference '[] where - arraySizeInstance = ASScalar - {-# INLINE arraySizeInstance #-} - inferSnocArrayInstance _ _ = Evidence - {-# INLINE inferSnocArrayInstance #-} - inferConsArrayInstance _ _ = Evidence - {-# INLINE inferConsArrayInstance #-} - inferInitArrayInstance _ = error "Init -- empty type-level list" - {-# INLINE inferInitArrayInstance #-} - -instance KnownDim d => ArraySizeInference '[d] where - arraySizeInstance = case dimVal' @d of - 0 -> unsafeCoerce# ASScalar - 1 -> unsafeCoerce# ASScalar - _ -> case (unsafeCoerce# Refl :: (5 <=? d) :~: 'True) of Refl -> ASArray - {-# INLINE arraySizeInstance #-} - inferSnocArrayInstance _ _ = Evidence - {-# INLINE inferSnocArrayInstance #-} - inferConsArrayInstance _ _ = Evidence - {-# INLINE inferConsArrayInstance #-} - inferInitArrayInstance _ = Evidence - {-# INLINE inferInitArrayInstance #-} - - -instance ArraySizeInference (d1 ': d2 ': ds) where - arraySizeInstance = ASArray - {-# INLINE arraySizeInstance #-} - -- I know that for dimensionality > 2 all instances are the same. - -- Hence this dirty hack should work. - -- I have to change this when I have customized N*M instances - inferSnocArrayInstance p q = unsafeCoerce# (inferConsArrayInstance q p) - {-# INLINE inferSnocArrayInstance #-} - inferConsArrayInstance _ _ = Evidence - {-# INLINE inferConsArrayInstance #-} - -- I know that for dimensionality > 2 all instances are the same. - -- Hence this dirty hack should work. - -- I have to change this when I have customized N*M instances - inferInitArrayInstance p = unsafeCoerce# (inferConsArrayInstance (Proxy @3) p) - {-# INLINE inferInitArrayInstance #-} - - - -getArrayInstance :: forall t (ds :: [Nat]) - . ArrayInstanceInference t ds - => ArrayInstance t ds -getArrayInstance = case (elemTypeInstance @t, arraySizeInstance @ds) of - (_ , ASScalar) -> AIScalar - - (ETFloat , ASArray) -> AIArrayF - (ETDouble , ASArray) -> AIArrayD - (ETInt , ASArray) -> AIArrayI - (ETInt8 , ASArray) -> AIArrayI8 - (ETInt16 , ASArray) -> AIArrayI16 - (ETInt32 , ASArray) -> AIArrayI32 - (ETWord , ASArray) -> AIArrayW - (ETWord8 , ASArray) -> AIArrayW8 - (ETWord16 , ASArray) -> AIArrayW16 - (ETWord32 , ASArray) -> AIArrayW32 - (ETWord8C , ASArray) -> AIArrayW8C - --- | Given element type instance and proper dimension list, --- infer a corresponding array instance -inferArrayInstance :: forall t ds - . ( FiniteList ds - , KnownDims ds - , ElemTypeInference t - ) - => ArrayInstanceEvidence t ds -inferArrayInstance = case tList @_ @ds of - TLEmpty -> Evidence - TLCons _ TLEmpty -> Evidence - TLCons _ (TLCons _ TLEmpty) -> Evidence - TLCons _ (TLCons _ (TLCons _ _)) -> Evidence - - -_suppressHlintUnboxedTuplesWarning :: () -> (# (), () #) -_suppressHlintUnboxedTuplesWarning = undefined diff --git a/src-ghcjs/Numeric/Array/Family/ArrayT.hs b/src-ghcjs/Numeric/Array/Family/ArrayT.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/Array/Family/ArrayT.hs +++ /dev/null @@ -1,1645 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} --- {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE Strict #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Array.Family.ArrayT () where - - -import GHC.Base (runRW#) -import GHC.Int (Int16 (..), Int32 (..), Int8 (..)) -import GHC.Word (Word16 (..), Word32 (..), Word8 (..)) -import GHC.Prim -import GHC.Types (Float (..), Double (..), Int (..), Word (..)) ---import GHCJS.Types - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions -import Numeric.Dimensions.Traverse -import Numeric.TypeLits -import Numeric.Matrix.Class - - -type instance ElemRep (ArrayT t ds) = ElemRep t -type instance ElemPrim (ArrayT Float ds) = Float# -type instance ElemPrim (ArrayT Double ds) = Double# -type instance ElemPrim (ArrayT Int ds) = Int# -type instance ElemPrim (ArrayT Int8 ds) = Int# -type instance ElemPrim (ArrayT Int16 ds) = Int# -type instance ElemPrim (ArrayT Int32 ds) = Int# -type instance ElemPrim (ArrayT Word ds) = Word# -type instance ElemPrim (ArrayT Word8 ds) = Word# -type instance ElemPrim (ArrayT Word16 ds) = Word# -type instance ElemPrim (ArrayT Word32 ds) = Word# -type instance ElemPrim (ArrayT Word8Clamped ds) = Int# - - -instance Dimensions ds => PrimBytes (ArrayT Float ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapFloatArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Float) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Float) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Float) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetFloat# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Double ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapDoubleArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Double) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Double) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Double) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetDouble# - {-# INLINE ix #-} - - -instance Dimensions ds => PrimBytes (ArrayT Int ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapIntArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Int) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Int) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Int) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetInt# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Int8 ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapInt8ArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Int8) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Int8) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Int8) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetInt8# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Int16 ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapInt16ArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Int16) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Int16) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Int16) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetInt16# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Int32 ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapInt32ArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Int32) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Int32) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Int32) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetInt32# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Word ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapWordArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Word) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Word) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Word) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetWord# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Word8 ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapWord8ArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Word8) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Word8) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Word8) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetWord8# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Word8Clamped ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapWord8ClampedArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Word8Clamped) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Word8Clamped) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Word8Clamped) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetWord8Clamped# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Word16 ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapWord16ArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Word16) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Word16) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Word16) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetWord16# - {-# INLINE ix #-} - -instance Dimensions ds => PrimBytes (ArrayT Word32 ds) where - toBytes v = (# js_byteOffset v `quotInt#` elementByteSize v , js_length v , js_wrapArrayT v #) - {-# INLINE toBytes #-} - fromBytes (# off, len, arr #) = js_unwrapWord32ArrayOffLen arr off len - {-# INLINE fromBytes #-} - byteSize ~_ = case totalDim (dim @ds) of I# n -> n *# byteSize (undefined :: Word32) - {-# INLINE byteSize #-} - byteAlign ~_ = byteAlign (undefined :: Word32) - {-# INLINE byteAlign #-} - elementByteSize ~_ = byteSize (undefined :: Word32) - {-# INLINE elementByteSize #-} - ix = js_indexArrayOffsetWord32# - {-# INLINE ix #-} - - - - -instance ( Dimensions ds - , Show t - , ElementWise (Idx ds) t (ArrayT t ds) - ) - => Show (ArrayT t (ds :: [Nat])) where - show x = case dim @ds of - D -> "{ " ++ show (x ! Z) ++ " }" - Dn :* D -> ('{' :) . drop 1 $ - foldr (\i s -> ", " ++ show (x ! i) ++ s) " }" - [minBound .. maxBound] - (Dn :: Dim (n :: Nat)) :* (Dn :: Dim (m :: Nat)) :* (_ :: Dim (dss :: [Nat])) -> - case inferDropNDimensions @2 @ds of - Evidence -> - let loopInner :: Idx dss -> Idx '[n,m] -> String - loopInner ods (n:!m:!_) = ('{' :) . drop 2 $ - foldr (\i ss -> '\n': - foldr (\j s -> - ", " ++ show (x ! (i :! j :! ods)) ++ s - ) ss [1..m] - ) " }" [1..n] - loopOuter :: Idx dss -> String -> String - loopOuter Z s = "\n" ++ loopInner Z maxBound ++ s - loopOuter ds s = "\n(i j" ++ drop 3 (show ds) ++ "):\n" - ++ loopInner ds maxBound ++ s - in drop 1 $ foldr loopOuter "" [minBound..maxBound] - - -instance Eq (ArrayT t ds) where - (==) = js_arrayTEq - (/=) = js_arrayTNEq -foreign import javascript unsafe "$1.every(function (e, i) { return e == $2[i]; })" js_arrayTEq :: ArrayT t ds -> ArrayT t ds -> Bool -foreign import javascript unsafe "$1.some(function (e, i) { return e !== $2[i]; })" js_arrayTNEq :: ArrayT t ds -> ArrayT t ds -> Bool - - - - -instance Ord (ArrayT t ds) where - (<) = js_arrayTLT - (<=) = js_arrayTLE - (>) = js_arrayTGT - (>=) = js_arrayTGE - compare a b = case js_arrayTCmp a b of - 1 -> GT - 0 -> EQ - _ -> LT - max = js_arrayMax - min = js_arrayMin -foreign import javascript unsafe "$1.every(function (e, i) { return e < $2[i]; })" js_arrayTLT :: ArrayT t ds -> ArrayT t ds -> Bool -foreign import javascript unsafe "$1.every(function (e, i) { return e <= $2[i]; })" js_arrayTLE :: ArrayT t ds -> ArrayT t ds -> Bool -foreign import javascript unsafe "$1.every(function (e, i) { return e > $2[i]; })" js_arrayTGT :: ArrayT t ds -> ArrayT t ds -> Bool -foreign import javascript unsafe "$1.every(function (e, i) { return e >= $2[i]; })" js_arrayTGE :: ArrayT t ds -> ArrayT t ds -> Bool -foreign import javascript unsafe "$1.reduce(function (r, e, i) { return r === 0 ? (e > $2[i] ? 1 : (e < $2[i] ? -1 : 0)) : r;}, 0)" js_arrayTCmp :: ArrayT t ds -> ArrayT t ds -> Int -foreign import javascript unsafe "$1.map(function (e, i) { return Math.max(e,$2[i]); })" js_arrayMax :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e, i) { return Math.min(e,$2[i]); })" js_arrayMin :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds - - -instance Dimensions ds => Num (ArrayT Float ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewFloatArray (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Double ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewDoubleArray (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Int ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewIntArray (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Int8 ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewInt8Array (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Int16 ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewInt16Array (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Int32 ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewInt32Array (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Word ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewWordArray (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Word8 ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewWord8Array (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Word16 ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewWord16Array (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Word32 ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewWord32Array (totalDim (dim @ds)) . fromInteger -instance Dimensions ds => Num (ArrayT Word8Clamped ds) where - (+) = js_arrayTPlus - (-) = js_arrayTMinus - (*) = js_arrayTTimes - negate = js_arrayTNegate - abs = js_arrayTAbs - signum = js_arrayTSignum - fromInteger = js_fillNewWord8ClampedArray (totalDim (dim @ds)) . fromInteger - -foreign import javascript unsafe "$1.map(function (e, i) { return e + $2[i]; })" js_arrayTPlus :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e, i) { return e - $2[i]; })" js_arrayTMinus :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e, i) { return e * $2[i]; })" js_arrayTTimes :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return -e; })" js_arrayTNegate :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.abs(e); })" js_arrayTAbs :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.sign(e); })" js_arrayTSignum :: ArrayT t ds -> ArrayT t ds - - - -instance Dimensions ds => Fractional (ArrayT Float ds) where - recip = js_arrayTRecip - (/) = js_arrayTDivide - fromRational = js_fillNewFloatArray (totalDim (dim @ds)) . fromRational -instance Dimensions ds => Fractional (ArrayT Double ds) where - recip = js_arrayTRecip - (/) = js_arrayTDivide - fromRational = js_fillNewDoubleArray (totalDim (dim @ds)) . fromRational - -foreign import javascript unsafe "$1.map(function (e, i) { return e/$2[i]; })" js_arrayTDivide :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return 1/e; })" js_arrayTRecip :: ArrayT t ds -> ArrayT t ds - - -instance Dimensions ds => Floating (ArrayT Float ds) where - pi = broadcast pi - {-# INLINE pi #-} - exp = js_arrayTexp - {-# INLINE exp #-} - log = js_arrayTlog - {-# INLINE log #-} - sqrt = js_arrayTsqrt - {-# INLINE sqrt #-} - sin = js_arrayTsin - {-# INLINE sin #-} - cos = js_arrayTcos - {-# INLINE cos #-} - tan = js_arrayTtan - {-# INLINE tan #-} - asin = js_arrayTasin - {-# INLINE asin #-} - acos = js_arrayTacos - {-# INLINE acos #-} - atan = js_arrayTatan - {-# INLINE atan #-} - sinh = js_arrayTsinh - {-# INLINE sinh #-} - cosh = js_arrayTcosh - {-# INLINE cosh #-} - tanh = js_arrayTtanh - {-# INLINE tanh #-} - (**) = js_arrayTpower - {-# INLINE (**) #-} - logBase = js_arrayTlogBase - {-# INLINE logBase #-} - asinh = js_arrayTasinh - {-# INLINE asinh #-} - acosh = js_arrayTacosh - {-# INLINE acosh #-} - atanh = js_arrayTatanh - {-# INLINE atanh #-} - -instance Dimensions ds => Floating (ArrayT Double ds) where - pi = broadcast pi - {-# INLINE pi #-} - exp = js_arrayTexp - {-# INLINE exp #-} - log = js_arrayTlog - {-# INLINE log #-} - sqrt = js_arrayTsqrt - {-# INLINE sqrt #-} - sin = js_arrayTsin - {-# INLINE sin #-} - cos = js_arrayTcos - {-# INLINE cos #-} - tan = js_arrayTtan - {-# INLINE tan #-} - asin = js_arrayTasin - {-# INLINE asin #-} - acos = js_arrayTacos - {-# INLINE acos #-} - atan = js_arrayTatan - {-# INLINE atan #-} - sinh = js_arrayTsinh - {-# INLINE sinh #-} - cosh = js_arrayTcosh - {-# INLINE cosh #-} - tanh = js_arrayTtanh - {-# INLINE tanh #-} - (**) = js_arrayTpower - {-# INLINE (**) #-} - logBase = js_arrayTlogBase - {-# INLINE logBase #-} - asinh = js_arrayTasinh - {-# INLINE asinh #-} - acosh = js_arrayTacosh - {-# INLINE acosh #-} - atanh = js_arrayTatanh - {-# INLINE atanh #-} - - -foreign import javascript unsafe "$1.map(function (e) { return Math.exp(e); })" js_arrayTexp :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.log(e); })" js_arrayTlog :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.sqrt(e); })" js_arrayTsqrt :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.sin(e); })" js_arrayTsin :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.cos(e); })" js_arrayTcos :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.tan(e); })" js_arrayTtan :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.asin(e); })" js_arrayTasin :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.acos(e); })" js_arrayTacos :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.atan(e); })" js_arrayTatan :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.sinh(e); })" js_arrayTsinh :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.cosh(e); })" js_arrayTcosh :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.tanh(e); })" js_arrayTtanh :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.asinh(e); })" js_arrayTasinh :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.acosh(e); })" js_arrayTacosh :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e) { return Math.atanh(e); })" js_arrayTatanh :: ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e,i) { return Math.log($2[i])/Math.log(e); })" js_arrayTlogBase :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds -foreign import javascript unsafe "$1.map(function (e,i) { return Math.pow(e,$2[i]); })" js_arrayTpower :: ArrayT t ds -> ArrayT t ds -> ArrayT t ds - - - -instance Dimensions ds => Bounded (ArrayT Int ds) where - maxBound = js_fillNewIntArray (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewIntArray (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Int8 ds) where - maxBound = js_fillNewInt8Array (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewInt8Array (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Int16 ds) where - maxBound = js_fillNewInt16Array (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewInt16Array (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Int32 ds) where - maxBound = js_fillNewInt32Array (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewInt32Array (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Word ds) where - maxBound = js_fillNewWordArray (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewWordArray (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Word8 ds) where - maxBound = js_fillNewWord8Array (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewWord8Array (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Word16 ds) where - maxBound = js_fillNewWord16Array (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewWord16Array (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Word32 ds) where - maxBound = js_fillNewWord32Array (totalDim (dim @ds)) maxBound - {-# INLINE maxBound #-} - minBound = js_fillNewWord32Array (totalDim (dim @ds)) minBound - {-# INLINE minBound #-} -instance Dimensions ds => Bounded (ArrayT Word8Clamped ds) where - maxBound = js_fillNewWord8ClampedArray (totalDim (dim @ds)) 255 - {-# INLINE maxBound #-} - minBound = js_fillNewWord8ClampedArray (totalDim (dim @ds)) 0 - {-# INLINE minBound #-} - - - - - - -wr :: (State# RealWorld -> (# State# RealWorld, MutableArrayT RealWorld t ds #) ) - -> (MutableArrayT RealWorld t ds -> State# RealWorld -> State# RealWorld) - -> ArrayT t ds -wr fma ff = case runRW# - ( \s0 -> case fma s0 of - (# s1, ma #) -> case ff ma s1 of s2 -> unsafeFreezeArrayT# ma s2 - ) of (# _, r #) -> r -{-# INLINE wr #-} - - - -instance Dimensions ds => ElementWise (Idx ds) Float (ArrayT Float ds) where - indexOffset# x i = js_indexArrayOffsetFloat i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetFloat j x - {-# INLINE (!) #-} - broadcast = js_fillNewFloatArray (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (F# v) = case fromEnum i of I# j -> js_setArrayOffsetFloat# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createFloatArray (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetFloat off x) of - (F# r) -> js_writeArrayOffsetFloat# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createFloatArray n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (F# r) -> js_writeArrayOffsetFloat# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createFloatArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(F# z) u a s -> js_writeArrayOffsetFloat# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetFloat off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetFloat off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createFloatArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(F# z) u a s -> js_writeArrayOffsetFloat# off z a (u a s) ) <$> f i (js_indexArrayOffsetFloat off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createFloatArray n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(F# z) u a s -> js_writeArrayOffsetFloat# off z a (u a s) ) <$> f (js_indexArrayOffsetFloat off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - -instance Dimensions ds => ElementWise (Idx ds) Double (ArrayT Double ds) where - indexOffset# x i = js_indexArrayOffsetDouble i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetDouble j x - {-# INLINE (!) #-} - broadcast = js_fillNewDoubleArray (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (D# v) = case fromEnum i of I# j -> js_setArrayOffsetDouble# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createDoubleArray (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetDouble off x) of - (D# r) -> js_writeArrayOffsetDouble# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createDoubleArray n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (D# r) -> js_writeArrayOffsetDouble# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createDoubleArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(D# z) u a s -> js_writeArrayOffsetDouble# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetDouble off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetDouble off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createDoubleArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(D# z) u a s -> js_writeArrayOffsetDouble# off z a (u a s) ) <$> f i (js_indexArrayOffsetDouble off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createDoubleArray n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(D# z) u a s -> js_writeArrayOffsetDouble# off z a (u a s) ) <$> f (js_indexArrayOffsetDouble off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - -instance Dimensions ds => ElementWise (Idx ds) Int32 (ArrayT Int32 ds) where - indexOffset# x i = js_indexArrayOffsetInt32 i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetInt32 j x - {-# INLINE (!) #-} - broadcast = js_fillNewInt32Array (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (I32# v) = case fromEnum i of I# j -> js_setArrayOffsetInt32# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createInt32Array (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetInt32 off x) of - (I32# r) -> js_writeArrayOffsetInt32# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createInt32Array n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (I32# r) -> js_writeArrayOffsetInt32# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createInt32Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I32# z) u a s -> js_writeArrayOffsetInt32# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetInt32 off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetInt32 off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createInt32Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I32# z) u a s -> js_writeArrayOffsetInt32# off z a (u a s) ) <$> f i (js_indexArrayOffsetInt32 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createInt32Array n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(I32# z) u a s -> js_writeArrayOffsetInt32# off z a (u a s) ) <$> f (js_indexArrayOffsetInt32 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - -instance Dimensions ds => ElementWise (Idx ds) Int16 (ArrayT Int16 ds) where - indexOffset# x i = js_indexArrayOffsetInt16 i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetInt16 j x - {-# INLINE (!) #-} - broadcast = js_fillNewInt16Array (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (I16# v) = case fromEnum i of I# j -> js_setArrayOffsetInt16# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createInt16Array (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetInt16 off x) of - (I16# r) -> js_writeArrayOffsetInt16# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createInt16Array n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (I16# r) -> js_writeArrayOffsetInt16# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createInt16Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I16# z) u a s -> js_writeArrayOffsetInt16# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetInt16 off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetInt16 off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createInt16Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I16# z) u a s -> js_writeArrayOffsetInt16# off z a (u a s) ) <$> f i (js_indexArrayOffsetInt16 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createInt16Array n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(I16# z) u a s -> js_writeArrayOffsetInt16# off z a (u a s) ) <$> f (js_indexArrayOffsetInt16 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - -instance Dimensions ds => ElementWise (Idx ds) Int8 (ArrayT Int8 ds) where - indexOffset# x i = js_indexArrayOffsetInt8 i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetInt8 j x - {-# INLINE (!) #-} - broadcast = js_fillNewInt8Array (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (I8# v) = case fromEnum i of I# j -> js_setArrayOffsetInt8# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createInt8Array (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetInt8 off x) of - (I8# r) -> js_writeArrayOffsetInt8# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createInt8Array n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (I8# r) -> js_writeArrayOffsetInt8# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createInt8Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I8# z) u a s -> js_writeArrayOffsetInt8# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetInt8 off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetInt8 off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createInt8Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I8# z) u a s -> js_writeArrayOffsetInt8# off z a (u a s) ) <$> f i (js_indexArrayOffsetInt8 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createInt8Array n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(I8# z) u a s -> js_writeArrayOffsetInt8# off z a (u a s) ) <$> f (js_indexArrayOffsetInt8 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - -instance Dimensions ds => ElementWise (Idx ds) Int (ArrayT Int ds) where - indexOffset# x i = js_indexArrayOffsetInt i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetInt j x - {-# INLINE (!) #-} - broadcast = js_fillNewIntArray (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (I# v) = case fromEnum i of I# j -> js_setArrayOffsetInt# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createIntArray (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetInt off x) of - (I# r) -> js_writeArrayOffsetInt# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createIntArray n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (I# r) -> js_writeArrayOffsetInt# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createIntArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I# z) u a s -> js_writeArrayOffsetInt# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetInt off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetInt off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createIntArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(I# z) u a s -> js_writeArrayOffsetInt# off z a (u a s) ) <$> f i (js_indexArrayOffsetInt off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createIntArray n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(I# z) u a s -> js_writeArrayOffsetInt# off z a (u a s) ) <$> f (js_indexArrayOffsetInt off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - - - -instance Dimensions ds => ElementWise (Idx ds) Word32 (ArrayT Word32 ds) where - indexOffset# x i = js_indexArrayOffsetWord32 i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetWord32 j x - {-# INLINE (!) #-} - broadcast = js_fillNewWord32Array (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (W32# v) = case fromEnum i of I# j -> js_setArrayOffsetWord32# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createWord32Array (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetWord32 off x) of - (W32# r) -> js_writeArrayOffsetWord32# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createWord32Array n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (W32# r) -> js_writeArrayOffsetWord32# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createWord32Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W32# z) u a s -> js_writeArrayOffsetWord32# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetWord32 off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetWord32 off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createWord32Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W32# z) u a s -> js_writeArrayOffsetWord32# off z a (u a s) ) <$> f i (js_indexArrayOffsetWord32 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createWord32Array n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(W32# z) u a s -> js_writeArrayOffsetWord32# off z a (u a s) ) <$> f (js_indexArrayOffsetWord32 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - -instance Dimensions ds => ElementWise (Idx ds) Word16 (ArrayT Word16 ds) where - indexOffset# x i = js_indexArrayOffsetWord16 i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetWord16 j x - {-# INLINE (!) #-} - broadcast = js_fillNewWord16Array (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (W16# v) = case fromEnum i of I# j -> js_setArrayOffsetWord16# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createWord16Array (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetWord16 off x) of - (W16# r) -> js_writeArrayOffsetWord16# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createWord16Array n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (W16# r) -> js_writeArrayOffsetWord16# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createWord16Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W16# z) u a s -> js_writeArrayOffsetWord16# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetWord16 off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetWord16 off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createWord16Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W16# z) u a s -> js_writeArrayOffsetWord16# off z a (u a s) ) <$> f i (js_indexArrayOffsetWord16 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createWord16Array n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(W16# z) u a s -> js_writeArrayOffsetWord16# off z a (u a s) ) <$> f (js_indexArrayOffsetWord16 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - -instance Dimensions ds => ElementWise (Idx ds) Word8 (ArrayT Word8 ds) where - indexOffset# x i = js_indexArrayOffsetWord8 i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetWord8 j x - {-# INLINE (!) #-} - broadcast = js_fillNewWord8Array (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (W8# v) = case fromEnum i of I# j -> js_setArrayOffsetWord8# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createWord8Array (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetWord8 off x) of - (W8# r) -> js_writeArrayOffsetWord8# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createWord8Array n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (W8# r) -> js_writeArrayOffsetWord8# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createWord8Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W8# z) u a s -> js_writeArrayOffsetWord8# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetWord8 off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetWord8 off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createWord8Array n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W8# z) u a s -> js_writeArrayOffsetWord8# off z a (u a s) ) <$> f i (js_indexArrayOffsetWord8 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createWord8Array n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(W8# z) u a s -> js_writeArrayOffsetWord8# off z a (u a s) ) <$> f (js_indexArrayOffsetWord8 off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - -instance Dimensions ds => ElementWise (Idx ds) Word (ArrayT Word ds) where - indexOffset# x i = js_indexArrayOffsetWord i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetWord j x - {-# INLINE (!) #-} - broadcast = js_fillNewWordArray (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (W# v) = case fromEnum i of I# j -> js_setArrayOffsetWord# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createWordArray (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetWord off x) of - (W# r) -> js_writeArrayOffsetWord# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createWordArray n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (W# r) -> js_writeArrayOffsetWord# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createWordArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W# z) u a s -> js_writeArrayOffsetWord# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetWord off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetWord off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createWordArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(W# z) u a s -> js_writeArrayOffsetWord# off z a (u a s) ) <$> f i (js_indexArrayOffsetWord off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createWordArray n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(W# z) u a s -> js_writeArrayOffsetWord# off z a (u a s) ) <$> f (js_indexArrayOffsetWord off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - - - -instance Dimensions ds => ElementWise (Idx ds) Word8Clamped (ArrayT Word8Clamped ds) where - indexOffset# x i = js_indexArrayOffsetWord8Clamped i x - {-# INLINE indexOffset# #-} - x ! i = case fromEnum i of I# j -> js_indexArrayOffsetWord8Clamped j x - {-# INLINE (!) #-} - broadcast = js_fillNewWord8ClampedArray (totalDim (dim @ds)) - {-# INLINE broadcast #-} - update i (Clamped (I# v)) = case fromEnum i of I# j -> js_setArrayOffsetWord8Clamped# j v - {-# INLINE update #-} - - ewmap f x = case runRW# - (\s0 -> case js_createWord8ClampedArray (js_length x) s0 of - (# s1, my #) -> case overDim_# (dim `inSpaceOf` x) - ( \ii off -> case f ii (js_indexArrayOffsetWord8Clamped off x) of - (Clamped (I# r)) -> js_writeArrayOffsetWord8Clamped# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - {-# INLINE ewmap #-} - - ewgen f = case runRW# - (\s0 -> case js_createWord8ClampedArray n s0 of - (# s1, my #) -> case overDim_# dds - ( \ii off -> case f ii of - (Clamped (I# r)) -> js_writeArrayOffsetWord8Clamped# off r my - ) 0# 1# s1 of - s3 -> unsafeFreezeArrayT# my s3 - ) of (# _, r #) -> r - where - dds = dim @ds - n = case totalDim dds of I# d -> d - {-# INLINE ewgen #-} - - ewgenA f = wr (js_createWord8ClampedArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(Clamped (I# z)) u a s -> js_writeArrayOffsetWord8Clamped# off z a (u a s) ) <$> f i <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - ewfoldr f v0 x - = foldDimReverse (dim `inSpaceOf` x) - (\ii off a -> f ii (js_indexArrayOffsetWord8Clamped off x) a) 0# 1# v0 - {-# INLINE ewfoldr #-} - - ewfoldl f v0 x - = foldDim (dim `inSpaceOf` x) - (\ii off a -> f ii a (js_indexArrayOffsetWord8Clamped off x)) 0# 1# v0 - {-# INLINE ewfoldl #-} - - indexWise f x = wr (js_createWord8ClampedArray n) <$> foldDim dds g 0# 1# (pure (\_ s -> s)) - where - g i off mf = (\(Clamped (I# z)) u a s -> js_writeArrayOffsetWord8Clamped# off z a (u a s) ) <$> f i (js_indexArrayOffsetWord8Clamped off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - elementWise f x = wr (js_createWord8ClampedArray n) <$> foldDimOff dds g 0# 1# (pure (\_ s -> s)) - where - g off mf = (\(Clamped (I# z)) u a s -> js_writeArrayOffsetWord8Clamped# off z a (u a s) ) <$> f (js_indexArrayOffsetWord8Clamped off x) <*> mf - n = case totalDim dds of I# d -> d - dds = dim @ds - - - - - - - -instance (KnownDim n, KnownDim m, ArrayT t '[n,m] ~ Array t '[n,m], 2 <= n, 2 <= m) - => MatrixCalculus t n m where - transpose = KnownDataFrame . js_transpose @t @n @m (dimVal' @n) . _getDF - -foreign import javascript unsafe "h$easytensor_transpose($1, $2)" js_transpose :: Int -> ArrayT t '[n,m] -> ArrayT t '[m,n] - - -instance ( KnownDim n, ArrayT Float '[n,n] ~ Array Float '[n,n] ) - => SquareMatrixCalculus Float n where - eye = KnownDataFrame $ js_eyeFloat (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagFloat (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceFloat m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detFloat m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Double '[n,n] ~ Array Double '[n,n] ) - => SquareMatrixCalculus Double n where - eye = KnownDataFrame $ js_eyeDouble (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagDouble (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceDouble m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detDouble m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Int '[n,n] ~ Array Int '[n,n] ) - => SquareMatrixCalculus Int n where - eye = KnownDataFrame $ js_eyeInt (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagInt (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceInt m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detInt m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Int8 '[n,n] ~ Array Int8 '[n,n] ) - => SquareMatrixCalculus Int8 n where - eye = KnownDataFrame $ js_eyeInt8 (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagInt8 (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceInt8 m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detInt8 m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Int16 '[n,n] ~ Array Int16 '[n,n] ) - => SquareMatrixCalculus Int16 n where - eye = KnownDataFrame $ js_eyeInt16 (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagInt16 (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceInt16 m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detInt16 m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Int32 '[n,n] ~ Array Int32 '[n,n] ) - => SquareMatrixCalculus Int32 n where - eye = KnownDataFrame $ js_eyeInt32 (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagInt32 (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceInt32 m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detInt32 m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Word '[n,n] ~ Array Word '[n,n] ) - => SquareMatrixCalculus Word n where - eye = KnownDataFrame $ js_eyeWord (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagWord (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceWord m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detWord m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Word8 '[n,n] ~ Array Word8 '[n,n] ) - => SquareMatrixCalculus Word8 n where - eye = KnownDataFrame $ js_eyeWord8 (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagWord8 (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceWord8 m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detWord8 m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Word16 '[n,n] ~ Array Word16 '[n,n] ) - => SquareMatrixCalculus Word16 n where - eye = KnownDataFrame $ js_eyeWord16 (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagWord16 (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceWord16 m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detWord16 m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Word32 '[n,n] ~ Array Word32 '[n,n] ) - => SquareMatrixCalculus Word32 n where - eye = KnownDataFrame $ js_eyeWord32 (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagWord32 (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceWord32 m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detWord32 m (dimVal' @n) - {-# INLINE det #-} - -instance ( KnownDim n, ArrayT Word8Clamped '[n,n] ~ Array Word8Clamped '[n,n] ) - => SquareMatrixCalculus Word8Clamped n where - eye = KnownDataFrame $ js_eyeWord8Clamped (dimVal' @n) - {-# INLINE eye #-} - diag (KnownDataFrame (Scalar x)) = KnownDataFrame $ js_diagWord8Clamped (dimVal' @n) x - {-# INLINE diag #-} - trace (KnownDataFrame m) = KnownDataFrame . Scalar $ js_traceWord8Clamped m (dimVal' @n) - {-# INLINE trace #-} - det (KnownDataFrame m) = KnownDataFrame . Scalar $ js_detWord8Clamped m (dimVal' @n) - {-# INLINE det #-} - -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detFloat :: ArrayT Float '[n,n] -> Int -> Float -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detDouble :: ArrayT Double '[n,n] -> Int -> Double -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detInt :: ArrayT Int '[n,n] -> Int -> Int -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detInt8 :: ArrayT Int8 '[n,n] -> Int -> Int8 -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detInt16 :: ArrayT Int16 '[n,n] -> Int -> Int16 -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detInt32 :: ArrayT Int32 '[n,n] -> Int -> Int32 -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detWord :: ArrayT Word '[n,n] -> Int -> Word -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detWord8 :: ArrayT Word8 '[n,n] -> Int -> Word8 -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detWord16 :: ArrayT Word16 '[n,n] -> Int -> Word16 -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detWord32 :: ArrayT Word32 '[n,n] -> Int -> Word32 -foreign import javascript unsafe "h$easytensor_det($1, $2)" js_detWord8Clamped :: ArrayT Word8Clamped '[n,n] -> Int -> Word8Clamped - -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceFloat :: ArrayT Float '[n,n] -> Int -> Float -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceDouble :: ArrayT Double '[n,n] -> Int -> Double -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceInt :: ArrayT Int '[n,n] -> Int -> Int -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceInt8 :: ArrayT Int8 '[n,n] -> Int -> Int8 -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceInt16 :: ArrayT Int16 '[n,n] -> Int -> Int16 -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceInt32 :: ArrayT Int32 '[n,n] -> Int -> Int32 -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceWord :: ArrayT Word '[n,n] -> Int -> Word -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceWord8 :: ArrayT Word8 '[n,n] -> Int -> Word8 -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceWord16 :: ArrayT Word16 '[n,n] -> Int -> Word16 -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceWord32 :: ArrayT Word32 '[n,n] -> Int -> Word32 -foreign import javascript unsafe "h$easytensor_trace($1, $2)" js_traceWord8Clamped :: ArrayT Word8Clamped '[n,n] -> Int -> Word8Clamped - - -foreign import javascript unsafe "h$easytensor_diagFloat32($1, $2)" js_diagFloat :: Int -> Float -> ArrayT Float '[n,n] -foreign import javascript unsafe "h$easytensor_diagFloat64($1, $2)" js_diagDouble :: Int -> Double -> ArrayT Double '[n,n] -foreign import javascript unsafe "h$easytensor_diagInt32($1, $2)" js_diagInt :: Int -> Int -> ArrayT Int '[n,n] -foreign import javascript unsafe "h$easytensor_diagInt8($1, $2)" js_diagInt8 :: Int -> Int8 -> ArrayT Int8 '[n,n] -foreign import javascript unsafe "h$easytensor_diagInt16($1, $2)" js_diagInt16 :: Int -> Int16 -> ArrayT Int16 '[n,n] -foreign import javascript unsafe "h$easytensor_diagInt32($1, $2)" js_diagInt32 :: Int -> Int32 -> ArrayT Int32 '[n,n] -foreign import javascript unsafe "h$easytensor_diagUint($1, $2)" js_diagWord :: Int -> Word -> ArrayT Word '[n,n] -foreign import javascript unsafe "h$easytensor_diagUint8($1, $2)" js_diagWord8 :: Int -> Word8 -> ArrayT Word8 '[n,n] -foreign import javascript unsafe "h$easytensor_diagUint16($1, $2)" js_diagWord16 :: Int -> Word16 -> ArrayT Word16 '[n,n] -foreign import javascript unsafe "h$easytensor_diagUint32($1, $2)" js_diagWord32 :: Int -> Word32 -> ArrayT Word32 '[n,n] -foreign import javascript unsafe "h$easytensor_diagUint8Clamped($1, $2)" js_diagWord8Clamped :: Int -> Word8Clamped ->ArrayT Word8Clamped '[n,n] - - -foreign import javascript unsafe "h$easytensor_eyeFloat32($1)" js_eyeFloat :: Int -> ArrayT Float '[n,n] -foreign import javascript unsafe "h$easytensor_eyeFloat64($1)" js_eyeDouble :: Int -> ArrayT Double '[n,n] -foreign import javascript unsafe "h$easytensor_eyeInt32($1)" js_eyeInt :: Int -> ArrayT Int '[n,n] -foreign import javascript unsafe "h$easytensor_eyeInt8($1)" js_eyeInt8 :: Int -> ArrayT Int8 '[n,n] -foreign import javascript unsafe "h$easytensor_eyeInt16($1)" js_eyeInt16 :: Int -> ArrayT Int16 '[n,n] -foreign import javascript unsafe "h$easytensor_eyeInt32($1)" js_eyeInt32 :: Int -> ArrayT Int32 '[n,n] -foreign import javascript unsafe "h$easytensor_eyeUint($1)" js_eyeWord :: Int -> ArrayT Word '[n,n] -foreign import javascript unsafe "h$easytensor_eyeUint8($1)" js_eyeWord8 :: Int -> ArrayT Word8 '[n,n] -foreign import javascript unsafe "h$easytensor_eyeUint16($1)" js_eyeWord16 :: Int -> ArrayT Word16 '[n,n] -foreign import javascript unsafe "h$easytensor_eyeUint32($1)" js_eyeWord32 :: Int -> ArrayT Word32 '[n,n] -foreign import javascript unsafe "h$easytensor_eyeUint8Clamped($1)" js_eyeWord8Clamped :: Int -> ArrayT Word8Clamped '[n,n] - - - - -instance (Fractional t, KnownNat n, ArrayT t '[n,n] ~ Array t '[n,n], 2 <= n) => MatrixInverse t n where - inverse (KnownDataFrame m) = KnownDataFrame $ js_inverse m (dimVal' @n) - -foreign import javascript unsafe "h$easytensor_inverse($1, $2)" js_inverse :: ArrayT t '[n,n] -> Int -> ArrayT t '[n,n] - - - - - - - - - - - - - - -unsafeFreezeArrayT# :: MutableArrayT s t ds -> State# s -> (# State# s, ArrayT t ds #) -unsafeFreezeArrayT# a s = (# s, coerce a #) -{-# INLINE unsafeFreezeArrayT# #-} - ---unsafeThawArrayT# :: ArrayT t ds -> State# s -> (#State# s, MutableArrayT s t ds #) ---unsafeThawArrayT# a s = (# s, coerce a #) ---{-# INLINE unsafeThawArrayT# #-} - - -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetFloat# :: Int# -> ArrayT Float ds -> Float# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetDouble# :: Int# -> ArrayT Double ds -> Double# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt# :: Int# -> ArrayT Int ds -> Int# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt8# :: Int# -> ArrayT Int8 ds -> Int# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt16# :: Int# -> ArrayT Int16 ds -> Int# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt32# :: Int# -> ArrayT Int32 ds -> Int# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord# :: Int# -> ArrayT Word ds -> Word# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord8# :: Int# -> ArrayT Word8 ds -> Word# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord8Clamped# :: Int# -> ArrayT Word8Clamped ds -> Int# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord16# :: Int# -> ArrayT Word16 ds -> Word# -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord32# :: Int# -> ArrayT Word32 ds -> Word# - - -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetFloat :: Int# -> ArrayT Float ds -> Float -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetDouble :: Int# -> ArrayT Double ds -> Double -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt :: Int# -> ArrayT Int ds -> Int -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt8 :: Int# -> ArrayT Int8 ds -> Int8 -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt16 :: Int# -> ArrayT Int16 ds -> Int16 -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetInt32 :: Int# -> ArrayT Int32 ds -> Int32 -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord :: Int# -> ArrayT Word ds -> Word -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord8 :: Int# -> ArrayT Word8 ds -> Word8 -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord8Clamped :: Int# -> ArrayT Word8Clamped ds -> Word8Clamped -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord16 :: Int# -> ArrayT Word16 ds -> Word16 -foreign import javascript unsafe "$2[$1]" js_indexArrayOffsetWord32 :: Int# -> ArrayT Word32 ds -> Word32 - - -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetFloat# :: Int# -> Float# -> ArrayT Float ds -> ArrayT Float ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetDouble# :: Int# -> Double# -> ArrayT Double ds -> ArrayT Double ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetInt# :: Int# -> Int# -> ArrayT Int ds -> ArrayT Int ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetInt8# :: Int# -> Int# -> ArrayT Int8 ds -> ArrayT Int8 ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetInt16# :: Int# -> Int# -> ArrayT Int16 ds -> ArrayT Int16 ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetInt32# :: Int# -> Int# -> ArrayT Int32 ds -> ArrayT Int32 ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetWord# :: Int# -> Word# -> ArrayT Word ds -> ArrayT Word ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetWord8# :: Int# -> Word# -> ArrayT Word8 ds -> ArrayT Word8 ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetWord8Clamped# :: Int# -> Int# -> ArrayT Word8Clamped ds -> ArrayT Word8Clamped ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetWord16# :: Int# -> Word# -> ArrayT Word16 ds -> ArrayT Word16 ds -foreign import javascript unsafe "$r = $3.slice(); $r[$1] = $2;" js_setArrayOffsetWord32# :: Int# -> Word# -> ArrayT Word32 ds -> ArrayT Word32 ds - - - - ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetFloat# :: Int# -> MutableArrayT s Float ds -> State# s -> (# State# s, Float# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetDouble# :: Int# -> MutableArrayT s Double ds -> State# s -> (# State# s, Double# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetInt# :: Int# -> MutableArrayT s Int ds -> State# s -> (# State# s, Int# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetInt8# :: Int# -> MutableArrayT s Int8 ds -> State# s -> (# State# s, Int# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetInt16# :: Int# -> MutableArrayT s Int16 ds -> State# s -> (# State# s, Int# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetInt32# :: Int# -> MutableArrayT s Int32 ds -> State# s -> (# State# s, Int# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetWord# :: Int# -> MutableArrayT s Word ds -> State# s -> (# State# s, Word# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetWord8# :: Int# -> MutableArrayT s Word8 ds -> State# s -> (# State# s, Word# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetWord8Clamped# :: Int# -> MutableArrayT s Word8Clamped ds -> State# s -> (# State# s, Int# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetWord16# :: Int# -> MutableArrayT s Word16 ds -> State# s -> (# State# s, Word# #) ---foreign import javascript unsafe "$2[$1]" js_readArrayOffsetWord32# :: Int# -> MutableArrayT s Word32 ds -> State# s -> (# State# s, Word# #) - - -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetFloat# :: Int# -> Float# -> MutableArrayT s Float ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetDouble# :: Int# -> Double# -> MutableArrayT s Double ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetInt# :: Int# -> Int# -> MutableArrayT s Int ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetInt8# :: Int# -> Int# -> MutableArrayT s Int8 ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetInt16# :: Int# -> Int# -> MutableArrayT s Int16 ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetInt32# :: Int# -> Int# -> MutableArrayT s Int32 ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetWord# :: Int# -> Word# -> MutableArrayT s Word ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetWord8# :: Int# -> Word# -> MutableArrayT s Word8 ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetWord8Clamped# :: Int# -> Int# -> MutableArrayT s Word8Clamped ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetWord16# :: Int# -> Word# -> MutableArrayT s Word16 ds -> State# s -> State# s -foreign import javascript unsafe "$3[$1] = $2;" js_writeArrayOffsetWord32# :: Int# -> Word# -> MutableArrayT s Word32 ds -> State# s -> State# s - - - - - - - - ------------------------------------------------------------------------------ --- Conversions between types ------------------------------------------------------------------------------ - - - - -foreign import javascript unsafe "$1.length" js_length :: ArrayT t ds -> Int# -foreign import javascript unsafe "$1.byteOffset" js_byteOffset :: ArrayT t ds -> Int# ---foreign import javascript unsafe "$1.byteLength" js_byteLength :: ArrayT t ds -> Int# - - ---foreign import javascript unsafe "$1.length" js_lengthM :: MutableArrayT s t ds -> State# s -> (# State# s, Int# #) ---foreign import javascript unsafe "$1.byteOffset" js_byteOffsetM :: MutableArrayT s t ds -> State# s -> (# State# s, Int# #) ---foreign import javascript unsafe "$1.byteLength" js_byteLengthM :: MutableArrayT s t ds -> State# s -> (# State# s, Int# #) - -foreign import javascript unsafe "h$wrapBuffer($1.buffer)" js_wrapArrayT :: ArrayT t ds -> ByteArray# ---foreign import javascript unsafe "h$wrapBuffer($1.buffer)" js_wrapMutableArrayT :: MutableArrayT s t ds -> State# s -> (# State# s, MutableByteArray# s #) --- --- ---foreign import javascript unsafe "$1.f3 || new Float32Array($1.buf)" js_unwrapFloatArray :: ByteArray# -> ArrayT Float ds ---foreign import javascript unsafe "$1.f6 || new Float64Array($1.buf)" js_unwrapDoubleArray :: ByteArray# -> ArrayT Double ds ---foreign import javascript unsafe "$1.i3 || new Int32Array($1.buf)" js_unwrapIntArray :: ByteArray# -> ArrayT Int ds ---foreign import javascript unsafe "$1.i3 || new Int32Array($1.buf)" js_unwrapInt32Array :: ByteArray# -> ArrayT Int32 ds ---foreign import javascript unsafe "$1.i1 || new Int16Array($1.buf)" js_unwrapInt16Array :: ByteArray# -> ArrayT Int16 ds ---foreign import javascript unsafe "$1.i8 || new Int8Array($1.buf)" js_unwrapInt8Array :: ByteArray# -> ArrayT Int8 ds ---foreign import javascript unsafe "$1.u3 || new Uint32Array($1.buf)" js_unwrapWordArray :: ByteArray# -> ArrayT Word ds ---foreign import javascript unsafe "$1.u3 || new Uint32Array($1.buf)" js_unwrapWord32Array :: ByteArray# -> ArrayT Word32 ds ---foreign import javascript unsafe "$1.u1 || new Uint16Array($1.buf)" js_unwrapWord16Array :: ByteArray# -> ArrayT Word16 ds ---foreign import javascript unsafe "$1.u8 || new Uint8Array($1.buf)" js_unwrapWord8Array :: ByteArray# -> ArrayT Word8 ds ---foreign import javascript unsafe "$1.uc || new Uint8ClampedArray($1.buf)" js_unwrapWord8ClampedArray :: ByteArray# -> ArrayT Word8Clamped ds - - - -foreign import javascript unsafe "new Float32Array($1.buf, $2*4, $3)" js_unwrapFloatArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Float ds -foreign import javascript unsafe "new Float64Array($1.buf, $2*8, $3)" js_unwrapDoubleArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Double ds -foreign import javascript unsafe "new Int32Array($1.buf, $2*4, $3)" js_unwrapIntArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Int ds -foreign import javascript unsafe "new Int32Array($1.buf, $2*4, $3)" js_unwrapInt32ArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Int32 ds -foreign import javascript unsafe "new Int16Array($1.buf, $2*2, $3)" js_unwrapInt16ArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Int16 ds -foreign import javascript unsafe "new Int8Array($1.buf, $2, $3)" js_unwrapInt8ArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Int8 ds -foreign import javascript unsafe "new Uint32Array($1.buf, $2*4, $3)" js_unwrapWordArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Word ds -foreign import javascript unsafe "new Uint32Array($1.buf, $2*4, $3)" js_unwrapWord32ArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Word32 ds -foreign import javascript unsafe "new Uint16Array($1.buf, $2*2, $3)" js_unwrapWord16ArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Word16 ds -foreign import javascript unsafe "new Uint8Array($1.buf, $2, $3)" js_unwrapWord8ArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Word8 ds -foreign import javascript unsafe "new Uint8ClampedArray($1.buf, $2, $3)" js_unwrapWord8ClampedArrayOffLen :: ByteArray# -> Int# -> Int# -> ArrayT Word8Clamped ds - - ---foreign import javascript unsafe "$1.i3 || new Int32Array($1.buf)" js_unwrapMutableIntArray :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Int ds #) ---foreign import javascript unsafe "$1.i3 || new Int32Array($1.buf)" js_unwrapMutableInt32Array :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Int32 ds #) ---foreign import javascript unsafe "$1.i1 || new Int16Array($1.buf)" js_unwrapMutableInt16Array :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Int16 ds #) ---foreign import javascript unsafe "$1.i8 || new Int8Array($1.buf)" js_unwrapMutableInt8Array :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Int8 ds #) ---foreign import javascript unsafe "$1.u3 || new Uint32Array($1.buf)" js_unwrapMutableWordArray :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Word ds #) ---foreign import javascript unsafe "$1.u3 || new Uint32Array($1.buf)" js_unwrapMutableWord32Array :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Word32 ds #) ---foreign import javascript unsafe "$1.u1 || new Uint16Array($1.buf)" js_unwrapMutableWord16Array :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Word16 ds #) ---foreign import javascript unsafe "$1.u8 || new Uint8Array($1.buf)" js_unwrapMutableWord8Array :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Word8 ds #) ---foreign import javascript unsafe "$1.f3 || new Float32Array($1.buf)" js_unwrapMutableFloatArray :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Float ds #) ---foreign import javascript unsafe "$1.f6 || new Float64Array($1.buf)" js_unwrapMutableDoubleArray :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Double ds #) ---foreign import javascript unsafe "$1.uc || new Uint8ClampedArray($1.buf)" js_unwrapMutableWord8ClampedArray :: MutableByteArray# s -> State# s -> (# State# s, MutableArrayT s Word8Clamped ds #) - - - ------------------------------------------------------------------------------ --- Create new arrays ------------------------------------------------------------------------------ - -foreign import javascript unsafe "new Float32Array($1)" js_createFloatArray :: Int# -> State# s -> (# State# s, MutableArrayT s Float ds #) -foreign import javascript unsafe "new Float64Array($1)" js_createDoubleArray :: Int# -> State# s -> (# State# s, MutableArrayT s Double ds #) -foreign import javascript unsafe "new Int32Array($1)" js_createIntArray :: Int# -> State# s -> (# State# s, MutableArrayT s Int ds #) -foreign import javascript unsafe "new Int32Array($1)" js_createInt32Array :: Int# -> State# s -> (# State# s, MutableArrayT s Int32 ds #) -foreign import javascript unsafe "new Int16Array($1)" js_createInt16Array :: Int# -> State# s -> (# State# s, MutableArrayT s Int16 ds #) -foreign import javascript unsafe "new Int8Array($1)" js_createInt8Array :: Int# -> State# s -> (# State# s, MutableArrayT s Int8 ds #) -foreign import javascript unsafe "new Uint32Array($1)" js_createWordArray :: Int# -> State# s -> (# State# s, MutableArrayT s Word ds #) -foreign import javascript unsafe "new Uint32Array($1)" js_createWord32Array :: Int# -> State# s -> (# State# s, MutableArrayT s Word32 ds #) -foreign import javascript unsafe "new Uint16Array($1)" js_createWord16Array :: Int# -> State# s -> (# State# s, MutableArrayT s Word16 ds #) -foreign import javascript unsafe "new Uint8Array($1)" js_createWord8Array :: Int# -> State# s -> (# State# s, MutableArrayT s Word8 ds #) -foreign import javascript unsafe "new Uint8ClampedArray($1)" js_createWord8ClampedArray :: Int# -> State# s -> (# State# s, MutableArrayT s Word8Clamped ds #) - -foreign import javascript unsafe "new Float32Array($1).fill($2)" js_fillNewFloatArray :: Int -> Float -> ArrayT Float ds -foreign import javascript unsafe "new Float64Array($1).fill($2)" js_fillNewDoubleArray :: Int -> Double -> ArrayT Double ds -foreign import javascript unsafe "new Int32Array($1).fill($2)" js_fillNewIntArray :: Int -> Int -> ArrayT Int ds -foreign import javascript unsafe "new Int32Array($1).fill($2)" js_fillNewInt32Array :: Int -> Int32 -> ArrayT Int32 ds -foreign import javascript unsafe "new Int16Array($1).fill($2)" js_fillNewInt16Array :: Int -> Int16 -> ArrayT Int16 ds -foreign import javascript unsafe "new Int8Array($1).fill($2)" js_fillNewInt8Array :: Int -> Int8 -> ArrayT Int8 ds -foreign import javascript unsafe "new Uint32Array($1).fill($2)" js_fillNewWordArray :: Int -> Word -> ArrayT Word ds -foreign import javascript unsafe "new Uint32Array($1).fill($2)" js_fillNewWord32Array :: Int -> Word32 -> ArrayT Word32 ds -foreign import javascript unsafe "new Uint16Array($1).fill($2)" js_fillNewWord16Array :: Int -> Word16 -> ArrayT Word16 ds -foreign import javascript unsafe "new Uint8Array($1).fill($2)" js_fillNewWord8Array :: Int -> Word8 -> ArrayT Word8 ds -foreign import javascript unsafe "new Uint8ClampedArray($1).fill($2)" js_fillNewWord8ClampedArray :: Int -> Word8Clamped -> ArrayT Word8Clamped ds - - - - - --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Float32Array(arr.length); $r.set(arr);" js_fromListFloatArray :: Exts.Any -> ArrayT Float ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Float64Array(arr.length); $r.set(arr);" js_fromListDoubleArray :: Exts.Any -> ArrayT Double ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Int32Array(arr.length); $r.set(arr);" js_fromListIntArray :: Exts.Any -> ArrayT Int ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Int32Array(arr.length); $r.set(arr);" js_fromListInt32Array :: Exts.Any -> ArrayT Int32 ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Int16Array(arr.length); $r.set(arr);" js_fromListInt16Array :: Exts.Any -> ArrayT Int16 ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Int8Array(arr.length); $r.set(arr);" js_fromListInt8Array :: Exts.Any -> ArrayT Int8 ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Uint32Array(arr.length); $r.set(arr);" js_fromListWordArray :: Exts.Any -> ArrayT Word ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Uint32Array(arr.length); $r.set(arr);" js_fromListWord32Array :: Exts.Any -> ArrayT Word32 ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Uint16Array(arr.length); $r.set(arr);" js_fromListWord16Array :: Exts.Any -> ArrayT Word16 ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Uint8Array(arr.length); $r.set(arr);" js_fromListWord8Array :: Exts.Any -> ArrayT Word8 ds --- foreign import javascript unsafe "var arr = LikeHS.listToArrayNoUnwrap($1); $r = new Uint8ClampedArray(arr.length); $r.set(arr);" js_fromListWord8ClampedArray :: Exts.Any -> ArrayT Word8Clamped ds - - --- foreign import javascript unsafe "$r = new Float32Array($1.length); $r.set($1);" js_fromArrayFloatArray :: SomeTypedArray m0 t -> ArrayT Float ds --- foreign import javascript unsafe "new Float32Array($1)" js_viewFloatArray :: SomeArrayBuffer m -> ArrayT Float ds --- --- foreign import javascript unsafe "$r = new Float64Array($1.length); $r.set($1);" js_fromArrayDoubleArray :: SomeTypedArray m0 t -> ArrayT Double ds --- foreign import javascript unsafe "new Float64Array($1)" js_viewDoubleArray :: SomeArrayBuffer m -> ArrayT Double ds --- --- foreign import javascript unsafe "$r = new Int32Array($1.length); $r.set($1);" js_fromArrayIntArray :: SomeTypedArray m0 t -> ArrayT Int ds --- foreign import javascript unsafe "new Int32Array($1)" js_viewIntArray :: SomeArrayBuffer m -> ArrayT Int ds --- --- foreign import javascript unsafe "$r = new Int32Array($1.length); $r.set($1);" js_fromArrayInt32Array :: SomeTypedArray m0 t -> ArrayT Int32 ds --- foreign import javascript unsafe "new Int32Array($1)" js_viewInt32Array :: SomeArrayBuffer m -> ArrayT Int32 ds --- --- foreign import javascript unsafe "$r = new Int16Array($1.length); $r.set($1);" js_fromArrayInt16Array :: SomeTypedArray m0 t -> ArrayT Int16 ds --- foreign import javascript unsafe "new Int16Array($1)" js_viewInt16Array :: SomeArrayBuffer m -> ArrayT Int16 ds --- --- foreign import javascript unsafe "$r = new Int8Array($1.length); $r.set($1);" js_fromArrayInt8Array :: SomeTypedArray m0 t -> ArrayT Int8 ds --- foreign import javascript unsafe "new Int8Array($1)" js_viewInt8Array :: SomeArrayBuffer m -> ArrayT Int8 ds --- --- foreign import javascript unsafe "$r = new Uint32Array($1.length); $r.set($1);" js_fromArrayWordArray :: SomeTypedArray m0 t -> ArrayT Word ds --- foreign import javascript unsafe "new Uint32Array($1)" js_viewWordArray :: SomeArrayBuffer m -> ArrayT Word ds --- --- foreign import javascript unsafe "$r = new Uint32Array($1.length); $r.set($1);" js_fromArrayWord32Array :: SomeTypedArray m0 t -> ArrayT Word32 ds --- foreign import javascript unsafe "new Uint32Array($1)" js_viewWord32Array :: SomeArrayBuffer m -> ArrayT Word32 ds --- --- foreign import javascript unsafe "$r = new Uint16Array($1.length); $r.set($1);" js_fromArrayWord16Array :: SomeTypedArray m0 t -> ArrayT Word16 ds --- foreign import javascript unsafe "new Uint16Array($1)" js_viewWord16Array :: SomeArrayBuffer m -> ArrayT Word16 ds --- --- foreign import javascript unsafe "$r = new Uint8Array($1.length); $r.set($1);" js_fromArrayWord8Array :: SomeTypedArray m0 t -> ArrayT Word8 ds --- foreign import javascript unsafe "new Uint8Array($1)" js_viewWord8Array :: SomeArrayBuffer m -> ArrayT Word8 ds --- --- foreign import javascript unsafe "$r = new Uint8ClampedArray($1.length); $r.set($1);" js_fromArrayWord8ClampedArray :: SomeTypedArray m0 t -> ArrayT Word8Clamped ds --- foreign import javascript unsafe "new Uint8ClampedArray($1)" js_viewWord8ClampedArray :: SomeArrayBuffer m -> ArrayT Word8Clamped ds diff --git a/src-ghcjs/Numeric/Array/Family/ArrayT.js b/src-ghcjs/Numeric/Array/Family/ArrayT.js deleted file mode 100644 --- a/src-ghcjs/Numeric/Array/Family/ArrayT.js +++ /dev/null @@ -1,488 +0,0 @@ - -// hypot may be not supported on old browsers and IE -// https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/hypot -Math.hypot = Math.hypot || function() { - var y = 0; - var length = arguments.length; - - for (var i = 0; i < length; i++) { - if (arguments[i] === Infinity || arguments[i] === -Infinity) { - return Infinity; - } - y += arguments[i] * arguments[i]; - } - return Math.sqrt(y); -}; - - -// ---------------------------------------------------------------------------------------- // -// --- Polyfills for partially missing math functions ------------------------------------- // -// ---------------------------------------------------------------------------------------- // - -Math.hypot = Math.hypot || function() { - var y = 0; - var length = arguments.length; - - for (var i = 0; i < length; i++) { - if (arguments[i] === Infinity || arguments[i] === -Infinity) { - return Infinity; - } - y += arguments[i] * arguments[i]; - } - return Math.sqrt(y); -}; -Math.tanh = Math.tanh || function(x){ - var a = Math.exp(+x), b = Math.exp(-x); - return a == Infinity ? 1 : b == Infinity ? -1 : (a - b) / (a + b); -}; -Math.atanh = Math.atanh || function(x) { - return Math.log((1+x)/(1-x)) / 2; -}; -Math.acosh = Math.acosh || function(x) { - return Math.log(x + Math.sqrt(x * x - 1)); -}; -Math.asinh = Math.asinh || function(x) { - if (x === -Infinity) { - return x; - } else { - return Math.log(x + Math.sqrt(x * x + 1)); - } -}; -Math.cosh = Math.cosh || function(x) { - var y = Math.exp(x); - return (y + 1 / y) / 2; -}; -Math.sinh = Math.sinh || function(x) { - var y = Math.exp(x); - return (y - 1 / y) / 2; -}; - -// ---------------------------------------------------------------------------------------- // -// --- Polyfills for partially missing typed array functions ------------------------------ // -// ---------------------------------------------------------------------------------------- // - -(function () { - -function polyfill_map(q) { - if (!q.prototype.map) { - q.prototype.map = function(f) { - var y = new this.constructor(this.length); - for(var i = 0; i < this.length; i++) { - y[i] = f(this[i],i,this); - } - return y; - }; - } -} -function polyfill_fill(q) { - if (!q.prototype.fill) { - q.prototype.fill = function(val, start, end) { - start = start === undefined ? 0 : (start < 0 ? this.length - start : start); - end = end === undefined ? this.length : (end < 0 ? this.length - end : end); - for(var i = start; i < end; i++) { - this[i] = val; - } - return this; - }; - } -} -function polyfill_reduce(q) { - if (!q.prototype.reduce) { - q.prototype.reduce = function(f, y0) { - var i0 = y0 === undefined ? 1 : 0, - y = i0 === 1 ? this[0] : y0; - for(var i = i0; i < this.length; i++) { - y = f(y,this[i],i,this); - } - return y; - }; - } -} -function polyfill_slice(q) { - if (!q.prototype.slice) { - q.prototype.slice = function(start, end) { - start = start === undefined ? 0 : (start < 0 ? this.length - start : start); - end = end === undefined ? this.length : (end < 0 ? this.length - end : end); - var xview = this.subarray(start, end), - y = new xview.constructor(xview.length); - y.set(xview); - return y; - }; - } -} -function polyfill_every(q) { - if (!q.prototype.every) { - q.prototype.every = function(f) { - if (this.length === 0) return true; - for(var i = 0; i < this.length; i++) { - if (!f(this[i],i,this)) { return false; } - } - return true; - }; - } -} -function polyfill_some(q) { - if (!q.prototype.some) { - q.prototype.some = function(f) { - if (this.length === 0) return false; - for(var i = 0; i < this.length; i++) { - if (f(this[i],i,this)) { return true; } - } - return false; - }; - } -} - - -var methods = [polyfill_map, polyfill_fill, polyfill_reduce, polyfill_slice, polyfill_every, polyfill_some]; - -if (typeof Int8Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Int8Array); } -} -if (typeof Uint8Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Uint8Array); } -} -if (typeof Uint8ClampedArray !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Uint8ClampedArray); } -} -if (typeof Int16Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Int16Array); } -} -if (typeof Uint16Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Uint16Array); } -} -if (typeof Int32Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Int32Array); } -} -if (typeof Uint32Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Uint32Array); } -} -if (typeof Float32Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Float32Array); } -} -if (typeof Float64Array !== 'undefined') { - for (var i = methods.length; i--;) { methods[i](Float64Array); } -} - -}()); - -// ---------------------------------------------------------------------------------------- // - - -function h$easytensor_transpose(n, mat) { - 'use strict'; - var nmat = new mat.constructor(mat.length), - m = Math.round(mat.length / n); - for(var i = 0; i < n; i++) { - for(var j = 0; j < m; j++) { - nmat[i*m+j] = mat[j*n+i]; - } - } - return nmat; -} - -function h$easytensor_eyeFloat32(n) { - 'use strict'; - var mat = new Float32Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeFloat64(n) { - 'use strict'; - var mat = new Float64Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeInt8(n) { - 'use strict'; - var mat = new Int8Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeInt16(n) { - 'use strict'; - var mat = new Int16Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeInt32(n) { - 'use strict'; - var mat = new Int32Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeUint8(n) { - 'use strict'; - var mat = new Uint8Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeUint8Clamped(n) { - 'use strict'; - var mat = new Uint8ClampedArray(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeUint16(n) { - 'use strict'; - var mat = new Uint16Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} -function h$easytensor_eyeUint32(n) { - 'use strict'; - var mat = new Uint32Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} - return mat; -} - - -function h$easytensor_diagFloat32(n,x) { - 'use strict'; - 'use strict'; - var mat = new Float32Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagFloat64(n,x) { - 'use strict'; - var mat = new Float64Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagInt8(n,x) { - 'use strict'; - var mat = new Int8Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagInt16(n,x) { - 'use strict'; - var mat = new Int16Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagInt32(n,x) { - 'use strict'; - var mat = new Int32Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagUint8(n,x) { - 'use strict'; - var mat = new Uint8Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagUint8Clamped(n,x) { - 'use strict'; - var mat = new Uint8ClampedArray(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagUint16(n,x) { - 'use strict'; - var mat = new Uint16Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} -function h$easytensor_diagUint32(n,x) { - 'use strict'; - var mat = new Uint32Array(n*n); - for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} - return mat; -} - -function h$easytensor_trace(mat, n) { - 'use strict'; - var r = 0; - for(var i = 0; i < n*n; i += n + 1){r+=mat[i];} - return r; -} - - -function h$easytensor_det(mat, n) { - 'use strict'; - switch (n) { - case 1: - return mat[0]; - case 2: - return h$easytensor_detJSMat2(mat); - case 3: - return h$easytensor_detJSMat3(mat); - case 4: - return h$easytensor_detJSMat4(mat); - default: - throw "Determinant for n = " + n + " is not implemented or does not make sense."; - } -} - -function h$easytensor_detJSMat2(mat) { - 'use strict'; - return (mat[0]*mat[3] - mat[1]*mat[2]); -} - -function h$easytensor_detJSMat3(mat) { - 'use strict'; - return ( - mat[0]*(mat[4]*mat[8]-mat[5]*mat[7]) - - mat[1]*(mat[3]*mat[8]-mat[5]*mat[6]) - + mat[2]*(mat[3]*mat[7]-mat[4]*mat[6]) - ); -} - -function h$easytensor_detJSMat4(mat) { - 'use strict'; - var n11 = mat[ 0 ], n12 = mat[ 4 ], n13 = mat[ 8 ], n14 = mat[ 12 ]; - var n21 = mat[ 1 ], n22 = mat[ 5 ], n23 = mat[ 9 ], n24 = mat[ 13 ]; - var n31 = mat[ 2 ], n32 = mat[ 6 ], n33 = mat[ 10 ], n34 = mat[ 14 ]; - var n41 = mat[ 3 ], n42 = mat[ 7 ], n43 = mat[ 11 ], n44 = mat[ 15 ]; - - return ( - n41 * ( - + n14 * n23 * n32 - - n13 * n24 * n32 - - n14 * n22 * n33 - + n12 * n24 * n33 - + n13 * n22 * n34 - - n12 * n23 * n34 - ) + - n42 * ( - + n11 * n23 * n34 - - n11 * n24 * n33 - + n14 * n21 * n33 - - n13 * n21 * n34 - + n13 * n24 * n31 - - n14 * n23 * n31 - ) + - n43 * ( - + n11 * n24 * n32 - - n11 * n22 * n34 - - n14 * n21 * n32 - + n12 * n21 * n34 - + n14 * n22 * n31 - - n12 * n24 * n31 - ) + - n44 * ( - - n13 * n22 * n31 - - n11 * n23 * n32 - + n11 * n22 * n33 - + n13 * n21 * n32 - - n12 * n21 * n33 - + n12 * n23 * n31 - ) - ); -} - - - - -function h$easytensor_inverse(mat, n) { - 'use strict'; - switch (n) { - case 1: - return 1 / mat[0]; - case 2: - return h$easytensor_inverseJSM2(mat); - case 3: - return h$easytensor_inverseJSM3(mat); - case 4: - return h$easytensor_inverseJSM4(mat); - default: - throw "Inverse for n = " + n + " is not implemented or does not make sense."; - } -} - - -function h$easytensor_inverseJSM4(mat) { - 'use strict'; - var rez = new mat.constructor(16); - rez[0] = mat[13]*(mat[ 6]*mat[11]-mat[10]*mat[ 7])+mat[ 9]*(mat[14]*mat[ 7]-mat[ 6]*mat[15])+mat[ 5]*(mat[10]*mat[15]-mat[14]*mat[11]); - rez[4] = mat[12]*(mat[10]*mat[ 7]-mat[ 6]*mat[11])+mat[ 8]*(mat[ 6]*mat[15]-mat[14]*mat[ 7])+mat[ 4]*(mat[14]*mat[11]-mat[10]*mat[15]); - rez[8] = mat[12]*(mat[ 5]*mat[11]-mat[ 9]*mat[ 7])+mat[ 8]*(mat[13]*mat[ 7]-mat[ 5]*mat[15])+mat[ 4]*(mat[ 9]*mat[15]-mat[13]*mat[11]); - rez[12] = mat[12]*(mat[ 9]*mat[ 6]-mat[ 5]*mat[10])+mat[ 8]*(mat[ 5]*mat[14]-mat[13]*mat[ 6])+mat[ 4]*(mat[13]*mat[10]-mat[ 9]*mat[14]); - rez[1] = mat[13]*(mat[10]*mat[ 3]-mat[ 2]*mat[11])+mat[ 9]*(mat[ 2]*mat[15]-mat[14]*mat[ 3])+mat[ 1]*(mat[14]*mat[11]-mat[10]*mat[15]); - rez[5] = mat[12]*(mat[ 2]*mat[11]-mat[10]*mat[ 3])+mat[ 8]*(mat[14]*mat[ 3]-mat[ 2]*mat[15])+mat[ 0]*(mat[10]*mat[15]-mat[14]*mat[11]); - rez[9] = mat[12]*(mat[ 9]*mat[ 3]-mat[ 1]*mat[11])+mat[ 8]*(mat[ 1]*mat[15]-mat[13]*mat[ 3])+mat[ 0]*(mat[13]*mat[11]-mat[ 9]*mat[15]); - rez[13] = mat[12]*(mat[ 1]*mat[10]-mat[ 9]*mat[ 2])+mat[ 8]*(mat[13]*mat[ 2]-mat[ 1]*mat[14])+mat[ 0]*(mat[ 9]*mat[14]-mat[13]*mat[10]); - rez[2] = mat[13]*(mat[ 2]*mat[ 7]-mat[ 6]*mat[ 3])+mat[ 5]*(mat[14]*mat[ 3]-mat[ 2]*mat[15])+mat[ 1]*(mat[ 6]*mat[15]-mat[14]*mat[ 7]); - rez[6] = mat[12]*(mat[ 6]*mat[ 3]-mat[ 2]*mat[ 7])+mat[ 4]*(mat[ 2]*mat[15]-mat[14]*mat[ 3])+mat[ 0]*(mat[14]*mat[ 7]-mat[ 6]*mat[15]); - rez[10] = mat[12]*(mat[ 1]*mat[ 7]-mat[ 5]*mat[ 3])+mat[ 4]*(mat[13]*mat[ 3]-mat[ 1]*mat[15])+mat[ 0]*(mat[ 5]*mat[15]-mat[13]*mat[ 7]); - rez[14] = mat[12]*(mat[ 5]*mat[ 2]-mat[ 1]*mat[ 6])+mat[ 4]*(mat[ 1]*mat[14]-mat[13]*mat[ 2])+mat[ 0]*(mat[13]*mat[ 6]-mat[ 5]*mat[14]); - rez[3] = mat[ 9]*(mat[ 6]*mat[ 3]-mat[ 2]*mat[ 7])+mat[ 5]*(mat[ 2]*mat[11]-mat[10]*mat[ 3])+mat[ 1]*(mat[10]*mat[ 7]-mat[ 6]*mat[11]); - rez[7] = mat[ 8]*(mat[ 2]*mat[ 7]-mat[ 6]*mat[ 3])+mat[ 4]*(mat[10]*mat[ 3]-mat[ 2]*mat[11])+mat[ 0]*(mat[ 6]*mat[11]-mat[10]*mat[ 7]); - rez[11] = mat[ 8]*(mat[ 5]*mat[ 3]-mat[ 1]*mat[ 7])+mat[ 4]*(mat[ 1]*mat[11]-mat[ 9]*mat[ 3])+mat[ 0]*(mat[ 9]*mat[ 7]-mat[ 5]*mat[11]); - rez[15] = mat[ 8]*(mat[ 1]*mat[ 6]-mat[ 5]*mat[ 2])+mat[ 4]*(mat[ 9]*mat[ 2]-mat[ 1]*mat[10])+mat[ 0]*(mat[ 5]*mat[10]-mat[ 9]*mat[ 6]); - var det = mat[ 0]*rez[ 0] + mat[ 1]*rez[ 4] + mat[ 2]*rez[ 8] + mat[3]*rez[12]; - if (det === 0) { - return undefined; - } else { - for(var i = 0; i < 16; i++) {rez[i] /= det;} - return rez; - } -} - -function h$easytensor_inverseJSM3(mat) { - 'use strict'; - var rez = new mat.constructor(9); - rez[0] = mat[4]*mat[8] - mat[7]*mat[5]; - rez[3] = mat[6]*mat[5] - mat[3]*mat[8]; - rez[6] = mat[3]*mat[7] - mat[6]*mat[4]; - rez[1] = mat[7]*mat[2] - mat[1]*mat[8]; - rez[4] = mat[0]*mat[8] - mat[6]*mat[2]; - rez[7] = mat[6]*mat[1] - mat[0]*mat[7]; - rez[2] = mat[1]*mat[5] - mat[4]*mat[2]; - rez[5] = mat[3]*mat[2] - mat[0]*mat[5]; - rez[8] = mat[0]*mat[4] - mat[3]*mat[1]; - var det = mat[0]*rez[0] + mat[1]*rez[3] + mat[2]*rez[6]; - if (det === 0) { - return undefined; - } else { - for(var i = 0; i < 9; i++) {rez[i] /= det;} - return rez; - } -} - -function h$easytensor_inverseJSM2(mat) { - 'use strict'; - var det = mat[0]*mat[3] - mat[1]*mat[2]; - if (det === 0) { - return undefined; - } - var rez = new mat.constructor(4); - rez[0] = mat[3]/det; - rez[2] = -mat[1]/det; - rez[1] = -mat[2]/det; - rez[3] = mat[0]/det; - return rez; -} - - -function h$easytensor_contract(n,m,k,lhs,rhs) { - 'use strict'; - var t, rez = new lhs.constructor(n*k); - for(var i = 0; i < n; i++) { - for(var j = 0; j < k; j++) { - t = 0; - for(var l = 0; l < m; l++) { - t += lhs[i+l*n]*rhs[l+j*m]; - } - rez[i+j*n] = t; - } - } - return rez; -} - - -function h$easytensor_dot(lhs, rhs) { - 'use strict'; - return lhs.reduce(function (r, e, i) { return r + e*rhs[i];}, 0); -} - -function h$easytensor_cross(a, b) { - 'use strict'; - return [ a[1]*b[2]-a[2]*b[1] - , a[2]*b[0]-a[0]*b[2] - , a[0]*b[1]-a[1]*b[0] - ]; -} diff --git a/src-ghcjs/Numeric/DataFrame/Contraction.hs b/src-ghcjs/Numeric/DataFrame/Contraction.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/DataFrame/Contraction.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE GHCForeignImportPrim #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Contraction --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- This modules provides generalization of a matrix product: --- tensor-like contraction. --- For matrices and vectors this is a normal matrix*matrix or vector*matrix or matrix*vector product, --- for larger dimensions it calculates the scalar product of "adjacent" dimesnions of a tensor. --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Contraction - ( Contraction (..), (%*) - ) where - -import Data.Type.Equality ((:~:) (..)) -import GHC.Prim -import GHC.Types (Int (..), Type) -import Unsafe.Coerce (unsafeCoerce) - -import Numeric.Array.Family -import Numeric.DataFrame.Type -import Numeric.Dimensions - - - -class ConcatList as bs asbs - => Contraction (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) - | asbs as -> bs, asbs bs -> as, as bs -> asbs where - -- | Generalization of a matrix product: take scalar product over one dimension - -- and, thus, concatenate other dimesnions - contract :: ( KnownDim m ) - => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs - --- | Tensor contraction. --- In particular: --- 1. matrix-matrix product --- 2. matrix-vector or vector-matrix product --- 3. dot product of two vectors. -(%*) :: ( ConcatList as bs (as ++ bs) - , Contraction t as bs asbs - , KnownDim m - ) => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t (as ++ bs) -(%*) = contract -{-# INLINE (%*) #-} -infixl 7 %* - -instance {-# OVERLAPPABLE #-} - ( ConcatList as bs asbs - , Dimensions as - , Dimensions bs - , asbs ~ (a' ': sbs') - ) => Contraction t as bs asbs where - contract :: forall m . KnownDim m => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs - contract dx dy - | Refl <- unsafeCoerce Refl :: Array t (as +: m) :~: ArrayT t (as +: m) - , Evidence <- inferConcatDimensions @as @bs - = KnownDataFrame $ js_contract @t @as @m @bs (dimVal (dim @as)) (dimVal' @m) (dimVal (dim @bs)) (coerce dx) (coerce dy) - - -foreign import javascript unsafe "h$easytensor_contract($1,$2,$3,$4,$5)" - js_contract :: forall t as m bs . Int -> Int -> Int -> ArrayT t (as +: m) -> ArrayT t (m :+ bs) -> ArrayT t (as ++ bs) - -instance {-# OVERLAPPING #-} - Contraction t '[] '[] '[] where - contract :: forall m . KnownDim m => DataFrame t '[m] -> DataFrame t '[m] -> DataFrame t ('[] :: [Nat]) - contract dx dy - = KnownDataFrame $ unsafeCoerce (js_contract0 (coerce dx) (coerce dy)) - -foreign import javascript unsafe "$1.reduce(function (r, e, i) { return e*$2[i] + r;}, 0)" - js_contract0 :: ArrayT t '[m] -> ArrayT t '[m] -> Any - - diff --git a/src-ghcjs/Numeric/DataFrame/Inference.hs b/src-ghcjs/Numeric/DataFrame/Inference.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/DataFrame/Inference.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Inference --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- The module provides data types and functions to infer typeclasses at runtime. --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Inference - ( PrimBytesEvidence, inferPrimBytes - , ElementWiseEvidence, inferElementWise - , NumericFrameEvidence, inferNumericFrame - ) where - -import Numeric.Array -import Numeric.Array.ElementWise -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions - - --- | Evidence for PrimBytes class -type PrimBytesEvidence t (ds :: [Nat]) - = Evidence (PrimBytes (DataFrame t ds)) - --- | Evidence for ElementWise class -type ElementWiseEvidence t (ds :: [Nat]) - = Evidence (ElementWise (Idx ds) t (DataFrame t ds)) - --- | Allow all common operations on available data frames -type NumericFrameEvidence t (ds :: [Nat]) - = Evidence ( NumericFrame t ds) - -inferPrimBytes :: forall t (ds :: [Nat]) - . ( ArrayInstanceInference t ds - , Dimensions ds - ) - => PrimBytesEvidence t ds -inferPrimBytes = case getArrayInstance @t @ds of - AIScalar -> case elemTypeInstance @t of - ETFloat -> Evidence - ETDouble -> Evidence - ETInt -> Evidence - ETInt8 -> Evidence - ETInt16 -> Evidence - ETInt32 -> Evidence - ETWord -> Evidence - ETWord8 -> Evidence - ETWord16 -> Evidence - ETWord32 -> Evidence - ETWord8C -> Evidence - AIArrayF -> Evidence - AIArrayD -> Evidence - AIArrayI -> Evidence - AIArrayI8 -> Evidence - AIArrayI16 -> Evidence - AIArrayI32 -> Evidence - AIArrayW -> Evidence - AIArrayW8 -> Evidence - AIArrayW16 -> Evidence - AIArrayW32 -> Evidence - AIArrayW8C -> Evidence - -inferElementWise :: forall t (ds :: [Nat]) - . ( ArrayInstanceInference t ds - , Dimensions ds - ) - => ElementWiseEvidence t ds -inferElementWise = case getArrayInstance @t @ds of - AIScalar -> Evidence - AIArrayF -> Evidence - AIArrayD -> Evidence - AIArrayI -> Evidence - AIArrayI8 -> Evidence - AIArrayI16 -> Evidence - AIArrayI32 -> Evidence - AIArrayW -> Evidence - AIArrayW8 -> Evidence - AIArrayW16 -> Evidence - AIArrayW32 -> Evidence - AIArrayW8C -> Evidence - - -inferNumericFrame :: forall t (ds :: [Nat]) - . ( ArrayInstanceInference t ds - , Dimensions ds - ) - => NumericFrameEvidence t ds -inferNumericFrame - | Evidence <- inferDimKnownDims @ds +!+ inferDimFiniteList @ds - = case getArrayInstance @t @ds of - AIScalar -> case elemTypeInstance @t of - ETFloat -> Evidence - ETDouble -> Evidence - ETInt -> Evidence - ETInt8 -> Evidence - ETInt16 -> Evidence - ETInt32 -> Evidence - ETWord -> Evidence - ETWord8 -> Evidence - ETWord16 -> Evidence - ETWord32 -> Evidence - ETWord8C -> Evidence - AIArrayF -> Evidence - AIArrayD -> Evidence - AIArrayI -> Evidence - AIArrayI8 -> Evidence - AIArrayI16 -> Evidence - AIArrayI32 -> Evidence - AIArrayW -> Evidence - AIArrayW8 -> Evidence - AIArrayW16 -> Evidence - AIArrayW32 -> Evidence - AIArrayW8C -> Evidence diff --git a/src-ghcjs/Numeric/DataFrame/Mutable.hs b/src-ghcjs/Numeric/DataFrame/Mutable.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/DataFrame/Mutable.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Mutable --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- Interfrace to perform primitive stateful operations on mutable frames. --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Mutable - ( MutableFrame (..), MDataFrame (..) - , newDataFrame#, copyDataFrame#, copyMDataFrame#, unsafeFreezeDataFrame# - , freezeDataFrame#, thawDataFrame# - , writeDataFrame#, readDataFrame# - , newArrayBuffer#, arrayBuffer#, viewFloatArray#, viewDoubleArray# - , viewIntArray#, viewInt32Array#, viewInt16Array#, viewInt8Array# - , viewWordArray#, viewWord32Array#, viewWord16Array#, viewWord8Array#, viewWord8ClampedArray# - ) where - - - -import GHCJS.Types (IsJSVal(), JSVal) -import GHC.Int (Int16 (..), Int32 (..),Int8 (..)) -import GHC.Prim -import GHC.Types (Double (..), Float (..), Int (..), Word (..)) -import GHC.Word (Word16 (..), Word32 (..), Word8 (..)) -import Unsafe.Coerce (unsafeCoerce) - -import Numeric.DataFrame.Type -import Numeric.Array.Family -import Numeric.Dimensions - - --- | Mutable DataFrame type -newtype MDataFrame s t (ns :: [Nat]) = MDataFrame (MutableArrayT s t ns) -instance IsJSVal (MDataFrame s t ds) - - --- | Create a new mutable DataFrame. -newDataFrame# :: forall t (ns :: [Nat]) s - . (ElemTypeInference t, Dimensions ns) - => State# s -> (# State# s, MDataFrame s t ns #) -newDataFrame# = case elemTypeInstance @t of - ETFloat -> js_createFloatArray n - ETDouble -> js_createDoubleArray n - ETInt -> js_createIntArray n - ETInt8 -> js_createInt8Array n - ETInt16 -> js_createInt16Array n - ETInt32 -> js_createInt32Array n - ETWord -> js_createWordArray n - ETWord8 -> js_createWord8Array n - ETWord16 -> js_createWord16Array n - ETWord32 -> js_createWord32Array n - ETWord8C -> js_createWord8ClampedArray n - where - n = dimVal (dim @ns) -{-# INLINE newDataFrame# #-} - - --- | Copy one DataFrame into another mutable DataFrame at specified position. -copyDataFrame# :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) s - . ( ArraySizeInference (as +: b') - , ConcatList as (b :+ bs) asbs - , Dimensions as - , Dimensions (b :+ bs) - ) - => DataFrame t (as +: b') -> Idx (b :+ bs) -> MDataFrame s t asbs -> State# s -> (# State# s, () #) -copyDataFrame# df i mdf s0 = case arraySizeInstance @(as +: b') of - ASScalar -> df `seq` (# js_writeArrayOffsetJSVal# mdf (fromEnum i) (unsafeCoerce df) s0, () #) - ASArray -> js_copyDataFrame (coerce df) (fromEnum i * dimVal (dim @as)) mdf s0 -{-# INLINE copyDataFrame# #-} - - - --- | Copy one mutable DataFrame into another mutable DataFrame at specified position. -copyMDataFrame# :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) s - . ( ConcatList as (b :+ bs) asbs - , Dimensions as - , Dimensions (b :+ bs) - ) - => MDataFrame s t (as +: b') -> Idx (b :+ bs) -> MDataFrame s t asbs -> State# s -> (# State# s, () #) -copyMDataFrame# d i = js_copyMDataFrame d (fromEnum i * dimVal (dim @as)) -{-# INLINE copyMDataFrame# #-} - - --- | Make a mutable DataFrame immutable, without copying. -unsafeFreezeDataFrame# :: forall t (ns :: [Nat]) s - . (MutableFrame t ns, ArraySizeInference ns) - => MDataFrame s t ns -> State# s -> (# State# s, DataFrame t ns #) -unsafeFreezeDataFrame# a s = case arraySizeInstance @ns of - ASScalar -> case readDataFrameOff# a 0# s of - (# s1, v #) -> (# s1, coerce v #) - ASArray -> (# s, coerce a #) -{-# INLINE unsafeFreezeDataFrame# #-} - - ---unsafeThawArrayT# :: ArrayT t ds -> State# s -> (#State# s, MutableArrayT s t ds #) ---unsafeThawArrayT# a s = (# s, coerce a #) ---{-# INLINE unsafeThawArrayT# #-} - - --- | Copy content of a mutable DataFrame into a new immutable DataFrame. -freezeDataFrame# :: forall t (ns :: [Nat]) s - . (MutableFrame t ns, ArraySizeInference ns) - => MDataFrame s t ns -> State# s -> (# State# s, DataFrame t ns #) -freezeDataFrame# a s = case arraySizeInstance @ns of - ASScalar -> case readDataFrameOff# a 0# s of - (# s1, v #) -> (# s1, coerce v #) - ASArray -> case js_freeze a s of - (# s1, v #) -> (# s1, coerce v #) -{-# INLINE freezeDataFrame# #-} - - - --- | Create a new mutable DataFrame and copy content of immutable one in there. -thawDataFrame# :: forall t (ns :: [Nat]) s - . (MutableFrame t ns, ArrayInstanceInference t ns) - => DataFrame t ns -> State# s -> (# State# s, MDataFrame s t ns #) -thawDataFrame# a s = case arraySizeInstance @ns of - ASScalar -> case newDataFrame# @t @'[] s of - (# s1, df #) -> (# writeDataFrameOff# df 0# (coerce a) s1, df #) - ASArray -> js_thaw (coerce a) s -{-# INLINE thawDataFrame# #-} - --- | Write a single element at the specified index -writeDataFrame# :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => MDataFrame s t ns -> Idx ns -> t -> State# s -> (# State# s, () #) -writeDataFrame# mdf ei x s | I# i <- fromEnum ei = (# writeDataFrameOff# mdf i x s, () #) -{-# INLINE writeDataFrame# #-} - --- | Read a single element at the specified index -readDataFrame# :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => MDataFrame s t ns -> Idx ns -> State# s -> (# State# s, t #) -readDataFrame# mdf ei | I# i <- fromEnum ei = readDataFrameOff# mdf i -{-# INLINE readDataFrame# #-} - -class MutableFrame t (ns :: [Nat]) where - -- | Write a single element at the specified element offset - writeDataFrameOff# :: MDataFrame s t ns -> Int# -> t -> State# s -> State# s - -- | Read a single element at the specified element offset - readDataFrameOff# :: MDataFrame s t ns -> Int# -> State# s -> (# State# s, t #) - -instance MutableFrame Float (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetFloat# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetFloat# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Double (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetDouble# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetDouble# - {-# INLINE readDataFrameOff# #-} - - -instance MutableFrame Int (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetInt# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetInt# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int8 (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetInt8# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetInt8# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int16 (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetInt16# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetInt16# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Int32 (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetInt32# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetInt32# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetWord# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetWord# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word8 (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetWord8# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetWord8# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word16 (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetWord16# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetWord16# - {-# INLINE readDataFrameOff# #-} - -instance MutableFrame Word32 (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetWord32# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# = js_readArrayOffsetWord32# - {-# INLINE readDataFrameOff# #-} - - -instance MutableFrame Word8Clamped (ns :: [Nat]) where - writeDataFrameOff# = js_writeArrayOffsetWord8Clamped# - {-# INLINE writeDataFrameOff# #-} - readDataFrameOff# m o s = case js_readArrayOffsetWord8Clamped# m o s of - (# s1, y #) -> (# s1, coerce y #) - {-# INLINE readDataFrameOff# #-} - - - -foreign import javascript unsafe "new Float32Array($1)" js_createFloatArray :: Int -> State# s -> (# State# s, MDataFrame s Float ds #) -foreign import javascript unsafe "new Float64Array($1)" js_createDoubleArray :: Int -> State# s -> (# State# s, MDataFrame s Double ds #) -foreign import javascript unsafe "new Int32Array($1)" js_createIntArray :: Int -> State# s -> (# State# s, MDataFrame s Int ds #) -foreign import javascript unsafe "new Int32Array($1)" js_createInt32Array :: Int -> State# s -> (# State# s, MDataFrame s Int32 ds #) -foreign import javascript unsafe "new Int16Array($1)" js_createInt16Array :: Int -> State# s -> (# State# s, MDataFrame s Int16 ds #) -foreign import javascript unsafe "new Int8Array($1)" js_createInt8Array :: Int -> State# s -> (# State# s, MDataFrame s Int8 ds #) -foreign import javascript unsafe "new Uint32Array($1)" js_createWordArray :: Int -> State# s -> (# State# s, MDataFrame s Word ds #) -foreign import javascript unsafe "new Uint32Array($1)" js_createWord32Array :: Int -> State# s -> (# State# s, MDataFrame s Word32 ds #) -foreign import javascript unsafe "new Uint16Array($1)" js_createWord16Array :: Int -> State# s -> (# State# s, MDataFrame s Word16 ds #) -foreign import javascript unsafe "new Uint8Array($1)" js_createWord8Array :: Int -> State# s -> (# State# s, MDataFrame s Word8 ds #) -foreign import javascript unsafe "new Uint8ClampedArray($1)" js_createWord8ClampedArray :: Int -> State# s -> (# State# s, MDataFrame s Word8Clamped ds #) - - -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetFloat# :: MDataFrame s Float ds -> Int# -> State# s -> (# State# s, Float #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetDouble# :: MDataFrame s Double ds -> Int# -> State# s -> (# State# s, Double #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetInt# :: MDataFrame s Int ds -> Int# -> State# s -> (# State# s, Int #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetInt8# :: MDataFrame s Int8 ds -> Int# -> State# s -> (# State# s, Int8 #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetInt16# :: MDataFrame s Int16 ds -> Int# -> State# s -> (# State# s, Int16 #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetInt32# :: MDataFrame s Int32 ds -> Int# -> State# s -> (# State# s, Int32 #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetWord# :: MDataFrame s Word ds -> Int# -> State# s -> (# State# s, Word #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetWord8# :: MDataFrame s Word8 ds -> Int# -> State# s -> (# State# s, Word8 #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetWord8Clamped# :: MDataFrame s Word8Clamped ds -> Int# -> State# s -> (# State# s, Int #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetWord16# :: MDataFrame s Word16 ds -> Int# -> State# s -> (# State# s, Word16 #) -foreign import javascript unsafe "$1[$2]" js_readArrayOffsetWord32# :: MDataFrame s Word32 ds -> Int# -> State# s -> (# State# s, Word32 #) - - - -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetFloat# :: MDataFrame s Float ds -> Int# -> Float -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetDouble# :: MDataFrame s Double ds -> Int# -> Double -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetInt# :: MDataFrame s Int ds -> Int# -> Int -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetInt8# :: MDataFrame s Int8 ds -> Int# -> Int8 -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetInt16# :: MDataFrame s Int16 ds -> Int# -> Int16 -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetInt32# :: MDataFrame s Int32 ds -> Int# -> Int32 -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetWord# :: MDataFrame s Word ds -> Int# -> Word -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetWord8# :: MDataFrame s Word8 ds -> Int# -> Word8 -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetWord8Clamped# :: MDataFrame s Word8Clamped ds -> Int# -> Word8Clamped -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetWord16# :: MDataFrame s Word16 ds -> Int# -> Word16 -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetWord32# :: MDataFrame s Word32 ds -> Int# -> Word32 -> State# s -> State# s -foreign import javascript unsafe "$1[$2] = $3;" js_writeArrayOffsetJSVal# :: MDataFrame s t ds -> Int -> JSVal -> State# s -> State# s - - -foreign import javascript unsafe "$3.set($1, $2);" js_copyDataFrame :: ArrayT t as -> Int -> MDataFrame s t asbs -> State# s -> (# State# s, () #) -foreign import javascript unsafe "$3.set($1, $2);" js_copyMDataFrame :: MDataFrame s t as -> Int -> MDataFrame s t asbs -> State# s -> (# State# s, () #) - - -foreign import javascript unsafe "$1.slice()" js_freeze :: MDataFrame s t as -> State# s -> (# State# s, ArrayT t ds #) -foreign import javascript unsafe "$1.slice()" js_thaw :: ArrayT t as -> State# s -> (# State# s, MDataFrame s t ds #) - - - -foreign import javascript unsafe "new ArrayBuffer($1)" newArrayBuffer# :: Int -> State# s -> (# State# s, JSVal #) -foreign import javascript unsafe "new Float32Array($1)" viewFloatArray# :: JSVal -> State# s -> (# State# s, MDataFrame s Float ds #) -foreign import javascript unsafe "new Float64Array($1)" viewDoubleArray# :: JSVal -> State# s -> (# State# s, MDataFrame s Double ds #) -foreign import javascript unsafe "new Int32Array($1)" viewIntArray# :: JSVal -> State# s -> (# State# s, MDataFrame s Int ds #) -foreign import javascript unsafe "new Int32Array($1)" viewInt32Array# :: JSVal -> State# s -> (# State# s, MDataFrame s Int32 ds #) -foreign import javascript unsafe "new Int16Array($1)" viewInt16Array# :: JSVal -> State# s -> (# State# s, MDataFrame s Int16 ds #) -foreign import javascript unsafe "new Int8Array($1)" viewInt8Array# :: JSVal -> State# s -> (# State# s, MDataFrame s Int8 ds #) -foreign import javascript unsafe "new Uint32Array($1)" viewWordArray# :: JSVal -> State# s -> (# State# s, MDataFrame s Word ds #) -foreign import javascript unsafe "new Uint32Array($1)" viewWord32Array# :: JSVal -> State# s -> (# State# s, MDataFrame s Word32 ds #) -foreign import javascript unsafe "new Uint16Array($1)" viewWord16Array# :: JSVal -> State# s -> (# State# s, MDataFrame s Word16 ds #) -foreign import javascript unsafe "new Uint8Array($1)" viewWord8Array# :: JSVal -> State# s -> (# State# s, MDataFrame s Word8 ds #) -foreign import javascript unsafe "new Uint8ClampedArray($1)" viewWord8ClampedArray# :: JSVal -> State# s -> (# State# s, MDataFrame s Word8Clamped ds #) -foreign import javascript unsafe "$1.buffer" arrayBuffer# :: MDataFrame s t ds -> State# s -> (# State# s, JSVal #) diff --git a/src-ghcjs/Numeric/Matrix/Mat44.js b/src-ghcjs/Numeric/Matrix/Mat44.js deleted file mode 100644 --- a/src-ghcjs/Numeric/Matrix/Mat44.js +++ /dev/null @@ -1,103 +0,0 @@ -function h$easytensor_m4fromHom(v) { - 'use strict'; - var r = v.slice(0,3), t = v[3]; - if (t !== 0) { - r[0] /= t; r[1] /= t; r[2] /= t; - } - return r; -} - - -function h$easytensor_m4translate(v) { - 'use strict'; - var m = new v.constructor(16); - m.set(v, 12); - m[0] = 1; - m[5] = 1; - m[10] = 1; - m[15] = 1; - return m; -} - -function h$easytensor_m4rotateX(a) { - 'use strict'; - var c = Math.cos(a), s = Math.sin(a); - return [ 1, 0, 0, 0 - , 0, c, s, 0 - , 0,-s, c, 0 - , 0, 0, 0, 1]; -} - -function h$easytensor_m4rotateY(a) { - 'use strict'; - var c = Math.cos(a), s = Math.sin(a); - return [ c, 0,-s, 0 - , 0, 1, 0, 0 - , s, 0, c, 0 - , 0, 0, 0, 1]; -} - -function h$easytensor_m4rotateZ(a) { - 'use strict'; - var c = Math.cos(a), s = Math.sin(a); - return [ c, s, 0, 0 - ,-s, c, 0, 0 - , 0, 0, 1, 0 - , 0, 0, 0, 1]; -} - -function h$easytensor_m4rotate(vec, a) { - 'use strict'; - var c = Math.cos(a); - var s = Math.sin(a); - var c1 = 1 - c; - var x = vec[0], y = vec[1], z = vec[2]; - return [ c + c1*x*x, c1*x*y + s*z, c1*x*z - s*y, 0 - , c1*x*y - s*z, c + c1*y*y, c1*y*z + s*x, 0 - , c1*x*z + s*y, c1*y*z - s*x, c + c1*z*z, 0 - , 0, 0, 0, 1]; -} - -function h$easytensor_m4rotateEuler(x, y, z) { - 'use strict'; - var cx = Math.cos(x), sx = Math.sin(x), cy = Math.cos(y), sy = Math.sin(y), cz = Math.cos(z), sz = Math.sin(z); - return [ cy*cz, -cy*sz, sy, 0 - , cx*sz + sx*sy*cz, cx*cz - sx*sy*sz, -sx*cy, 0 - , sx*sz - cx*sy*cz, sx*cz + cx*sy*sz, cx*cy, 0 - , 0, 0, 0, 1]; -} - -function h$easytensor_m4lookAt(up,camera,point) { - 'use strict'; - var zDir = [ camera[0] - point[0], camera[1] - point[1], camera[2] - point[2] ]; - var t = Math.hypot.apply(null,zDir); - zDir = zDir.map(function (e){return e / t;}); - var xDir = h$easytensor_cross(up,zDir); - t = Math.hypot.apply(null,xDir); - xDir = xDir.map(function (e){return e / t;}); - var yDir = h$easytensor_cross(zDir,xDir); - return [ xDir[0], yDir[0], zDir[0], 0 - , xDir[1], yDir[1], zDir[1], 0 - , xDir[2], yDir[2], zDir[2], 0 - , - h$easytensor_dot(xDir,camera), - h$easytensor_dot(yDir,camera), - h$easytensor_dot(zDir,camera), 1 - ]; -} - -function h$easytensor_m4perspective(n, f, fovy, aspect) { - 'use strict'; - var h2 = n*Math.tan(fovy/2); - var w2 = aspect*h2; - return [ n/w2, 0, 0, 0 - , 0, n/h2, 0, 0 - , 0, 0, (n+f)/(n-f),-1 - , 0, 0, 2*n*f/(n-f), 0 ]; -} - -function h$easytensor_m4orthogonal(n, f, w, h) { - 'use strict'; - return [ 2/w, 0, 0, 0 - , 0, 2/h, 0, 0 - , 0, 0, 2/(n-f), 0 - , 0, 0, (n+f)/(n-f), 1 ]; -} - diff --git a/src-ghcjs/Numeric/Matrix/Mat44d.hs b/src-ghcjs/Numeric/Matrix/Mat44d.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/Matrix/Mat44d.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Matrix.Mat44d () where - - -import Numeric.DataFrame.Type -import Numeric.Vector -import Numeric.Matrix.Class - - -instance HomTransform4 Double where - translate4 = js_translate - {-# INLINE translate4 #-} - translate3 = js_translate - {-# INLINE translate3 #-} - rotateX = js_rotateX - {-# INLINE rotateX #-} - rotateY = js_rotateY - {-# INLINE rotateY #-} - rotateZ = js_rotateZ - {-# INLINE rotateZ #-} - rotate = js_rotate - {-# INLINE rotate #-} - rotateEuler = js_rotateEuler - {-# INLINE rotateEuler #-} - lookAt = js_lookAt - {-# INLINE lookAt #-} - perspective = js_perspective - {-# INLINE perspective #-} - orthogonal = js_orthogonal - {-# INLINE orthogonal #-} - toHomPoint = js_toHomPoint - {-# INLINE toHomPoint #-} - toHomVector = js_toHomVector - {-# INLINE toHomVector #-} - fromHom = js_fromHom - {-# INLINE fromHom #-} - - - -foreign import javascript unsafe "h$easytensor_m4translate($1)" - js_translate :: Vector Double n -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4rotateX($1))" - js_rotateX :: Double -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4rotateY($1))" - js_rotateY :: Double -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4rotateZ($1))" - js_rotateZ :: Double -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4rotate($1, $2))" - js_rotate :: Vector Double 3 -> Double -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4rotateEuler($1, $2, $3))" - js_rotateEuler :: Double -> Double -> Double -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4lookAt($1,$2,$3))" - js_lookAt :: Vector Double 3 -> Vector Double 3 -> Vector Double 3 -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4perspective($1, $2, $3, $4))" - js_perspective :: Double -> Double -> Double -> Double -> Matrix Double 4 4 -foreign import javascript unsafe "new Float64Array(h$easytensor_m4orthogonal($1, $2, $3, $4))" - js_orthogonal :: Double -> Double -> Double -> Double -> Matrix Double 4 4 - -foreign import javascript unsafe "$r = new $1.constructor(4); $r.set($1); $r[3] = 1;" - js_toHomPoint :: Vector Double 3 -> Vector Double 4 -foreign import javascript unsafe "$r = new $1.constructor(4); $r.set($1); $r[3] = 0;" - js_toHomVector :: Vector Double 3 -> Vector Double 4 -foreign import javascript unsafe "h$easytensor_m4fromHom($1)" - js_fromHom :: Vector Double 4 -> Vector Double 3 - - - diff --git a/src-ghcjs/Numeric/Matrix/Mat44f.hs b/src-ghcjs/Numeric/Matrix/Mat44f.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/Matrix/Mat44f.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Matrix.Mat44f () where - - -import Numeric.DataFrame.Type -import Numeric.Vector -import Numeric.Matrix.Class - - -instance HomTransform4 Float where - translate4 = js_translate - {-# INLINE translate4 #-} - translate3 = js_translate - {-# INLINE translate3 #-} - rotateX = js_rotateX - {-# INLINE rotateX #-} - rotateY = js_rotateY - {-# INLINE rotateY #-} - rotateZ = js_rotateZ - {-# INLINE rotateZ #-} - rotate = js_rotate - {-# INLINE rotate #-} - rotateEuler = js_rotateEuler - {-# INLINE rotateEuler #-} - lookAt = js_lookAt - {-# INLINE lookAt #-} - perspective = js_perspective - {-# INLINE perspective #-} - orthogonal = js_orthogonal - {-# INLINE orthogonal #-} - toHomPoint = js_toHomPoint - {-# INLINE toHomPoint #-} - toHomVector = js_toHomVector - {-# INLINE toHomVector #-} - fromHom = js_fromHom - {-# INLINE fromHom #-} - - - -foreign import javascript unsafe "h$easytensor_m4translate($1)" - js_translate :: Vector Float n -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4rotateX($1))" - js_rotateX :: Float -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4rotateY($1))" - js_rotateY :: Float -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4rotateZ($1))" - js_rotateZ :: Float -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4rotate($1, $2))" - js_rotate :: Vector Float 3 -> Float -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4rotateEuler($1, $2, $3))" - js_rotateEuler :: Float -> Float -> Float -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4lookAt($1,$2,$3))" - js_lookAt :: Vector Float 3 -> Vector Float 3 -> Vector Float 3 -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4perspective($1, $2, $3, $4))" - js_perspective :: Float -> Float -> Float -> Float -> Matrix Float 4 4 -foreign import javascript unsafe "new Float32Array(h$easytensor_m4orthogonal($1, $2, $3, $4))" - js_orthogonal :: Float -> Float -> Float -> Float -> Matrix Float 4 4 - -foreign import javascript unsafe "$r = new $1.constructor(4); $r.set($1); $r[3] = 1;" - js_toHomPoint :: Vector Float 3 -> Vector Float 4 -foreign import javascript unsafe "$r = new $1.constructor(4); $r.set($1); $r[3] = 0;" - js_toHomVector :: Vector Float 3 -> Vector Float 4 -foreign import javascript unsafe "h$easytensor_m4fromHom($1)" - js_fromHom :: Vector Float 4 -> Vector Float 3 - - - diff --git a/src-ghcjs/Numeric/Quaternion/QDouble.hs b/src-ghcjs/Numeric/Quaternion/QDouble.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/Quaternion/QDouble.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Quaternion.QDouble - ( QDouble, Quater (..) - ) where - -import Data.JSString (JSString, unpack') -import Data.Coerce (coerce) - -import Numeric.Array -import Numeric.DataFrame.Type -import Numeric.Vector -import Numeric.Matrix - -import Numeric.Quaternion.Class - - -type QDouble = Quater Double - -instance Quaternion Double where - newtype Quater Double = QDouble (ArrayT Double '[4]) - {-# INLINE packQ #-} - packQ = js_packQ - {-# INLINE fromVecNum #-} - fromVecNum = js_fromVecNum - {-# INLINE fromVec4 #-} - fromVec4 = coerce - {-# INLINE toVec4 #-} - toVec4 = coerce - {-# INLINE unpackQ #-} - unpackQ = js_unpackQ - {-# INLINE square #-} - square = js_square - {-# INLINE im #-} - im = js_im - {-# INLINE re #-} - re = js_re - {-# INLINE imVec #-} - imVec = js_imVec - {-# INLINE taker #-} - taker = js_taker - {-# INLINE takei #-} - takei = js_takei - {-# INLINE takej #-} - takej = js_takej - {-# INLINE takek #-} - takek = js_takek - {-# INLINE conjugate #-} - conjugate = js_conjugate - {-# INLINE rotScale #-} - rotScale = js_rotScale - {-# INLINE getRotScale #-} - getRotScale = js_getRotScale - {-# INLINE axisRotation #-} - axisRotation = js_axisRotation - {-# INLINE qArg #-} - qArg = js_qArg - {-# INLINE fromMatrix33 #-} - fromMatrix33 = js_fromMatrix33 - {-# INLINE fromMatrix44 #-} - fromMatrix44 = js_fromMatrix44 - {-# INLINE toMatrix33 #-} - toMatrix33 = js_toMatrix33 - {-# INLINE toMatrix44 #-} - toMatrix44 = js_toMatrix44 - - -foreign import javascript unsafe "new Float64Array([$1,$2,$3,$4])" - js_packQ :: Double -> Double -> Double -> Double -> QDouble - -foreign import javascript unsafe "new Float64Array([$1[0],$1[1],$1[2],$2])" - js_fromVecNum :: Vector Double 3 -> Double -> QDouble - -foreign import javascript unsafe "$r1 = $1[0];$r2 = $1[1];$r3 = $1[2];$r4 = $1[3];" - js_unpackQ :: QDouble -> (Double,Double,Double,Double) - - -foreign import javascript unsafe "$1[0]*$1[0] + $1[1]*$1[1] + $1[2]*$1[2] + $1[3]*$1[3]" - js_square :: QDouble -> Double - -foreign import javascript unsafe "new Float64Array([$1[0],$1[1],$1[2],0])" - js_im :: QDouble -> QDouble - -foreign import javascript unsafe "$1.slice(0,3)" - js_imVec :: QDouble -> Vector Double 3 - -foreign import javascript unsafe "$r = new Float64Array(4); $r[3] = $1[3];" - js_re :: QDouble -> QDouble - -foreign import javascript unsafe "$1[3]" - js_taker :: QDouble -> Double - -foreign import javascript unsafe "$1[0]" - js_takei :: QDouble -> Double - -foreign import javascript unsafe "$1[1]" - js_takej :: QDouble -> Double - -foreign import javascript unsafe "$1[2]" - js_takek :: QDouble -> Double - -foreign import javascript unsafe "new Float64Array([-$1[0],-$1[1],-$1[2],$1[3]])" - js_conjugate :: QDouble -> QDouble - - -foreign import javascript unsafe "new Float64Array(h$easytensor_rotScale($1,$2))" - js_rotScale :: QDouble -> Vector Double 3 -> Vector Double 3 - -foreign import javascript unsafe "new Float64Array(h$easytensor_getRotScale($1,$2))" - js_getRotScale :: Vector Double 3 -> Vector Double 3 -> QDouble - -foreign import javascript unsafe "new Float64Array(h$easytensor_axisRotation($1,$2))" - js_axisRotation :: Vector Double 3 -> Double -> QDouble - -foreign import javascript unsafe "h$easytensor_qArg($1)" - js_qArg :: QDouble -> Double - -foreign import javascript unsafe "new Float64Array(h$easytensor_qfromMatrix33($1))" - js_fromMatrix33 :: Matrix Double 3 3 -> QDouble - -foreign import javascript unsafe "new Float64Array(h$easytensor_qfromMatrix44($1))" - js_fromMatrix44 :: Matrix Double 4 4 -> QDouble - -foreign import javascript unsafe "new Float64Array(h$easytensor_qtoMatrix33($1))" - js_toMatrix33 :: QDouble -> Matrix Double 3 3 - -foreign import javascript unsafe "new Float64Array(h$easytensor_qtoMatrix44($1))" - js_toMatrix44 :: QDouble -> Matrix Double 4 4 - - --------------------------------------------------------------------------- --- Num --------------------------------------------------------------------------- - -instance Num QDouble where - {-# INLINE (+) #-} - (+) = js_plus - {-# INLINE (-) #-} - (-) = js_minus - {-# INLINE (*) #-} - (*) = js_times - {-# INLINE abs #-} - abs = js_abs - {-# INLINE signum #-} - signum = js_signum - {-# INLINE negate #-} - negate = fromVec4 . negate . toVec4 - {-# INLINE fromInteger #-} - fromInteger = js_toQuaternion . fromInteger - -foreign import javascript unsafe "$1.map(function (e, i) {return e + $2[i];})" - js_plus :: QDouble -> QDouble -> QDouble - - -foreign import javascript unsafe "$1.map(function (e, i) {return e - $2[i];})" - js_minus :: QDouble -> QDouble -> QDouble - -foreign import javascript unsafe "new Float64Array(\ - \[ $1[3]*$2[0] + $1[0]*$2[3] + $1[1]*$2[2] - $1[2]*$2[1]\ - \, $1[3]*$2[1] - $1[0]*$2[2] + $1[1]*$2[3] + $1[2]*$2[0]\ - \, $1[3]*$2[2] + $1[0]*$2[1] - $1[1]*$2[0] + $1[2]*$2[3]\ - \, $1[3]*$2[3] - $1[0]*$2[0] - $1[1]*$2[1] - $1[2]*$2[2] ])" - js_times :: QDouble -> QDouble -> QDouble - -foreign import javascript unsafe "new Float64Array([0,0,0,Math.hypot($1[0],$1[1],$1[2],$1[3])])" - js_abs :: QDouble -> QDouble - -foreign import javascript unsafe "var l = Math.hypot($1[0],$1[1],$1[2],$1[3]); $r = (l == 0) ? (new Float64Array(4)) : $1.map(function (e) {return e/l;})" - js_signum :: QDouble -> QDouble - -foreign import javascript unsafe "$r = new Float64Array(4); $r[3] = $1;" - js_toQuaternion :: Double -> QDouble - -{-# RULES -"realToFrac/DoubleQDouble" realToFrac = js_toQuaternion -"realToFrac/aQDouble" realToFrac = js_toQuaternion . realToFrac -"fromIntegral/aQDouble" fromIntegral = js_toQuaternion . fromIntegral - #-} - - --------------------------------------------------------------------------- --- Fractional --------------------------------------------------------------------------- - -instance Fractional QDouble where - {-# INLINE recip #-} - recip = js_recip - {-# INLINE (/) #-} - (/) p = js_times p . js_recip - {-# INLINE fromRational #-} - fromRational = js_toQuaternion . fromRational - -foreign import javascript unsafe "new Float64Array(h$easytensor_qrecip($1))" - js_recip :: QDouble -> QDouble - - --------------------------------------------------------------------------- --- Floating --------------------------------------------------------------------------- - -instance Floating QDouble where - {-# INLINE pi #-} - pi = js_toQuaternion pi - {-# INLINE exp #-} - exp = js_exp - {-# INLINE log #-} - log = js_log - {-# INLINE sqrt #-} - sqrt = js_sqrt - {-# INLINE sin #-} - sin = js_sin - {-# INLINE cos #-} - cos = js_cos - {-# INLINE tan #-} - tan = js_tan - {-# INLINE sinh #-} - sinh = js_sinh - {-# INLINE cosh #-} - cosh = js_cosh - {-# INLINE tanh #-} - tanh = js_tanh - {-# INLINE asin #-} - asin q = -i * log (i*q + sqrt (1 - q*q)) - where i = signum . im $ q - {-# INLINE acos #-} - acos q = pi/2 - asin q - {-# INLINE atan #-} - atan q = if square imq == 0 - then js_toQuaternion (atan $ taker q) - else i / 2 * log ( (i + q) / (i - q) ) - where i = signum imq - imq = im q - {-# INLINE asinh #-} - asinh q = log (q + sqrt (q*q + 1)) - {-# INLINE acosh #-} - acosh q = log (q + sqrt (q*q - 1)) - {-# INLINE atanh #-} - atanh q = 0.5 * log ((1+q)/(1-q)) - -foreign import javascript unsafe "new Float64Array(h$easytensor_qexp($1))" js_exp :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qlog($1))" js_log :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qsqrt($1))" js_sqrt :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qsin($1))" js_sin :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qcos($1))" js_cos :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qtan($1))" js_tan :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qsinh($1))" js_sinh :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qcosh($1))" js_cosh :: QDouble -> QDouble -foreign import javascript unsafe "new Float64Array(h$easytensor_qtanh($1))" js_tanh :: QDouble -> QDouble - - --------------------------------------------------------------------------- --- Eq --------------------------------------------------------------------------- - -instance Eq QDouble where - {-# INLINE (==) #-} - (==) = js_eq - {-# INLINE (/=) #-} - (/=) = js_neq - - - -foreign import javascript unsafe "$1[0] === $2[0] && $1[1] === $2[1] && $1[2] === $2[2] && $1[3] === $2[3]" - js_eq :: QDouble -> QDouble -> Bool -foreign import javascript unsafe "$1[0] !== $2[0] || $1[1] !== $2[1] || $1[2] !== $2[2] || $1[3] !== $2[3]" - js_neq :: QDouble -> QDouble -> Bool - - - --------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------- - -instance Show QDouble where - show = unpack' . js_show - -foreign import javascript unsafe "$1[3].toPrecision(8)\ - \ + ($1[0] >= 0 ? ' + ' : ' - ') + Math.abs($1[0]).toPrecision(8) + 'i'\ - \ + ($1[1] >= 0 ? ' + ' : ' - ') + Math.abs($1[1]).toPrecision(8) + 'j'\ - \ + ($1[2] >= 0 ? ' + ' : ' - ') + Math.abs($1[2]).toPrecision(8) + 'k'" - js_show:: QDouble -> JSString diff --git a/src-ghcjs/Numeric/Quaternion/QFloat.hs b/src-ghcjs/Numeric/Quaternion/QFloat.hs deleted file mode 100644 --- a/src-ghcjs/Numeric/Quaternion/QFloat.hs +++ /dev/null @@ -1,295 +0,0 @@ --- Note, --- --- The whole module is made by copying Numeric.Quaternion.QDouble and replacing: --- Double -> Float --- Float64 -> Float32 --- --- If we are doing any refactoring of one of these modules, just do the same operation. - -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Quaternion.QFloat - ( QFloat, Quater (..) - ) where - -import Data.JSString (JSString, unpack') -import Data.Coerce (coerce) - -import Numeric.Array -import Numeric.DataFrame.Type -import Numeric.Vector -import Numeric.Matrix - -import Numeric.Quaternion.Class - - -type QFloat = Quater Float - -instance Quaternion Float where - newtype Quater Float = QFloat (ArrayT Float '[4]) - {-# INLINE packQ #-} - packQ = js_packQ - {-# INLINE fromVecNum #-} - fromVecNum = js_fromVecNum - {-# INLINE fromVec4 #-} - fromVec4 = coerce - {-# INLINE toVec4 #-} - toVec4 = coerce - {-# INLINE unpackQ #-} - unpackQ = js_unpackQ - {-# INLINE square #-} - square = js_square - {-# INLINE im #-} - im = js_im - {-# INLINE re #-} - re = js_re - {-# INLINE imVec #-} - imVec = js_imVec - {-# INLINE taker #-} - taker = js_taker - {-# INLINE takei #-} - takei = js_takei - {-# INLINE takej #-} - takej = js_takej - {-# INLINE takek #-} - takek = js_takek - {-# INLINE conjugate #-} - conjugate = js_conjugate - {-# INLINE rotScale #-} - rotScale = js_rotScale - {-# INLINE getRotScale #-} - getRotScale = js_getRotScale - {-# INLINE axisRotation #-} - axisRotation = js_axisRotation - {-# INLINE qArg #-} - qArg = js_qArg - {-# INLINE fromMatrix33 #-} - fromMatrix33 = js_fromMatrix33 - {-# INLINE fromMatrix44 #-} - fromMatrix44 = js_fromMatrix44 - {-# INLINE toMatrix33 #-} - toMatrix33 = js_toMatrix33 - {-# INLINE toMatrix44 #-} - toMatrix44 = js_toMatrix44 - - -foreign import javascript unsafe "new Float32Array([$1,$2,$3,$4])" - js_packQ :: Float -> Float -> Float -> Float -> QFloat - -foreign import javascript unsafe "new Float32Array([$1[0],$1[1],$1[2],$2])" - js_fromVecNum :: Vector Float 3 -> Float -> QFloat - -foreign import javascript unsafe "$r1 = $1[0];$r2 = $1[1];$r3 = $1[2];$r4 = $1[3];" - js_unpackQ :: QFloat -> (Float,Float,Float,Float) - - -foreign import javascript unsafe "$1[0]*$1[0] + $1[1]*$1[1] + $1[2]*$1[2] + $1[3]*$1[3]" - js_square :: QFloat -> Float - -foreign import javascript unsafe "new Float32Array([$1[0],$1[1],$1[2],0])" - js_im :: QFloat -> QFloat - -foreign import javascript unsafe "$1.slice(0,3)" - js_imVec :: QFloat -> Vector Float 3 - -foreign import javascript unsafe "$r = new Float32Array(4); $r[3] = $1[3];" - js_re :: QFloat -> QFloat - -foreign import javascript unsafe "$1[3]" - js_taker :: QFloat -> Float - -foreign import javascript unsafe "$1[0]" - js_takei :: QFloat -> Float - -foreign import javascript unsafe "$1[1]" - js_takej :: QFloat -> Float - -foreign import javascript unsafe "$1[2]" - js_takek :: QFloat -> Float - -foreign import javascript unsafe "new Float32Array([-$1[0],-$1[1],-$1[2],$1[3]])" - js_conjugate :: QFloat -> QFloat - - -foreign import javascript unsafe "new Float32Array(h$easytensor_rotScale($1,$2))" - js_rotScale :: QFloat -> Vector Float 3 -> Vector Float 3 - -foreign import javascript unsafe "new Float32Array(h$easytensor_getRotScale($1,$2))" - js_getRotScale :: Vector Float 3 -> Vector Float 3 -> QFloat - -foreign import javascript unsafe "new Float32Array(h$easytensor_axisRotation($1,$2))" - js_axisRotation :: Vector Float 3 -> Float -> QFloat - -foreign import javascript unsafe "h$easytensor_qArg($1)" - js_qArg :: QFloat -> Float - -foreign import javascript unsafe "new Float32Array(h$easytensor_qfromMatrix33($1))" - js_fromMatrix33 :: Matrix Float 3 3 -> QFloat - -foreign import javascript unsafe "new Float32Array(h$easytensor_qfromMatrix44($1))" - js_fromMatrix44 :: Matrix Float 4 4 -> QFloat - -foreign import javascript unsafe "new Float32Array(h$easytensor_qtoMatrix33($1))" - js_toMatrix33 :: QFloat -> Matrix Float 3 3 - -foreign import javascript unsafe "new Float32Array(h$easytensor_qtoMatrix44($1))" - js_toMatrix44 :: QFloat -> Matrix Float 4 4 - - --------------------------------------------------------------------------- --- Num --------------------------------------------------------------------------- - -instance Num QFloat where - {-# INLINE (+) #-} - (+) = js_plus - {-# INLINE (-) #-} - (-) = js_minus - {-# INLINE (*) #-} - (*) = js_times - {-# INLINE abs #-} - abs = js_abs - {-# INLINE signum #-} - signum = js_signum - {-# INLINE negate #-} - negate = fromVec4 . negate . toVec4 - {-# INLINE fromInteger #-} - fromInteger = js_toQuaternion . fromInteger - -foreign import javascript unsafe "$1.map(function (e, i) {return e + $2[i];})" - js_plus :: QFloat -> QFloat -> QFloat - - -foreign import javascript unsafe "$1.map(function (e, i) {return e - $2[i];})" - js_minus :: QFloat -> QFloat -> QFloat - -foreign import javascript unsafe "new Float32Array(\ - \[ $1[3]*$2[0] + $1[0]*$2[3] + $1[1]*$2[2] - $1[2]*$2[1]\ - \, $1[3]*$2[1] - $1[0]*$2[2] + $1[1]*$2[3] + $1[2]*$2[0]\ - \, $1[3]*$2[2] + $1[0]*$2[1] - $1[1]*$2[0] + $1[2]*$2[3]\ - \, $1[3]*$2[3] - $1[0]*$2[0] - $1[1]*$2[1] - $1[2]*$2[2] ])" - js_times :: QFloat -> QFloat -> QFloat - -foreign import javascript unsafe "new Float32Array([0,0,0,Math.hypot($1[0],$1[1],$1[2],$1[3])])" - js_abs :: QFloat -> QFloat - -foreign import javascript unsafe "var l = Math.hypot($1[0],$1[1],$1[2],$1[3]); $r = (l == 0) ? (new Float32Array(4)) : $1.map(function (e) {return e/l;})" - js_signum :: QFloat -> QFloat - -foreign import javascript unsafe "$r = new Float32Array(4); $r[3] = $1;" - js_toQuaternion :: Float -> QFloat - -{-# RULES -"realToFrac/FloatQFloat" realToFrac = js_toQuaternion -"realToFrac/aQFloat" realToFrac = js_toQuaternion . realToFrac -"fromIntegral/aQFloat" fromIntegral = js_toQuaternion . fromIntegral - #-} - - --------------------------------------------------------------------------- --- Fractional --------------------------------------------------------------------------- - -instance Fractional QFloat where - {-# INLINE recip #-} - recip = js_recip - {-# INLINE (/) #-} - (/) p = js_times p . js_recip - {-# INLINE fromRational #-} - fromRational = js_toQuaternion . fromRational - -foreign import javascript unsafe "new Float32Array(h$easytensor_qrecip($1))" - js_recip :: QFloat -> QFloat - - --------------------------------------------------------------------------- --- Floating --------------------------------------------------------------------------- - -instance Floating QFloat where - {-# INLINE pi #-} - pi = js_toQuaternion pi - {-# INLINE exp #-} - exp = js_exp - {-# INLINE log #-} - log = js_log - {-# INLINE sqrt #-} - sqrt = js_sqrt - {-# INLINE sin #-} - sin = js_sin - {-# INLINE cos #-} - cos = js_cos - {-# INLINE tan #-} - tan = js_tan - {-# INLINE sinh #-} - sinh = js_sinh - {-# INLINE cosh #-} - cosh = js_cosh - {-# INLINE tanh #-} - tanh = js_tanh - {-# INLINE asin #-} - asin q = -i * log (i*q + sqrt (1 - q*q)) - where i = signum . im $ q - {-# INLINE acos #-} - acos q = pi/2 - asin q - {-# INLINE atan #-} - atan q = if square imq == 0 - then js_toQuaternion (atan $ taker q) - else i / 2 * log ( (i + q) / (i - q) ) - where i = signum imq - imq = im q - {-# INLINE asinh #-} - asinh q = log (q + sqrt (q*q + 1)) - {-# INLINE acosh #-} - acosh q = log (q + sqrt (q*q - 1)) - {-# INLINE atanh #-} - atanh q = 0.5 * log ((1+q)/(1-q)) - -foreign import javascript unsafe "new Float32Array(h$easytensor_qexp($1))" js_exp :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qlog($1))" js_log :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qsqrt($1))" js_sqrt :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qsin($1))" js_sin :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qcos($1))" js_cos :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qtan($1))" js_tan :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qsinh($1))" js_sinh :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qcosh($1))" js_cosh :: QFloat -> QFloat -foreign import javascript unsafe "new Float32Array(h$easytensor_qtanh($1))" js_tanh :: QFloat -> QFloat - - --------------------------------------------------------------------------- --- Eq --------------------------------------------------------------------------- - -instance Eq QFloat where - {-# INLINE (==) #-} - (==) = js_eq - {-# INLINE (/=) #-} - (/=) = js_neq - - - -foreign import javascript unsafe "$1[0] === $2[0] && $1[1] === $2[1] && $1[2] === $2[2] && $1[3] === $2[3]" - js_eq :: QFloat -> QFloat -> Bool -foreign import javascript unsafe "$1[0] !== $2[0] || $1[1] !== $2[1] || $1[2] !== $2[2] || $1[3] !== $2[3]" - js_neq :: QFloat -> QFloat -> Bool - - - --------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------- - -instance Show QFloat where - show = unpack' . js_show - -foreign import javascript unsafe "$1[3].toPrecision(8)\ - \ + ($1[0] >= 0 ? ' + ' : ' - ') + Math.abs($1[0]).toPrecision(8) + 'i'\ - \ + ($1[1] >= 0 ? ' + ' : ' - ') + Math.abs($1[1]).toPrecision(8) + 'j'\ - \ + ($1[2] >= 0 ? ' + ' : ' - ') + Math.abs($1[2]).toPrecision(8) + 'k'" - js_show:: QFloat -> JSString - - diff --git a/src-ghcjs/Numeric/Quaternion/Quaternion.js b/src-ghcjs/Numeric/Quaternion/Quaternion.js deleted file mode 100644 --- a/src-ghcjs/Numeric/Quaternion/Quaternion.js +++ /dev/null @@ -1,205 +0,0 @@ -function h$easytensor_rotScale(quat, vec) { - 'use strict'; - var i = quat[0], j = quat[1], k = quat[2], t = quat[3]; - var x = vec[0], y = vec[1], z = vec[2]; - var l = t*t - i*i - j*j - k*k; - var d = 2*(i*x + j*y + k*z); - t *= 2; - return [ l*x + d*i + t*(z*j - y*k) - , l*y + d*j + t*(x*k - z*i) - , l*z + d*k + t*(y*i - x*j) - ]; -} - -function h$easytensor_qArg(quat) { - 'use strict'; - return Math.atan2( Math.hypot(quat[0],quat[1],quat[2]) , quat[3] ) * 2 ; -} - -function h$easytensor_getRotScale(a, b) { - 'use strict'; - if (b[0] === 0 && b[1] === 0 && b[2] === 0) { return [0,0,0,0];} - if (a[0] === 0 && a[1] === 0 && a[2] === 0) { return [Infinity,Infinity,Infinity,Infinity];} - var t = h$easytensor_cross(a, b); - var ma = Math.hypot(a[0],a[1],a[2]); - var mb = Math.hypot(b[0],b[1],b[2]); - var dot = a[0]*b[0]+a[1]*b[1]+a[2]*b[2]; - if (t[0] === 0 && t[1] === 0 && t[2] === 0) { - if (dot > 0) {return [0,0,0,Math.sqrt(mb/ma)];} - else {return [0,0,Math.sqrt(mb/ma),0];} - } - var c = Math.sqrt(ma*mb + dot); - ma *= Math.SQRT2; - return [ t[0]/(ma*c) - , t[1]/(ma*c) - , t[2]/(ma*c) - , c/ma - ]; -} - -function h$easytensor_axisRotation(axis, a) { - 'use strict'; - if (axis[0] === 0 && axis[1] === 0 && axis[2] === 0) { return [0,0,0,1];} - var c = Math.cos(a*0.5), s = Math.sin(a*0.5) / Math.hypot(axis[0],axis[1],axis[2]); - return [ axis[0]*s, axis[1]*s, axis[2]*s, c]; -} - -function h$easytensor_qfromMatrix33(m) { - 'use strict'; - var d = Math.cbrt( - m[0]*(m[4]*m[8]-m[5]*m[7]) - - m[1]*(m[3]*m[8]-m[5]*m[6]) - + m[2]*(m[3]*m[7]-m[4]*m[6])); - return [ Math.sqrt(Math.max( 0, d + m[0] - m[4] - m[8] )) * Math.sign(m[5] - m[7]) * 0.5 - , Math.sqrt(Math.max( 0, d - m[0] + m[4] - m[8] )) * Math.sign(m[6] - m[2]) * 0.5 - , Math.sqrt(Math.max( 0, d - m[0] - m[4] + m[8] )) * Math.sign(m[1] - m[3]) * 0.5 - , Math.sqrt(Math.max( 0, d + m[0] + m[4] + m[8] )) * 0.5 ]; -} - -function h$easytensor_qfromMatrix44(m) { - 'use strict'; - var d = Math.cbrt( - m[0]*(m[5]*m[10]-m[6]*m[9]) - - m[1]*(m[4]*m[10]-m[6]*m[8]) - + m[2]*(m[4]*m[ 9]-m[5]*m[8])); - return [ Math.sqrt(Math.max( 0, d + m[0] - m[5] - m[10] )) * Math.sign(m[6] - m[9]) * 0.5 / m[15] - , Math.sqrt(Math.max( 0, d - m[0] + m[5] - m[10] )) * Math.sign(m[8] - m[2]) * 0.5 / m[15] - , Math.sqrt(Math.max( 0, d - m[0] - m[5] + m[10] )) * Math.sign(m[1] - m[4]) * 0.5 / m[15] - , Math.sqrt(Math.max( 0, d + m[0] + m[5] + m[10] )) * 0.5 / m[15] ]; -} - -function h$easytensor_qtoMatrix33(quat) { - 'use strict'; - var x = quat[0], y = quat[1], z = quat[2], w = quat[3]; - var w2 = w*w; - if (x === 0 && y === 0 && z === 0) { - return [w2,0,0 - ,0,w2,0 - ,0,0,w2]; - } - var x2 = x*x, y2 = y*y, z2 = z*z; - var l2 = x2+y2+z2+w2; - return [ l2 - 2*(z2 + y2), 2*(x*y + z*w), 2*(x*z - y*w) - , 2*(x*y - z*w), l2 - 2*(z2 + x2), 2*(y*z + x*w) - , 2*(x*z + y*w), 2*(y*z - x*w), l2 - 2*(y2 + x2) ]; -} - -function h$easytensor_qtoMatrix44(quat) { - 'use strict'; - var x = quat[0], y = quat[1], z = quat[2], w = quat[3]; - var w2 = w*w; - if (x === 0 && y === 0 && z === 0) { - return [w2,0,0,0 - ,0,w2,0,0 - ,0,0,w2,0 - ,0,0,0,1]; - } - var x2 = x*x, y2 = y*y, z2 = z*z; - var l2 = x2+y2+z2+w2; - return [ l2 - 2*(z2 + y2), 2*(x*y + z*w), 2*(x*z - y*w), 0 - , 2*(x*y - z*w), l2 - 2*(z2 + x2), 2*(y*z + x*w), 0 - , 2*(x*z + y*w), 2*(y*z - x*w), l2 - 2*(y2 + x2), 0 - , 0, 0, 0, 1]; -} - -function h$easytensor_qrecip(q) { - 'use strict'; - var c = -1 / (q[0]*q[0] + q[1]*q[1] + q[2]*q[2] + q[3]*q[3]); - return [q[0]*c,q[1]*c,q[2]*c,-q[3]*c]; -} - -function h$easytensor_qexp(q) { - 'use strict'; - var mv = Math.hypot(q[0],q[1],q[2]), et = Math.exp(q[3]); - if(mv === 0) {return [0,0,0,et];} - var l = et * Math.sin(mv) / mv; - return [q[0]*l,q[1]*l,q[2]*l,et*Math.cos(mv)]; -} -function h$easytensor_qlog(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) { - if(q[3] >= 0){ - return [0,0,0,Math.log(q[3])]; - } else { - return [Math.PI,0,0,Math.log(-q[3])]; - } - } - var mq = Math.sqrt(mv + q[3]*q[3]); - mv = Math.sqrt(mv); - var l = Math.atan2( mv, q[3] ) / mv; - return [q[0]*l,q[1]*l,q[2]*l,Math.log(mq)]; -} -function h$easytensor_qsqrt(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) { - if(q[3] >= 0){ - return [0,0,0,Math.sqrt(q[3])]; - } else { - return [Math.sqrt(-q[3]),0,0,0]; - } - } - var l = Math.sqrt(mv + q[3]*q[3]); - var l2 = Math.sqrt(l); - var tq = q[3] / (l * 2); - var sina = Math.sqrt(0.5 - tq) * l2 / Math.sqrt(mv); - return [q[0]*sina,q[1]*sina,q[2]*sina,Math.sqrt(0.5 + tq) * l2]; -} - -// A good tutorial on complex number trigonometric functions is available here -// http://www.milefoot.com/math/complex/functionsofi.htm -// I extend it to complex numbers by replacing complex i with quaternion vector ijk - -function h$easytensor_qsin(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) {return [0,0,0,Math.sin(q[3])];} - mv = Math.sqrt(mv); - var l = Math.cos(q[3]) * Math.sinh(mv) / mv; - return [q[0]*l,q[1]*l,q[2]*l, Math.sin(q[3])*Math.cosh(mv)]; -} -function h$easytensor_qcos(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) {return [0,0,0,Math.cos(q[3])];} - mv = Math.sqrt(mv); - var l = - Math.sin(q[3]) * Math.sinh(mv) / mv; - return [q[0]*l,q[1]*l,q[2]*l, Math.cos(q[3])*Math.cosh(mv)]; -} -function h$easytensor_qtan(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) {return [0,0,0,Math.tan(q[3])];} - mv = Math.sqrt(mv); - var chv = Math.cosh(mv), shv = Math.sinh(mv), ct = Math.cos(q[3]), st = Math.sin(q[3]); - var cq = 1 / (ct*ct*chv*chv + st*st*shv*shv); - var l = chv * shv * cq / mv; - return [q[0]*l,q[1]*l,q[2]*l, ct * st * cq]; -} -function h$easytensor_qsinh(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) {return [0,0,0,Math.sinh(q[3])];} - mv = Math.sqrt(mv); - var l = Math.cosh(q[3]) * Math.sin(mv) / mv; - return [q[0]*l,q[1]*l,q[2]*l, Math.sinh(q[3])*Math.cos(mv)]; -} -function h$easytensor_qcosh(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) {return [0,0,0,Math.cosh(q[3])];} - mv = Math.sqrt(mv); - var l = Math.sinh(q[3]) * Math.sin(mv) / mv; - return [q[0]*l,q[1]*l,q[2]*l, Math.cosh(q[3])*Math.cos(mv)]; -} -function h$easytensor_qtanh(q) { - 'use strict'; - var mv = q[0]*q[0] + q[1]*q[1] + q[2]*q[2]; - if(mv === 0) {return [0,0,0,Math.tanh(q[3])];} - mv = Math.sqrt(mv); - var cv = Math.cos(mv), sv = Math.sin(mv), cht = Math.cosh(q[3]), sht = Math.sinh(q[3]); - var cq = 1 / (cht*cht*cv*cv + sht*sht*sv*sv); - var l = cv * sv * cq / mv; - return [q[0]*l,q[1]*l,q[2]*l, cht * sht * cq]; -} diff --git a/src/Numeric/Array/ElementWise.hs b/src/Numeric/Array/ElementWise.hs deleted file mode 100644 --- a/src/Numeric/Array/ElementWise.hs +++ /dev/null @@ -1,349 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE Strict #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Array.ElementWise --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.ElementWise - ( ElementWise (..) - ) where - -#ifdef ghcjs_HOST_OS -import Data.Int (Int16, Int32, Int8) -import Data.Word (Word16, Word32, Word8) -#else -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -#endif -import GHC.Prim (Int#) - --- | Access elements. --- i is an index type --- x is an element --- t is a container type -class ElementWise i x t | t -> x i where - -- | Index an element by its offset in the container - indexOffset# :: t -> Int# -> x - -- | Index an element in the container - (!) :: t -> i -> x - -- | map all elements with index - ewmap :: (i -> x -> x) -> t -> t - -- | generate data from elements - ewgen :: (i -> x) -> t - -- | generate data from elements in applicative functor - ewgenA :: forall f . Applicative f => (i -> f x) -> f t - -- | fold all element with index - ewfoldl :: (i -> a -> x -> a) -> a -> t -> a - -- | fold all element with index - ewfoldr :: (i -> x -> a -> a) -> a -> t -> a - -- | Apply an applicative functor on each element (Lens-like traversal) - elementWise :: forall f . Applicative f => (x -> f x) -> t -> f t - -- | Apply an applicative functor on each element with its index - -- (Lens-like indexed traversal) - indexWise :: forall f . Applicative f => (i -> x -> f x) -> t -> f t - -- | Fill a container with a single value - broadcast :: x -> t - -- | Update a single element - update :: i -> x -> t -> t - - -instance ElementWise Int Float Float where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - {-# INLINE ewfoldr #-} - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - - -instance ElementWise Int Double Double where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - -instance ElementWise Int Int Int where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - -instance ElementWise Int Int8 Int8 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - -instance ElementWise Int Int16 Int16 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - -instance ElementWise Int Int32 Int32 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - -#ifndef ghcjs_HOST_OS -instance ElementWise Int Int64 Int64 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} -#endif - -instance ElementWise Int Word Word where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - -instance ElementWise Int Word8 Word8 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - -instance ElementWise Int Word16 Word16 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - -instance ElementWise Int Word32 Word32 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} - - -#ifndef ghcjs_HOST_OS -instance ElementWise Int Word64 Word64 where - indexOffset# x _ = x - {-# INLINE indexOffset# #-} - (!) x _ = x - {-# INLINE (!) #-} - ewmap f = f 1 - {-# INLINE ewmap #-} - ewgen f = f 1 - {-# INLINE ewgen #-} - ewgenA f = f 1 - {-# INLINE ewgenA #-} - ewfoldl f = f 1 - {-# INLINE ewfoldl #-} - ewfoldr f x0 x = f 1 x x0 - elementWise = id - {-# INLINE elementWise #-} - indexWise f = f 1 - {-# INLINE indexWise #-} - broadcast = id - {-# INLINE broadcast #-} - update _ = const - {-# INLINE update #-} -#endif diff --git a/src/Numeric/Commons.hs b/src/Numeric/Commons.hs deleted file mode 100644 --- a/src/Numeric/Commons.hs +++ /dev/null @@ -1,428 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -#ifdef ghcjs_HOST_OS -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE UnliftedFFITypes #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Numeric.Commons --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Commons - ( ElemRep, ElemPrim - , PrimBytes (..) - ) where - -#include "MachDeps.h" - -#ifndef ghcjs_HOST_OS -import GHC.Base (runRW#) -#endif -import GHC.Int (Int16 (..), Int32 (..), Int64 (..), Int8 (..)) -import GHC.Prim -import GHC.Types (Double (..), Float (..), Int (..), RuntimeRep (..), - Type, Word (..)) - -import GHC.Word (Word16 (..), Word32 (..), Word64 (..), Word8 (..)) - - -type family ElemRep a :: RuntimeRep -type instance ElemRep Float = 'FloatRep -type instance ElemRep Double = 'DoubleRep -type instance ElemRep Int = 'IntRep -type instance ElemRep Int8 = 'IntRep -type instance ElemRep Int16 = 'IntRep -type instance ElemRep Int32 = 'IntRep -#if WORD_SIZE_IN_BITS < 64 -type instance ElemRep Int64 = 'Int64Rep -#else -type instance ElemRep Int64 = 'IntRep -#endif -type instance ElemRep Word = 'WordRep -type instance ElemRep Word8 = 'WordRep -type instance ElemRep Word16 = 'WordRep -type instance ElemRep Word32 = 'WordRep -#if WORD_SIZE_IN_BITS < 64 -type instance ElemRep Word64 = 'Word64Rep -#else -type instance ElemRep Word64 = 'WordRep -#endif - -type family ElemPrim a :: TYPE (r :: RuntimeRep) -type instance ElemPrim Float = Float# -type instance ElemPrim Double = Double# -type instance ElemPrim Int = Int# -type instance ElemPrim Int8 = Int# -type instance ElemPrim Int16 = Int# -type instance ElemPrim Int32 = Int# -#if WORD_SIZE_IN_BITS < 64 -type instance ElemPrim Int64 = Int64# -#else -type instance ElemPrim Int64 = Int# -#endif -type instance ElemPrim Word = Word# -type instance ElemPrim Word8 = Word# -type instance ElemPrim Word16 = Word# -type instance ElemPrim Word32 = Word# -#if WORD_SIZE_IN_BITS < 64 -type instance ElemPrim Word64 = Word64# -#else -type instance ElemPrim Word64 = Word# -#endif - - --- | Facilities to convert to and from raw byte array. --- Warning! offsets and sizes are in elements, not in bytes! --- Therefore one must be really carefull if having a crazy idea of --- converting between types of different element sizes. -class PrimBytes (a :: Type) where - -- | Store content of a data type in a primitive byte array - -- (ElementOffset, NumberOfElements, ByteArrayContent ) - toBytes :: a -> (# Int# , Int# , ByteArray# #) - -- | Load content of a data type from a primitive byte array - -- (ElementOffset, NumberOfElements, ByteArrayContent ) - fromBytes :: (# Int# , Int# , ByteArray# #) -> a - -- | Size of a data type in bytes - byteSize :: a -> Int# - -- | Alignment of a data type in bytes - byteAlign :: a -> Int# - -- | Size of a conainer type elements in bytes - elementByteSize :: a -> Int# - -- | Primitive indexing - ix :: Int# -> a -> (ElemPrim a :: TYPE (ElemRep a)) - -instance PrimBytes Float where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapFloat v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapFloat arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(F# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = F# (indexFloatArray# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_HSFLOAT# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSFLOAT# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (F# x) = x - {-# INLINE ix #-} - -instance PrimBytes Double where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapDouble v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapDouble arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(D# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = D# (indexDoubleArray# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_HSDOUBLE# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSDOUBLE# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (D# x) = x - {-# INLINE ix #-} - -instance PrimBytes Int where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapInt v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapInt arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(I# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeIntArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = I# (indexIntArray# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_HSINT# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSINT# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (I# x) = x - {-# INLINE ix #-} - -instance PrimBytes Int8 where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapInt8 v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapInt8 arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(I8# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeInt8Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = I8# (indexInt8Array# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_INT8# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT8# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (I8# x) = x - {-# INLINE ix #-} - -instance PrimBytes Int16 where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapInt16 v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapInt16 arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(I16# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeInt16Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = I16# (indexInt16Array# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_INT16# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT16# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (I16# x) = x - {-# INLINE ix #-} - -instance PrimBytes Int32 where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapInt32 v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapInt32 arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(I32# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeInt32Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = I32# (indexInt32Array# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_INT32# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT32# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (I32# x) = x - {-# INLINE ix #-} - -#ifndef ghcjs_HOST_OS -instance PrimBytes Int64 where - toBytes v@(I64# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeInt64Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = I64# (indexInt64Array# arr off) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_INT64# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT64# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (I64# x) = x - {-# INLINE ix #-} -#endif - -instance PrimBytes Word where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapWord v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapWord arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(W# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeWordArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = W# (indexWordArray# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_HSWORD# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSWORD# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (W# x) = x - {-# INLINE ix #-} - -instance PrimBytes Word8 where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapWord8 v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapWord8 arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(W8# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeWord8Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = W8# (indexWord8Array# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_WORD8# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD8# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (W8# x) = x - {-# INLINE ix #-} - -instance PrimBytes Word16 where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapWord16 v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapWord16 arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(W16# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeWord16Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = W16# (indexWord16Array# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_WORD16# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD16# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (W16# x) = x - {-# INLINE ix #-} - -instance PrimBytes Word32 where -#ifdef ghcjs_HOST_OS - toBytes v = (# 0#, 1#, js_wrapWord32 v #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = js_unwrapWord32 arr off - {-# INLINE fromBytes #-} -#else - toBytes v@(W32# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeWord32Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = W32# (indexWord32Array# arr off) - {-# INLINE fromBytes #-} -#endif - byteSize _ = SIZEOF_WORD32# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD32# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (W32# x) = x - {-# INLINE ix #-} - - -#ifndef ghcjs_HOST_OS -instance PrimBytes Word64 where - toBytes v@(W64# x) = case runRW# - ( \s0 -> case newByteArray# (byteSize v) s0 of - (# s1, marr #) -> case writeWord64Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> (# 0#, 1#, a #) - {-# INLINE toBytes #-} - fromBytes (# off, _, arr #) = W64# (indexWord64Array# arr off) - {-# INLINE fromBytes #-} - byteSize _ = SIZEOF_WORD64# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD64# - {-# INLINE byteAlign #-} - elementByteSize = byteSize - {-# INLINE elementByteSize #-} - ix _ (W64# x) = x - {-# INLINE ix #-} -#endif - -#ifdef ghcjs_HOST_OS -foreign import javascript unsafe "h$wrapBuffer((new Float32Array([$1])).buffer)" js_wrapFloat :: Float -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Float64Array([$1])).buffer)" js_wrapDouble :: Double -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Int32Array([$1])).buffer)" js_wrapInt :: Int -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Int32Array([$1])).buffer)" js_wrapInt32 :: Int32 -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Int16Array([$1])).buffer)" js_wrapInt16 :: Int16 -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Int8Array([$1])).buffer)" js_wrapInt8 :: Int8 -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Uint32Array([$1])).buffer)" js_wrapWord :: Word -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Uint32Array([$1])).buffer)" js_wrapWord32 :: Word32 -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Uint16Array([$1])).buffer)" js_wrapWord16 :: Word16 -> ByteArray# -foreign import javascript unsafe "h$wrapBuffer((new Uint8Array([$1])).buffer)" js_wrapWord8 :: Word8 -> ByteArray# - - - -foreign import javascript unsafe "($1.f3 || new Float32Array($1.buf))[$2]" js_unwrapFloat :: ByteArray# -> Int# -> Float -foreign import javascript unsafe "($1.f6 || new Float64Array($1.buf))[$2]" js_unwrapDouble :: ByteArray# -> Int# -> Double -foreign import javascript unsafe "($1.i3 || new Int32Array($1.buf))[$2]" js_unwrapInt :: ByteArray# -> Int# -> Int -foreign import javascript unsafe "($1.i3 || new Int32Array($1.buf))[$2]" js_unwrapInt32 :: ByteArray# -> Int# -> Int32 -foreign import javascript unsafe "($1.i1 || new Int16Array($1.buf))[$2]" js_unwrapInt16 :: ByteArray# -> Int# -> Int16 -foreign import javascript unsafe "($1.i8 || new Int8Array($1.buf))[$2]" js_unwrapInt8 :: ByteArray# -> Int# -> Int8 -foreign import javascript unsafe "($1.u3 || new Uint32Array($1.buf))[$2]" js_unwrapWord :: ByteArray# -> Int# -> Word -foreign import javascript unsafe "($1.u3 || new Uint32Array($1.buf))[$2]" js_unwrapWord32 :: ByteArray# -> Int# -> Word32 -foreign import javascript unsafe "($1.u1 || new Uint16Array($1.buf))[$2]" js_unwrapWord16 :: ByteArray# -> Int# -> Word16 -foreign import javascript unsafe "($1.u8 || new Uint8Array($1.buf))[$2]" js_unwrapWord8 :: ByteArray# -> Int# -> Word8 -#endif diff --git a/src/Numeric/DataFrame.hs b/src/Numeric/DataFrame.hs --- a/src/Numeric/DataFrame.hs +++ b/src/Numeric/DataFrame.hs @@ -1,19 +1,7 @@ ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ +{-# LANGUAGE PatternSynonyms #-} module Numeric.DataFrame - ( DataFrame (SomeDataFrame) - , NumericFrame - -- * Utility type families and constraints - , FPFRame, IntegralFrame, NumericVariantFrame, CommonOpFrame + ( module Numeric.DataFrame.Type -- * Simplified type aliases , module Numeric.Scalar , module Numeric.Vector @@ -21,19 +9,12 @@ -- * Functionality , module Numeric.DataFrame.SubSpace , module Numeric.DataFrame.Contraction - , module Numeric.DataFrame.Inference , module Numeric.DataFrame.Shape - , ElementWise () - , ArrayInstanceEvidence, ArrayInstance (..), getArrayInstance, inferArrayInstance - , ArraySizeInference (..), ArraySize (..) - , ElemTypeInference (..), ElemType (..) ) where -import Numeric.Array -import Numeric.Array.ElementWise +import Numeric.DataFrame.Internal.Array () import Numeric.DataFrame.Contraction -import Numeric.DataFrame.Inference import Numeric.DataFrame.Shape import Numeric.DataFrame.SubSpace import Numeric.DataFrame.Type @@ -41,5 +22,3 @@ import Numeric.Matrix import Numeric.Scalar import Numeric.Vector - - diff --git a/src/Numeric/DataFrame/Contraction.hs b/src/Numeric/DataFrame/Contraction.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Contraction.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.DataFrame.Contraction +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- Maintainer : chirkin@arch.ethz.ch +-- +-- This modules provides generalization of a matrix product: +-- tensor-like contraction. +-- For matrices and vectors this is a normal matrix*matrix or vector*matrix or matrix*vector product, +-- for larger dimensions it calculates the scalar product of "adjacent" dimesnions of a tensor. +-- +----------------------------------------------------------------------------- + +module Numeric.DataFrame.Contraction + ( Contraction (..), (%*) + ) where + +import GHC.Base + +import Numeric.DataFrame.Family +import Numeric.DataFrame.Internal.Array.Class +import Numeric.Dimensions + + + +class ConcatList as bs asbs + => Contraction (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) + | asbs as -> bs, asbs bs -> as, as bs -> asbs where + -- | Generalization of a matrix product: take scalar product over one dimension + -- and, thus, concatenate other dimesnions + contract :: ( KnownDim m + , PrimArray t (DataFrame t (as +: m)) + , PrimArray t (DataFrame t (m :+ bs)) + , PrimArray t (DataFrame t asbs) + ) + => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs + +-- | Tensor contraction. +-- In particular: +-- 1. matrix-matrix product +-- 2. matrix-vector or vector-matrix product +-- 3. dot product of two vectors. +(%*) :: ( ConcatList as bs (as ++ bs) + , Contraction t as bs asbs + , KnownDim m + , PrimArray t (DataFrame t (as +: m)) + , PrimArray t (DataFrame t (m :+ bs)) + , PrimArray t (DataFrame t (as ++ bs)) + ) => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t (as ++ bs) +(%*) = contract +{-# INLINE (%*) #-} +infixl 7 %* + + + +instance ( ConcatList as bs asbs + , Dimensions as + , Dimensions bs + , Num t + ) => Contraction t as bs asbs where + contract :: forall m . + ( KnownDim m + , PrimArray t (DataFrame t (as +: m)) + , PrimArray t (DataFrame t (m :+ bs)) + , PrimArray t (DataFrame t asbs) + ) + => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs + contract x y + | I# m <- fromIntegral $ dimVal' @m + , I# n <- fromIntegral $ totalDim' @as + , I# k <- fromIntegral $ totalDim' @bs + , nk <- n *# k + = let loop i j l r | isTrue# (l ==# m) = r + | otherwise = loop i j (l +# 1#) + (r + ix# (i +# n *# l) x * ix# (l +# m *# j) y) + + loop2 (T# i j) | isTrue# (j ==# k) = (# T# i j, 0 #) + | isTrue# (i ==# n) = loop2 (T# 0# (j +# 1#)) + | otherwise = (# T# (i +# 1#) j, loop i j 0# 0 #) + in case gen# nk loop2 (T# 0# 0#) of + (# _, r #) -> r + +data T# = T# Int# Int# diff --git a/src/Numeric/DataFrame/Family.hs b/src/Numeric/DataFrame/Family.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Family.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- | The very core of DataFrame: definition of the data family. +module Numeric.DataFrame.Family ( DataFrame ) where + +-- | Keep data in a primitive data frame +-- and maintain information about Dimensions in the type system +data family DataFrame (t :: l) (xs :: [k]) diff --git a/src/Numeric/DataFrame/IO.hs b/src/Numeric/DataFrame/IO.hs --- a/src/Numeric/DataFrame/IO.hs +++ b/src/Numeric/DataFrame/IO.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,10 +5,11 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -19,334 +19,193 @@ -- -- Maintainer : chirkin@arch.ethz.ch -- ----- Mutable DataFrames living in IO. +-- Mutable DataFrames living in IO. -- ----------------------------------------------------------------------------- module Numeric.DataFrame.IO - ( -#ifdef ghcjs_HOST_OS - MutableFrame (), IODataFrame (..), MDataFrame (..), MutableArrayT (..) -#else - MutableFrame (), IODataFrame () -#endif - , SomeIODataFrame (..) - , newDataFrame, copyDataFrame, copyMutableDataFrame - , unsafeFreezeDataFrame - , freezeDataFrame, thawDataFrame - , writeDataFrame, readDataFrame - , writeDataFrameOff, readDataFrameOff -#ifdef ghcjs_HOST_OS - -- * JavaScript-specific functions - , MutableArrayBuffer - , newArrayBuffer, arrayBuffer, viewFloatArray, viewDoubleArray - , viewIntArray, viewInt32Array, viewInt16Array, viewInt8Array - , viewWordArray, viewWord32Array, viewWord16Array, viewWord8Array, viewWord8ClampedArray -#endif + ( IODataFrame (XIOFrame), SomeIODataFrame (..) + , newDataFrame, newPinnedDataFrame + , copyDataFrame, copyMutableDataFrame + , freezeDataFrame, unsafeFreezeDataFrame + , thawDataFrame, thawPinDataFrame, unsafeThawDataFrame + , writeDataFrame, writeDataFrameOff + , readDataFrame, readDataFrameOff + , withDataFramePtr, isDataFramePinned ) where -import GHC.Prim (RealWorld) -import GHC.Types (Int (..), IO (..)) +import GHC.Base +import GHC.IO (IO (..)) +import GHC.Ptr (Ptr (..)) -#ifdef ghcjs_HOST_OS -import Numeric.Array.Family hiding (Scalar) -import JavaScript.TypedArray.ArrayBuffer -import GHC.Prim -import Data.Int -import Data.Word -import Data.Maybe -import GHCJS.Types -import Numeric.DataFrame.Inference -#endif -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.DataFrame.Mutable +import Numeric.DataFrame.Family +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Mutable import Numeric.Dimensions -import Numeric.Scalar +import Numeric.PrimBytes + -- | Mutable DataFrame that lives in IO. --- Internal representation is always a ByteArray. -newtype IODataFrame t (ns :: [Nat]) = IODataFrame (MDataFrame RealWorld t (ns :: [Nat])) -#ifdef ghcjs_HOST_OS -instance IsJSVal (IODataFrame t ds) -#endif +-- Internal representation is always a MutableByteArray. +data family IODataFrame (t :: Type) (ns :: [k]) + +-- | Pure wrapper on a mutable byte array +newtype instance IODataFrame t (ns :: [Nat]) = IODataFrame (MDataFrame RealWorld t (ns :: [Nat])) + +-- | Data frame with some dimensions missing at compile time. +-- Pattern-match against its constructor to get a Nat-indexed mutable data frame. +data instance IODataFrame t (xs :: [XNat]) + = forall (ns :: [Nat]) . Dimensions ns + => XIOFrame (IODataFrame t ns) + -- | Mutable DataFrame of unknown dimensionality -data SomeIODataFrame t (xns :: [XNat]) - = forall (ns :: [Nat]) - . ( FixedDim xns ns ~ ns - , FixedXDim xns ns ~ xns - , NumericFrame t ns - ) - => SomeIODataFrame (IODataFrame t ns) +data SomeIODataFrame (t :: Type) + = forall (ns :: [Nat]) . Dimensions ns => SomeIODataFrame (IODataFrame t ns) -- | Create a new mutable DataFrame. newDataFrame :: forall t (ns :: [Nat]) -#ifdef ghcjs_HOST_OS - . ( ElemTypeInference t, Dimensions ns) -#else - . ( PrimBytes t, Dimensions ns) -#endif - => IO (IODataFrame t ns) + . ( PrimBytes t, Dimensions ns) + => IO (IODataFrame t ns) newDataFrame = IODataFrame <$> IO (newDataFrame# @t @ns) {-# INLINE newDataFrame #-} + +-- | Create a new mutable DataFrame. +newPinnedDataFrame :: forall t (ns :: [Nat]) + . ( PrimBytes t, Dimensions ns) + => IO (IODataFrame t ns) +newPinnedDataFrame = IODataFrame <$> IO (newPinnedDataFrame# @t @ns) +{-# INLINE newPinnedDataFrame #-} + + -- | Copy one DataFrame into another mutable DataFrame at specified position. -copyDataFrame :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) - . ( ConcatList as (b :+ bs) asbs, Dimensions (b :+ bs) -#ifdef ghcjs_HOST_OS - , ArraySizeInference (as +: b'), Dimensions as -#else +copyDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) + (bs :: [Nat]) (asbs :: [Nat]) + . ( PrimBytes t , PrimBytes (DataFrame t (as +: b')) -#endif + , ConcatList as (b :+ bs) asbs + , Dimensions (b :+ bs) ) - => DataFrame t (as +: b') -> Idx (b :+ bs) -> IODataFrame t asbs -> IO () + => DataFrame t (as +: b') -> Idxs (b :+ bs) -> IODataFrame t asbs -> IO () copyDataFrame df ei (IODataFrame mdf) = IO (copyDataFrame# df ei mdf) {-# INLINE copyDataFrame #-} - -- | Copy one mutable DataFrame into another mutable DataFrame at specified position. -copyMutableDataFrame :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) - . ( PrimBytes t - , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) -#ifdef ghcjs_HOST_OS - , Dimensions as -#endif - ) - => IODataFrame t (as +: b') -> Idx (b :+ bs) -> IODataFrame t asbs -> IO () +copyMutableDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) + (bs :: [Nat]) (asbs :: [Nat]) + . ( PrimBytes t + , ConcatList as (b :+ bs) asbs + , Dimensions (b :+ bs) + ) + => IODataFrame t (as +: b') -> Idxs (b :+ bs) + -> IODataFrame t asbs -> IO () copyMutableDataFrame (IODataFrame mdfA) ei (IODataFrame mdfB) = IO (copyMDataFrame# mdfA ei mdfB) {-# INLINE copyMutableDataFrame #-} -- | Make a mutable DataFrame immutable, without copying. -unsafeFreezeDataFrame :: forall t (ns :: [Nat]) -#ifdef ghcjs_HOST_OS - . (MutableFrame t ns, ArraySizeInference ns) -#else - . PrimBytes (DataFrame t ns) -#endif - => IODataFrame t ns -> IO (DataFrame t ns) +unsafeFreezeDataFrame :: forall (t :: Type) (ns :: [Nat]) + . PrimArray t (DataFrame t ns) + => IODataFrame t ns -> IO (DataFrame t ns) unsafeFreezeDataFrame (IODataFrame mdf) = IO (unsafeFreezeDataFrame# mdf) {-# INLINE unsafeFreezeDataFrame #-} -- | Copy content of a mutable DataFrame into a new immutable DataFrame. -freezeDataFrame :: forall t (ns :: [Nat]) -#ifdef ghcjs_HOST_OS - . (MutableFrame t ns, ArraySizeInference ns) -#else - . PrimBytes (DataFrame t ns) -#endif +freezeDataFrame :: forall (t :: Type) (ns :: [Nat]) + . PrimArray t (DataFrame t ns) => IODataFrame t ns -> IO (DataFrame t ns) freezeDataFrame (IODataFrame mdf) = IO (freezeDataFrame# mdf) {-# INLINE freezeDataFrame #-} -- | Create a new mutable DataFrame and copy content of immutable one in there. -thawDataFrame :: forall t (ns :: [Nat]) -#ifdef ghcjs_HOST_OS - . (MutableFrame t ns, ArrayInstanceInference t ns) -#else - . PrimBytes (DataFrame t ns) -#endif - => DataFrame t ns -> IO (IODataFrame t ns) +thawDataFrame :: forall (t :: Type) (ns :: [Nat]) + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> IO (IODataFrame t ns) thawDataFrame df = IODataFrame <$> IO (thawDataFrame# df) {-# INLINE thawDataFrame #-} +-- | Create a new mutable DataFrame and copy content of immutable one in there. +-- The result array is pinned and aligned. +thawPinDataFrame :: forall (t :: Type) (ns :: [Nat]) + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> IO (IODataFrame t ns) +thawPinDataFrame df = IODataFrame <$> IO (thawPinDataFrame# df) +{-# INLINE thawPinDataFrame #-} +-- | UnsafeCoerces an underlying byte array. +unsafeThawDataFrame :: forall (t :: Type) (ns :: [Nat]) + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> IO (IODataFrame t ns) +unsafeThawDataFrame df = IODataFrame <$> IO (unsafeThawDataFrame# df) +{-# INLINE unsafeThawDataFrame #-} + + -- | Write a single element at the specified index writeDataFrame :: forall t (ns :: [Nat]) - . ( MutableFrame t ns, Dimensions ns ) - => IODataFrame t ns -> Idx ns -> Scalar t -> IO () -writeDataFrame (IODataFrame mdf) ei = IO . writeDataFrame# mdf ei . unScalar + . ( PrimBytes t, Dimensions ns ) + => IODataFrame t ns -> Idxs ns -> DataFrame t ('[] :: [Nat]) -> IO () +writeDataFrame (IODataFrame mdf) ei = IO . writeDataFrame# mdf ei . unsafeCoerce# {-# INLINE writeDataFrame #-} -- | Read a single element at the specified index -readDataFrame :: forall t (ns :: [Nat]) - . ( MutableFrame t ns, Dimensions ns ) - => IODataFrame t ns -> Idx ns -> IO (Scalar t) -readDataFrame (IODataFrame mdf) = fmap scalar . IO . readDataFrame# mdf +readDataFrame :: forall (t :: Type) (ns :: [Nat]) + . ( PrimBytes t, Dimensions ns ) + => IODataFrame t ns -> Idxs ns -> IO (DataFrame t ('[] :: [Nat])) +readDataFrame (IODataFrame mdf) = unsafeCoerce# . IO . readDataFrame# mdf {-# INLINE readDataFrame #-} -- | Write a single element at the specified element offset -writeDataFrameOff :: forall t (ns :: [Nat]) - . ( MutableFrame t ns, Dimensions ns ) - => IODataFrame t ns -> Int -> Scalar t -> IO () -writeDataFrameOff (IODataFrame mdf) (I# i) x = IO $ \s -> (# writeDataFrameOff# mdf i (unScalar x) s, () #) +writeDataFrameOff :: forall (t :: Type) (ns :: [Nat]) + . PrimBytes t + => IODataFrame t ns -> Int -> DataFrame t ('[] :: [Nat]) -> IO () +writeDataFrameOff (IODataFrame mdf) (I# i) + = IO . writeDataFrameOff# mdf i . unsafeCoerce# {-# INLINE writeDataFrameOff #-} -- | Read a single element at the specified element offset -readDataFrameOff :: forall t (ns :: [Nat]) - . ( MutableFrame t ns, Dimensions ns ) - => IODataFrame t ns -> Int -> IO (Scalar t) -readDataFrameOff (IODataFrame mdf) (I# i) = scalar <$> IO (readDataFrameOff# mdf i) +readDataFrameOff :: forall (t :: Type) (ns :: [Nat]) + . PrimBytes t + => IODataFrame t ns -> Int -> IO (DataFrame t ('[] :: [Nat])) +readDataFrameOff (IODataFrame mdf) (I# i) + = unsafeCoerce# (IO (readDataFrameOff# mdf i)) {-# INLINE readDataFrameOff #-} -#ifdef ghcjs_HOST_OS -newArrayBuffer :: Int -> IO MutableArrayBuffer -newArrayBuffer n = unsafeCoerce# <$> IO (newArrayBuffer# n) - -viewFloatArray :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Float (AsXDims ds +: XN 0)) -viewFloatArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Float))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewFloatArray# (jsval ab) :: IO (IODataFrame Float (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Float ds) pn - of - Evidence -> case inferNumericFrame @Float @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewDoubleArray :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Double (AsXDims ds +: XN 0)) -viewDoubleArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Double))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewDoubleArray# (jsval ab) :: IO (IODataFrame Double (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Double ds) pn - of - Evidence -> case inferNumericFrame @Double @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewIntArray :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Int (AsXDims ds +: XN 0)) -viewIntArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewIntArray# (jsval ab) :: IO (IODataFrame Int (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int ds) pn - of - Evidence -> case inferNumericFrame @Int @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewInt32Array :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Int32 (AsXDims ds +: XN 0)) -viewInt32Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int32))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewInt32Array# (jsval ab) :: IO (IODataFrame Int32 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int32 ds) pn - of - Evidence -> case inferNumericFrame @Int32 @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewInt16Array :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Int16 (AsXDims ds +: XN 0)) -viewInt16Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int16))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewInt16Array# (jsval ab) :: IO (IODataFrame Int16 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int16 ds) pn - of - Evidence -> case inferNumericFrame @Int16 @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewInt8Array :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Int8 (AsXDims ds +: XN 0)) -viewInt8Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int8))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewInt8Array# (jsval ab) :: IO (IODataFrame Int8 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int8 ds) pn - of - Evidence -> case inferNumericFrame @Int8 @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewWordArray :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Word (AsXDims ds +: XN 0)) -viewWordArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewWordArray# (jsval ab) :: IO (IODataFrame Word (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word ds) pn - of - Evidence -> case inferNumericFrame @Word @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewWord32Array :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Word32 (AsXDims ds +: XN 0)) -viewWord32Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word32))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewWord32Array# (jsval ab) :: IO (IODataFrame Word32 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word32 ds) pn - of - Evidence -> case inferNumericFrame @Word32 @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewWord16Array :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Word16 (AsXDims ds +: XN 0)) -viewWord16Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word16))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewWord16Array# (jsval ab) :: IO (IODataFrame Word16 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word16 ds) pn - of - Evidence -> case inferNumericFrame @Word16 @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewWord8Array :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Word8 (AsXDims ds +: XN 0)) -viewWord8Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word8))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewWord8Array# (jsval ab) :: IO (IODataFrame Word8 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word8 ds) pn - of - Evidence -> case inferNumericFrame @Word8 @(ds +: n) of - Evidence -> SomeIODataFrame df - -viewWord8ClampedArray :: forall ds - . ( Dimensions ds, ArraySizeInference ds) - => MutableArrayBuffer -> IO (SomeIODataFrame Word8Clamped (AsXDims ds +: XN 0)) -viewWord8ClampedArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word8Clamped))) (dim @ds) ab - df <- fmap IODataFrame . IO $ viewWord8ClampedArray# (jsval ab) :: IO (IODataFrame Word8Clamped (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word8Clamped ds) pn - of - Evidence -> case inferNumericFrame @Word8Clamped @(ds +: n) of - Evidence -> SomeIODataFrame df - -arrayBuffer :: IODataFrame t ds -> IO MutableArrayBuffer -arrayBuffer (IODataFrame x) = unsafeCoerce# <$> IO (arrayBuffer# x) +-- | Allow arbitrary IO operations on a pointer to the beginning of the data +-- keeping the data from garbage collecting until the arg function returns. +-- +-- Warning: do not let @Ptr t@ leave the scope of the arg function, +-- the data may be garbage-collected by then. +-- +-- Warning: use this function on a pinned DataFrame only; +-- otherwise, the data may be relocated before the arg fun finishes. +withDataFramePtr :: forall (t :: Type) (ns :: [k]) (r :: Type) + . (PrimBytes t, KnownDimKind k) + => IODataFrame t ns + -> ( Ptr t -> IO r ) + -> IO r +withDataFramePtr df k = case dimKind @k of + DimNat -> case df of + IODataFrame x + -> IO $ withDataFramePtr# x (unsafeCoerce# k) + DimXNat -> case df of + XIOFrame (IODataFrame x) + -> IO $ withDataFramePtr# x (unsafeCoerce# k) -foreign import javascript unsafe "$1.length" js_abLength :: MutableArrayBuffer -> IO Int - -abDim :: Int -> Dim (ds :: [Nat]) -> MutableArrayBuffer -> IO SomeDim -abDim elS d ab = fromMaybe (SomeDim (Dn :: Dim 0)) . someDimVal . (`quot` (elS * dimVal d)) <$> js_abLength ab - -unsafeForceFixedDims :: forall ds n - . Evidence ( FixedDim (AsXDims ds +: XN 0) (ds +: n) ~ (ds +: n) - , FixedXDim (AsXDims ds +: XN 0) (ds +: n) ~ (AsXDims ds +: XN 0) - ) -unsafeForceFixedDims = unsafeCoerce# (Evidence :: Evidence ( (ds +: n) ~ (ds +: n) , (ds +: n) ~ (ds +: n) )) - -#endif +-- | Check if the byte array wrapped by this DataFrame is pinned, +-- which means cannot be relocated by GC. +isDataFramePinned :: forall (t :: Type) (ns :: [k]) + . KnownDimKind k + => IODataFrame t ns -> Bool +isDataFramePinned df = case dimKind @k of + DimNat -> case df of + IODataFrame x -> isDataFramePinned# x + DimXNat -> case df of + XIOFrame (IODataFrame x) -> isDataFramePinned# x diff --git a/src/Numeric/DataFrame/Internal/Array.hs b/src/Numeric/DataFrame/Internal/Array.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.DataFrame.Internal.Array +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- Maintainer : chirkin@arch.ethz.ch +-- +-- Low-level implementations of data frames +-- +----------------------------------------------------------------------------- + +module Numeric.DataFrame.Internal.Array + ( module Numeric.DataFrame.Internal.Array.Family + ) where + +import Numeric.DataFrame.Internal.Array.Family +-- import Numeric.DataFrame.Internal.Array.Family.ArrayBase () + +-- import Numeric.DataFrame.Internal.Array.Family.FloatX2 () +-- import Numeric.DataFrame.Internal.Array.Family.FloatX3 () +-- import Numeric.DataFrame.Internal.Array.Family.FloatX4 () +-- +-- import Numeric.DataFrame.Internal.Array.Family.DoubleX2 () +-- import Numeric.DataFrame.Internal.Array.Family.DoubleX3 () +-- import Numeric.DataFrame.Internal.Array.Family.DoubleX4 () diff --git a/src/Numeric/DataFrame/Internal/Array/Class.hs b/src/Numeric/DataFrame/Internal/Array/Class.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Class.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Array.Class + ( PrimArray (..) + , ixOff, unsafeFromFlatList + ) where + +import GHC.Base (ByteArray#, Int#, Int (..)) +import Numeric.PrimBytes + + +class PrimBytes t => PrimArray t a | a -> t where + -- | Broadcast element into array + broadcast :: t -> a + -- | Index an array given an offset + ix# :: Int# -> a -> t + -- | Generate an array using an accumulator funtion + gen# :: Int# -- ^ number of elements, not checked! + -- Avoid using this argument if possible. + -> (s -> (# s, t #)) + -> s -> (# s, a #) + -- | update a single element in an array given an offset + upd# :: Int# -- ^ number of elements, not checked! + -- Avoid using this argument if possible. + -> Int# -> t -> a -> a + + -- | Offset of an array in number of elements + elemOffset :: a -> Int# + + -- | Number of elements in an array. + -- Returns zero if this information is not available at runtime. + -- This is possible only if all elements are same in an array. + elemSize0 :: a -> Int# + + -- | Get array by its offset and size in a ByteArray. + -- Both offset and size are given in element number. + fromElems :: Int# -> Int# -> ByteArray# -> a + +-- | Index array by an integer offset (starting from 0). +ixOff :: PrimArray t a => Int -> a -> t +ixOff (I# i) = ix# i + +-- | Construct an array from a flat list and length +unsafeFromFlatList :: PrimArray t a => Int -> [t] -> a +unsafeFromFlatList (I# n) vs = case gen# n f vs of (# _, r #) -> r + where + f [] = (# [], undefined #) + f (x:xs) = (# xs, x #) diff --git a/src/Numeric/DataFrame/Internal/Array/Family.hs b/src/Numeric/DataFrame/Internal/Array/Family.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.DataFrame.Internal.Array.Family +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- Maintainer : chirkin@arch.ethz.ch +-- +-- +----------------------------------------------------------------------------- + +module Numeric.DataFrame.Internal.Array.Family + ( Array, ScalarBase (..), ArrayBase (..) + , ArraySingleton (..) + , ArraySing (..), aSingEv, inferASing + , inferPrimElem, inferPrim, inferEq, inferShow, inferOrd, inferNum + , inferFractional, inferFloating + ) where + + +import GHC.Base + + +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.Family.ArrayBase +import Numeric.DataFrame.Internal.Array.Family.DoubleX2 +import Numeric.DataFrame.Internal.Array.Family.DoubleX3 +import Numeric.DataFrame.Internal.Array.Family.DoubleX4 +import Numeric.DataFrame.Internal.Array.Family.FloatX2 +import Numeric.DataFrame.Internal.Array.Family.FloatX3 +import Numeric.DataFrame.Internal.Array.Family.FloatX4 +import Numeric.DataFrame.Internal.Array.Family.ScalarBase +import Numeric.Dimensions +import Numeric.PrimBytes + + +-- | This type family aggregates all types used for arrays with different +-- dimensioinality. +-- The family is injective; thus, it is possible to get type family instance +-- given the data constructor (and vice versa). +-- If GHC knows the dimensionality of an array at compile time, it chooses +-- a more efficient specialized instance of Array, e.g. Scalar newtype wrapper. +-- Otherwise, it falls back to the generic ArrayBase implementation. +-- +-- Data family would not work here, because it would give overlapping instances. +type family Array (t :: Type) (ds :: [Nat]) = (v :: Type) | v -> t ds where + Array t '[] = ScalarBase t + Array Float '[2] = FloatX2 + Array Float '[3] = FloatX3 + Array Float '[4] = FloatX4 + Array Double '[2] = DoubleX2 + Array Double '[3] = DoubleX3 + Array Double '[4] = DoubleX4 + Array t ds = ArrayBase t ds + +-- | A framework for using Array type family instances. +class ArraySingleton (t :: Type) (ds :: [Nat]) where + -- | Get Array type family instance + aSing :: ArraySing t ds + +data ArraySing t (ds :: [Nat]) where + AScalar :: (Array t ds ~ ScalarBase t) => ArraySing t '[] + AF2 :: (Array t ds ~ FloatX2) => ArraySing Float '[2] + AF3 :: (Array t ds ~ FloatX3) => ArraySing Float '[3] + AF4 :: (Array t ds ~ FloatX4) => ArraySing Float '[4] + AD2 :: (Array t ds ~ DoubleX2) => ArraySing Double '[2] + AD3 :: (Array t ds ~ DoubleX3) => ArraySing Double '[3] + AD4 :: (Array t ds ~ DoubleX4) => ArraySing Double '[4] + ABase :: ( Array t ds ~ ArrayBase t ds + , PrimBytes t + ) => ArraySing t ds + +deriving instance Eq (ArraySing t ds) +deriving instance Ord (ArraySing t ds) +deriving instance Show (ArraySing t ds) + + + +-- | This function does GHC's magic to convert user-supplied `aSing` function +-- to create an instance of `ArraySingleton` typeclass at runtime. +-- The trick is taken from Edward Kmett's reflection library explained +-- in https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection +reifyArraySing :: forall r t ds + . ArraySing t ds -> ( ArraySingleton t ds => r) -> r +reifyArraySing as k + = unsafeCoerce# (MagicArraySing k :: MagicArraySing t ds r) as +{-# INLINE reifyArraySing #-} +newtype MagicArraySing t (ds :: [Nat]) r + = MagicArraySing (ArraySingleton t ds => r) + +-- | Use `ArraySing` GADT to construct an `ArraySingleton` dictionary. +-- In other words, bring an evidence of `ArraySingleton` instance into +-- a scope at runtime. +aSingEv :: ArraySing t ds -> Evidence (ArraySingleton t ds) +aSingEv ds = reifyArraySing ds E +{-# INLINE aSingEv #-} + +-- | Use `ArraySing` GADT to construct an `ArraySingleton` dictionary. +-- The same as `aSingEv`, but relies on `PrimBytes` and `Dimensions`. +inferASing :: forall t ds + . (PrimBytes t, Dimensions ds) + => Evidence (ArraySingleton t ds) +inferASing = case (dims @_ @ds, primTag @t undefined) of + (U, _) -> E + (d :* U, PTagFloat) + | Just E <- sameDim (D @2) d -> E + | Just E <- sameDim (D @3) d -> E + | Just E <- sameDim (D @4) d -> E + (d :* U, PTagDouble) + | Just E <- sameDim (D @2) d -> E + | Just E <- sameDim (D @3) d -> E + | Just E <- sameDim (D @4) d -> E + _ -> case (unsafeCoerce# (E @(ds ~ ds)) :: Evidence (ds ~ '[0])) of E -> E +{-# INLINE inferASing #-} + + +instance {-# OVERLAPPABLE #-} + (Array t ds ~ ArrayBase t ds, PrimBytes t) + => ArraySingleton t ds where + aSing = ABase +instance {-# OVERLAPPING #-} ArraySingleton t '[] where + aSing = AScalar +instance {-# OVERLAPPING #-} ArraySingleton Float '[2] where + aSing = AF2 +instance {-# OVERLAPPING #-} ArraySingleton Float '[3] where + aSing = AF3 +instance {-# OVERLAPPING #-} ArraySingleton Float '[4] where + aSing = AF4 +instance {-# OVERLAPPING #-} ArraySingleton Double '[2] where + aSing = AD2 +instance {-# OVERLAPPING #-} ArraySingleton Double '[3] where + aSing = AD3 +instance {-# OVERLAPPING #-} ArraySingleton Double '[4] where + aSing = AD4 + +-- | This is a special function, because Scalar does not require PrimBytes. +-- That is why the dimension list in the argument is not empty. +inferPrimElem :: forall t d ds + . ArraySingleton t (d ': ds) + => Evidence (PrimBytes t) +inferPrimElem = case (aSing :: ArraySing t (d ': ds)) of + AF2 -> E + AF3 -> E + AF4 -> E + AD2 -> E + AD3 -> E + AD4 -> E + ABase -> E + +-- Rather verbose way to show that there is an instance of a required type class +-- for every instance of the type family. +#define WITNESS case (aSing :: ArraySing t ds) of {\ + AScalar -> E;\ + AF2 -> E;\ + AF3 -> E;\ + AF4 -> E;\ + AD2 -> E;\ + AD3 -> E;\ + AD4 -> E;\ + ABase -> E} + +inferPrim :: forall t ds + . ( PrimBytes t + , ArraySingleton t ds + , Dimensions ds + ) + => Evidence (PrimBytes (Array t ds), PrimArray t (Array t ds)) +inferPrim = WITNESS + +inferEq :: forall t ds + . (Eq t, ArraySingleton t ds) + => Evidence (Eq (Array t ds)) +inferEq = WITNESS + +inferOrd :: forall t ds + . (Ord t, ArraySingleton t ds) + => Evidence (Ord (Array t ds)) +inferOrd = WITNESS + +inferNum :: forall t ds + . (Num t, ArraySingleton t ds) + => Evidence (Num (Array t ds)) +inferNum = WITNESS + +inferFractional :: forall t ds + . (Fractional t, ArraySingleton t ds) + => Evidence (Fractional (Array t ds)) +inferFractional = WITNESS + +inferFloating :: forall t ds + . (Floating t, ArraySingleton t ds) + => Evidence (Floating (Array t ds)) +inferFloating = WITNESS + +inferShow :: forall t ds + . (Show t, Dimensions ds, ArraySingleton t ds) + => Evidence (Show (Array t ds)) +inferShow = WITNESS diff --git a/src/Numeric/DataFrame/Internal/Array/Family/ArrayBase.hs b/src/Numeric/DataFrame/Internal/Array/Family/ArrayBase.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/ArrayBase.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +module Numeric.DataFrame.Internal.Array.Family.ArrayBase + ( ArrayBase (..) + ) where + +import Data.Int +import Data.Word +import GHC.Base hiding (foldr) +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.Dimensions +import Numeric.PrimBytes + +-- | Generic Array implementation. +-- This array can reside in plain `ByteArray#` and can share the @ByteArray#@ +-- with other arrays. +-- However, byte offset in the @ByteArray#@ must be multiple of the element size. +data ArrayBase (t :: Type) (ds :: [Nat]) + = ArrayBase + (# t + -- Same value for each element; + -- this is the cheapest way to initialize an array. + -- It is also used for Num instances to avoid dependency on Dimensions. + | (# Int# -- Offset measured in elements. + , Int# -- Number of elements. + , ByteArray# -- Content. + #) + #) + + +instance (PrimBytes t, Dimensions ds) => PrimBytes (ArrayBase t ds) where + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word64 ds) #-} + + getBytes (ArrayBase a ) = case a of + (# t | #) + | W# nw <- totalDim' @ds + , n <- word2Int# nw + , tbs <- byteSize t -> go tbs (tbs *# n) t + (# | (# _, _, arr #) #) -> + -- very weird trick with touch# allows to workaround GHC bug + -- "internal error: ARR_WORDS object entered!" + -- TODO: report this + case runRW# (\s -> (# touch# arr s, arr #)) of (# _, ba #) -> ba + where + go tbs bsize t = case runRW# + ( \s0 -> case newByteArray# bsize s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop# 0# tbs bsize (\i -> writeBytes mba i t) s1 ) + ) of (# _, ba #) -> ba + {-# NOINLINE go #-} + {-# INLINE getBytes #-} + + fromBytes bOff ba + | W# nw <- totalDim' @ds + , n <- word2Int# nw + , tbs <- byteSize (undefined :: t) + , (# offN, offRem #) <- quotRemInt# bOff tbs + = case offRem of + 0# -> ArrayBase (# | (# offN, n , ba #) #) + _ -> go n (tbs *# n) + where + go n bsize = case runRW# + ( \s0 -> case ( if isTrue# (isByteArrayPinned# ba) + then newAlignedPinnedByteArray# bsize + (byteAlign @t undefined) + else newByteArray# bsize + ) s0 + of + (# s1, mba #) -> unsafeFreezeByteArray# mba + (copyByteArray# ba bOff mba 0# bsize s1) + ) of (# _, r #) -> ArrayBase (# | (# 0# , n , r #) #) + {-# NOINLINE go #-} + {-# INLINE fromBytes #-} + + readBytes mba bOff s0 + | W# nw <- totalDim' @ds + , n <- word2Int# nw + , tbs <- byteSize (undefined :: t) + , bsize <- tbs *# n + = case newByteArray# bsize s0 of + (# s1, mba1 #) -> case unsafeFreezeByteArray# mba1 + (copyMutableByteArray# mba bOff mba1 0# bsize s1) of + (# s2, ba #) -> (# s2, ArrayBase (# | (# 0# , n , ba #) #) #) + {-# INLINE readBytes #-} + + writeBytes mba bOff (ArrayBase c) + | tbs <- byteSize (undefined :: t) = case c of + (# t | #) | W# n <- totalDim' @ds -> + loop# bOff tbs (bOff +# word2Int# n *# tbs) (\i -> writeBytes mba i t) + (# | (# offN, n, arr #) #) -> + copyByteArray# arr (offN *# tbs) mba bOff (n *# tbs) + {-# INLINE writeBytes #-} + + readAddr addr s0 + | W# nw <- totalDim' @ds + , n <- word2Int# nw + , tbs <- byteSize (undefined :: t) + , bsize <- tbs *# n + = case newByteArray# bsize s0 of + (# s1, mba1 #) -> case unsafeFreezeByteArray# mba1 + (copyAddrToByteArray# addr mba1 0# bsize s1) of + (# s2, ba #) -> (# s2, ArrayBase (# | (# 0# , n , ba #) #) #) + {-# INLINE readAddr #-} + + writeAddr (ArrayBase c) addr + | tbs <- byteSize (undefined :: t) = case c of + (# t | #) | W# n <- totalDim' @ds -> + loop# 0# tbs (word2Int# n *# tbs) (\i -> writeAddr t (plusAddr# addr i)) + (# | (# offN, n, arr #) #) -> + copyByteArrayToAddr# arr (offN *# tbs) addr (n *# tbs) + {-# INLINE writeAddr #-} + + + byteSize _ = case totalDim' @ds of -- WARNING: slow! + W# n -> byteSize (undefined :: t) *# word2Int# n + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign (undefined :: t) + {-# INLINE byteAlign #-} + + byteOffset (ArrayBase a) = case a of + (# _ | #) -> 0# + (# | (# off, _, _ #) #) -> off *# byteSize (undefined :: t) + {-# INLINE byteOffset #-} + + indexArray ba off + | W# nw <- totalDim' @ds + , n <- word2Int# nw + = ArrayBase (# | (# off *# n, n, ba #) #) + {-# INLINE indexArray #-} + + + +-- | Accumulates only idempotent operations! +-- Being applied to FromScalars, executes only once! +-- Here, idempotance means: assuming @f a b = g @, @g (g x) = g x@ +-- +-- Also, I assume the size of arrays is the same +accumV2Idempotent :: PrimBytes t + => a + -> (t -> t -> a -> a) + -> ArrayBase t ds -> ArrayBase t ds -> a +accumV2Idempotent x f + (ArrayBase (# a | #)) + (ArrayBase (# b | #)) + = f a b x +accumV2Idempotent x f + a@(ArrayBase (# | (# _, nA, _ #) #)) + b@(ArrayBase (# | (# _, nB, _ #) #)) + = loop1a# (minInt# nA nB) (\i -> f (ix# i a) (ix# i b)) x +accumV2Idempotent x f + (ArrayBase (# a | #)) + b@(ArrayBase (# | (# _, n, _ #) #)) + = loop1a# n (\i -> f a (ix# i b)) x +accumV2Idempotent x f + a@(ArrayBase (# | (# _, n, _ #) #)) + (ArrayBase (# b | #)) + = loop1a# n (\i -> f (ix# i a) b) x +{-# INLINE accumV2Idempotent #-} + +mapV :: PrimBytes t => (t -> t) -> ArrayBase t ds -> ArrayBase t ds +mapV f (ArrayBase (# t | #)) + = ArrayBase (# f t | #) +mapV f x@(ArrayBase (# | (# offN, n, ba #) #)) + | tbs <- byteSize (undefEl x) + = go (tbs *# n) + where + go bsize = case runRW# + ( \s0 -> case newByteArray# bsize s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop1# n + (\i -> writeArray mba i (f (indexArray ba (offN +# i)))) s1 + ) + ) of (# _, r #) -> ArrayBase (# | (# 0#, n, r #) #) + {-# NOINLINE go #-} +{-# INLINE mapV #-} + + +zipV :: PrimBytes t => (t -> t -> t) + -> ArrayBase t ds -> ArrayBase t ds -> ArrayBase t ds +zipV f (ArrayBase (# x | #)) b = mapV (f x) b +zipV f a (ArrayBase (# y | #)) = mapV (flip f y) a +zipV f a@(ArrayBase (# | (# oa, na, ba #) #)) + (ArrayBase (# | (# ob, nb, bb #) #)) + | n <- (minInt# na nb) + = go n (byteSize (undefEl a) *# n) + where + go n bsize = case runRW# + ( \s0 -> case newByteArray# bsize s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop1# n + (\i -> writeArray mba i + (f (indexArray ba (oa +# i)) + (indexArray bb (ob +# i)) + ) + ) s1 + ) + ) of (# _, r #) -> ArrayBase (# | (# 0#, n, r #) #) + {-# NOINLINE go #-} +{-# INLINE zipV #-} + + +-- TODO: to improve performance, I can either compare bytearrays using memcmp +-- or implement early termination if the first elements do not match. +-- On the other hand, hopefully @(&&)@ and @(||)@ ops take care of that. +instance (Eq t, PrimBytes t) => Eq (ArrayBase t ds) where + {-# SPECIALIZE instance Eq (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word64 ds) #-} + (==) = accumV2Idempotent True (\x y r -> r && x == y) + (/=) = accumV2Idempotent False (\x y r -> r || x /= y) + +-- | Implement partial ordering for `>`, `<`, `>=`, `<=` +-- and lexicographical ordering for `compare` +instance (Ord t, PrimBytes t) => Ord (ArrayBase t ds) where + {-# SPECIALIZE instance Ord (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word64 ds) #-} + -- | Partiall ordering: all elements GT + (>) = accumV2Idempotent True (\x y r -> r && x > y) + {-# INLINE (>) #-} + -- | Partiall ordering: all elements LT + (<) = accumV2Idempotent True (\x y r -> r && x < y) + {-# INLINE (<) #-} + -- | Partiall ordering: all elements GE + (>=) = accumV2Idempotent True (\x y r -> r && x >= y) + {-# INLINE (>=) #-} + -- | Partiall ordering: all elements LE + (<=) = accumV2Idempotent True (\x y r -> r && x <= y) + {-# INLINE (<=) #-} + -- | Compare lexicographically + compare = accumV2Idempotent EQ (\x y -> flip mappend (compare x y)) + {-# INLINE compare #-} + -- | Element-wise minimum + min = zipV min + {-# INLINE min #-} + -- | Element-wise maximum + max = zipV max + {-# INLINE max #-} + +instance (Dimensions ds, PrimBytes t, Show t) + => Show (ArrayBase t ds) where + show x = case dims @_ @ds of + U -> "{ " ++ show (ix# 0# x) ++ " }" + Dim :* U -> ('{' :) . drop 1 $ + foldr (\i s -> ", " ++ show (ix i x) ++ s) " }" + [minBound .. maxBound] + (Dim :: Dim n) :* (Dim :: Dim m) :* (Dims :: Dims dss) -> + let loopInner :: Idxs dss -> Idxs '[n,m] -> String + loopInner ods (n:*m:*_) = ('{' :) . drop 2 $ + foldr (\i ss -> '\n': + foldr (\j s -> + ", " ++ show (ix (i :* j :* ods) x) ++ s + ) ss [1..m] + ) " }" [1..n] + loopOuter :: Idxs dss -> String -> String + loopOuter U s = "\n" ++ loopInner U maxBound ++ s + loopOuter ds s = "\n(i j" ++ drop 4 (show ds) ++ "):\n" + ++ loopInner ds maxBound ++ s + in drop 1 $ foldr loopOuter "" [minBound..maxBound] + +instance {-# OVERLAPPING #-} Bounded (ArrayBase Double ds) where + maxBound = ArrayBase (# inftyD | #) + minBound = ArrayBase (# negate inftyD | #) + +instance {-# OVERLAPPING #-} Bounded (ArrayBase Float ds) where + maxBound = ArrayBase (# inftyF | #) + minBound = ArrayBase (# negate inftyF | #) + +instance {-# OVERLAPPABLE #-} Bounded t => Bounded (ArrayBase t ds) where + {-# SPECIALIZE instance Bounded (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word64 ds) #-} + maxBound = ArrayBase (# maxBound | #) + minBound = ArrayBase (# minBound | #) + +instance (Num t, PrimBytes t) => Num (ArrayBase t ds) where + {-# SPECIALIZE instance Num (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word64 ds) #-} + (+) = zipV (+) + {-# INLINE (+) #-} + (-) = zipV (-) + {-# INLINE (-) #-} + (*) = zipV (*) + {-# INLINE (*) #-} + negate = mapV negate + {-# INLINE negate #-} + abs = mapV abs + {-# INLINE abs #-} + signum = mapV signum + {-# INLINE signum #-} + fromInteger i = ArrayBase (# fromInteger i | #) + {-# INLINE fromInteger #-} + +instance (Fractional t, PrimBytes t) => Fractional (ArrayBase t ds) where + {-# SPECIALIZE instance Fractional (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Fractional (ArrayBase Double ds) #-} + (/) = zipV (/) + {-# INLINE (/) #-} + recip = mapV recip + {-# INLINE recip #-} + fromRational r = ArrayBase (# fromRational r | #) + {-# INLINE fromRational #-} + + +instance (Floating t, PrimBytes t) => Floating (ArrayBase t ds) where + {-# SPECIALIZE instance Floating (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Floating (ArrayBase Double ds) #-} + pi = ArrayBase (# pi | #) + {-# INLINE pi #-} + exp = mapV exp + {-# INLINE exp #-} + log = mapV log + {-# INLINE log #-} + sqrt = mapV sqrt + {-# INLINE sqrt #-} + sin = mapV sin + {-# INLINE sin #-} + cos = mapV cos + {-# INLINE cos #-} + tan = mapV tan + {-# INLINE tan #-} + asin = mapV asin + {-# INLINE asin #-} + acos = mapV acos + {-# INLINE acos #-} + atan = mapV atan + {-# INLINE atan #-} + sinh = mapV sinh + {-# INLINE sinh #-} + cosh = mapV cosh + {-# INLINE cosh #-} + tanh = mapV tanh + {-# INLINE tanh #-} + (**) = zipV (**) + {-# INLINE (**) #-} + logBase = zipV logBase + {-# INLINE logBase #-} + asinh = mapV asinh + {-# INLINE asinh #-} + acosh = mapV acosh + {-# INLINE acosh #-} + atanh = mapV atanh + {-# INLINE atanh #-} + +instance PrimBytes t => PrimArray t (ArrayBase t ds) where + {-# SPECIALIZE instance PrimArray Float (ArrayBase Float ds) #-} + {-# SPECIALIZE instance PrimArray Double (ArrayBase Double ds) #-} + {-# SPECIALIZE instance PrimArray Int (ArrayBase Int ds) #-} + {-# SPECIALIZE instance PrimArray Word (ArrayBase Word ds) #-} + {-# SPECIALIZE instance PrimArray Int8 (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance PrimArray Int16 (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance PrimArray Int32 (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance PrimArray Int64 (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance PrimArray Word8 (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance PrimArray Word16 (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance PrimArray Word32 (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance PrimArray Word64 (ArrayBase Word64 ds) #-} + + broadcast t = ArrayBase (# t | #) + {-# INLINE broadcast #-} + + ix# i (ArrayBase a) = case a of + (# t | #) -> t + (# | (# off, _, arr #) #) -> indexArray arr (off +# i) + {-# INLINE ix# #-} + + gen# n f z0 = go (byteSize @t undefined *# n) + where + go bsize = case runRW# + ( \s0 -> case newByteArray# bsize s0 of + (# s1, mba #) -> case loop0 mba 0# z0 s1 of + (# s2, z1 #) -> case unsafeFreezeByteArray# mba s2 of + (# s3, ba #) -> (# s3, (# z1, ba #) #) + ) of (# _, (# z1, ba #) #) -> (# z1, ArrayBase (# | (# 0# , n , ba #) #) #) + {-# NOINLINE go #-} + loop0 mba i z s + | isTrue# (i ==# n) = (# s, z #) + | otherwise = case f z of + (# z', x #) -> loop0 mba (i +# 1#) z' (writeArray mba i x s) + {-# INLINE gen# #-} + + upd# n i x (ArrayBase (# a | #)) = go (byteSize x) + where + go tbs = case runRW# + ( \s0 -> case newByteArray# (tbs *# n) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + (writeArray mba i x + (loop1# n (\j -> writeArray mba j a) s1) + ) + ) of (# _, r #) -> ArrayBase (# | (# 0# , n , r #) #) + {-# NOINLINE go #-} + upd# _ i x (ArrayBase (# | (# offN , n , ba #) #)) = go (byteSize x) + where + go tbs = case runRW# + ( \s0 -> case newByteArray# (tbs *# n) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + (writeArray mba i x + (copyByteArray# ba (offN *# tbs) mba 0# (tbs *# n) s1) + ) + ) of (# _, r #) -> ArrayBase (# | (# 0# , n , r #) #) + {-# NOINLINE go #-} + {-# INLINE upd# #-} + + elemOffset (ArrayBase a) = case a of + (# _ | #) -> 0# + (# | (# off, _, _ #) #) -> off + {-# INLINE elemOffset #-} + + elemSize0 (ArrayBase a) = case a of + (# _ | #) -> 0# + (# | (# _, n, _ #) #) -> n + {-# INLINE elemSize0 #-} + + fromElems off n ba = ArrayBase (# | (# off , n , ba #) #) + {-# INLINE fromElems #-} + + + +-------------------------------------------------------------------------------- +-- * Utility functions +-------------------------------------------------------------------------------- + + +ix :: (PrimBytes t, Dimensions ds) => Idxs ds -> ArrayBase t ds -> t +ix i (ArrayBase a) = case a of + (# t | #) -> t + (# | (# off, _, arr #) #) -> case fromEnum i of + I# i# -> indexArray arr (off +# i#) +{-# INLINE ix #-} + + +undefEl :: ArrayBase t ds -> t +undefEl = const undefined diff --git a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX2.hs b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX2.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX2.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Array.Family.DoubleX2 (DoubleX2 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.PrimBytes + + +data DoubleX2 = DoubleX2# Double# Double# + + +instance Bounded DoubleX2 where + maxBound = case inftyD of D# x -> DoubleX2# x x + minBound = case negate inftyD of D# x -> DoubleX2# x x + + +instance Show DoubleX2 where + show (DoubleX2# a1 a2) + = "{ " ++ show (D# a1) + ++ ", " ++ show (D# a2) + ++ " }" + + + +instance Eq DoubleX2 where + + DoubleX2# a1 a2 == DoubleX2# b1 b2 = + isTrue# + ( (a1 ==## b1) + `andI#` (a2 ==## b2) + ) + {-# INLINE (==) #-} + + DoubleX2# a1 a2 /= DoubleX2# b1 b2 = + isTrue# + ( (a1 /=## b1) + `orI#` (a2 /=## b2) + ) + {-# INLINE (/=) #-} + + + +-- | Implement partial ordering for `>`, `<`, `>=`, `<=` +-- and lexicographical ordering for `compare` +instance Ord DoubleX2 where + DoubleX2# a1 a2 > DoubleX2# b1 b2 = + isTrue# + ( (a1 >## b1) + `andI#` (a2 >## b2) + ) + {-# INLINE (>) #-} + + DoubleX2# a1 a2 < DoubleX2# b1 b2 = + isTrue# + ( (a1 <## b1) + `andI#` (a2 <## b2) + ) + {-# INLINE (<) #-} + + DoubleX2# a1 a2 >= DoubleX2# b1 b2 = + isTrue# + ( (a1 >=## b1) + `andI#` (a2 >=## b2) + ) + {-# INLINE (>=) #-} + + DoubleX2# a1 a2 <= DoubleX2# b1 b2 = + isTrue# + ( (a1 <=## b1) + `andI#` (a2 <=## b2) + ) + {-# INLINE (<=) #-} + + -- | Compare lexicographically + compare (DoubleX2# a1 a2) (DoubleX2# b1 b2) + | isTrue# (a1 >## b1) = GT + | isTrue# (a1 <## b1) = LT + | isTrue# (a2 >## b2) = GT + | isTrue# (a2 <## b2) = LT + | otherwise = EQ + {-# INLINE compare #-} + + -- | Element-wise minimum + min (DoubleX2# a1 a2) (DoubleX2# b1 b2) = DoubleX2# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + {-# INLINE min #-} + + -- | Element-wise maximum + max (DoubleX2# a1 a2) (DoubleX2# b1 b2) = DoubleX2# + (if isTrue# (a1 >## b1) then a1 else b1) + (if isTrue# (a2 >## b2) then a2 else b2) + {-# INLINE max #-} + + + +-- | element-wise operations for vectors +instance Num DoubleX2 where + + DoubleX2# a1 a2 + DoubleX2# b1 b2 + = DoubleX2# ((+##) a1 b1) ((+##) a2 b2) + {-# INLINE (+) #-} + + DoubleX2# a1 a2 - DoubleX2# b1 b2 + = DoubleX2# ((-##) a1 b1) ((-##) a2 b2) + {-# INLINE (-) #-} + + DoubleX2# a1 a2 * DoubleX2# b1 b2 + = DoubleX2# ((*##) a1 b1) ((*##) a2 b2) + {-# INLINE (*) #-} + + negate (DoubleX2# a1 a2) = DoubleX2# + (negateDouble# a1) (negateDouble# a2) + {-# INLINE negate #-} + + abs (DoubleX2# a1 a2) + = DoubleX2# + (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) + (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) + {-# INLINE abs #-} + + signum (DoubleX2# a1 a2) + = DoubleX2# (if isTrue# (a1 >## 0.0##) + then 1.0## + else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a2 >## 0.0##) + then 1.0## + else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of D# x -> DoubleX2# x x + {-# INLINE fromInteger #-} + + + +instance Fractional DoubleX2 where + + DoubleX2# a1 a2 / DoubleX2# b1 b2 = DoubleX2# + ((/##) a1 b1) ((/##) a2 b2) + {-# INLINE (/) #-} + + recip (DoubleX2# a1 a2) = DoubleX2# + ((/##) 1.0## a1) ((/##) 1.0## a2) + {-# INLINE recip #-} + + fromRational r = case fromRational r of D# x -> DoubleX2# x x + {-# INLINE fromRational #-} + + + +instance Floating DoubleX2 where + + pi = DoubleX2# + 3.141592653589793238## + 3.141592653589793238## + {-# INLINE pi #-} + + exp (DoubleX2# a1 a2) = DoubleX2# + (expDouble# a1) (expDouble# a2) + {-# INLINE exp #-} + + log (DoubleX2# a1 a2) = DoubleX2# + (logDouble# a1) (logDouble# a2) + {-# INLINE log #-} + + sqrt (DoubleX2# a1 a2) = DoubleX2# + (sqrtDouble# a1) (sqrtDouble# a2) + {-# INLINE sqrt #-} + + sin (DoubleX2# a1 a2) = DoubleX2# + (sinDouble# a1) (sinDouble# a2) + {-# INLINE sin #-} + + cos (DoubleX2# a1 a2) = DoubleX2# + (cosDouble# a1) (cosDouble# a2) + {-# INLINE cos #-} + + tan (DoubleX2# a1 a2) = DoubleX2# + (tanDouble# a1) (tanDouble# a2) + {-# INLINE tan #-} + + asin (DoubleX2# a1 a2) = DoubleX2# + (asinDouble# a1) (asinDouble# a2) + {-# INLINE asin #-} + + acos (DoubleX2# a1 a2) = DoubleX2# + (acosDouble# a1) (acosDouble# a2) + {-# INLINE acos #-} + + atan (DoubleX2# a1 a2) = DoubleX2# + (atanDouble# a1) (atanDouble# a2) + {-# INLINE atan #-} + + sinh (DoubleX2# a1 a2) = DoubleX2# + (sinhDouble# a1) (sinhDouble# a2) + {-# INLINE sinh #-} + + cosh (DoubleX2# a1 a2) = DoubleX2# + (coshDouble# a1) (coshDouble# a2) + {-# INLINE cosh #-} + + tanh (DoubleX2# a1 a2) = DoubleX2# + (tanhDouble# a1) (tanhDouble# a2) + {-# INLINE tanh #-} + + DoubleX2# a1 a2 ** DoubleX2# b1 b2 = DoubleX2# + ((**##) a1 b1) ((**##) a2 b2) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# +#define ELEM_N 2 + +instance PrimBytes DoubleX2 where + + getBytes (DoubleX2# a1 a2) = case runRW# + ( \s0 -> case newByteArray# (byteSize @DoubleX2 undefined) s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of + s2 -> case writeDoubleArray# marr 1# a2 s2 of + s3 -> unsafeFreezeByteArray# marr s3 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = DoubleX2# + (indexDoubleArray# arr i) + (indexDoubleArray# arr (i +# 1#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) + {-# INLINE readBytes #-} + + writeBytes mba off (DoubleX2# a1 a2) s + | i <- BOFF_TO_PRIMOFF(off) + = writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readDoubleOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of + (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) + {-# INLINE readAddr #-} + + writeAddr (DoubleX2# a1 a2) addr s + = writeDoubleOffAddr# addr 1# a2 + ( writeDoubleOffAddr# addr 0# a1 s ) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Double undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Double undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = DoubleX2# + (indexDoubleArray# ba i) + (indexDoubleArray# ba (i +# 1#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) + {-# INLINE readArray #-} + + writeArray mba off (DoubleX2# a1 a2) s + | i <- off *# ELEM_N# + = writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ) + {-# INLINE writeArray #-} + + +instance PrimArray Double DoubleX2 where + + broadcast (D# x) = DoubleX2# x x + {-# INLINE broadcast #-} + + ix# 0# (DoubleX2# a1 _) = D# a1 + ix# 1# (DoubleX2# _ a2) = D# a2 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, D# a1 #) -> case f s1 of + (# s2, D# a2 #) -> (# s2, DoubleX2# a1 a2 #) + + + upd# _ 0# (D# q) (DoubleX2# _ y) = DoubleX2# q y + upd# _ 1# (D# q) (DoubleX2# x _) = DoubleX2# x q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + elemOffset _ = 0# + {-# INLINE elemOffset #-} + + elemSize0 _ = ELEM_N# + {-# INLINE elemSize0 #-} + + fromElems off _ ba = DoubleX2# + (indexDoubleArray# ba off) + (indexDoubleArray# ba (off +# 1#)) + {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX3.hs b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX3.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX3.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Array.Family.DoubleX3 (DoubleX3 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.PrimBytes + + +data DoubleX3 = DoubleX3# Double# Double# Double# + + +instance Bounded DoubleX3 where + maxBound = case inftyD of D# x -> DoubleX3# x x x + minBound = case negate inftyD of D# x -> DoubleX3# x x x + + +instance Show DoubleX3 where + show (DoubleX3# a1 a2 a3) + = "{ " ++ show (D# a1) + ++ ", " ++ show (D# a2) + ++ ", " ++ show (D# a3) + ++ " }" + + + +instance Eq DoubleX3 where + + DoubleX3# a1 a2 a3 == DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 ==## b1) + `andI#` (a2 ==## b2) + `andI#` (a3 ==## b3) + ) + {-# INLINE (==) #-} + + DoubleX3# a1 a2 a3 /= DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 /=## b1) + `orI#` (a2 /=## b2) + `orI#` (a3 /=## b3) + ) + {-# INLINE (/=) #-} + + + +-- | Implement partial ordering for `>`, `<`, `>=`, `<=` +-- and lexicographical ordering for `compare` +instance Ord DoubleX3 where + DoubleX3# a1 a2 a3 > DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 >## b1) + `andI#` (a2 >## b2) + `andI#` (a3 >## b3) + ) + {-# INLINE (>) #-} + + DoubleX3# a1 a2 a3 < DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 <## b1) + `andI#` (a2 <## b2) + `andI#` (a3 <## b3) + ) + {-# INLINE (<) #-} + + DoubleX3# a1 a2 a3 >= DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 >=## b1) + `andI#` (a2 >=## b2) + `andI#` (a3 >=## b3) + ) + {-# INLINE (>=) #-} + + DoubleX3# a1 a2 a3 <= DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 <=## b1) + `andI#` (a2 <=## b2) + `andI#` (a3 <=## b3) + ) + {-# INLINE (<=) #-} + + -- | Compare lexicographically + compare (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) + | isTrue# (a1 >## b1) = GT + | isTrue# (a1 <## b1) = LT + | isTrue# (a2 >## b2) = GT + | isTrue# (a2 <## b2) = LT + | isTrue# (a3 >## b3) = GT + | isTrue# (a3 <## b3) = LT + | otherwise = EQ + {-# INLINE compare #-} + + -- | Element-wise minimum + min (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) = DoubleX3# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + (if isTrue# (a3 >## b3) then b3 else a3) + {-# INLINE min #-} + + -- | Element-wise maximum + max (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) = DoubleX3# + (if isTrue# (a1 >## b1) then a1 else b1) + (if isTrue# (a2 >## b2) then a2 else b2) + (if isTrue# (a3 >## b3) then a3 else b3) + {-# INLINE max #-} + + + +-- | element-wise operations for vectors +instance Num DoubleX3 where + + DoubleX3# a1 a2 a3 + DoubleX3# b1 b2 b3 + = DoubleX3# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) + {-# INLINE (+) #-} + + DoubleX3# a1 a2 a3 - DoubleX3# b1 b2 b3 + = DoubleX3# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) + {-# INLINE (-) #-} + + DoubleX3# a1 a2 a3 * DoubleX3# b1 b2 b3 + = DoubleX3# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) + {-# INLINE (*) #-} + + negate (DoubleX3# a1 a2 a3) = DoubleX3# + (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) + {-# INLINE negate #-} + + abs (DoubleX3# a1 a2 a3) + = DoubleX3# + (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) + (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) + (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) + {-# INLINE abs #-} + + signum (DoubleX3# a1 a2 a3) + = DoubleX3# (if isTrue# (a1 >## 0.0##) + then 1.0## + else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a2 >## 0.0##) + then 1.0## + else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a3 >## 0.0##) + then 1.0## + else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of D# x -> DoubleX3# x x x + {-# INLINE fromInteger #-} + + + +instance Fractional DoubleX3 where + + DoubleX3# a1 a2 a3 / DoubleX3# b1 b2 b3 = DoubleX3# + ((/##) a1 b1) ((/##) a2 b2) ((/##) a3 b3) + {-# INLINE (/) #-} + + recip (DoubleX3# a1 a2 a3) = DoubleX3# + ((/##) 1.0## a1) ((/##) 1.0## a2) ((/##) 1.0## a3) + {-# INLINE recip #-} + + fromRational r = case fromRational r of D# x -> DoubleX3# x x x + {-# INLINE fromRational #-} + + + +instance Floating DoubleX3 where + + pi = DoubleX3# + 3.141592653589793238## + 3.141592653589793238## + 3.141592653589793238## + {-# INLINE pi #-} + + exp (DoubleX3# a1 a2 a3) = DoubleX3# + (expDouble# a1) (expDouble# a2) (expDouble# a3) + {-# INLINE exp #-} + + log (DoubleX3# a1 a2 a3) = DoubleX3# + (logDouble# a1) (logDouble# a2) (logDouble# a3) + {-# INLINE log #-} + + sqrt (DoubleX3# a1 a2 a3) = DoubleX3# + (sqrtDouble# a1) (sqrtDouble# a2) (sqrtDouble# a3) + {-# INLINE sqrt #-} + + sin (DoubleX3# a1 a2 a3) = DoubleX3# + (sinDouble# a1) (sinDouble# a2) (sinDouble# a3) + {-# INLINE sin #-} + + cos (DoubleX3# a1 a2 a3) = DoubleX3# + (cosDouble# a1) (cosDouble# a2) (cosDouble# a3) + {-# INLINE cos #-} + + tan (DoubleX3# a1 a2 a3) = DoubleX3# + (tanDouble# a1) (tanDouble# a2) (tanDouble# a3) + {-# INLINE tan #-} + + asin (DoubleX3# a1 a2 a3) = DoubleX3# + (asinDouble# a1) (asinDouble# a2) (asinDouble# a3) + {-# INLINE asin #-} + + acos (DoubleX3# a1 a2 a3) = DoubleX3# + (acosDouble# a1) (acosDouble# a2) (acosDouble# a3) + {-# INLINE acos #-} + + atan (DoubleX3# a1 a2 a3) = DoubleX3# + (atanDouble# a1) (atanDouble# a2) (atanDouble# a3) + {-# INLINE atan #-} + + sinh (DoubleX3# a1 a2 a3) = DoubleX3# + (sinhDouble# a1) (sinhDouble# a2) (sinhDouble# a3) + {-# INLINE sinh #-} + + cosh (DoubleX3# a1 a2 a3) = DoubleX3# + (coshDouble# a1) (coshDouble# a2) (coshDouble# a3) + {-# INLINE cosh #-} + + tanh (DoubleX3# a1 a2 a3) = DoubleX3# + (tanhDouble# a1) (tanhDouble# a2) (tanhDouble# a3) + {-# INLINE tanh #-} + + DoubleX3# a1 a2 a3 ** DoubleX3# b1 b2 b3 = DoubleX3# + ((**##) a1 b1) ((**##) a2 b2) ((**##) a3 b3) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# +#define ELEM_N 3 + +instance PrimBytes DoubleX3 where + + getBytes (DoubleX3# a1 a2 a3) = case runRW# + ( \s0 -> case newByteArray# (byteSize @DoubleX3 undefined) s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of + s2 -> case writeDoubleArray# marr 1# a2 s2 of + s3 -> case writeDoubleArray# marr 2# a3 s3 of + s4 -> unsafeFreezeByteArray# marr s4 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = DoubleX3# + (indexDoubleArray# arr i) + (indexDoubleArray# arr (i +# 1#)) + (indexDoubleArray# arr (i +# 2#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + {-# INLINE readBytes #-} + + writeBytes mba off (DoubleX3# a1 a2 a3) s + | i <- BOFF_TO_PRIMOFF(off) + = writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s )) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readDoubleOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readDoubleOffAddr# addr 2# s2 of + (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + {-# INLINE readAddr #-} + + writeAddr (DoubleX3# a1 a2 a3) addr s + = writeDoubleOffAddr# addr 2# a3 + ( writeDoubleOffAddr# addr 1# a2 + ( writeDoubleOffAddr# addr 0# a1 s )) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Double undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Double undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = DoubleX3# + (indexDoubleArray# ba i) + (indexDoubleArray# ba (i +# 1#)) + (indexDoubleArray# ba (i +# 2#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + {-# INLINE readArray #-} + + writeArray mba off (DoubleX3# a1 a2 a3) s + | i <- off *# ELEM_N# + = writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s )) + {-# INLINE writeArray #-} + + +instance PrimArray Double DoubleX3 where + + broadcast (D# x) = DoubleX3# x x x + {-# INLINE broadcast #-} + + ix# 0# (DoubleX3# a1 _ _) = D# a1 + ix# 1# (DoubleX3# _ a2 _) = D# a2 + ix# 2# (DoubleX3# _ _ a3) = D# a3 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, D# a1 #) -> case f s1 of + (# s2, D# a2 #) -> case f s2 of + (# s3, D# a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + + + upd# _ 0# (D# q) (DoubleX3# _ y z) = DoubleX3# q y z + upd# _ 1# (D# q) (DoubleX3# x _ z) = DoubleX3# x q z + upd# _ 2# (D# q) (DoubleX3# x y _) = DoubleX3# x y q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + elemOffset _ = 0# + {-# INLINE elemOffset #-} + + elemSize0 _ = ELEM_N# + {-# INLINE elemSize0 #-} + + fromElems off _ ba = DoubleX3# + (indexDoubleArray# ba off) + (indexDoubleArray# ba (off +# 1#)) + (indexDoubleArray# ba (off +# 2#)) + {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX4.hs b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX4.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX4.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Array.Family.DoubleX4 (DoubleX4 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.PrimBytes + + +data DoubleX4 = DoubleX4# Double# Double# Double# Double# + + +instance Bounded DoubleX4 where + maxBound = case inftyD of D# x -> DoubleX4# x x x x + minBound = case negate inftyD of D# x -> DoubleX4# x x x x + + +instance Show DoubleX4 where + show (DoubleX4# a1 a2 a3 a4) + = "{ " ++ show (D# a1) + ++ ", " ++ show (D# a2) + ++ ", " ++ show (D# a3) + ++ ", " ++ show (D# a4) + ++ " }" + + + +instance Eq DoubleX4 where + + DoubleX4# a1 a2 a3 a4 == DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 ==## b1) + `andI#` (a2 ==## b2) + `andI#` (a3 ==## b3) + `andI#` (a4 ==## b4) + ) + {-# INLINE (==) #-} + + DoubleX4# a1 a2 a3 a4 /= DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 /=## b1) + `orI#` (a2 /=## b2) + `orI#` (a3 /=## b3) + `orI#` (a4 /=## b4) + ) + {-# INLINE (/=) #-} + + + +-- | Implement partial ordering for `>`, `<`, `>=`, `<=` +-- and lexicographical ordering for `compare` +instance Ord DoubleX4 where + DoubleX4# a1 a2 a3 a4 > DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 >## b1) + `andI#` (a2 >## b2) + `andI#` (a3 >## b3) + `andI#` (a4 >## b4) + ) + {-# INLINE (>) #-} + + DoubleX4# a1 a2 a3 a4 < DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 <## b1) + `andI#` (a2 <## b2) + `andI#` (a3 <## b3) + `andI#` (a4 <## b4) + ) + {-# INLINE (<) #-} + + DoubleX4# a1 a2 a3 a4 >= DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 >=## b1) + `andI#` (a2 >=## b2) + `andI#` (a3 >=## b3) + `andI#` (a4 >=## b4) + ) + {-# INLINE (>=) #-} + + DoubleX4# a1 a2 a3 a4 <= DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 <=## b1) + `andI#` (a2 <=## b2) + `andI#` (a3 <=## b3) + `andI#` (a4 <=## b4) + ) + {-# INLINE (<=) #-} + + -- | Compare lexicographically + compare (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) + | isTrue# (a1 >## b1) = GT + | isTrue# (a1 <## b1) = LT + | isTrue# (a2 >## b2) = GT + | isTrue# (a2 <## b2) = LT + | isTrue# (a3 >## b3) = GT + | isTrue# (a3 <## b3) = LT + | isTrue# (a4 >## b4) = GT + | isTrue# (a4 <## b4) = LT + | otherwise = EQ + {-# INLINE compare #-} + + -- | Element-wise minimum + min (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) = DoubleX4# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + (if isTrue# (a3 >## b3) then b3 else a3) + (if isTrue# (a4 >## b4) then b4 else a4) + {-# INLINE min #-} + + -- | Element-wise maximum + max (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) = DoubleX4# + (if isTrue# (a1 >## b1) then a1 else b1) + (if isTrue# (a2 >## b2) then a2 else b2) + (if isTrue# (a3 >## b3) then a3 else b3) + (if isTrue# (a4 >## b4) then a4 else b4) + {-# INLINE max #-} + + + +-- | element-wise operations for vectors +instance Num DoubleX4 where + + DoubleX4# a1 a2 a3 a4 + DoubleX4# b1 b2 b3 b4 + = DoubleX4# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) ((+##) a4 b4) + {-# INLINE (+) #-} + + DoubleX4# a1 a2 a3 a4 - DoubleX4# b1 b2 b3 b4 + = DoubleX4# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) ((-##) a4 b4) + {-# INLINE (-) #-} + + DoubleX4# a1 a2 a3 a4 * DoubleX4# b1 b2 b3 b4 + = DoubleX4# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) ((*##) a4 b4) + {-# INLINE (*) #-} + + negate (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) (negateDouble# a4) + {-# INLINE negate #-} + + abs (DoubleX4# a1 a2 a3 a4) + = DoubleX4# + (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) + (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) + (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) + (if isTrue# (a4 >=## 0.0##) then a4 else negateDouble# a4) + {-# INLINE abs #-} + + signum (DoubleX4# a1 a2 a3 a4) + = DoubleX4# (if isTrue# (a1 >## 0.0##) + then 1.0## + else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a2 >## 0.0##) + then 1.0## + else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a3 >## 0.0##) + then 1.0## + else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a4 >## 0.0##) + then 1.0## + else if isTrue# (a4 <## 0.0##) then -1.0## else 0.0## ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of D# x -> DoubleX4# x x x x + {-# INLINE fromInteger #-} + + + +instance Fractional DoubleX4 where + + DoubleX4# a1 a2 a3 a4 / DoubleX4# b1 b2 b3 b4 = DoubleX4# + ((/##) a1 b1) ((/##) a2 b2) ((/##) a3 b3) ((/##) a4 b4) + {-# INLINE (/) #-} + + recip (DoubleX4# a1 a2 a3 a4) = DoubleX4# + ((/##) 1.0## a1) ((/##) 1.0## a2) ((/##) 1.0## a3) ((/##) 1.0## a4) + {-# INLINE recip #-} + + fromRational r = case fromRational r of D# x -> DoubleX4# x x x x + {-# INLINE fromRational #-} + + + +instance Floating DoubleX4 where + + pi = DoubleX4# + 3.141592653589793238## + 3.141592653589793238## + 3.141592653589793238## + 3.141592653589793238## + {-# INLINE pi #-} + + exp (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (expDouble# a1) (expDouble# a2) (expDouble# a3) (expDouble# a4) + {-# INLINE exp #-} + + log (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (logDouble# a1) (logDouble# a2) (logDouble# a3) (logDouble# a4) + {-# INLINE log #-} + + sqrt (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (sqrtDouble# a1) (sqrtDouble# a2) (sqrtDouble# a3) (sqrtDouble# a4) + {-# INLINE sqrt #-} + + sin (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (sinDouble# a1) (sinDouble# a2) (sinDouble# a3) (sinDouble# a4) + {-# INLINE sin #-} + + cos (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (cosDouble# a1) (cosDouble# a2) (cosDouble# a3) (cosDouble# a4) + {-# INLINE cos #-} + + tan (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (tanDouble# a1) (tanDouble# a2) (tanDouble# a3) (tanDouble# a4) + {-# INLINE tan #-} + + asin (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (asinDouble# a1) (asinDouble# a2) (asinDouble# a3) (asinDouble# a4) + {-# INLINE asin #-} + + acos (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (acosDouble# a1) (acosDouble# a2) (acosDouble# a3) (acosDouble# a4) + {-# INLINE acos #-} + + atan (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (atanDouble# a1) (atanDouble# a2) (atanDouble# a3) (atanDouble# a4) + {-# INLINE atan #-} + + sinh (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (sinhDouble# a1) (sinhDouble# a2) (sinhDouble# a3) (sinhDouble# a4) + {-# INLINE sinh #-} + + cosh (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (coshDouble# a1) (coshDouble# a2) (coshDouble# a3) (coshDouble# a4) + {-# INLINE cosh #-} + + tanh (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (tanhDouble# a1) (tanhDouble# a2) (tanhDouble# a3) (tanhDouble# a4) + {-# INLINE tanh #-} + + DoubleX4# a1 a2 a3 a4 ** DoubleX4# b1 b2 b3 b4 = DoubleX4# + ((**##) a1 b1) ((**##) a2 b2) ((**##) a3 b3) ((**##) a4 b4) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# +#define ELEM_N 4 + +instance PrimBytes DoubleX4 where + + getBytes (DoubleX4# a1 a2 a3 a4) = case runRW# + ( \s0 -> case newByteArray# (byteSize @DoubleX4 undefined) s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of + s2 -> case writeDoubleArray# marr 1# a2 s2 of + s3 -> case writeDoubleArray# marr 2# a3 s3 of + s4 -> case writeDoubleArray# marr 3# a4 s4 of + s5 -> unsafeFreezeByteArray# marr s5 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = DoubleX4# + (indexDoubleArray# arr i) + (indexDoubleArray# arr (i +# 1#)) + (indexDoubleArray# arr (i +# 2#)) + (indexDoubleArray# arr (i +# 3#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readDoubleArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + {-# INLINE readBytes #-} + + writeBytes mba off (DoubleX4# a1 a2 a3 a4) s + | i <- BOFF_TO_PRIMOFF(off) + = writeDoubleArray# mba (i +# 3#) a4 + ( writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ))) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readDoubleOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readDoubleOffAddr# addr 2# s2 of + (# s3, a3 #) -> case readDoubleOffAddr# addr 3# s3 of + (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + {-# INLINE readAddr #-} + + writeAddr (DoubleX4# a1 a2 a3 a4) addr s + = writeDoubleOffAddr# addr 3# a4 + ( writeDoubleOffAddr# addr 2# a3 + ( writeDoubleOffAddr# addr 1# a2 + ( writeDoubleOffAddr# addr 0# a1 s ))) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Double undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Double undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = DoubleX4# + (indexDoubleArray# ba i) + (indexDoubleArray# ba (i +# 1#)) + (indexDoubleArray# ba (i +# 2#)) + (indexDoubleArray# ba (i +# 3#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readDoubleArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + {-# INLINE readArray #-} + + writeArray mba off (DoubleX4# a1 a2 a3 a4) s + | i <- off *# ELEM_N# + = writeDoubleArray# mba (i +# 3#) a4 + ( writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ))) + {-# INLINE writeArray #-} + + +instance PrimArray Double DoubleX4 where + + broadcast (D# x) = DoubleX4# x x x x + {-# INLINE broadcast #-} + + ix# 0# (DoubleX4# a1 _ _ _) = D# a1 + ix# 1# (DoubleX4# _ a2 _ _) = D# a2 + ix# 2# (DoubleX4# _ _ a3 _) = D# a3 + ix# 3# (DoubleX4# _ _ _ a4) = D# a4 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, D# a1 #) -> case f s1 of + (# s2, D# a2 #) -> case f s2 of + (# s3, D# a3 #) -> case f s3 of + (# s4, D# a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + + + upd# _ 0# (D# q) (DoubleX4# _ y z w) = DoubleX4# q y z w + upd# _ 1# (D# q) (DoubleX4# x _ z w) = DoubleX4# x q z w + upd# _ 2# (D# q) (DoubleX4# x y _ w) = DoubleX4# x y q w + upd# _ 3# (D# q) (DoubleX4# x y z _) = DoubleX4# x y z q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + elemOffset _ = 0# + {-# INLINE elemOffset #-} + + elemSize0 _ = ELEM_N# + {-# INLINE elemSize0 #-} + + fromElems off _ ba = DoubleX4# + (indexDoubleArray# ba off) + (indexDoubleArray# ba (off +# 1#)) + (indexDoubleArray# ba (off +# 2#)) + (indexDoubleArray# ba (off +# 3#)) + {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/FloatX2.hs b/src/Numeric/DataFrame/Internal/Array/Family/FloatX2.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/FloatX2.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Array.Family.FloatX2 (FloatX2 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.PrimBytes + + +data FloatX2 = FloatX2# Float# Float# + + +instance Bounded FloatX2 where + maxBound = case inftyF of F# x -> FloatX2# x x + minBound = case negate inftyF of F# x -> FloatX2# x x + + +instance Show FloatX2 where + show (FloatX2# a1 a2) + = "{ " ++ show (F# a1) + ++ ", " ++ show (F# a2) + ++ " }" + + + +instance Eq FloatX2 where + + FloatX2# a1 a2 == FloatX2# b1 b2 = + isTrue# + ( (a1 `eqFloat#` b1) + `andI#` (a2 `eqFloat#` b2) + ) + {-# INLINE (==) #-} + + FloatX2# a1 a2 /= FloatX2# b1 b2 = + isTrue# + ( (a1 `neFloat#` b1) + `orI#` (a2 `neFloat#` b2) + ) + {-# INLINE (/=) #-} + + + +-- | Implement partial ordering for `>`, `<`, `>=`, `<=` +-- and lexicographical ordering for `compare` +instance Ord FloatX2 where + FloatX2# a1 a2 > FloatX2# b1 b2 = + isTrue# + ( (a1 `gtFloat#` b1) + `andI#` (a2 `gtFloat#` b2) + ) + {-# INLINE (>) #-} + + FloatX2# a1 a2 < FloatX2# b1 b2 = + isTrue# + ( (a1 `ltFloat#` b1) + `andI#` (a2 `ltFloat#` b2) + ) + {-# INLINE (<) #-} + + FloatX2# a1 a2 >= FloatX2# b1 b2 = + isTrue# + ( (a1 `geFloat#` b1) + `andI#` (a2 `geFloat#` b2) + ) + {-# INLINE (>=) #-} + + FloatX2# a1 a2 <= FloatX2# b1 b2 = + isTrue# + ( (a1 `leFloat#` b1) + `andI#` (a2 `leFloat#` b2) + ) + {-# INLINE (<=) #-} + + -- | Compare lexicographically + compare (FloatX2# a1 a2) (FloatX2# b1 b2) + | isTrue# (a1 `gtFloat#` b1) = GT + | isTrue# (a1 `ltFloat#` b1) = LT + | isTrue# (a2 `gtFloat#` b2) = GT + | isTrue# (a2 `ltFloat#` b2) = LT + | otherwise = EQ + {-# INLINE compare #-} + + -- | Element-wise minimum + min (FloatX2# a1 a2) (FloatX2# b1 b2) = FloatX2# + (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) + (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) + {-# INLINE min #-} + + -- | Element-wise maximum + max (FloatX2# a1 a2) (FloatX2# b1 b2) = FloatX2# + (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) + (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) + {-# INLINE max #-} + + + +-- | element-wise operations for vectors +instance Num FloatX2 where + + FloatX2# a1 a2 + FloatX2# b1 b2 + = FloatX2# (plusFloat# a1 b1) (plusFloat# a2 b2) + {-# INLINE (+) #-} + + FloatX2# a1 a2 - FloatX2# b1 b2 + = FloatX2# (minusFloat# a1 b1) (minusFloat# a2 b2) + {-# INLINE (-) #-} + + FloatX2# a1 a2 * FloatX2# b1 b2 + = FloatX2# (timesFloat# a1 b1) (timesFloat# a2 b2) + {-# INLINE (*) #-} + + negate (FloatX2# a1 a2) = FloatX2# + (negateFloat# a1) (negateFloat# a2) + {-# INLINE negate #-} + + abs (FloatX2# a1 a2) + = FloatX2# + (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) + (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) + {-# INLINE abs #-} + + signum (FloatX2# a1 a2) + = FloatX2# (if isTrue# (a1 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a2 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of F# x -> FloatX2# x x + {-# INLINE fromInteger #-} + + + +instance Fractional FloatX2 where + + FloatX2# a1 a2 / FloatX2# b1 b2 = FloatX2# + (divideFloat# a1 b1) (divideFloat# a2 b2) + {-# INLINE (/) #-} + + recip (FloatX2# a1 a2) = FloatX2# + (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) + {-# INLINE recip #-} + + fromRational r = case fromRational r of F# x -> FloatX2# x x + {-# INLINE fromRational #-} + + + +instance Floating FloatX2 where + + pi = FloatX2# + 3.141592653589793238# + 3.141592653589793238# + {-# INLINE pi #-} + + exp (FloatX2# a1 a2) = FloatX2# + (expFloat# a1) (expFloat# a2) + {-# INLINE exp #-} + + log (FloatX2# a1 a2) = FloatX2# + (logFloat# a1) (logFloat# a2) + {-# INLINE log #-} + + sqrt (FloatX2# a1 a2) = FloatX2# + (sqrtFloat# a1) (sqrtFloat# a2) + {-# INLINE sqrt #-} + + sin (FloatX2# a1 a2) = FloatX2# + (sinFloat# a1) (sinFloat# a2) + {-# INLINE sin #-} + + cos (FloatX2# a1 a2) = FloatX2# + (cosFloat# a1) (cosFloat# a2) + {-# INLINE cos #-} + + tan (FloatX2# a1 a2) = FloatX2# + (tanFloat# a1) (tanFloat# a2) + {-# INLINE tan #-} + + asin (FloatX2# a1 a2) = FloatX2# + (asinFloat# a1) (asinFloat# a2) + {-# INLINE asin #-} + + acos (FloatX2# a1 a2) = FloatX2# + (acosFloat# a1) (acosFloat# a2) + {-# INLINE acos #-} + + atan (FloatX2# a1 a2) = FloatX2# + (atanFloat# a1) (atanFloat# a2) + {-# INLINE atan #-} + + sinh (FloatX2# a1 a2) = FloatX2# + (sinhFloat# a1) (sinhFloat# a2) + {-# INLINE sinh #-} + + cosh (FloatX2# a1 a2) = FloatX2# + (coshFloat# a1) (coshFloat# a2) + {-# INLINE cosh #-} + + tanh (FloatX2# a1 a2) = FloatX2# + (tanhFloat# a1) (tanhFloat# a2) + {-# INLINE tanh #-} + + FloatX2# a1 a2 ** FloatX2# b1 b2 = FloatX2# + (powerFloat# a1 b1) (powerFloat# a2 b2) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# +#define ELEM_N 2 + +instance PrimBytes FloatX2 where + + getBytes (FloatX2# a1 a2) = case runRW# + ( \s0 -> case newByteArray# (byteSize @FloatX2 undefined) s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of + s2 -> case writeFloatArray# marr 1# a2 s2 of + s3 -> unsafeFreezeByteArray# marr s3 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = FloatX2# + (indexFloatArray# arr i) + (indexFloatArray# arr (i +# 1#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) + {-# INLINE readBytes #-} + + writeBytes mba off (FloatX2# a1 a2) s + | i <- BOFF_TO_PRIMOFF(off) + = writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readFloatOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of + (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) + {-# INLINE readAddr #-} + + writeAddr (FloatX2# a1 a2) addr s + = writeFloatOffAddr# addr 1# a2 + ( writeFloatOffAddr# addr 0# a1 s ) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Float undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Float undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = FloatX2# + (indexFloatArray# ba i) + (indexFloatArray# ba (i +# 1#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) + {-# INLINE readArray #-} + + writeArray mba off (FloatX2# a1 a2) s + | i <- off *# ELEM_N# + = writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ) + {-# INLINE writeArray #-} + + +instance PrimArray Float FloatX2 where + + broadcast (F# x) = FloatX2# x x + {-# INLINE broadcast #-} + + ix# 0# (FloatX2# a1 _) = F# a1 + ix# 1# (FloatX2# _ a2) = F# a2 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, F# a1 #) -> case f s1 of + (# s2, F# a2 #) -> (# s2, FloatX2# a1 a2 #) + + + upd# _ 0# (F# q) (FloatX2# _ y) = FloatX2# q y + upd# _ 1# (F# q) (FloatX2# x _) = FloatX2# x q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + elemOffset _ = 0# + {-# INLINE elemOffset #-} + + elemSize0 _ = ELEM_N# + {-# INLINE elemSize0 #-} + + fromElems off _ ba = FloatX2# + (indexFloatArray# ba off) + (indexFloatArray# ba (off +# 1#)) + {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/FloatX3.hs b/src/Numeric/DataFrame/Internal/Array/Family/FloatX3.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/FloatX3.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Array.Family.FloatX3 (FloatX3 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.PrimBytes + + +data FloatX3 = FloatX3# Float# Float# Float# + + +instance Bounded FloatX3 where + maxBound = case inftyF of F# x -> FloatX3# x x x + minBound = case negate inftyF of F# x -> FloatX3# x x x + + +instance Show FloatX3 where + show (FloatX3# a1 a2 a3) + = "{ " ++ show (F# a1) + ++ ", " ++ show (F# a2) + ++ ", " ++ show (F# a3) + ++ " }" + + + +instance Eq FloatX3 where + + FloatX3# a1 a2 a3 == FloatX3# b1 b2 b3 = + isTrue# + ( (a1 `eqFloat#` b1) + `andI#` (a2 `eqFloat#` b2) + `andI#` (a3 `eqFloat#` b3) + ) + {-# INLINE (==) #-} + + FloatX3# a1 a2 a3 /= FloatX3# b1 b2 b3 = + isTrue# + ( (a1 `neFloat#` b1) + `orI#` (a2 `neFloat#` b2) + `orI#` (a3 `neFloat#` b3) + ) + {-# INLINE (/=) #-} + + + +-- | Implement partial ordering for `>`, `<`, `>=`, `<=` +-- and lexicographical ordering for `compare` +instance Ord FloatX3 where + FloatX3# a1 a2 a3 > FloatX3# b1 b2 b3 = + isTrue# + ( (a1 `gtFloat#` b1) + `andI#` (a2 `gtFloat#` b2) + `andI#` (a3 `gtFloat#` b3) + ) + {-# INLINE (>) #-} + + FloatX3# a1 a2 a3 < FloatX3# b1 b2 b3 = + isTrue# + ( (a1 `ltFloat#` b1) + `andI#` (a2 `ltFloat#` b2) + `andI#` (a3 `ltFloat#` b3) + ) + {-# INLINE (<) #-} + + FloatX3# a1 a2 a3 >= FloatX3# b1 b2 b3 = + isTrue# + ( (a1 `geFloat#` b1) + `andI#` (a2 `geFloat#` b2) + `andI#` (a3 `geFloat#` b3) + ) + {-# INLINE (>=) #-} + + FloatX3# a1 a2 a3 <= FloatX3# b1 b2 b3 = + isTrue# + ( (a1 `leFloat#` b1) + `andI#` (a2 `leFloat#` b2) + `andI#` (a3 `leFloat#` b3) + ) + {-# INLINE (<=) #-} + + -- | Compare lexicographically + compare (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) + | isTrue# (a1 `gtFloat#` b1) = GT + | isTrue# (a1 `ltFloat#` b1) = LT + | isTrue# (a2 `gtFloat#` b2) = GT + | isTrue# (a2 `ltFloat#` b2) = LT + | isTrue# (a3 `gtFloat#` b3) = GT + | isTrue# (a3 `ltFloat#` b3) = LT + | otherwise = EQ + {-# INLINE compare #-} + + -- | Element-wise minimum + min (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) = FloatX3# + (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) + (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) + (if isTrue# (a3 `gtFloat#` b3) then b3 else a3) + {-# INLINE min #-} + + -- | Element-wise maximum + max (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) = FloatX3# + (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) + (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) + (if isTrue# (a3 `gtFloat#` b3) then a3 else b3) + {-# INLINE max #-} + + + +-- | element-wise operations for vectors +instance Num FloatX3 where + + FloatX3# a1 a2 a3 + FloatX3# b1 b2 b3 + = FloatX3# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) + {-# INLINE (+) #-} + + FloatX3# a1 a2 a3 - FloatX3# b1 b2 b3 + = FloatX3# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) + {-# INLINE (-) #-} + + FloatX3# a1 a2 a3 * FloatX3# b1 b2 b3 + = FloatX3# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) + {-# INLINE (*) #-} + + negate (FloatX3# a1 a2 a3) = FloatX3# + (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) + {-# INLINE negate #-} + + abs (FloatX3# a1 a2 a3) + = FloatX3# + (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) + (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) + (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) + {-# INLINE abs #-} + + signum (FloatX3# a1 a2 a3) + = FloatX3# (if isTrue# (a1 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a2 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a3 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of F# x -> FloatX3# x x x + {-# INLINE fromInteger #-} + + + +instance Fractional FloatX3 where + + FloatX3# a1 a2 a3 / FloatX3# b1 b2 b3 = FloatX3# + (divideFloat# a1 b1) (divideFloat# a2 b2) (divideFloat# a3 b3) + {-# INLINE (/) #-} + + recip (FloatX3# a1 a2 a3) = FloatX3# + (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) (divideFloat# 1.0# a3) + {-# INLINE recip #-} + + fromRational r = case fromRational r of F# x -> FloatX3# x x x + {-# INLINE fromRational #-} + + + +instance Floating FloatX3 where + + pi = FloatX3# + 3.141592653589793238# + 3.141592653589793238# + 3.141592653589793238# + {-# INLINE pi #-} + + exp (FloatX3# a1 a2 a3) = FloatX3# + (expFloat# a1) (expFloat# a2) (expFloat# a3) + {-# INLINE exp #-} + + log (FloatX3# a1 a2 a3) = FloatX3# + (logFloat# a1) (logFloat# a2) (logFloat# a3) + {-# INLINE log #-} + + sqrt (FloatX3# a1 a2 a3) = FloatX3# + (sqrtFloat# a1) (sqrtFloat# a2) (sqrtFloat# a3) + {-# INLINE sqrt #-} + + sin (FloatX3# a1 a2 a3) = FloatX3# + (sinFloat# a1) (sinFloat# a2) (sinFloat# a3) + {-# INLINE sin #-} + + cos (FloatX3# a1 a2 a3) = FloatX3# + (cosFloat# a1) (cosFloat# a2) (cosFloat# a3) + {-# INLINE cos #-} + + tan (FloatX3# a1 a2 a3) = FloatX3# + (tanFloat# a1) (tanFloat# a2) (tanFloat# a3) + {-# INLINE tan #-} + + asin (FloatX3# a1 a2 a3) = FloatX3# + (asinFloat# a1) (asinFloat# a2) (asinFloat# a3) + {-# INLINE asin #-} + + acos (FloatX3# a1 a2 a3) = FloatX3# + (acosFloat# a1) (acosFloat# a2) (acosFloat# a3) + {-# INLINE acos #-} + + atan (FloatX3# a1 a2 a3) = FloatX3# + (atanFloat# a1) (atanFloat# a2) (atanFloat# a3) + {-# INLINE atan #-} + + sinh (FloatX3# a1 a2 a3) = FloatX3# + (sinhFloat# a1) (sinhFloat# a2) (sinhFloat# a3) + {-# INLINE sinh #-} + + cosh (FloatX3# a1 a2 a3) = FloatX3# + (coshFloat# a1) (coshFloat# a2) (coshFloat# a3) + {-# INLINE cosh #-} + + tanh (FloatX3# a1 a2 a3) = FloatX3# + (tanhFloat# a1) (tanhFloat# a2) (tanhFloat# a3) + {-# INLINE tanh #-} + + FloatX3# a1 a2 a3 ** FloatX3# b1 b2 b3 = FloatX3# + (powerFloat# a1 b1) (powerFloat# a2 b2) (powerFloat# a3 b3) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# +#define ELEM_N 3 + +instance PrimBytes FloatX3 where + + getBytes (FloatX3# a1 a2 a3) = case runRW# + ( \s0 -> case newByteArray# (byteSize @FloatX3 undefined) s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of + s2 -> case writeFloatArray# marr 1# a2 s2 of + s3 -> case writeFloatArray# marr 2# a3 s3 of + s4 -> unsafeFreezeByteArray# marr s4 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = FloatX3# + (indexFloatArray# arr i) + (indexFloatArray# arr (i +# 1#)) + (indexFloatArray# arr (i +# 2#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + {-# INLINE readBytes #-} + + writeBytes mba off (FloatX3# a1 a2 a3) s + | i <- BOFF_TO_PRIMOFF(off) + = writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s )) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readFloatOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readFloatOffAddr# addr 2# s2 of + (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + {-# INLINE readAddr #-} + + writeAddr (FloatX3# a1 a2 a3) addr s + = writeFloatOffAddr# addr 2# a3 + ( writeFloatOffAddr# addr 1# a2 + ( writeFloatOffAddr# addr 0# a1 s )) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Float undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Float undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = FloatX3# + (indexFloatArray# ba i) + (indexFloatArray# ba (i +# 1#)) + (indexFloatArray# ba (i +# 2#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + {-# INLINE readArray #-} + + writeArray mba off (FloatX3# a1 a2 a3) s + | i <- off *# ELEM_N# + = writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s )) + {-# INLINE writeArray #-} + + +instance PrimArray Float FloatX3 where + + broadcast (F# x) = FloatX3# x x x + {-# INLINE broadcast #-} + + ix# 0# (FloatX3# a1 _ _) = F# a1 + ix# 1# (FloatX3# _ a2 _) = F# a2 + ix# 2# (FloatX3# _ _ a3) = F# a3 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, F# a1 #) -> case f s1 of + (# s2, F# a2 #) -> case f s2 of + (# s3, F# a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + + + upd# _ 0# (F# q) (FloatX3# _ y z) = FloatX3# q y z + upd# _ 1# (F# q) (FloatX3# x _ z) = FloatX3# x q z + upd# _ 2# (F# q) (FloatX3# x y _) = FloatX3# x y q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + elemOffset _ = 0# + {-# INLINE elemOffset #-} + + elemSize0 _ = ELEM_N# + {-# INLINE elemSize0 #-} + + fromElems off _ ba = FloatX3# + (indexFloatArray# ba off) + (indexFloatArray# ba (off +# 1#)) + (indexFloatArray# ba (off +# 2#)) + {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/FloatX4.hs b/src/Numeric/DataFrame/Internal/Array/Family/FloatX4.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/FloatX4.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Numeric.DataFrame.Internal.Array.Family.FloatX4 (FloatX4 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.DataFrame.SubSpace +import Numeric.Dimensions +import Numeric.PrimBytes + + +data FloatX4 = FloatX4# Float# Float# Float# Float# + + +instance Bounded FloatX4 where + maxBound = case inftyF of F# x -> FloatX4# x x x x + minBound = case negate inftyF of F# x -> FloatX4# x x x x + + +instance Show FloatX4 where + show (FloatX4# a1 a2 a3 a4) + = "{ " ++ show (F# a1) + ++ ", " ++ show (F# a2) + ++ ", " ++ show (F# a3) + ++ ", " ++ show (F# a4) + ++ " }" + + + +instance Eq FloatX4 where + + FloatX4# a1 a2 a3 a4 == FloatX4# b1 b2 b3 b4 = + isTrue# + ( (a1 `eqFloat#` b1) + `andI#` (a2 `eqFloat#` b2) + `andI#` (a3 `eqFloat#` b3) + `andI#` (a4 `eqFloat#` b4) + ) + {-# INLINE (==) #-} + + FloatX4# a1 a2 a3 a4 /= FloatX4# b1 b2 b3 b4 = + isTrue# + ( (a1 `neFloat#` b1) + `orI#` (a2 `neFloat#` b2) + `orI#` (a3 `neFloat#` b3) + `orI#` (a4 `neFloat#` b4) + ) + {-# INLINE (/=) #-} + + + +-- | Implement partial ordering for `>`, `<`, `>=`, `<=` +-- and lexicographical ordering for `compare` +instance Ord FloatX4 where + FloatX4# a1 a2 a3 a4 > FloatX4# b1 b2 b3 b4 = + isTrue# + ( (a1 `gtFloat#` b1) + `andI#` (a2 `gtFloat#` b2) + `andI#` (a3 `gtFloat#` b3) + `andI#` (a4 `gtFloat#` b4) + ) + {-# INLINE (>) #-} + + FloatX4# a1 a2 a3 a4 < FloatX4# b1 b2 b3 b4 = + isTrue# + ( (a1 `ltFloat#` b1) + `andI#` (a2 `ltFloat#` b2) + `andI#` (a3 `ltFloat#` b3) + `andI#` (a4 `ltFloat#` b4) + ) + {-# INLINE (<) #-} + + FloatX4# a1 a2 a3 a4 >= FloatX4# b1 b2 b3 b4 = + isTrue# + ( (a1 `geFloat#` b1) + `andI#` (a2 `geFloat#` b2) + `andI#` (a3 `geFloat#` b3) + `andI#` (a4 `geFloat#` b4) + ) + {-# INLINE (>=) #-} + + FloatX4# a1 a2 a3 a4 <= FloatX4# b1 b2 b3 b4 = + isTrue# + ( (a1 `leFloat#` b1) + `andI#` (a2 `leFloat#` b2) + `andI#` (a3 `leFloat#` b3) + `andI#` (a4 `leFloat#` b4) + ) + {-# INLINE (<=) #-} + + -- | Compare lexicographically + compare (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) + | isTrue# (a1 `gtFloat#` b1) = GT + | isTrue# (a1 `ltFloat#` b1) = LT + | isTrue# (a2 `gtFloat#` b2) = GT + | isTrue# (a2 `ltFloat#` b2) = LT + | isTrue# (a3 `gtFloat#` b3) = GT + | isTrue# (a3 `ltFloat#` b3) = LT + | isTrue# (a4 `gtFloat#` b4) = GT + | isTrue# (a4 `ltFloat#` b4) = LT + | otherwise = EQ + {-# INLINE compare #-} + + -- | Element-wise minimum + min (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) = FloatX4# + (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) + (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) + (if isTrue# (a3 `gtFloat#` b3) then b3 else a3) + (if isTrue# (a4 `gtFloat#` b4) then b4 else a4) + {-# INLINE min #-} + + -- | Element-wise maximum + max (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) = FloatX4# + (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) + (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) + (if isTrue# (a3 `gtFloat#` b3) then a3 else b3) + (if isTrue# (a4 `gtFloat#` b4) then a4 else b4) + {-# INLINE max #-} + + + +-- | element-wise operations for vectors +instance Num FloatX4 where + + FloatX4# a1 a2 a3 a4 + FloatX4# b1 b2 b3 b4 + = FloatX4# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) (plusFloat# a4 b4) + {-# INLINE (+) #-} + + FloatX4# a1 a2 a3 a4 - FloatX4# b1 b2 b3 b4 + = FloatX4# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) (minusFloat# a4 b4) + {-# INLINE (-) #-} + + FloatX4# a1 a2 a3 a4 * FloatX4# b1 b2 b3 b4 + = FloatX4# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) (timesFloat# a4 b4) + {-# INLINE (*) #-} + + negate (FloatX4# a1 a2 a3 a4) = FloatX4# + (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) (negateFloat# a4) + {-# INLINE negate #-} + + abs (FloatX4# a1 a2 a3 a4) + = FloatX4# + (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) + (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) + (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) + (if isTrue# (a4 `geFloat#` 0.0#) then a4 else negateFloat# a4) + {-# INLINE abs #-} + + signum (FloatX4# a1 a2 a3 a4) + = FloatX4# (if isTrue# (a1 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a2 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a3 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a4 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a4 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of F# x -> FloatX4# x x x x + {-# INLINE fromInteger #-} + + + +instance Fractional FloatX4 where + + FloatX4# a1 a2 a3 a4 / FloatX4# b1 b2 b3 b4 = FloatX4# + (divideFloat# a1 b1) (divideFloat# a2 b2) (divideFloat# a3 b3) (divideFloat# a4 b4) + {-# INLINE (/) #-} + + recip (FloatX4# a1 a2 a3 a4) = FloatX4# + (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) (divideFloat# 1.0# a3) (divideFloat# 1.0# a4) + {-# INLINE recip #-} + + fromRational r = case fromRational r of F# x -> FloatX4# x x x x + {-# INLINE fromRational #-} + + + +instance Floating FloatX4 where + + pi = FloatX4# + 3.141592653589793238# + 3.141592653589793238# + 3.141592653589793238# + 3.141592653589793238# + {-# INLINE pi #-} + + exp (FloatX4# a1 a2 a3 a4) = FloatX4# + (expFloat# a1) (expFloat# a2) (expFloat# a3) (expFloat# a4) + {-# INLINE exp #-} + + log (FloatX4# a1 a2 a3 a4) = FloatX4# + (logFloat# a1) (logFloat# a2) (logFloat# a3) (logFloat# a4) + {-# INLINE log #-} + + sqrt (FloatX4# a1 a2 a3 a4) = FloatX4# + (sqrtFloat# a1) (sqrtFloat# a2) (sqrtFloat# a3) (sqrtFloat# a4) + {-# INLINE sqrt #-} + + sin (FloatX4# a1 a2 a3 a4) = FloatX4# + (sinFloat# a1) (sinFloat# a2) (sinFloat# a3) (sinFloat# a4) + {-# INLINE sin #-} + + cos (FloatX4# a1 a2 a3 a4) = FloatX4# + (cosFloat# a1) (cosFloat# a2) (cosFloat# a3) (cosFloat# a4) + {-# INLINE cos #-} + + tan (FloatX4# a1 a2 a3 a4) = FloatX4# + (tanFloat# a1) (tanFloat# a2) (tanFloat# a3) (tanFloat# a4) + {-# INLINE tan #-} + + asin (FloatX4# a1 a2 a3 a4) = FloatX4# + (asinFloat# a1) (asinFloat# a2) (asinFloat# a3) (asinFloat# a4) + {-# INLINE asin #-} + + acos (FloatX4# a1 a2 a3 a4) = FloatX4# + (acosFloat# a1) (acosFloat# a2) (acosFloat# a3) (acosFloat# a4) + {-# INLINE acos #-} + + atan (FloatX4# a1 a2 a3 a4) = FloatX4# + (atanFloat# a1) (atanFloat# a2) (atanFloat# a3) (atanFloat# a4) + {-# INLINE atan #-} + + sinh (FloatX4# a1 a2 a3 a4) = FloatX4# + (sinhFloat# a1) (sinhFloat# a2) (sinhFloat# a3) (sinhFloat# a4) + {-# INLINE sinh #-} + + cosh (FloatX4# a1 a2 a3 a4) = FloatX4# + (coshFloat# a1) (coshFloat# a2) (coshFloat# a3) (coshFloat# a4) + {-# INLINE cosh #-} + + tanh (FloatX4# a1 a2 a3 a4) = FloatX4# + (tanhFloat# a1) (tanhFloat# a2) (tanhFloat# a3) (tanhFloat# a4) + {-# INLINE tanh #-} + + FloatX4# a1 a2 a3 a4 ** FloatX4# b1 b2 b3 b4 = FloatX4# + (powerFloat# a1 b1) (powerFloat# a2 b2) (powerFloat# a3 b3) (powerFloat# a4 b4) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# +#define ELEM_N 4 + +instance PrimBytes FloatX4 where + + getBytes (FloatX4# a1 a2 a3 a4) = case runRW# + ( \s0 -> case newByteArray# (byteSize @FloatX4 undefined) s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of + s2 -> case writeFloatArray# marr 1# a2 s2 of + s3 -> case writeFloatArray# marr 2# a3 s3 of + s4 -> case writeFloatArray# marr 3# a4 s4 of + s5 -> unsafeFreezeByteArray# marr s5 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = FloatX4# + (indexFloatArray# arr i) + (indexFloatArray# arr (i +# 1#)) + (indexFloatArray# arr (i +# 2#)) + (indexFloatArray# arr (i +# 3#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readFloatArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + {-# INLINE readBytes #-} + + writeBytes mba off (FloatX4# a1 a2 a3 a4) s + | i <- BOFF_TO_PRIMOFF(off) + = writeFloatArray# mba (i +# 3#) a4 + ( writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ))) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readFloatOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readFloatOffAddr# addr 2# s2 of + (# s3, a3 #) -> case readFloatOffAddr# addr 3# s3 of + (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + {-# INLINE readAddr #-} + + writeAddr (FloatX4# a1 a2 a3 a4) addr s + = writeFloatOffAddr# addr 3# a4 + ( writeFloatOffAddr# addr 2# a3 + ( writeFloatOffAddr# addr 1# a2 + ( writeFloatOffAddr# addr 0# a1 s ))) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Float undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Float undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = FloatX4# + (indexFloatArray# ba i) + (indexFloatArray# ba (i +# 1#)) + (indexFloatArray# ba (i +# 2#)) + (indexFloatArray# ba (i +# 3#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readFloatArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + {-# INLINE readArray #-} + + writeArray mba off (FloatX4# a1 a2 a3 a4) s + | i <- off *# ELEM_N# + = writeFloatArray# mba (i +# 3#) a4 + ( writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ))) + {-# INLINE writeArray #-} + + +instance PrimArray Float FloatX4 where + + broadcast (F# x) = FloatX4# x x x x + {-# INLINE broadcast #-} + + ix# 0# (FloatX4# a1 _ _ _) = F# a1 + ix# 1# (FloatX4# _ a2 _ _) = F# a2 + ix# 2# (FloatX4# _ _ a3 _) = F# a3 + ix# 3# (FloatX4# _ _ _ a4) = F# a4 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, F# a1 #) -> case f s1 of + (# s2, F# a2 #) -> case f s2 of + (# s3, F# a3 #) -> case f s3 of + (# s4, F# a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + + + upd# _ 0# (F# q) (FloatX4# _ y z w) = FloatX4# q y z w + upd# _ 1# (F# q) (FloatX4# x _ z w) = FloatX4# x q z w + upd# _ 2# (F# q) (FloatX4# x y _ w) = FloatX4# x y q w + upd# _ 3# (F# q) (FloatX4# x y z _) = FloatX4# x y z q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + elemOffset _ = 0# + {-# INLINE elemOffset #-} + + elemSize0 _ = ELEM_N# + {-# INLINE elemSize0 #-} + + fromElems off _ ba = FloatX4# + (indexFloatArray# ba off) + (indexFloatArray# ba (off +# 1#)) + (indexFloatArray# ba (off +# 2#)) + (indexFloatArray# ba (off +# 3#)) + {-# INLINE fromElems #-} + + +-------------------------------------------------------------------------------- +-- Rewrite rules to improve efficiency of algorithms +-- +-- Here we don't have access to DataFrame constructors, because we cannot import +-- Numeric.DataFrame.Type module. +-- However, we know that all DataFrame instances are just newtype wrappers +-- (as well as Scalar). Thus, we can use unsafeCoerce# to get access to Arrays +-- inside DataFrames. +-- +-------------------------------------------------------------------------------- + +getIdxOffset :: Idxs '[4] -> Int# +getIdxOffset is = case unsafeCoerce# is of + [W# i] -> word2Int# i -# 1# + _ -> 0# +{-# INLINE getIdxOffset #-} + + +{-# RULES +"index/FloatX4" forall i . (!.) @Float @'[] i + = unsafeCoerce# (ix# @Float @FloatX4 (getIdxOffset i)) + + #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/ScalarBase.hs b/src/Numeric/DataFrame/Internal/Array/Family/ScalarBase.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/Family/ScalarBase.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Array.Family.ScalarBase (ScalarBase (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps +import Numeric.PrimBytes + +-- | Specialize ScalarBase type without any arrays +newtype ScalarBase t = ScalarBase { _unScalarBase :: t } + deriving ( Enum, Eq, Integral + , Num, Fractional, Floating, Ord, Read, Real, RealFrac, RealFloat + , PrimBytes) + +instance Show t => Show (ScalarBase t) where + show (ScalarBase t) = "{ " ++ show t ++ " }" + +deriving instance {-# OVERLAPPABLE #-} Bounded t => Bounded (ScalarBase t) +instance {-# OVERLAPPING #-} Bounded (ScalarBase Double) where + maxBound = ScalarBase inftyD + minBound = ScalarBase $ negate inftyD +instance {-# OVERLAPPING #-} Bounded (ScalarBase Float) where + maxBound = ScalarBase inftyF + minBound = ScalarBase $ negate inftyF + +instance PrimBytes t => PrimArray t (ScalarBase t) where + broadcast = unsafeCoerce# + {-# INLINE broadcast #-} + ix# _ = unsafeCoerce# + {-# INLINE ix# #-} + gen# _ = unsafeCoerce# + {-# INLINE gen# #-} + upd# _ 0# = const . ScalarBase + upd# _ _ = const id + {-# INLINE upd# #-} + elemOffset _ = 0# + {-# INLINE elemOffset #-} + elemSize0 _ = 1# + {-# INLINE elemSize0 #-} + fromElems off _ ba = indexArray ba off + {-# INLINE fromElems #-} + +_suppressHlintUnboxedTuplesWarning :: () -> (# (), () #) +_suppressHlintUnboxedTuplesWarning = undefined diff --git a/src/Numeric/DataFrame/Internal/Array/PrimOps.hs b/src/Numeric/DataFrame/Internal/Array/PrimOps.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Array/PrimOps.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UnboxedTuples #-} +-- | Internal primitive functions shared across modules +module Numeric.DataFrame.Internal.Array.PrimOps where + +import GHC.Base +import Numeric.Dimensions + +inftyD :: Double +inftyD = read "Infinity" +{-# INLINE inftyD #-} + +inftyF :: Float +inftyF = read "Infinity" +{-# INLINE inftyF #-} + + + +minInt# :: Int# -> Int# -> Int# +minInt# a b | isTrue# (a ># b) = b + | otherwise = a +{-# INLINE minInt# #-} + + +loop# :: Int# -- ^ initial value + -> Int# -- ^ step + -> Int# -- ^ final value (LESS THAN condition) + -> (Int# -> State# s -> State# s) -> State# s -> State# s +loop# n0 di n1 f = loop0 n0 + where + loop0 i s | isTrue# (i >=# n1) = s + | otherwise = loop0 (i +# di) (f i s) +{-# INLINE loop# #-} + + +-- | Loop with given increment, plus keep the step number +-- in the first argument of the iterated function +loopWithI# :: Int# -- ^ initial value + -> Int# -- ^ step + -> Int# -- ^ final value (LESS THAN condition) + -> (Int# -> Int# -> State# s -> State# s) -> State# s -> State# s +loopWithI# n0 di n1 f = loop0 0# n0 + where + loop0 j i s | isTrue# (i >=# n1) = s + | otherwise = loop0 (j +# 1#) (i +# di) (f j i s) +{-# INLINE loopWithI# #-} + + +-- | Do something in a loop for int i from 0 to (n-1) +loop1# :: Int# -> (Int# -> State# s -> State# s) -> State# s -> State# s +loop1# n f = loop0 0# + where + loop0 i s | isTrue# (i ==# n) = s + | otherwise = loop0 (i +# 1#) (f i s) +{-# INLINE loop1# #-} + +-- | Do something in a loop for int i from 0 to (n-1) +loop1a# :: Int# -> (Int# -> a -> a) -> a -> a +loop1a# n f = loop0 0# + where + loop0 i s | isTrue# (i ==# n) = s + | otherwise = s `seq` case f i s of s1 -> s1 `seq` loop0 (i +# 1#) s1 +{-# INLINE loop1a# #-} + + +-- | Same as overDim#, but with no return value +overDim_# :: Dims (ds :: [k]) + -> (Idxs ds -> Int# -> State# s -> State# s) -- ^ function to map over each dimension + -> Int# -- ^ Initial offset + -> Int# -- ^ offset step + -> State# s + -> State# s +overDim_# ds f off0# step# s0 = case overDim_'# ds g off0# s0 of + (# s1, _ #) -> s1 + where + g i off# s = (# f i off# s, off# +# step# #) +{-# INLINE overDim_# #-} + + +overDim_'# :: Dims (ds :: [k]) + -> (Idxs ds -> Int# -> State# s -> (# State# s, Int# #)) -- ^ function to map over each dimension + -> Int# -- ^ Initial offset + -> State# s + -> (# State# s, Int# #) +overDim_'# U f = f U +overDim_'# (d :* ds) f = overDim_'# ds (loop 1) + where + n = dimVal d + loop i js off# s | i > n = (# s , off# #) + | otherwise = case f (Idx i :* js) off# s of + (# s', off1# #) -> loop (i+1) js off1# s' diff --git a/src/Numeric/DataFrame/Internal/Mutable.hs b/src/Numeric/DataFrame/Internal/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Mutable.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.DataFrame.Internal.Mutable +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- Maintainer : chirkin@arch.ethz.ch +-- +-- Interfrace to perform primitive stateful operations on mutable frames. +-- +----------------------------------------------------------------------------- + +module Numeric.DataFrame.Internal.Mutable + ( MDataFrame () + , newDataFrame#, newPinnedDataFrame# + , copyDataFrame#, copyMDataFrame# + , freezeDataFrame#, unsafeFreezeDataFrame# + , thawDataFrame#, thawPinDataFrame#, unsafeThawDataFrame# + , writeDataFrame#, writeDataFrameOff# + , readDataFrame#, readDataFrameOff# + , withDataFramePtr#, isDataFramePinned# + ) where + + +import GHC.Base +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Type +import Numeric.Dimensions +import Numeric.PrimBytes + + +-- | Mutable DataFrame type. +-- Keeps element offset, number of elements, and a mutable byte storage +data MDataFrame s t (ns :: [Nat]) + = MDataFrame# Int# Int# (MutableByteArray# s) + + +-- | Create a new mutable DataFrame. +newDataFrame# :: forall t (ns :: [Nat]) s + . ( PrimBytes t, Dimensions ns) + => State# s -> (# State# s, MDataFrame s t ns #) +newDataFrame# s0 + | W# nw <- totalDim' @ns + , n <- word2Int# nw + , (# s1, mba #) <- newByteArray# (n *# byteSize @t undefined) s0 + = (# s1, MDataFrame# 0# n mba #) +{-# INLINE newDataFrame# #-} + +-- | Create a new mutable DataFrame. +newPinnedDataFrame# :: forall t (ns :: [Nat]) s + . ( PrimBytes t, Dimensions ns) + => State# s -> (# State# s, MDataFrame s t ns #) +newPinnedDataFrame# s0 + | W# nw <- totalDim' @ns + , n <- word2Int# nw + , (# s1, mba #) <- newAlignedPinnedByteArray# + (n *# byteSize @t undefined) + (byteAlign @t undefined) s0 + = (# s1, MDataFrame# 0# n mba #) +{-# INLINE newPinnedDataFrame# #-} + +-- | Copy one DataFrame into another mutable DataFrame at specified position. +copyDataFrame# :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) + (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t + , PrimBytes (DataFrame t (as +: b')) + , ConcatList as (b :+ bs) asbs + , Dimensions (b :+ bs) + ) + => DataFrame t (as +: b') -> Idxs (b :+ bs) -> MDataFrame s t asbs + -> State# s -> (# State# s, () #) +copyDataFrame# df ei (MDataFrame# off _ mba) s + | I# i <- fromEnum ei + = (# writeBytes mba ((off +# i) *# byteSize @t undefined) df s, () #) +{-# INLINE copyDataFrame# #-} + +-- | Copy one mutable DataFrame into another mutable DataFrame at specified position. +copyMDataFrame# :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) + (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t + , ConcatList as (b :+ bs) asbs + , Dimensions (b :+ bs) + ) + => MDataFrame s t (as +: b') -> Idxs (b :+ bs) -> MDataFrame s t asbs + -> State# s -> (# State# s, () #) +copyMDataFrame# (MDataFrame# offA lenA arrA) ei (MDataFrame# offM _ arrM) s + | elS <- byteSize @t undefined + , I# i <- fromEnum ei + = (# copyMutableByteArray# arrA (offA *# elS) + arrM ((offM +# i) *# elS) (lenA *# elS) s + , () #) +{-# INLINE copyMDataFrame# #-} + +-- | Make a mutable DataFrame immutable, without copying. +unsafeFreezeDataFrame# :: forall (t :: Type) (ns :: [Nat]) s + . PrimArray t (DataFrame t ns) + => MDataFrame s t ns + -> State# s -> (# State# s, DataFrame t ns #) +unsafeFreezeDataFrame# (MDataFrame# offM lenM arrM) s1 + | (# s2, arrA #) <- unsafeFreezeByteArray# arrM s1 + = (# s2, fromElems offM lenM arrA #) +{-# INLINE unsafeFreezeDataFrame# #-} + +-- | Copy content of a mutable DataFrame into a new immutable DataFrame. +freezeDataFrame# :: forall (t :: Type) (ns :: [Nat]) s + . PrimArray t (DataFrame t ns) + => MDataFrame s t ns -> State# s -> (# State# s, DataFrame t ns #) +freezeDataFrame# (MDataFrame# offM n arrM) s0 + | elS <- byteSize @t undefined + , (# s1, mba #) <- newByteArray# (n *# elS) s0 + , s2 <- copyMutableByteArray# arrM (offM *# elS) mba 0# (n *# elS) s1 + , (# s3, arrA #) <- unsafeFreezeByteArray# mba s2 + = (# s3, fromElems 0# n arrA #) +{-# INLINE freezeDataFrame# #-} + +-- | Create a new mutable DataFrame and copy content of immutable one in there. +thawDataFrame# :: forall (t :: Type) (ns :: [Nat]) s + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> State# s -> (# State# s, MDataFrame s t ns #) +thawDataFrame# df s0 + | elS <- byteSize @t undefined + , arrA <- getBytes df + , boff <- byteOffset df + , bsize <- byteSize df + , (# s1, arrM #) <- newByteArray# bsize s0 + , s2 <- copyByteArray# arrA boff arrM 0# bsize s1 + = (# s2, MDataFrame# 0# (quotInt# bsize elS) arrM #) +{-# INLINE thawDataFrame# #-} + +-- | Create a new mutable DataFrame and copy content of immutable one in there. +-- The result array is pinned and aligned. +thawPinDataFrame# :: forall (t :: Type) (ns :: [Nat]) s + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> State# s -> (# State# s, MDataFrame s t ns #) +thawPinDataFrame# df s0 + | elS <- byteSize @t undefined + , arrA <- getBytes df + , boff <- byteOffset df + , bsize <- byteSize df + , (# s1, arrM #) <- newAlignedPinnedByteArray# bsize (byteAlign df) s0 + , s2 <- copyByteArray# arrA boff arrM 0# bsize s1 + = (# s2, MDataFrame# 0# (quotInt# bsize elS) arrM #) +{-# INLINE thawPinDataFrame# #-} + +-- | UnsafeCoerces an underlying byte array. +unsafeThawDataFrame# :: forall (t :: Type) (ns :: [Nat]) s + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns + -> State# s -> (# State# s, MDataFrame s t ns #) +unsafeThawDataFrame# df s0 + | elS <- byteSize @t undefined + , arrA <- getBytes df + , boff <- byteOffset df + , bsize <- byteSize df + = (# s0 + , MDataFrame# (quotInt# boff elS) (quotInt# bsize elS) (unsafeCoerce# arrA) + #) +{-# INLINE unsafeThawDataFrame# #-} + + +-- | Write a single element at the specified element offset +writeDataFrameOff# :: forall (t :: Type) (ns :: [Nat]) s + . PrimBytes t + => MDataFrame s t ns -> Int# -> t -> State# s -> (# State# s, () #) +writeDataFrameOff# (MDataFrame# off _ mba) i x s + = (# writeArray mba (off +# i) x s, () #) +{-# INLINE writeDataFrameOff# #-} + +-- | Write a single element at the specified index +writeDataFrame# :: forall (t :: Type) (ns :: [Nat]) s + . ( PrimBytes t, Dimensions ns ) + => MDataFrame s t ns -> Idxs ns -> t -> State# s -> (# State# s, () #) +writeDataFrame# mdf ei | I# i <- fromEnum ei = writeDataFrameOff# mdf i +{-# INLINE writeDataFrame# #-} + +-- | Read a single element at the specified element offset +readDataFrameOff# :: forall (t :: Type) (ns :: [Nat]) s + . PrimBytes t + => MDataFrame s t ns -> Int# -> State# s -> (# State# s, t #) +readDataFrameOff# (MDataFrame# off _ mba) i = readArray mba (off +# i) +{-# INLINE readDataFrameOff# #-} + +-- | Read a single element at the specified index +readDataFrame# :: forall (t :: Type) (ns :: [Nat]) s + . ( PrimBytes t, Dimensions ns ) + => MDataFrame s t ns -> Idxs ns -> State# s -> (# State# s, t #) +readDataFrame# mdf ei | I# i <- fromEnum ei = readDataFrameOff# mdf i +{-# INLINE readDataFrame# #-} + +-- | Allow arbitrary operations on a pointer to the beginning of the data. +-- Only possible with @RealWord@ state (thus, in @IO@) due to semantics of +-- @touch#@ operation that keeps the data from being garbage collected. +withDataFramePtr# :: forall (t :: Type) (ns :: [Nat]) (r :: Type) + . PrimBytes t + => MDataFrame RealWorld t ns + -> ( Addr# -> State# RealWorld -> (# State# RealWorld, r #) ) + -> State# RealWorld -> (# State# RealWorld, r #) +withDataFramePtr# (MDataFrame# off _ mba) k s0 + | (# s1, a #) <- unsafeFreezeByteArray# mba s0 + , (# s2, r #) <- k ( byteArrayContents# a + `plusAddr#` (off *# byteSize @t undefined) + ) s1 + = (# touch# mba s2, r #) + +-- | Check if the byte array wrapped by this DataFrame is pinned, +-- which means cannot be relocated by GC. +isDataFramePinned# :: forall (t :: Type) (ns :: [Nat]) s + . MDataFrame s t ns -> Bool +isDataFramePinned# (MDataFrame# _ _ mba) + = isTrue# (isMutableByteArrayPinned# mba) diff --git a/src/Numeric/DataFrame/ST.hs b/src/Numeric/DataFrame/ST.hs --- a/src/Numeric/DataFrame/ST.hs +++ b/src/Numeric/DataFrame/ST.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,10 +5,11 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -24,331 +24,165 @@ ----------------------------------------------------------------------------- module Numeric.DataFrame.ST - ( -#ifdef ghcjs_HOST_OS - MutableFrame (), STDataFrame (..), MDataFrame (..), MutableArrayT (..) -#else - MutableFrame (), STDataFrame () -#endif - , SomeSTDataFrame (..) - , newDataFrame, copyDataFrame, copyMutableDataFrame - , unsafeFreezeDataFrame - , freezeDataFrame, thawDataFrame - , writeDataFrame, readDataFrame - , writeDataFrameOff, readDataFrameOff -#ifdef ghcjs_HOST_OS - -- * JavaScript-specific functions - , STArrayBuffer - , newArrayBuffer, arrayBuffer, viewFloatArray, viewDoubleArray - , viewIntArray, viewInt32Array, viewInt16Array, viewInt8Array - , viewWordArray, viewWord32Array, viewWord16Array, viewWord8Array, viewWord8ClampedArray -#endif + ( STDataFrame (XSTFrame), SomeSTDataFrame (..) + , newDataFrame, newPinnedDataFrame + , copyDataFrame, copyMutableDataFrame + , freezeDataFrame, unsafeFreezeDataFrame + , thawDataFrame, thawPinDataFrame, unsafeThawDataFrame + , writeDataFrame, writeDataFrameOff + , readDataFrame, readDataFrameOff + , isDataFramePinned ) where -import GHC.Types (Int (..)) -import GHC.ST (ST(..)) +import GHC.Base +import GHC.ST (ST (..)) -#ifdef ghcjs_HOST_OS -import Numeric.Array.Family hiding (Scalar) -import JavaScript.TypedArray.ArrayBuffer.ST -import GHC.Prim -import Data.Int -import Data.Word -import Data.Maybe -import GHCJS.Types -import Numeric.DataFrame.Inference -#endif -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.DataFrame.Mutable +import Numeric.DataFrame.Family +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Mutable import Numeric.Dimensions -import Numeric.Scalar +import Numeric.PrimBytes -- | Mutable DataFrame that lives in ST. --- Internal representation is always a ByteArray. -newtype STDataFrame s t (ns :: [Nat]) = STDataFrame (MDataFrame s t (ns :: [Nat])) -#ifdef ghcjs_HOST_OS -instance IsJSVal (STDataFrame s t ds) -#endif +-- Internal representation is always a MutableByteArray. +data family STDataFrame s (t :: Type) (ns :: [k]) + +-- | Pure wrapper on a mutable byte array +newtype instance STDataFrame s t (ns :: [Nat]) = STDataFrame (MDataFrame s t (ns :: [Nat])) + +-- | Data frame with some dimensions missing at compile time. +-- Pattern-match against its constructor to get a Nat-indexed mutable data frame. +data instance STDataFrame s t (xs :: [XNat]) + = forall (ns :: [Nat]) . Dimensions ns + => XSTFrame (STDataFrame s t ns) + -- | Mutable DataFrame of unknown dimensionality -data SomeSTDataFrame s t (xns :: [XNat]) - = forall (ns :: [Nat]) - . ( FixedDim xns ns ~ ns - , FixedXDim xns ns ~ xns - , NumericFrame t ns - ) - => SomeSTDataFrame (STDataFrame s t ns) +data SomeSTDataFrame s (t :: Type) + = forall (ns :: [Nat]) . Dimensions ns => SomeSTDataFrame (STDataFrame s t ns) -- | Create a new mutable DataFrame. newDataFrame :: forall t (ns :: [Nat]) s -#ifdef ghcjs_HOST_OS - . ( ElemTypeInference t, Dimensions ns) -#else - . ( PrimBytes t, Dimensions ns) -#endif - => ST s (STDataFrame s t ns) + . ( PrimBytes t, Dimensions ns) + => ST s (STDataFrame s t ns) newDataFrame = STDataFrame <$> ST (newDataFrame# @t @ns) {-# INLINE newDataFrame #-} + +-- | Create a new mutable DataFrame. +newPinnedDataFrame :: forall t (ns :: [Nat]) s + . ( PrimBytes t, Dimensions ns) + => ST s (STDataFrame s t ns) +newPinnedDataFrame = STDataFrame <$> ST (newPinnedDataFrame# @t @ns) +{-# INLINE newPinnedDataFrame #-} + + -- | Copy one DataFrame into another mutable DataFrame at specified position. -copyDataFrame :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) s - . ( ConcatList as (b :+ bs) asbs, Dimensions (b :+ bs) -#ifdef ghcjs_HOST_OS - , ArraySizeInference (as +: b'), Dimensions as -#else +copyDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) + (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t , PrimBytes (DataFrame t (as +: b')) -#endif + , ConcatList as (b :+ bs) asbs + , Dimensions (b :+ bs) ) - => DataFrame t (as +: b') -> Idx (b :+ bs) -> STDataFrame s t asbs -> ST s () + => DataFrame t (as +: b') -> Idxs (b :+ bs) -> STDataFrame s t asbs -> ST s () copyDataFrame df ei (STDataFrame mdf) = ST (copyDataFrame# df ei mdf) {-# INLINE copyDataFrame #-} -- | Copy one mutable DataFrame into another mutable DataFrame at specified position. -copyMutableDataFrame :: forall t (as :: [Nat]) (b' :: Nat) (b :: Nat) (bs :: [Nat]) (asbs :: [Nat]) s - . ( PrimBytes t - , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) -#ifdef ghcjs_HOST_OS - , Dimensions as -#endif - ) - => STDataFrame s t (as +: b') -> Idx (b :+ bs) -> STDataFrame s t asbs -> ST s () +copyMutableDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) + (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t + , ConcatList as (b :+ bs) asbs + , Dimensions (b :+ bs) + ) + => STDataFrame s t (as +: b') -> Idxs (b :+ bs) + -> STDataFrame s t asbs -> ST s () copyMutableDataFrame (STDataFrame mdfA) ei (STDataFrame mdfB) = ST (copyMDataFrame# mdfA ei mdfB) {-# INLINE copyMutableDataFrame #-} -- | Make a mutable DataFrame immutable, without copying. -unsafeFreezeDataFrame :: forall t (ns :: [Nat]) s -#ifdef ghcjs_HOST_OS - . (MutableFrame t ns, ArraySizeInference ns) -#else - . PrimBytes (DataFrame t ns) -#endif - => STDataFrame s t ns -> ST s (DataFrame t ns) +unsafeFreezeDataFrame :: forall (t :: Type) (ns :: [Nat]) s + . PrimArray t (DataFrame t ns) + => STDataFrame s t ns -> ST s (DataFrame t ns) unsafeFreezeDataFrame (STDataFrame mdf) = ST (unsafeFreezeDataFrame# mdf) {-# INLINE unsafeFreezeDataFrame #-} -- | Copy content of a mutable DataFrame into a new immutable DataFrame. -freezeDataFrame :: forall t (ns :: [Nat]) s -#ifdef ghcjs_HOST_OS - . (MutableFrame t ns, ArraySizeInference ns) -#else - . PrimBytes (DataFrame t ns) -#endif - => STDataFrame s t ns -> ST s (DataFrame t ns) +freezeDataFrame :: forall (t :: Type) (ns :: [Nat]) s + . PrimArray t (DataFrame t ns) + => STDataFrame s t ns -> ST s (DataFrame t ns) freezeDataFrame (STDataFrame mdf) = ST (freezeDataFrame# mdf) {-# INLINE freezeDataFrame #-} -- | Create a new mutable DataFrame and copy content of immutable one in there. -thawDataFrame :: forall t (ns :: [Nat]) s -#ifdef ghcjs_HOST_OS - . (MutableFrame t ns, ArrayInstanceInference t ns) -#else - . PrimBytes (DataFrame t ns) -#endif - => DataFrame t ns -> ST s (STDataFrame s t ns) +thawDataFrame :: forall (t :: Type) (ns :: [Nat]) s + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> ST s (STDataFrame s t ns) thawDataFrame df = STDataFrame <$> ST (thawDataFrame# df) {-# INLINE thawDataFrame #-} +-- | Create a new mutable DataFrame and copy content of immutable one in there. +-- The result array is pinned and aligned. +thawPinDataFrame :: forall (t :: Type) (ns :: [Nat]) s + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> ST s (STDataFrame s t ns) +thawPinDataFrame df = STDataFrame <$> ST (thawPinDataFrame# df) +{-# INLINE thawPinDataFrame #-} +-- | UnsafeCoerces an underlying byte array. +unsafeThawDataFrame :: forall (t :: Type) (ns :: [Nat]) s + . (PrimBytes (DataFrame t ns), PrimBytes t) + => DataFrame t ns -> ST s (STDataFrame s t ns) +unsafeThawDataFrame df = STDataFrame <$> ST (unsafeThawDataFrame# df) +{-# INLINE unsafeThawDataFrame #-} + + -- | Write a single element at the specified index writeDataFrame :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => STDataFrame s t ns -> Idx ns -> Scalar t -> ST s () -writeDataFrame (STDataFrame mdf) ei = ST . writeDataFrame# mdf ei . unScalar + . ( PrimBytes t, Dimensions ns ) + => STDataFrame s t ns -> Idxs ns -> DataFrame t ('[] :: [Nat]) -> ST s () +writeDataFrame (STDataFrame mdf) ei = ST . writeDataFrame# mdf ei . unsafeCoerce# {-# INLINE writeDataFrame #-} -- | Read a single element at the specified index -readDataFrame :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => STDataFrame s t ns -> Idx ns -> ST s (Scalar t) -readDataFrame (STDataFrame mdf) = fmap scalar . ST . readDataFrame# mdf +readDataFrame :: forall (t :: Type) (ns :: [Nat]) s + . ( PrimBytes t, Dimensions ns ) + => STDataFrame s t ns -> Idxs ns -> ST s (DataFrame t ('[] :: [Nat])) +readDataFrame (STDataFrame mdf) = unsafeCoerce# . ST . readDataFrame# mdf {-# INLINE readDataFrame #-} -- | Write a single element at the specified element offset -writeDataFrameOff :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => STDataFrame s t ns -> Int -> Scalar t -> ST s () -writeDataFrameOff (STDataFrame mdf) (I# i) x = ST $ \s -> (# writeDataFrameOff# mdf i (unScalar x) s, () #) +writeDataFrameOff :: forall (t :: Type) (ns :: [Nat]) s + . PrimBytes t + => STDataFrame s t ns -> Int -> DataFrame t ('[] :: [Nat]) -> ST s () +writeDataFrameOff (STDataFrame mdf) (I# i) + = ST . writeDataFrameOff# mdf i . unsafeCoerce# {-# INLINE writeDataFrameOff #-} -- | Read a single element at the specified element offset -readDataFrameOff :: forall t (ns :: [Nat]) s - . ( MutableFrame t ns, Dimensions ns ) - => STDataFrame s t ns -> Int -> ST s (Scalar t) -readDataFrameOff (STDataFrame mdf) (I# i) = scalar <$> ST (readDataFrameOff# mdf i) +readDataFrameOff :: forall (t :: Type) (ns :: [Nat]) s + . PrimBytes t + => STDataFrame s t ns -> Int -> ST s (DataFrame t ('[] :: [Nat])) +readDataFrameOff (STDataFrame mdf) (I# i) + = unsafeCoerce# (ST (readDataFrameOff# mdf i)) {-# INLINE readDataFrameOff #-} -#ifdef ghcjs_HOST_OS - -newArrayBuffer :: Int -> ST s (STArrayBuffer s) -newArrayBuffer n = unsafeCoerce# <$> ST (newArrayBuffer# n) - -viewFloatArray :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Float (AsXDims ds +: XN 0)) -viewFloatArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Float))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewFloatArray# (jsval ab) :: ST s (STDataFrame s Float (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Float ds) pn - of - Evidence -> case inferNumericFrame @Float @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewDoubleArray :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Double (AsXDims ds +: XN 0)) -viewDoubleArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Double))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewDoubleArray# (jsval ab) :: ST s (STDataFrame s Double (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Double ds) pn - of - Evidence -> case inferNumericFrame @Double @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewIntArray :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Int (AsXDims ds +: XN 0)) -viewIntArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewIntArray# (jsval ab) :: ST s (STDataFrame s Int (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int ds) pn - of - Evidence -> case inferNumericFrame @Int @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewInt32Array :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Int32 (AsXDims ds +: XN 0)) -viewInt32Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int32))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewInt32Array# (jsval ab) :: ST s (STDataFrame s Int32 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int32 ds) pn - of - Evidence -> case inferNumericFrame @Int32 @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewInt16Array :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Int16 (AsXDims ds +: XN 0)) -viewInt16Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int16))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewInt16Array# (jsval ab) :: ST s (STDataFrame s Int16 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int16 ds) pn - of - Evidence -> case inferNumericFrame @Int16 @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewInt8Array :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Int8 (AsXDims ds +: XN 0)) -viewInt8Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Int8))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewInt8Array# (jsval ab) :: ST s (STDataFrame s Int8 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Int8 ds) pn - of - Evidence -> case inferNumericFrame @Int8 @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewWordArray :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Word (AsXDims ds +: XN 0)) -viewWordArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewWordArray# (jsval ab) :: ST s (STDataFrame s Word (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word ds) pn - of - Evidence -> case inferNumericFrame @Word @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewWord32Array :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Word32 (AsXDims ds +: XN 0)) -viewWord32Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word32))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewWord32Array# (jsval ab) :: ST s (STDataFrame s Word32 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word32 ds) pn - of - Evidence -> case inferNumericFrame @Word32 @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewWord16Array :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Word16 (AsXDims ds +: XN 0)) -viewWord16Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word16))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewWord16Array# (jsval ab) :: ST s (STDataFrame s Word16 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word16 ds) pn - of - Evidence -> case inferNumericFrame @Word16 @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewWord8Array :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Word8 (AsXDims ds +: XN 0)) -viewWord8Array ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word8))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewWord8Array# (jsval ab) :: ST s (STDataFrame s Word8 (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word8 ds) pn - of - Evidence -> case inferNumericFrame @Word8 @(ds +: n) of - Evidence -> SomeSTDataFrame df - -viewWord8ClampedArray :: forall s ds - . ( Dimensions ds, ArraySizeInference ds) - => STArrayBuffer s -> ST s (SomeSTDataFrame s Word8Clamped (AsXDims ds +: XN 0)) -viewWord8ClampedArray ab = do - SomeDim (pn@Dn :: Dim (n :: Nat)) <- abDim (I# (byteSize (undefined :: Word8Clamped))) (dim @ds) ab - df <- fmap STDataFrame . ST $ viewWord8ClampedArray# (jsval ab) :: ST s (STDataFrame s Word8Clamped (ds +: n)) - return $ case unsafeForceFixedDims @ds @n - `sumEvs` inferSnocDimensions @ds @n - `sumEvs` inferSnocArrayInstance (undefined :: DataFrame Word8Clamped ds) pn - of - Evidence -> case inferNumericFrame @Word8Clamped @(ds +: n) of - Evidence -> SomeSTDataFrame df - -arrayBuffer :: STDataFrame s t ds -> ST s (STArrayBuffer s) -arrayBuffer (STDataFrame x) = unsafeCoerce# <$> ST (arrayBuffer# x) - - -foreign import javascript unsafe "$1.length" js_abLength :: STArrayBuffer s -> Int - -abDim :: Int -> Dim (ds :: [Nat]) -> STArrayBuffer s -> ST s SomeDim -abDim elS d ab = fromMaybe (SomeDim (Dn :: Dim 0)) . someDimVal . (`quot` (elS * dimVal d)) <$> pure (js_abLength ab) -{-# NOINLINE abDim #-} - -unsafeForceFixedDims :: forall ds n - . Evidence ( FixedDim (AsXDims ds +: XN 0) (ds +: n) ~ (ds +: n) - , FixedXDim (AsXDims ds +: XN 0) (ds +: n) ~ (AsXDims ds +: XN 0) - ) -unsafeForceFixedDims = unsafeCoerce# (Evidence :: Evidence ( (ds +: n) ~ (ds +: n) , (ds +: n) ~ (ds +: n) )) - -#endif +-- | Check if the byte array wrapped by this DataFrame is pinned, +-- which means cannot be relocated by GC. +isDataFramePinned :: forall (t :: Type) (ns :: [k]) s + . KnownDimKind k + => STDataFrame s t ns -> Bool +isDataFramePinned df = case dimKind @k of + DimNat -> case df of + STDataFrame x -> isDataFramePinned# x + DimXNat -> case df of + XSTFrame (STDataFrame x) -> isDataFramePinned# x diff --git a/src/Numeric/DataFrame/Shape.hs b/src/Numeric/DataFrame/Shape.hs --- a/src/Numeric/DataFrame/Shape.hs +++ b/src/Numeric/DataFrame/Shape.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,7 +13,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.DataFrame.Shape @@ -29,27 +28,27 @@ module Numeric.DataFrame.Shape ( (<:>), (<::>), (<+:>) - , fromList, DataFrameToList (..), fromScalar + , fromScalar + , DataFrameToList (..) + , fromListN, fromList ) where -import Data.Type.Equality ((:~:) (..)) -import GHC.Base (runRW#) -import qualified GHC.Exts as Exts (IsList (..)) -import GHC.Prim -import GHC.Types (Int (..), Type, isTrue#) -import Unsafe.Coerce (unsafeCoerce) +import GHC.Base -import qualified Numeric.Array.ElementWise as EW -import Numeric.Array.Family hiding (Scalar) -import Numeric.Commons -import Numeric.DataFrame.Inference -import Numeric.DataFrame.Type +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.Family (inferASing, inferPrim, + inferPrimElem) +import Numeric.DataFrame.SubSpace +import Numeric.DataFrame.Type (DataFrame (..)) import Numeric.Dimensions -import Numeric.TypeLits -import Numeric.Scalar as Scalar -import Numeric.Vector (vec2) +import Numeric.PrimBytes +import Numeric.Scalar as Scalar +import Numeric.TypedList (TypedList (..)) +import qualified Numeric.TypedList as Dims +import Numeric.Vector --- | Append one DataFrame to another, adding up their last dimensionality + +-- | Append one DataFrame to another, sum up last dimension (<:>) :: forall (n :: Nat) (m :: Nat) (npm :: Nat) (ds :: [Nat]) (t :: Type) . ( PrimBytes (DataFrame t (ds +: n)) @@ -62,19 +61,12 @@ => DataFrame t (ds +: n) -> DataFrame t (ds +: m) -> DataFrame t (ds +: npm) -a <:> b = case (# toBytes a, toBytes b - , byteSize a - , byteSize b - , elementByteSize a #) of - (# (# off1, n1, arr1 #), (# off2, n2, arr2 #), bs1, bs2, ebs #) -> case runRW# - ( \s0 -> case newByteArray# (bs1 +# bs2) s0 of - (# s1, mr #) -> case copyByteArray# arr1 (off1 *# ebs) mr 0# bs1 s1 of - s2 -> case copyByteArray# arr2 (off2 *# ebs) mr bs1 bs2 s2 of - s3 -> unsafeFreezeByteArray# mr s3 - ) of (# _, r #) -> fromBytes (# 0#, n1 +# n2, r #) +(<:>) = appendDF infixl 5 <:> +{-# INLINE [1] (<:>) #-} --- | Append one DataFrame to another, adding up their last dimensionality +-- | Append one DataFrame to another, +-- add another @Dim = 2@ to their dimension list. (<::>) :: forall (ds :: [Nat]) (t :: Type) . ( PrimBytes (DataFrame t ds) , PrimBytes (DataFrame t ds) @@ -83,27 +75,24 @@ => DataFrame t ds -> DataFrame t ds -> DataFrame t (ds +: 2 :: [Nat]) -a <::> b = case (# toBytes a, toBytes b - , byteSize a - , byteSize b - , elementByteSize a #) of - (# (# off1, n1, arr1 #), (# off2, n2, arr2 #), bs1, bs2, ebs #) -> case runRW# - ( \s0 -> case newByteArray# (bs1 +# bs2) s0 of - (# s1, mr #) -> case copyByteArray# arr1 (off1 *# ebs) mr 0# bs1 s1 of - s2 -> case copyByteArray# arr2 (off2 *# ebs) mr bs1 bs2 s2 of - s3 -> unsafeFreezeByteArray# mr s3 - ) of (# _, r #) -> fromBytes (# 0#, n1 +# n2, r #) +(<::>) = appendDF infixl 5 <::> -{-# NOINLINE [1] (<::>) #-} +{-# INLINE [1] (<::>) #-} + +vec2t :: forall t . SubSpace t '[] '[2] '[2] => Scalar t -> Scalar t -> Vector t 2 +vec2t = unsafeCoerce# (vec2 @t) +{-# INLINE vec2t #-} + {-# RULES -"<::>/vec2-Float" forall (a :: Scalar Float) (b :: Scalar Float) . a <::> b = vec2 (unScalar a) (unScalar b) -"<::>/vec2-Double" forall (a :: Scalar Double) (b :: Scalar Double) . a <::> b = vec2 (unScalar a) (unScalar b) -"<::>/vec2-Int" forall (a :: Scalar Int) (b :: Scalar Int) . a <::> b = vec2 (unScalar a) (unScalar b) --- "<::>/vec2-Word" forall (a :: Scalar Word) (b :: Scalar Word) . a <::> b = vec2 (unScalar a) (unScalar b) +"<::>/vec2-Float" (<::>) = vec2t @Float +"<::>/vec2-Double" (<::>) = vec2t @Double +"<::>/vec2-Int" (<::>) = vec2t @Int +"<::>/vec2-Word" (<::>) = vec2t @Word #-} --- | Append one DataFrame to another, adding up their last dimensionality +-- | Grow the first DataFrame by adding the second one to it +-- incrementing the last Dim in the list. (<+:>) :: forall (ds :: [Nat]) (n :: Nat) (m :: Nat) (t :: Type) . ( PrimBytes (DataFrame t (ds +: n)) , PrimBytes (DataFrame t ds) @@ -113,153 +102,137 @@ => DataFrame t (ds +: n) -> DataFrame t ds -> DataFrame t (ds +: m) -a <+:> b = case (# toBytes a, toBytes b - , byteSize a - , byteSize b - , elementByteSize a #) of - (# (# off1, n1, arr1 #), (# off2, n2, arr2 #), bs1, bs2, ebs #) -> case runRW# - ( \s0 -> case newByteArray# (bs1 +# bs2) s0 of - (# s1, mr #) -> case copyByteArray# arr1 (off1 *# ebs) mr 0# bs1 s1 of - s2 -> case copyByteArray# arr2 (off2 *# ebs) mr bs1 bs2 s2 of - s3 -> unsafeFreezeByteArray# mr s3 - ) of (# _, r #) -> fromBytes (# 0#, n1 +# n2, r #) +(<+:>) = appendDF infixl 5 <+:> +{-# INLINE [1] (<+:>) #-} --- | Input must be parametrized by [Nat] to make sure every element +-- | Concatenate a list of @DataFrame@s. +-- Returns @Nothing@ if the list does not have enough elements. +-- +-- Input must be parametrized by @[Nat]@ to make sure every element -- in the input list has the same dimensionality. --- Output is in [XNat], because the last dimension is unknown at compile time -fromList :: forall ns t xns xnsm - . ( ns ~ AsDims xns - , xnsm ~ (xns +: XN 2) - , PrimBytes (DataFrame t ns) - , Dimensions ns - , ArrayInstanceInference t ns +-- Output is in @[XNat]@, because the last dimension is unknown at compile time. +fromList :: forall m ns t + . ( Dimensions ns + , PrimBytes t ) - => [DataFrame t ns] -> DataFrame t (xns +: XN 2) -fromList xs = fromListN (length xs) xs + => Dim m + -- ^ Minimum number of elements in a list + -> [DataFrame t ns] + -- ^ List of frames to concatenate + -> Maybe (DataFrame t (AsXDims ns +: XN m)) +fromList d xs = fromListN d (length xs) xs + + -- | Implement function `toList`. -- We need to create a dedicated type class for this -- to make it polymorphic over kind k (Nat <-> XNat). -class DataFrameToList t z (ds :: [k]) where +class DataFrameToList (t :: Type) (ds :: [k]) (z :: k) where -- | Unwrap the last dimension of a DataFrame into a list of smaller frames toList :: DataFrame t (ds +: z) -> [DataFrame t ds] -instance ( Dimensions ns - , Dimensions (ns +: z) - , PrimBytes (DataFrame t ns) - , PrimBytes (DataFrame t (ns +: z)) +instance ( Dimensions (ns +: z) + , PrimBytes t ) - => DataFrameToList t z (ns :: [Nat]) where - toList df@(KnownDataFrame _) = go offset - where - !(I# step) = totalDim (Proxy @ns) - !(# offset, lenN, arr #) = toBytes df - lim = offset +# lenN - go pos | isTrue# (pos >=# lim) = [] - | otherwise = fromBytes (# pos, step , arr #) : go (pos +# step) - -instance DataFrameToList t xz (xns :: [XNat]) where - toList (SomeDataFrame (df :: DataFrame t nsz)) - | (pns :: Proxy ns, _ :: Proxy z, Refl, Refl, Refl, Refl, Refl) <- getXSZ @nsz - , Just Evidence <- inferInitDimensions @nsz - , Evidence <- inferInitArrayInstance df - , Evidence <- inferNumericFrame @t @ns - , I# step <- totalDim pns - , (# offset, lenN, arr #) <- toBytes df - = go pns step arr (offset +# lenN) offset - where - getXSZ :: forall xs z . (Proxy xs, Proxy z - , (xs +: z) :~: nsz - , xs :~: Init nsz - , (Head nsz :+ Tail nsz) :~: nsz - , FixedDim xns (Init nsz) :~: Init nsz - , FixedXDim xns (Init nsz) :~: xns) - getXSZ = ( Proxy, Proxy, unsafeCoerce Refl - , unsafeCoerce Refl - , unsafeCoerce Refl - , unsafeCoerce Refl - , unsafeCoerce Refl) - go :: forall ns - . ( FixedDim xns ns ~ ns - , FixedXDim xns ns ~ xns - , NumericFrame t ns - , Dimensions ns - ) - => Proxy ns -> Int# -> ByteArray# -> Int# -> Int# -> [DataFrame t xns] - go p step arr lim pos | isTrue# (pos >=# lim) = [] - | otherwise = SomeDataFrame ( - fromBytes (# pos, step , arr #) :: DataFrame t ns - ) - : go p step arr lim (pos +# step) - toList _ = error "(DataFrameToList.ToList) Impossible happend: DataFrame has rank zero!" + => DataFrameToList t (ns :: [Nat]) (z :: Nat) where + toList df + | Dims.Snoc (Dims :: Dims ns') dn <- dims @Nat @(ns +: z) + -- TODO: line below is a workaround and should be avoided. + , E <- unsafeCoerce# (E @(ns ~ ns)) :: Evidence (ns ~ ns') + , E <- inferASing @t @ns + , E <- inferASing @t @(ns +: z) + , E <- inferPrim @t @(ns +: z) + , E <- inferPrim @t @ns + , n <- dimVal dn + , I# step <- fromIntegral $ totalDim' @ns + , off0 <- elemOffset df + , ba <- getBytes df + = let go 0 _ = [] + go k off = fromElems off step ba : go (k-1) (off +# step) + in go n off0 + | otherwise = [] +instance DataFrameToList t (xns :: [XNat]) (xz :: XNat) where + toList (XFrame (df :: DataFrame t nsz)) + | nsz <- dims @Nat @nsz + , xnsz <- xDims @(xns +: xz) nsz + -- TODO: line below is a workaround and should be avoided. + , E <- unsafeCoerce# (E @(xns ~ xns)) :: Evidence (xns ~ Init (xns +: xz)) + , xns <- Dims.init xnsz + , TypeList <- types xnsz + , EvList <- Dims.init (EvList @_ @KnownXNatType @(xns +: xz)) + , Dims.Snoc (ns@Dims :: Dims ns) _ <- nsz + , Dims.Cons (_ :: Dim k) (_ :: Dims ks) <- nsz + , E <- inferPrimElem @t @k @ks + , XDims ns' <- xns + , Just E <- sameDims ns ns' + , E <- inferASing @t @ns + = map XFrame (toList df) + toList _ = [] -fromListN :: forall ns t xns xnsm - . ( ns ~ AsDims xns - , xnsm ~ (xns +: XN 2) - , PrimBytes (DataFrame t ns) - , Dimensions ns - , ArrayInstanceInference t ns +-- | Concatenate a list of @DataFrame@s. +-- Returns @Nothing@ if the list does not have enough elements +-- or if provided length is invalid. +fromListN :: forall (m :: Nat) (ns :: [Nat]) (t :: Type) + . ( Dimensions ns + , PrimBytes t ) - => Int -> [DataFrame t ns] -> DataFrame t (xns +: XN 2) -fromListN _ [] = error "DataFrame fromList: the list must have at least two elements" -fromListN _ [_] = error "DataFrame fromList: the list must have at least two elements" -fromListN n@(I# n#) xs | Just (SomeNat (pm :: Proxy m)) <- someNatVal (fromIntegral n) - , (pnsm, Refl, Refl, Refl) <- snocP pm - , I# len# <- totalDim (Proxy @ns) - , resultBytes# <- df len# - , Evidence <- inferSnocDimensions @ns @m - , Evidence <- inferSnocArrayInstance (head xs) pm - , Evidence <- inferPrimBytes @t @(ns +: m) - , Evidence <- inferNumericFrame @t @(ns +: m) - = SomeDataFrame . enforceDim @t pnsm $ fromBytes (# 0#, n# *# len#, resultBytes# #) - where - elSize# = elementByteSize (head xs) - df :: Int# -> ByteArray# - df len# = case runRW# - ( \s0 -> let !(# s1, marr #) = newByteArray# (n# *# elSize# *# len#) s0 - go s _ [] = s - go s pos (earr : as) = case toBytes earr of - (# eoff#, _, ea #) -> go - (copyByteArray# ea (eoff# *# elSize#) marr (pos *# elSize#) (elSize# *# len#) s) - (pos +# len#) - as - s2 = go s1 0# xs - in unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> r - snocP :: forall m . Proxy m -> - ( Proxy (ns +: m) - , FixedXDim xnsm (ns +: m) :~: xnsm - , FixedDim xnsm (ns +: m) :~: (ns +: m) - , (2 <=? m) :~: 'True - ) - snocP _ = (Proxy, unsafeCoerce Refl, unsafeCoerce Refl, unsafeCoerce Refl) - enforceDim :: forall s nsm . Proxy nsm -> DataFrame s nsm -> DataFrame s nsm - enforceDim _ = id -fromListN n _ = error $ "DataFrame fromList: not a proper list length: " ++ show n + => Dim m + -- ^ Minimum number of elements in a list + -> Int + -- ^ How many elements of a list to take. + -- Must be not smaller than @m@ and not greater than @length ns@. + -> [DataFrame t ns] + -- ^ List of frames to concatenate + -> Maybe (DataFrame t (AsXDims ns +: XN m)) +fromListN Dim n@(I# n#) xs' + | n < 0 = Nothing + | Just dxn@(Dx dn@(D :: Dim n)) <- constrain @m (someDimVal (fromIntegral n)) + , Just xs <- takeMaybe n xs' + , ns@(AsXDims xns) <- dims @Nat @ns + , nsn@Dims <- Dims.snoc ns dn + , xnsn <- Dims.snoc xns dxn + , EvList <- Dims.snoc (EvList @XNat @KnownXNatType @(AsXDims ns)) + (toEvidence' (E @(KnownXNatType (XN m)))) + , XDims nsn' <- xnsn + , Just E <- sameDims nsn nsn' + , E <- inferASing @t @ns + , E <- inferASing @t @(ns +: n) + , E <- inferPrim @t @ns + , E <- inferPrim @t @(ns +: n) + , I# partElN <- fromIntegral $ totalDim' @ns + , totalElN <- partElN *# n# + , elS <- byteSize @t undefined + , partBS <- partElN *# elS + = case runRW# + ( \s0 -> case newByteArray# (totalElN *# elS) s0 of + (# s1, mba #) -> + let go _ [] s = s + go off (p : ps) s = go (off +# partBS) ps (writeBytes mba off p s) + in unsafeFreezeByteArray# mba (go 0# xs s1) + ) of (# _, r #) + -> Just (XFrame (fromElems 0# totalElN r :: DataFrame t (ns +: n))) +fromListN _ _ _ = Nothing +takeMaybe :: Int -> [a] -> Maybe [a] +takeMaybe 0 _ = Just [] +takeMaybe _ [] = Nothing +takeMaybe n (x : xs) = (x:) <$> takeMaybe (n-1) xs -instance ( xnsm ~ (x ': xns') - , xns ~ Init xnsm - , Last xnsm ~ XN 2 - , ns ~ AsDims xns - , (x ': xns') ~ (xns +: XN 2) - , PrimBytes (DataFrame t ns) - , Dimensions ns - , ArrayInstanceInference t ns - ) - => Exts.IsList (DataFrame t ((x ': xns') :: [XNat])) where - type Item (DataFrame t (x ': xns')) = DataFrame t (AsDims (Init (x ': xns'))) - fromList xs = fromListN (length xs) xs - fromListN = fromListN - toList (SomeDataFrame (df :: DataFrame t ds)) - | Refl <- unsafeCoerce Refl :: ds :~: (ns +: Last ds) = toList df --- | Broadcast scalar value onto a whole data frame -fromScalar :: EW.ElementWise (Idx ds) t (DataFrame t ds) - => Scalar.Scalar t -> DataFrame t ds -fromScalar = EW.broadcast . Scalar.unScalar + +appendDF :: (PrimBytes x, PrimBytes y, PrimBytes z) + => x -> y -> z +appendDF x y + | sx <- byteSize x + = case runRW# + ( \s0 -> case newByteArray# (sx +# byteSize y) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( writeBytes mba sx y + ( writeBytes mba 0# x s1)) + ) of (# _, r #) -> fromBytes 0# r +{-# INLINE appendDF #-} diff --git a/src/Numeric/DataFrame/SubSpace.hs b/src/Numeric/DataFrame/SubSpace.hs --- a/src/Numeric/DataFrame/SubSpace.hs +++ b/src/Numeric/DataFrame/SubSpace.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,10 +14,6 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -#ifdef ghcjs_HOST_OS -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE UnliftedFFITypes #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Numeric.DataFrame.SubSpace @@ -31,28 +26,19 @@ ----------------------------------------------------------------------------- module Numeric.DataFrame.SubSpace - ( SubSpace (..), (!), element + ( SubSpace (..), (!), (!.), element , ewfoldMap, iwfoldMap , ewzip, iwzip , indexWise_, elementWise_ ) where -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), Type) - -#ifdef ghcjs_HOST_OS -import GHCJS.Types (JSVal) -import Unsafe.Coerce (unsafeCoerce) -#endif +import GHC.Base -import qualified Numeric.Array.ElementWise as EW -import Numeric.Commons -import Numeric.DataFrame.Type +import Numeric.DataFrame.Family +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.PrimOps import Numeric.Dimensions -import Numeric.Dimensions.Traverse -import Numeric.TypeLits -import Numeric.Scalar +import Numeric.PrimBytes -- | Operations on DataFrames -- @@ -66,22 +52,21 @@ , Dimensions as , Dimensions bs , Dimensions asbs + , PrimArray t (DataFrame t asbs) ) => SubSpace (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) | asbs as -> bs, asbs bs -> as, as bs -> asbs where - -- | Unsafely get a sub-dataframe by its primitive element subset. + -- | Unsafely get a sub-dataframe by its primitive element offset. -- The offset is not checked to be aligned to the space structure or for bounds. -- Arguments are zero-based primitive element offset and subset ("as" element) size (aka `totalDim` of sub dataframe) -- -- Normal indexing can be expressed in terms of `indexOffset#`: -- -- > i !. x = case (# dimVal (dim @as), fromEnum i #) of (# I# n, I# j #) -> indexOffset# (n *# j) n x - indexOffset# :: Int# -> Int# -> DataFrame t asbs -> DataFrame t as - -- | Get an element by its index in the dataframe - (!.) :: Idx bs -> DataFrame t asbs -> DataFrame t as - (!.) i = case (# dimVal (dim @as), fromEnum i #) of (# I# n, I# j #) -> indexOffset# (n *# j) n - {-# INLINE (!.) #-} + indexOffset# :: Int# -- ^ Prim element offset + -> Int# -- ^ Number of prim elements in the prefix subspace + -> DataFrame t asbs -> DataFrame t as -- | Set a new value to an element - update :: Idx bs -> DataFrame t as -> DataFrame t asbs -> DataFrame t asbs + update :: Idxs bs -> DataFrame t as -> DataFrame t asbs -> DataFrame t asbs -- | Map a function over each element of DataFrame ewmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) . SubSpace s as' bs asbs' @@ -90,12 +75,12 @@ -- | Map a function over each element with its index of DataFrame iwmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) . SubSpace s as' bs asbs' - => (Idx bs -> DataFrame s as' -> DataFrame t as) + => (Idxs bs -> DataFrame s as' -> DataFrame t as) -> DataFrame s asbs' -> DataFrame t asbs -- | Generate a DataFrame by repeating an element ewgen :: DataFrame t as -> DataFrame t asbs -- | Generate a DataFrame by iterating a function (index -> element) - iwgen :: (Idx bs -> DataFrame t as) -> DataFrame t asbs + iwgen :: (Idxs bs -> DataFrame t as) -> DataFrame t asbs -- | Left-associative fold of a DataFrame. -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not @@ -105,7 +90,7 @@ -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not -- produce memory leaks deeply inside the result data type. - iwfoldl :: (Idx bs -> b -> DataFrame t as -> b) -> b -> DataFrame t asbs -> b + iwfoldl :: (Idxs bs -> b -> DataFrame t as -> b) -> b -> DataFrame t asbs -> b -- | Right-associative fold of a DataFrame -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not @@ -115,7 +100,7 @@ -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not -- produce memory leaks deeply inside the result data type. - iwfoldr :: (Idx bs -> DataFrame t as -> b -> b) -> b -> DataFrame t asbs -> b + iwfoldr :: (Idxs bs -> DataFrame t as -> b -> b) -> b -> DataFrame t asbs -> b -- | Apply an applicative functor on each element (Lens-like traversal) elementWise :: forall s (as' :: [Nat]) (asbs' :: [Nat]) f . ( Applicative f @@ -129,15 +114,23 @@ . ( Applicative f , SubSpace s as' bs asbs' ) - => (Idx bs -> DataFrame s as' -> f (DataFrame t as)) + => (Idxs bs -> DataFrame s as' -> f (DataFrame t as)) -> DataFrame s asbs' -> f (DataFrame t asbs) + +-- | Get an element by its index in the dataframe +(!.) :: forall t as bs asbs + . SubSpace t as bs asbs + => Idxs bs -> DataFrame t asbs -> DataFrame t as +(!.) i = case (# totalDim (dims @_ @as), fromEnum i #) of + (# W# n, I# j #) -> indexOffset# (word2Int# n *# j) (word2Int# n) +{-# INLINE [1] (!.) #-} infixr 4 !. -- | Apply an applicative functor on each element with its index -- (Lens-like indexed traversal) indexWise_ :: forall t as bs asbs f b . (SubSpace t as bs asbs, Applicative f) - => (Idx bs -> DataFrame t as -> f b) + => (Idxs bs -> DataFrame t as -> f b) -> DataFrame t asbs -> f () indexWise_ f = iwfoldr (\i -> (*>) . f i) (pure ()) @@ -152,7 +145,7 @@ -- | Apply a functor over a single element (simple lens) element :: forall t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) f . (SubSpace t as bs asbs, Applicative f) - => Idx bs + => Idxs bs -> (DataFrame t as -> f (DataFrame t as)) -> DataFrame t asbs -> f (DataFrame t asbs) element i f df = flip (update i) df <$> f (i !. df) @@ -160,7 +153,7 @@ -- | Index an element (reverse of !.) (!) :: SubSpace t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) - => DataFrame t asbs -> Idx bs -> DataFrame t as + => DataFrame t asbs -> Idxs bs -> DataFrame t as (!) = flip (!.) infixl 4 ! {-# INLINE (!) #-} @@ -174,7 +167,7 @@ iwfoldMap :: forall t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) m . ( Monoid m, SubSpace t as bs asbs) - => (Idx bs -> DataFrame t as -> m) -> DataFrame t asbs -> m + => (Idxs bs -> DataFrame t as -> m) -> DataFrame t asbs -> m iwfoldMap f = iwfoldl (\i m b -> m `seq` (mappend m $! f i b)) mempty {-# INLINE iwfoldMap #-} @@ -188,7 +181,7 @@ , SubSpace s as' bs asbs' , SubSpace r as'' bs asbs'' ) - => (Idx bs -> DataFrame t as -> DataFrame s as' -> DataFrame r as'') + => (Idxs bs -> DataFrame t as -> DataFrame s as' -> DataFrame r as'') -> DataFrame t asbs -> DataFrame s asbs' -> DataFrame r asbs'' @@ -213,117 +206,145 @@ {-# INLINE ewzip #-} -#ifdef ghcjs_HOST_OS -foreign import javascript unsafe "$3.subarray($1,$1 + $2)" js_subarray :: Int# -> Int# -> JSVal -> JSVal -#endif - -instance {-# OVERLAPPABLE #-} - ( ConcatList as bs asbs +instance ( ConcatList as bs asbs , Dimensions as , Dimensions bs , Dimensions asbs - , PrimBytes (DataFrame t as) - , PrimBytes (DataFrame t asbs) - , as ~ (a'' ': as'') - , asbs ~ (a'' ': asbs'') + , PrimArray t (DataFrame t as) + , PrimArray t (DataFrame t asbs) + , PrimBytes (DataFrame t as) + , PrimBytes (DataFrame t asbs) ) => SubSpace t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) where -#ifdef ghcjs_HOST_OS - indexOffset# i l = unsafeCoerce . js_subarray i l . unsafeCoerce -#else - indexOffset# i l d = case toBytes d of - (# off, _, arr #) -> fromBytes (# off +# i, l, arr #) -#endif - {-# INLINE indexOffset# #-} + indexOffset# i l d = case elemSize0 d of + -- if elemSize0 returns 0, then this is a fromScalar-like constructor + 0# -> broadcast (ix# 0# d) + _ -> fromElems (elemOffset d +# i) l (getBytes d) + + + update ei x df + | I# i <- fromEnum ei + , I# len <- fromIntegral $ totalDim' @asbs + = case runRW# + ( \s0 -> case newByteArray# (len *# byteSize @t undefined) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( writeArray mba i x + ( writeBytes mba 0# df s1 ) + ) + ) of (# _, r #) -> fromElems 0# len r + ewmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) . SubSpace s as' bs asbs' => (DataFrame s as' -> DataFrame t as) -> DataFrame s asbs' -> DataFrame t asbs ewmap f df - | elS <- elementByteSize (undefined :: DataFrame t asbs) - , I# lenBS <- totalDim (Proxy @bs) - , I# lenAS <- totalDim (Proxy @as) - , I# lenAS' <- totalDim (Proxy @as') - , lenASB <- lenAS *# elS + | elS <- byteSize @t undefined + , W# lenBSW <- totalDim' @bs + , W# lenASW <- totalDim' @as + , W# lenAS'W <- totalDim' @as' + , lenBS <- word2Int# lenBSW + , lenAS <- word2Int# lenASW + , lenAS' <- word2Int# lenAS'W + , lenASBS <- lenAS *# lenBS + , lenAS'BS <- lenAS' *# lenBS = case runRW# - ( \s0 -> case newByteArray# (lenAS *# lenBS *# elS) s0 of - (# s1, marr #) -> case overDimOff_# - (dim @bs) - ( \pos s -> case toBytes $ f (indexOffset# (pos *# lenAS') lenAS' df) of - (# offX, _, arrX #) -> copyByteArray# arrX (offX *# elS) marr (pos *# lenASB) lenASB s - ) 0# 1# s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, lenAS *# lenBS, r #) + ( \s0 -> case newByteArray# (lenASBS *# elS) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loopWithI# 0# lenAS' lenAS'BS + (\i off -> writeArray mba i (f (indexOffset# off lenAS' df))) + s1 + ) + ) of (# _, r #) -> fromElems 0# lenASBS r {-# INLINE ewmap #-} + iwmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) . SubSpace s as' bs asbs' - => (Idx bs -> DataFrame s as' -> DataFrame t as) + => (Idxs bs -> DataFrame s as' -> DataFrame t as) -> DataFrame s asbs' -> DataFrame t asbs iwmap f df - | elS <- elementByteSize (undefined :: DataFrame t asbs) - , I# lenBS <- totalDim (Proxy @bs) - , I# lenAS <- totalDim (Proxy @as) - , I# lenAS' <- totalDim (Proxy @as') - , lenASB <- lenAS *# elS - = case runRW# - ( \s0 -> case newByteArray# (lenAS *# lenBS *# elS) s0 of - (# s1, marr #) -> case overDim_# - (dim @bs) - ( \i pos s -> case toBytes $ f i (indexOffset# (pos *# lenAS') lenAS' df) of - (# offX, _, arrX #) -> copyByteArray# arrX (offX *# elS) marr (pos *# lenASB) lenASB s - ) 0# 1# s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, lenAS *# lenBS, r #) - - ewgen x - | (# offX, lenX, arrX #) <- toBytes x - , I# lenASBS <- totalDim (Proxy @asbs) - , elS <- elementByteSize x - , offXB <- offX *# elS - , lenXB <- lenX *# elS + | elS <- byteSize @t undefined + , dbs <- dims @_ @bs + , W# lenBSW <- totalDim dbs + , W# lenASW <- totalDim' @as + , W# lenAS'W <- totalDim' @as' + , lenBS <- word2Int# lenBSW + , lenAS <- word2Int# lenASW + , lenAS' <- word2Int# lenAS'W + , lenASBS <- lenAS *# lenBS = case runRW# ( \s0 -> case newByteArray# (lenASBS *# elS) s0 of - (# s1, marr #) -> case overDimOff_# (dim @bs) - ( \posB -> copyByteArray# arrX offXB marr posB lenXB ) - 0# lenXB s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, lenASBS, r #) + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( overDim_# dbs + ( \i pos -> + writeArray mba pos (f i (indexOffset# (pos *# lenAS') lenAS' df)) + ) 0# 1# s1 + ) + ) of (# _, r #) -> fromElems 0# lenASBS r + ewgen x = case elemSize0 x of + 0# -> broadcast (ix# 0# x) + 1# -> broadcast (ix# 0# x) + lenAS + | elS <- byteSize @t undefined + , W# lenBSW <- totalDim' @bs + , lenBS <- word2Int# lenBSW + , lenASBS <- lenAS *# lenBS + , bsize <- lenASBS *# elS + -> case runRW# + ( \s0 -> case newByteArray# bsize s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop# 0# (lenAS *# elS) bsize + (\off -> writeBytes mba off x) + s1 + ) + ) of (# _, r #) -> fromElems 0# lenASBS r + {-# INLINE [1] ewgen #-} + iwgen f - | I# lenASBS <- totalDim (Proxy @asbs) - , elS <- elementByteSize (undefined :: DataFrame t asbs) - , I# lenAS <- totalDim (Proxy @as) - , lenASB <- lenAS *# elS + | elS <- byteSize @t undefined + , dbs <- dims @_ @bs + , W# lenBSW <- totalDim dbs + , W# lenASW <- totalDim' @as + , lenBS <- word2Int# lenBSW + , lenAS <- word2Int# lenASW + , lenASBS <- lenAS *# lenBS = case runRW# ( \s0 -> case newByteArray# (lenASBS *# elS) s0 of - (# s1, marr #) -> case overDim_# (dim @bs) - ( \i pos s -> case toBytes (f i) of - (# offX, _, arrX #) -> copyByteArray# arrX (offX *# elS) marr pos lenASB s - ) 0# lenASB s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, r #) -> fromBytes (# 0#, lenASBS, r #) + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( overDim_# dbs + ( \i pos -> writeArray mba pos (f i) + ) 0# 1# s1 + ) + ) of (# _, r #) -> fromElems 0# lenASBS r - ewfoldl f x0 df = case (# toBytes df, totalDim ( Proxy @as) #) of - (# (# off, _, arr #), I# step #) -> foldDimOff (dim @bs) - (\pos acc -> f acc $! fromBytes (# pos, step, arr #)) - off step x0 + ewfoldl f x0 df + | ba <- getBytes df + = foldDimOff (dims @_ @bs) (\(I# o) acc -> f acc (fromBytes o ba)) + (I# (byteOffset df)) + (I# (byteSize @t undefined) * fromIntegral (totalDim' @as)) x0 - iwfoldl f x0 df = case (# toBytes df, totalDim ( Proxy @as) #) of - (# (# off, _, arr #), I# step #) -> foldDim (dim @bs) - (\i pos acc -> f i acc $! fromBytes (# pos, step, arr #)) - off step x0 + iwfoldl f x0 df + | ba <- getBytes df + = foldDim (dims @_ @bs) (\i (I# o) acc -> f i acc (fromBytes o ba)) + (I# (byteOffset df)) + (I# (byteSize @t undefined) * fromIntegral (totalDim' @as)) x0 - ewfoldr f x0 df = case (# toBytes df, totalDim ( Proxy @as) #) of - (# (# off, len, arr #), I# step #) -> foldDimOff (dim @bs) - (\pos -> f (fromBytes (# pos, step, arr #))) - (off +# len -# step) (negateInt# step) x0 + ewfoldr f x0 df + | step <- I# (byteSize @t undefined) * fromIntegral (totalDim' @as) + , ba <- getBytes df + = foldDimOff (dims @_ @bs) (\(I# o) -> f (fromBytes o ba)) + (I# (byteOffset df +# byteSize df) - step) + (negate step) x0 - iwfoldr f x0 df = case (# toBytes df, totalDim ( Proxy @as) #) of - (# (# off, _, arr #), I# step #) -> foldDimReverse (dim @bs) - (\i pos -> f i (fromBytes (# pos, step, arr #)) ) - off step x0 + iwfoldr f x0 df + | step <- I# (byteSize @t undefined) * fromIntegral (totalDim' @as) + , ba <- getBytes df + = foldDimReverse (dims @_ @bs) (\i (I# o) -> f i (fromBytes o ba)) + (I# (byteOffset df +# byteSize df) - step) + step x0 + -- implement elementWise in terms of indexWise elementWise = indexWise . const {-# INLINE elementWise #-} @@ -332,7 +353,7 @@ . ( Applicative f , SubSpace s as' bs asbs' ) - => (Idx bs -> DataFrame s as' -> f (DataFrame t as)) + => (Idxs bs -> DataFrame s as' -> f (DataFrame t as)) -> DataFrame s asbs' -> f (DataFrame t asbs) indexWise f df = runWithState <$> iwfoldl applyF (pure initialState) df where @@ -342,7 +363,7 @@ runWithState g = case runRW# ( \s0 -> case g s0 of (# s1, (# marr, _ #) #) -> unsafeFreezeByteArray# marr s1 - ) of (# _, arr #) -> fromBytes (# 0#, rezLength#, arr #) + ) of (# _, arr #) -> fromElems 0# rezLength# arr -- Prepare empty byte array for the result DataFrame and keep a current position counter -- Input: state @@ -356,8 +377,8 @@ updateChunk :: (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) -> DataFrame t as -> (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) - updateChunk g dfChunk = case toBytes dfChunk of - (# off#, _, arr# #) -> \s -> case g s of + updateChunk g dfChunk = case (# byteOffset dfChunk, getBytes dfChunk #) of + (# off#, arr# #) -> \s -> case g s of (# s1, (# marr#, pos# #) #) -> case copyByteArray# arr# (off# *# rezElBSize#) marr# (pos# *# rezElBSize#) @@ -365,63 +386,24 @@ s2 -> (# s2, (# marr#, pos# +# rezStepN# #) #) -- Apply applicative functor on each chunk and update a state. - applyF :: Idx bs + applyF :: Idxs bs -> f (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) -> DataFrame s as' -> f (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) applyF idx s dfChunk = idx `seq` dfChunk `seq` updateChunk <$> s <*> f idx dfChunk -- Element byte size of the result DataFrame (byte size of s) - rezElBSize# = elementByteSize (undefined :: DataFrame t asbs) + rezElBSize# = byteSize @t undefined -- Number of primitive elements in the result DataFrame chunk - !(I# rezStepN#) = totalDim (Proxy @as) + !(I# rezStepN#) = fromIntegral $ totalDim' @as -- Number of primitive elements in the result DataFrame - !(I# rezLength#) = totalDim (Proxy @asbs) - - update ei x df - | I# i <- fromEnum ei - , (# off, len, arr #) <- toBytes df - , (# offX, lenX, arrX #) <- toBytes x - , elS <- elementByteSize df - = case runRW# - ( \s0 -> case newByteArray# ( len *# elS ) s0 of - (# s1, marr #) -> case copyByteArray# arr (off *# elS) marr 0# (len *# elS) s1 of - s2 -> case copyByteArray# arrX (offX *# elS) marr (lenX *# i *# elS) (lenX *# elS) s2 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, r #) -> fromBytes (# 0#, len, r #) + !(I# rezLength#) = fromIntegral $ totalDim' @asbs +unSc :: DataFrame (t :: Type) ('[] :: [Nat]) -> t +unSc = unsafeCoerce# +{-# RULES +"ewgen/broadcast" ewgen = broadcast . unSc --- | Specialized instance of SubSpace for operating on scalars. -instance {-# OVERLAPPING #-} - ( Dimensions bs - , EW.ElementWise (Idx bs) t (DataFrame t bs) - , PrimBytes (DataFrame t bs) - ) => SubSpace t ('[] :: [Nat]) (bs :: [Nat]) (bs :: [Nat]) where - indexOffset# i _ x = scalar (EW.indexOffset# x i) - {-# INLINE indexOffset# #-} - i !. x = scalar $ x EW.! i - {-# INLINE (!.) #-} - ewmap = iwmap . const - {-# INLINE ewmap #-} - iwmap f x = EW.ewgen (\i -> unScalar $ f i (i !. x)) - {-# INLINE iwmap #-} - ewgen = EW.broadcast . unScalar - {-# INLINE ewgen #-} - iwgen f = EW.ewgen (unScalar . f) - {-# INLINE iwgen #-} - ewfoldl f = EW.ewfoldl (\_ a -> f a . scalar) - {-# INLINE ewfoldl #-} - iwfoldl f = EW.ewfoldl (\i a -> f i a . scalar) - {-# INLINE iwfoldl #-} - ewfoldr f = EW.ewfoldr (\_ x -> f (scalar x)) - {-# INLINE ewfoldr #-} - iwfoldr f = EW.ewfoldr (\i x -> f i (scalar x)) - {-# INLINE iwfoldr #-} - elementWise = indexWise . const - {-# INLINE elementWise #-} - indexWise f x = EW.ewgenA (\i -> unScalar <$> f i (i !. x)) - {-# INLINE indexWise #-} - update i x = EW.update i (unScalar x) - {-# INLINE update #-} + #-} diff --git a/src/Numeric/DataFrame/Type.hs b/src/Numeric/DataFrame/Type.hs --- a/src/Numeric/DataFrame/Type.hs +++ b/src/Numeric/DataFrame/Type.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} @@ -10,130 +8,191 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Type --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Numeric.DataFrame.Type ( -- * Data types DataFrame (..) - -- * Bring type classes into scope - , NumericFrame - -- * Utility type families and constraints - , FPFRame, IntegralFrame, NumericVariantFrame, CommonOpFrame + , SomeDataFrame (..), DataFrame' + , pattern (:*:), pattern Z + -- * Infer type class instances + , AllTypes, ImplAllows, ArraySingletons, PrimFrames + , DataFrameInference (..) + , inferOrd, inferNum, inferFractional, inferFloating + , inferOrd', inferNum', inferFractional', inferFloating' + , inferASing', inferEq', inferShow', inferPrim', inferPrimElem' + -- * Misc + , ixOff, unsafeFromFlatList + , Dim1 (..), Dim2 (..), Dim3 (..) + , dimSize1, dimSize2, dimSize3 + , bSizeOf, bAlignOf + -- * Re-exports from dimensions + , Dim (..), Idx (..), XNat (..), Dims, Idxs, TypedList (..) ) where -#include "MachDeps.h" -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import Foreign.Storable (Storable (..)) -import GHC.Exts (Int (..), Ptr (..), Float#, Double#, Int#, Word# -#ifndef ghcjs_HOST_OS -#if WORD_SIZE_IN_BITS < 64 - , Int64#, Word64# -#endif -#endif - ) -import GHC.Prim (copyAddrToByteArray#, - copyByteArrayToAddr#, newByteArray#, - plusAddr#, quotInt#, - unsafeFreezeByteArray#, (*#)) -import GHC.Types (Constraint, IO (..), Type, RuntimeRep (..)) +import Data.Proxy (Proxy) +import Foreign.Storable (Storable (..)) +import GHC.Base +import GHC.Ptr (Ptr (..)) -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons +import Numeric.DataFrame.Family +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.Family (Array, ArraySingleton (..)) +import qualified Numeric.DataFrame.Internal.Array.Family as AFam import Numeric.Dimensions +import Numeric.PrimBytes --- | Keep data in a primitive data frame --- and maintain information about Dimensions in the type-system -data family DataFrame (t :: Type) (xs :: [k]) +-- | Single frame +newtype instance DataFrame (t :: Type) (ns :: [Nat]) + = SingleFrame { _getDF :: Array t ns } --- | Completely fixed at compile time -newtype instance Dimensions ns => DataFrame t (ns :: [Nat]) - = KnownDataFrame { _getDF :: Array t ns } +-- | Multiple "columns" of data frames of the same shape +newtype instance DataFrame (ts :: [Type]) (ns :: [Nat]) + = MultiFrame { _getDFS :: TypedList (DataFrame' ns) ts } --- | Partially known at compile time -data instance DataFrame t (xns :: [XNat]) +-- | Data frame with some dimensions missing at compile time. +-- Pattern-match against its constructor to get a Nat-indexed data frame. +data instance DataFrame (ts :: l) (xns :: [XNat]) = forall (ns :: [Nat]) - . ( FixedDim xns ns ~ ns - , FixedXDim xns ns ~ xns - , NumericFrame t ns - ) + . (KnownXNatTypes xns, FixedDims xns ns, Dimensions ns, ArraySingletons ts ns) + => XFrame (DataFrame ts ns) + +-- | Data frame that has an unknown dimensionality at compile time. +-- Pattern-match against its constructor to get a Nat-indexed data frame +data SomeDataFrame (t :: l) + = forall (ns :: [Nat]) . (Dimensions ns, ArraySingletons t ns) => SomeDataFrame (DataFrame t ns) --- | Allow all numeric operations depending on element type -type NumericFrame t ds = (CommonOpFrame t ds, NumericVariantFrame t ds) +-- | DataFrame with its type arguments swapped. +newtype DataFrame' (xs :: [k]) (t :: l) = DataFrame' (DataFrame t xs) --- | Allow all common operations on data frames -type CommonOpFrame t ds - = ( Show (DataFrame t ds) - , Eq (DataFrame t ds) - , Ord (DataFrame t ds) - , Num (DataFrame t ds) - , ElementWise (Idx ds) t (DataFrame t ds) - , PrimBytes (DataFrame t ds) - , ArrayInstanceInference t ds - , KnownDims ds - , FiniteList ds - , Dimensions ds - ) +{-# COMPLETE Z, (:*:) #-} --- | Allow floating-point operations on data frames -type FPFRame t ds - = ( Fractional (DataFrame t ds) - , Floating (DataFrame t ds) - ) --- | Allow some integer-like operations on data frames -type IntegralFrame t (ds :: [Nat]) - = Bounded (DataFrame t ds) +-- | Constructing a @MultiFrame@ using DataFrame columns +pattern (:*:) :: forall (xs :: [Type]) (ns :: [Nat]) + . () + => forall (y :: Type) (ys :: [Type]) + . (xs ~ (y ': ys)) + => DataFrame y ns + -> DataFrame ys ns -> DataFrame xs ns +pattern (:*:) x xs <- (MultiFrame (DataFrame' x :* (MultiFrame -> xs))) + where + (:*:) x (MultiFrame xs) = MultiFrame (DataFrame' x :* xs) +infixr 6 :*: +-- | Empty MultiFrame +pattern Z :: forall (xs :: [Type]) (ns :: [Nat]) + . () => (xs ~ '[]) => DataFrame xs ns +pattern Z = MultiFrame U -type family NumericVariantFrame t ds :: Constraint where - NumericVariantFrame Float ds = FPFRame Float ds - NumericVariantFrame Double ds = FPFRame Double ds - NumericVariantFrame Int ds = IntegralFrame Int ds - NumericVariantFrame Int8 ds = IntegralFrame Int8 ds - NumericVariantFrame Int16 ds = IntegralFrame Int16 ds - NumericVariantFrame Int32 ds = IntegralFrame Int32 ds - NumericVariantFrame Int64 ds = IntegralFrame Int64 ds - NumericVariantFrame Word ds = IntegralFrame Word ds - NumericVariantFrame Word8 ds = IntegralFrame Word8 ds - NumericVariantFrame Word16 ds = IntegralFrame Word16 ds - NumericVariantFrame Word32 ds = IntegralFrame Word32 ds - NumericVariantFrame Word64 ds = IntegralFrame Word64 ds - NumericVariantFrame _ _ = () +-------------------------------------------------------------------------------- +-- All Eq instances +-------------------------------------------------------------------------------- +deriving instance Eq (Array t ds) => Eq (DataFrame (t :: Type) (ds :: [Nat])) +instance ImplAllows Eq ts ds => Eq (DataFrame (ts :: [Type]) ds) where + Z == Z = True + (a :*: as) == (b :*: bs) = a == b && as == bs +instance (AllTypes Eq t, DataFrameInference t) + => Eq (DataFrame (t :: l) (ds :: [XNat])) where + (XFrame dfa) == (XFrame dfb) + | Just E <- sameDims' dfa dfb + , E <- inferEq dfa = dfa == dfb + _ == _ = False + +instance (AllTypes Eq t, DataFrameInference t) + => Eq (SomeDataFrame (t :: l)) where + (SomeDataFrame dfa) == (SomeDataFrame dfb) + | Just E <- sameDims' dfa dfb + , E <- inferEq dfa = dfa == dfb + _ == _ = False + + +-------------------------------------------------------------------------------- +-- All Show instances +-------------------------------------------------------------------------------- + instance ( Show (Array t ds) , Dimensions ds - ) => Show (DataFrame t ds) where - show (KnownDataFrame arr) = unlines - [ "DF [" ++ drop 4 (show $ dim @ds) ++ "]:" + ) => Show (DataFrame (t :: Type) (ds :: [Nat])) where + show (SingleFrame arr) = unlines + [ "DF " ++ drop 5 (show $ dims @_ @ds) ++ ":" , show arr ] + +instance ( Dimensions ds + , ImplAllows Show ts ds + ) => Show (DataFrame (ts :: [Type]) (ds :: [Nat])) where + show dfs = unlines $ + ("DF " ++ show (order dds) ++ " x " ++ drop 5 (show dds) ++ ":") + : showAll 1 dfs + where + dds = dims @_ @ds + showAll :: ImplAllows Show xs ds + => Word -> DataFrame (xs :: [Type]) ds -> [String] + showAll _ Z = [] + showAll n (SingleFrame arr :*: fs) + = ("Var " ++ show n) : show arr : showAll (n+1) fs + + +instance (AllTypes Show t, DataFrameInference t) + => Show (DataFrame (t :: l) (xns :: [XNat])) where + show (XFrame df) + | E <- inferShow df = 'X': show df + +instance (AllTypes Show t, DataFrameInference t) + => Show (SomeDataFrame (t :: l)) where + show (SomeDataFrame df) + | E <- inferShow df = "Some" ++ show df + +-------------------------------------------------------------------------------- + + + +type family AllTypes (f :: Type -> Constraint) (ts :: l) :: Constraint where + AllTypes f (t :: Type) = f t + AllTypes f (ts :: [Type]) = All f ts + +type family ImplAllows (f :: Type -> Constraint) (ts :: l) (ds :: [Nat]) + :: Constraint where + ImplAllows f (t :: Type) ds = f (Array t ds) + ImplAllows _ ('[] :: [Type]) _ = () + ImplAllows f (t ': ts :: [Type]) ds = (f (Array t ds), ImplAllows f ts ds) + +type family ArraySingletons (ts :: l) (ns :: [Nat]) :: Constraint where + ArraySingletons (t :: Type) ns = ArraySingleton t ns + ArraySingletons ('[] :: [Type]) _ = () + ArraySingletons (t ': ts :: [Type]) ns + = (ArraySingleton t ns, ArraySingletons ts ns) + +type family PrimFrames (ts :: l) (ns :: [Nat]) :: Constraint where + PrimFrames (t :: Type) ns + = (PrimBytes (DataFrame t ns), PrimArray t (DataFrame t ns)) + PrimFrames ('[] :: [Type]) _ = () + PrimFrames (t ': ts :: [Type]) ns + = ( PrimBytes (DataFrame t ns), PrimArray t (DataFrame t ns) + , PrimFrames ts ns) + + deriving instance Bounded (Array t ds) => Bounded (DataFrame t ds) deriving instance Enum (Array t ds) => Enum (DataFrame t ds) -deriving instance Eq (Array t ds) => Eq (DataFrame t ds) deriving instance Integral (Array t ds) => Integral (DataFrame t ds) deriving instance Num (Array t ds) @@ -152,163 +211,254 @@ => RealFrac (DataFrame t ds) deriving instance RealFloat (Array t ds) => RealFloat (DataFrame t ds) -instance ( Dimensions ds - , ElementWise (Idx ds) t (Array t ds) - ) => ElementWise (Idx ds) t (DataFrame t ds) where - indexOffset# = indexOffset# . _getDF - {-# INLINE indexOffset# #-} - (!) = (!) . _getDF - {-# INLINE (!) #-} - ewmap f = KnownDataFrame . ewmap f . _getDF - {-# INLINE ewmap #-} - ewgen = KnownDataFrame . ewgen - {-# INLINE ewgen #-} - ewgenA = fmap KnownDataFrame . ewgenA - {-# INLINE ewgenA #-} - ewfoldl f x0 = ewfoldl f x0 . _getDF - {-# INLINE ewfoldl #-} - ewfoldr f x0 = ewfoldr f x0 . _getDF - {-# INLINE ewfoldr #-} - elementWise f = fmap KnownDataFrame . elementWise f . _getDF - {-# INLINE elementWise #-} - indexWise f = fmap KnownDataFrame . indexWise f . _getDF - {-# INLINE indexWise #-} - broadcast = KnownDataFrame . broadcast - {-# INLINE broadcast #-} - update i x = KnownDataFrame . update i x . _getDF - {-# INLINE update #-} +deriving instance (PrimArray t (Array t ds), PrimBytes t) + => PrimArray t (DataFrame t ds) +deriving instance PrimBytes (Array t ds) + => PrimBytes (DataFrame t ds) + instance PrimBytes (DataFrame t ds) => Storable (DataFrame t ds) where - sizeOf x = I# (byteSize x) - alignment x = I# (byteAlign x) - peekElemOff ptr (I# offset) = - peekByteOff ptr (I# (offset *# byteSize (undefined :: DataFrame t ds))) - pokeElemOff ptr (I# offset) = - pokeByteOff ptr (I# (offset *# byteSize (undefined :: DataFrame t ds))) - peekByteOff (Ptr addr) (I# offset) = IO $ \s0 -> case newByteArray# bsize s0 of - (# s1, marr #) -> case copyAddrToByteArray# (addr `plusAddr#` offset) - marr 0# bsize s1 of - s2 -> case unsafeFreezeByteArray# marr s2 of - (# s3, arr #) -> (# s3, fromBytes (# 0#, bsize `quotInt#` ebsize, arr #) #) - where - bsize = byteSize (undefined :: DataFrame t ds) - ebsize = elementByteSize (undefined :: DataFrame t ds) - pokeByteOff (Ptr addr) (I# offset) x = IO - $ \s0 -> case copyByteArrayToAddr# xbytes xboff - (addr `plusAddr#` offset) - bsize s0 of - s2 -> (# s2, () #) - where - !(# elOff, elNum, xbytes #) = toBytes x - bsize = elementByteSize x *# elNum - xboff = elementByteSize x *# elOff - peek ptr = peekByteOff ptr 0 - poke ptr = pokeByteOff ptr 0 + sizeOf x = I# (byteSize x) + alignment x = I# (byteAlign x) + peek (Ptr addr) = IO (readAddr addr) + poke (Ptr addr) a = IO (\s -> (# writeAddr a addr s, () #)) +class DataFrameInference (t :: l) where + -- | Bring an evidence of `ArraySingleton` instance into + -- a scope at runtime. + -- This is often used to let GHC infer other complex type class instances, + -- such as `SubSpace`. + inferASing + :: (AllTypes PrimBytes t, Dimensions ds) + => DataFrame t ds -> Evidence (ArraySingletons t ds) + inferEq + :: (AllTypes Eq t, ArraySingletons t ds) + => DataFrame t ds -> Evidence (Eq (DataFrame t ds)) + inferShow + :: (AllTypes Show t, ArraySingletons t ds, Dimensions ds) + => DataFrame t ds -> Evidence (Show (DataFrame t ds)) + inferPrim + :: (AllTypes PrimBytes t, ArraySingletons t ds, Dimensions ds) + => DataFrame t ds -> Evidence (PrimFrames t ds) + -- | This is a special function, because Scalar does not require PrimBytes. + -- That is why the dimension list in the argument nust not be empty. + inferPrimElem + :: (ArraySingletons t ds, ds ~ (Head ds ': Tail ds)) + => DataFrame t ds -> Evidence (AllTypes PrimBytes t) -type instance ElemRep (DataFrame t xs) = ElemRep (Array t xs) -type instance ElemPrim (DataFrame Float ds) = Float# -type instance ElemPrim (DataFrame Double ds) = Double# -type instance ElemPrim (DataFrame Int ds) = Int# -type instance ElemPrim (DataFrame Int8 ds) = Int# -type instance ElemPrim (DataFrame Int16 ds) = Int# -type instance ElemPrim (DataFrame Int32 ds) = Int# -#ifndef ghcjs_HOST_OS -#if WORD_SIZE_IN_BITS < 64 -type instance ElemPrim (DataFrame Int64 ds) = Int64# -#else -type instance ElemPrim (DataFrame Int64 ds) = Int# -#endif -#endif -type instance ElemPrim (DataFrame Word ds) = Word# -type instance ElemPrim (DataFrame Word8 ds) = Word# -type instance ElemPrim (DataFrame Word16 ds) = Word# -type instance ElemPrim (DataFrame Word32 ds) = Word# -#ifdef ghcjs_HOST_OS -type instance ElemPrim (DataFrame Word8Clamped ds) = Int# -#else -#if WORD_SIZE_IN_BITS < 64 -type instance ElemPrim (DataFrame Word64 ds) = Word64# -#else -type instance ElemPrim (DataFrame Word64 ds) = Word# -#endif -#endif -deriving instance ( PrimBytes (Array Float ds) - , ElemPrim (Array Float ds) ~ Float# - , ElemRep (Array Float ds) ~ 'FloatRep) => PrimBytes (DataFrame Float ds) -deriving instance ( PrimBytes (Array Double ds) - , ElemPrim (Array Double ds) ~ Double# - , ElemRep (Array Double ds) ~ 'DoubleRep) => PrimBytes (DataFrame Double ds) -deriving instance ( PrimBytes (Array Int ds) - , ElemPrim (Array Int ds) ~ Int# - , ElemRep (Array Int ds) ~ 'IntRep) => PrimBytes (DataFrame Int ds) -deriving instance ( PrimBytes (Array Int8 ds) - , ElemPrim (Array Int8 ds) ~ Int# - , ElemRep (Array Int8 ds) ~ 'IntRep) => PrimBytes (DataFrame Int8 ds) -deriving instance ( PrimBytes (Array Int16 ds) - , ElemPrim (Array Int16 ds) ~ Int# - , ElemRep (Array Int16 ds) ~ 'IntRep) => PrimBytes (DataFrame Int16 ds) -deriving instance ( PrimBytes (Array Int32 ds) - , ElemPrim (Array Int32 ds) ~ Int# - , ElemRep (Array Int32 ds) ~ 'IntRep) => PrimBytes (DataFrame Int32 ds) -#ifndef ghcjs_HOST_OS -deriving instance ( PrimBytes (Array Int64 ds) -#if WORD_SIZE_IN_BITS < 64 - , ElemPrim (Array Int64 ds) ~ Int64# - , ElemRep (Array Int64 ds) ~ 'Int64Rep -#else - , ElemPrim (Array Int64 ds) ~ Int# - , ElemRep (Array Int64 ds) ~ 'IntRep -#endif - ) => PrimBytes (DataFrame Int64 ds) -#endif -deriving instance ( PrimBytes (Array Word ds) - , ElemPrim (Array Word ds) ~ Word# - , ElemRep (Array Word ds) ~ 'WordRep) => PrimBytes (DataFrame Word ds) -deriving instance ( PrimBytes (Array Word8 ds) - , ElemPrim (Array Word8 ds) ~ Word# - , ElemRep (Array Word8 ds) ~ 'WordRep) => PrimBytes (DataFrame Word8 ds) -deriving instance ( PrimBytes (Array Word16 ds) - , ElemPrim (Array Word16 ds) ~ Word# - , ElemRep (Array Word16 ds) ~ 'WordRep) => PrimBytes (DataFrame Word16 ds) -deriving instance ( PrimBytes (Array Word32 ds) - , ElemPrim (Array Word32 ds) ~ Word# - , ElemRep (Array Word32 ds) ~ 'WordRep) => PrimBytes (DataFrame Word32 ds) -#ifdef ghcjs_HOST_OS -deriving instance ( PrimBytes (Array Word8Clamped ds) - , ElemPrim (Array Word8Clamped ds) ~ Int# - , ElemRep (Array Word8Clamped ds) ~ 'IntRep) => PrimBytes (DataFrame Word8Clamped ds) -#else -deriving instance ( PrimBytes (Array Word64 ds) -#if WORD_SIZE_IN_BITS < 64 - , ElemPrim (Array Word64 ds) ~ Word64# - , ElemRep (Array Word64 ds) ~ 'Word64Rep -#else - , ElemPrim (Array Word64 ds) ~ Word# - , ElemRep (Array Word64 ds) ~ 'WordRep -#endif - ) => PrimBytes (DataFrame Word64 ds) -#endif +instance DataFrameInference (t :: Type) where + inferASing (_ :: DataFrame t ds) + = AFam.inferASing @t @ds + inferEq (_ :: DataFrame t ds) + = case AFam.inferEq @t @ds of E -> E + inferShow (_ :: DataFrame t ds) + = case AFam.inferShow @t @ds of E -> E + inferPrim (_ :: DataFrame t ds) + = case AFam.inferPrim @t @ds of E -> E + inferPrimElem (_ :: DataFrame t ds) + = case AFam.inferPrimElem @t @(Head ds) @(Tail ds) of E -> E +inferOrd' :: forall t ds + . (Ord t, ArraySingleton t ds) + => Evidence (Ord (DataFrame t ds)) +inferOrd' = case AFam.inferOrd @t @ds of E -> E +inferNum' :: forall t ds + . (Num t, ArraySingletons t ds) + => Evidence (Num (DataFrame t ds)) +inferNum' = case AFam.inferNum @t @ds of E -> E +inferFractional' :: forall t ds + . (Fractional t, ArraySingleton t ds) + => Evidence (Fractional (DataFrame t ds)) +inferFractional' = case AFam.inferFractional @t @ds of E -> E +inferFloating' :: forall t ds + . (Floating t, ArraySingleton t ds) + => Evidence (Floating (DataFrame t ds)) +inferFloating' = case AFam.inferFloating @t @ds of E -> E -instance Eq (DataFrame t (ds :: [XNat])) where - SomeDataFrame (a :: DataFrame t nsa) == SomeDataFrame (b :: DataFrame t nsb) - = case sameDim (dim @nsa) (dim @nsb) of - Just Evidence -> a == b - Nothing -> False -instance Show (DataFrame t (ds :: [XNat])) where - show (SomeDataFrame arr) = show arr +instance RepresentableList ts => DataFrameInference (ts :: [Type]) where + inferASing (_ :: DataFrame t ds) + = inferASings @ts @ds (tList @_ @ts) + inferEq (_ :: DataFrame t ds) + = case inferEqs @ts @ds (tList @_ @ts) of E -> E + inferShow (_ :: DataFrame t ds) + = case inferShows @ts @ds (tList @_ @ts) of E -> E + inferPrim (_ :: DataFrame t ds) + = case inferPrims @ts @ds (tList @_ @ts) of E -> E + inferPrimElem (_ :: DataFrame t ds) + = case inferPrimElems @ts @(Head ds) @(Tail ds) (tList @_ @ts) of E -> E -_suppressHlintUnboxedTuplesWarning :: () -> (# (), () #) -_suppressHlintUnboxedTuplesWarning = undefined +inferASings :: forall ts ds + . (All PrimBytes ts, Dimensions ds) + => TypeList ts -> Evidence (ArraySingletons ts ds) +inferASings U = E +inferASings ((_ :: Proxy t) :* ts) + = case (inferASing' @t @ds, inferASings @_ @ds ts) of (E, E) -> E + + + +inferEqs :: forall ts ds + . (All Eq ts, ArraySingletons ts ds) + => TypeList ts -> Evidence (ImplAllows Eq ts ds) +inferEqs U = E +inferEqs ((_ :: Proxy t) :* ts) + = case (AFam.inferEq @t @ds, inferEqs @_ @ds ts) of (E, E) -> E + +inferShows :: forall ts ds + . (All Show ts, ArraySingletons ts ds, Dimensions ds) + => TypeList ts -> Evidence (ImplAllows Show ts ds) +inferShows U = E +inferShows ((_ :: Proxy t) :* ts) + = case (AFam.inferShow @t @ds, inferShows @_ @ds ts) of (E, E) -> E + +inferPrims :: forall ts ds + . (All PrimBytes ts, ArraySingletons ts ds, Dimensions ds) + => TypeList ts -> Evidence (PrimFrames ts ds) +inferPrims U = E +inferPrims ((_ :: Proxy t) :* ts) + = case (AFam.inferPrim @t @ds, inferPrims @_ @ds ts) of (E, E) -> E + +inferPrimElems :: forall ts d ds + . (ArraySingletons ts (d ': ds)) + => TypeList ts -> Evidence (All PrimBytes ts) +inferPrimElems U = E +inferPrimElems ((_ :: Proxy t) :* ts) + = case (AFam.inferPrimElem @t @d @ds, inferPrimElems @_ @d @ds ts) of (E, E) -> E + + +inferASing' :: forall t ds + . (DataFrameInference t, AllTypes PrimBytes t, Dimensions ds) + => Evidence (ArraySingletons t ds) +inferASing' = inferASing (undefined :: DataFrame t ds) + +inferEq' :: forall t ds + . (DataFrameInference t, AllTypes Eq t, ArraySingletons t ds) + => Evidence (Eq (DataFrame t ds)) +inferEq' = inferEq (undefined :: DataFrame t ds) + +inferShow' :: forall t ds + . ( DataFrameInference t, AllTypes Show t + , ArraySingletons t ds, Dimensions ds) + => Evidence (Show (DataFrame t ds)) +inferShow' = inferShow (undefined :: DataFrame t ds) + + +inferPrim' :: forall t ds + . ( DataFrameInference t, AllTypes PrimBytes t + , ArraySingletons t ds, Dimensions ds) + => Evidence (PrimFrames t ds) +inferPrim' = inferPrim (undefined :: DataFrame t ds) + + +inferPrimElem' :: forall t ds + . ( DataFrameInference t, ArraySingletons t ds + , ds ~ (Head ds ': Tail ds)) + => Evidence (AllTypes PrimBytes t) +inferPrimElem' = inferPrimElem (undefined :: DataFrame t ds) + +inferOrd :: forall t ds + . (Ord t, ArraySingleton t ds) + => DataFrame t ds -> Evidence (Ord (DataFrame t ds)) +inferOrd = const (inferOrd' @t @ds) + +inferNum :: forall t ds + . (Num t, ArraySingletons t ds) + => DataFrame t ds -> Evidence (Num (DataFrame t ds)) +inferNum = const (inferNum' @t @ds) + +inferFractional :: forall t ds + . (Fractional t, ArraySingleton t ds) + => DataFrame t ds -> Evidence (Fractional (DataFrame t ds)) +inferFractional = const (inferFractional' @t @ds) + +inferFloating :: forall t ds + . (Floating t, ArraySingleton t ds) + => DataFrame t ds -> Evidence (Floating (DataFrame t ds)) +inferFloating = const (inferFloating' @t @ds) + + +-------------------------------------------------------------------------------- +-- * Misc +-------------------------------------------------------------------------------- + +-- | A wrapper on `byteSize` +bSizeOf :: PrimBytes a => a -> Int +bSizeOf a = I# (byteSize a) + +-- | A wrapper on `byteAlign` +bAlignOf :: PrimBytes a => a -> Int +bAlignOf a = I# (byteAlign a) + +-- | Number of elements along the 1st dimension. +dimSize1 :: Dim1 t ds => t ds -> Word +dimSize1 = dimVal . dim1 + +-- | Number of elements along the 2nd dimension. +dimSize2 :: Dim2 t ds => t ds -> Word +dimSize2 = dimVal . dim2 + +-- | Number of elements along the 3rd dimension. +dimSize3 :: Dim3 t ds => t ds -> Word +dimSize3 = dimVal . dim3 + +class Dim1 (t :: [k] -> Type) (ds :: [k]) where + dim1 :: t ds -> Dim (Head ds) + +class Dim2 (t :: [k] -> Type) (ds :: [k]) where + dim2 :: t ds -> Dim (Head (Tail ds)) + +class Dim3 (t :: [k] -> Type) (ds :: [k]) where + dim3 :: t ds -> Dim (Head (Tail (Tail ds))) + + +instance {-# OVERLAPPABLE #-} + Dimensions (d ': ds) + => Dim1 t (d ': ds :: [k]) where + dim1 _ = case dims @k @(d ': ds) of d :* _ -> d + +instance {-# OVERLAPPING #-} + Dim1 (TypedList Dim) (d ': ds) where + dim1 (d :* _) = d + +instance {-# OVERLAPPING #-} + Dim1 (DataFrame l) (d ': ds :: [XNat]) where + dim1 (XFrame (_ :: DataFrame l ns)) + = case xDims' @(d ': ds) @ns of d :* _ -> d + +instance {-# OVERLAPPABLE #-} + Dimensions (d1 ': d2 ': ds) + => Dim2 t (d1 ': d2 ': ds :: [k]) where + dim2 _ = case dims @k @(d1 ': d2 ': ds) of _ :* d :* _ -> d + +instance {-# OVERLAPPING #-} + Dim2 (TypedList Dim) (d1 ': d2 ': ds) where + dim2 (_ :* d :* _) = d + +instance {-# OVERLAPPING #-} + Dim2 (DataFrame l) (d1 ': d2 ': ds :: [XNat]) where + dim2 (XFrame (_ :: DataFrame l ns)) + = case xDims' @(d1 ': d2 ': ds) @ns of _ :* d :* _ -> d + +instance {-# OVERLAPPABLE #-} + Dimensions (d1 ': d2 ': d3 ': ds) + => Dim3 t (d1 ': d2 ': d3 ': ds :: [k]) where + dim3 _ = case dims @k @(d1 ': d2 ': d3 ': ds) of _ :* _ :* d :* _ -> d + +instance {-# OVERLAPPING #-} + Dim3 (TypedList Dim) (d1 ': d2 ': d3 ': ds) where + dim3 (_ :* _ :* d :* _) = d + +instance {-# OVERLAPPING #-} + Dim3 (DataFrame l) (d1 ': d2 ': d3 ': ds :: [XNat]) where + dim3 (XFrame (_ :: DataFrame l ns)) + = case xDims' @(d1 ': d2 ': d3 ': ds) @ns of _ :* _ :* d :* _ -> d diff --git a/src/Numeric/Matrix.hs b/src/Numeric/Matrix.hs --- a/src/Numeric/Matrix.hs +++ b/src/Numeric/Matrix.hs @@ -1,11 +1,21 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Matrix @@ -18,10 +28,11 @@ ----------------------------------------------------------------------------- module Numeric.Matrix - ( MatrixCalculus (..) - , SquareMatrixCalculus (..) + ( MatrixTranspose (..) + , SquareMatrix (..) + , MatrixDeterminant (..) , MatrixInverse (..) - , HomTransform4 (..) + , MatrixLU (..), LUFact (..) , Matrix , Mat22f, Mat23f, Mat24f , Mat32f, Mat33f, Mat34f @@ -31,23 +42,24 @@ , Mat42d, Mat43d, Mat44d , mat22, mat33, mat44 , (%*) + , pivotMat, luSolve ) where - -#ifdef ghcjs_HOST_OS -import Numeric.Array.Family (ElemTypeInference) -#endif - -import GHC.Types (Type) - -import Numeric.Commons -import Numeric.DataFrame.Contraction ((%*)) +import Control.Monad (foldM) +import Data.Foldable (forM_, foldl') +import Data.List (delete) +import GHC.Base +import Numeric.DataFrame.Contraction ((%*)) +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.Family as AFam import Numeric.DataFrame.Shape -import Numeric.Dimensions (Nat, Idx (..)) +import Numeric.DataFrame.SubSpace +import Numeric.DataFrame.Type +import Numeric.Dimensions import Numeric.Matrix.Class -import Numeric.Matrix.Mat44d () -import Numeric.Matrix.Mat44f () +import Numeric.PrimBytes +import Numeric.Scalar import Numeric.Vector import Control.Monad.ST @@ -56,47 +68,275 @@ -- | Compose a 2x2D matrix -mat22 :: ( PrimBytes (Vector t 2) +mat22 :: ( PrimBytes (Vector (t :: Type) 2) , PrimBytes (Matrix t 2 2) ) => Vector t 2 -> Vector t 2 -> Matrix t 2 2 mat22 = (<::>) -- | Compose a 3x3D matrix -mat33 :: ( -#ifdef ghcjs_HOST_OS - ElemTypeInference t, MutableFrame t '[3,3] -#else - PrimBytes t +mat33 :: ( PrimBytes (t :: Type) , PrimBytes (Vector t 3) , PrimBytes (Matrix t 3 3) -#endif ) => Vector t 3 -> Vector t 3 -> Vector t 3 -> Matrix t 3 3 mat33 a b c = runST $ do mmat <- newDataFrame - copyDataFrame a (1:!1:!Z) mmat - copyDataFrame b (1:!2:!Z) mmat - copyDataFrame c (1:!3:!Z) mmat + copyDataFrame a (1:*1:*U) mmat + copyDataFrame b (1:*2:*U) mmat + copyDataFrame c (1:*3:*U) mmat unsafeFreezeDataFrame mmat -- | Compose a 4x4D matrix mat44 :: forall (t :: Type) - . ( -#ifdef ghcjs_HOST_OS - ElemTypeInference t, MutableFrame t '[4,4] -#else - PrimBytes t + . ( PrimBytes t , PrimBytes (Vector t (4 :: Nat)) , PrimBytes (Matrix t (4 :: Nat) (4 :: Nat)) -#endif ) - => Vector t (4 :: Nat) -> Vector t (4 :: Nat) -> Vector t (4 :: Nat) -> Vector t (4 :: Nat) + => Vector t (4 :: Nat) + -> Vector t (4 :: Nat) + -> Vector t (4 :: Nat) + -> Vector t (4 :: Nat) -> Matrix t (4 :: Nat) (4 :: Nat) mat44 a b c d = runST $ do mmat <- newDataFrame - copyDataFrame a (1:!1:!Z) mmat - copyDataFrame b (1:!2:!Z) mmat - copyDataFrame c (1:!3:!Z) mmat - copyDataFrame d (1:!4:!Z) mmat + copyDataFrame a (1:*1:*U) mmat + copyDataFrame b (1:*2:*U) mmat + copyDataFrame c (1:*3:*U) mmat + copyDataFrame d (1:*4:*U) mmat unsafeFreezeDataFrame mmat + + + +instance ( KnownDim n, KnownDim m + , PrimArray t (Matrix t n m) + , PrimArray t (Matrix t m n) + ) => MatrixTranspose t (n :: Nat) (m :: Nat) where + transpose df = case elemSize0 df of + 0# -> broadcast (ix# 0# df) + nm | I# m <- fromIntegral $ dimVal' @m + , I# n <- fromIntegral $ dimVal' @n + -> let f ( I# j, I# i ) + | isTrue# (j ==# m) = f ( 0 , I# (i +# 1#) ) + | otherwise = (# ( I# (j +# 1#), I# i ) + , ix# (j *# n +# i) df + #) + in case gen# nm f (0,0) of + (# _, r #) -> r + +instance MatrixTranspose (t :: Type) (xn :: XNat) (xm :: XNat) where + transpose (XFrame (df :: DataFrame t ns)) + | ((D :: Dim n) :* (D :: Dim m) :* U) <- dims @Nat @ns + , E <- AFam.inferPrimElem @t @n @'[m] + = XFrame (transpose df :: Matrix t m n) + transpose _ = error "MatrixTranspose/transpose: impossible argument" + +instance (KnownDim n, PrimArray t (Matrix t n n), Num t) + => SquareMatrix t n where + eye + | n@(I# n#) <- fromIntegral $ dimVal' @n + = let f 0 = (# n, 1 #) + f k = (# k - 1, 0 #) + in case gen# (n# *# n#) f 0 of + (# _, r #) -> r + diag se + | n@(I# n#) <- fromIntegral $ dimVal' @n + , e <- unScalar se + = let f 0 = (# n, e #) + f k = (# k - 1, 0 #) + in case gen# (n# *# n#) f 0 of + (# _, r #) -> r + trace df + | I# n <- fromIntegral $ dimVal' @n + , n1 <- n +# 1# + = let f 0# = ix# 0# df + f k = ix# k df + f (k -# n1) + in scalar $ f (n *# n -# 1#) + + +instance ( KnownDim n, Ord t, Fractional t + , PrimBytes t + , PrimArray t (Matrix t n n) + , PrimArray t (Vector t n) + , PrimBytes (Vector t n) + , PrimBytes (Matrix t n n) + ) + => MatrixInverse t n where + inverse m = ewmap (luSolve (lu m)) eye + + +instance ( KnownDim n, Ord t, Fractional t + , PrimBytes t, PrimArray t (Matrix t n n)) + => MatrixDeterminant t n where + det m = prodF (luUpper f) * prodF (luLower f) * luPermSign f + where + f = lu m + !(I# n) = fromIntegral $ dimVal' @n + n1 = n +# 1# + nn1 = n *# n -# 1# + prodF a = scalar $ prodF' nn1 a + prodF' 0# a = ix# 0# a + prodF' k a = ix# k a * prodF' (k -# n1) a + + +instance ( KnownDim n, Ord t, Fractional t + , PrimBytes t, PrimArray t (Matrix t n n)) + => MatrixLU t n where + lu m' = case runRW# go of + (# _, (# bu, bl #) #) -> LUFact + { luLower = fromElems 0# nn bl + , luUpper = fromElems 0# nn bu + , luPerm = p + , luPermSign = si + } + where + (m, p, si) = pivotMat m' + !(I# n) = fromIntegral $ dimVal' @n + nn = n *# n + tbs = byteSize @t undefined + bsize = nn *# tbs + ixm i j = ix# (i +# n *# j) m + loop :: (Int# -> a -> State# s -> (# State# s, a #)) + -> Int# -> Int# -> a -> State# s -> (# State# s, a #) + loop f i k x s + | isTrue# (i ==# k) = (# s, x #) + | otherwise = case f i x s of + (# s', y #) -> loop f ( i +# 1# ) k y s' + go s0 + | (# s1, mbl #) <- newByteArray# bsize s0 + , (# s2, mbu #) <- newByteArray# bsize s1 + , s3 <- setByteArray# mbl 0# bsize 0# s2 + , s4 <- setByteArray# mbu 0# bsize 0# s3 + , readL <- \i j -> readArray @t mbl (i +# n *# j) + , readU <- \i j -> readArray @t mbu (i +# n *# j) + , writeL <- \i j -> writeArray @t mbl (i +# n *# j) + , writeU <- \i j -> writeArray @t mbu (i +# n *# j) + , computeU <- \i j -> + let f k x s + | (# s' , ukj #) <- readU k j s + , (# s'', lik #) <- readL i k s' + = (# s'', x - ukj * lik #) + in loop f 0# i (ixm i j) + , computeL' <- \i j -> + let f k x s + | (# s' , ukj #) <- readU k j s + , (# s'', lik #) <- readL i k s' + = (# s'', x - ukj * lik #) + in loop f 0# j (ixm i j) + , (# sr, () #) <- + loop + ( \j _ sj -> case sj of + sj0 + | sj1 <- writeL j j 1 sj0 + , (# sj2, () #) <- loop + ( \i _ sij0 -> case computeU i j sij0 of + (# sij1, uij #) -> (# writeU i j uij sij1, () #) + ) 0# j () sj1 + , (# sj3, ujj #) <- computeU j j sj2 + , sj4 <- writeU j j ujj sj3 + -> case ujj of + 0 -> loop + ( \i _ sij -> (# writeL i j 0 sij, () #) + ) (j +# 1#) n () sj4 + x -> loop + ( \i _ sij0 -> case computeL' i j sij0 of + (# sij1, lij #) -> (# writeL i j (lij / x) sij1, () #) + ) (j +# 1#) n () sj4 + ) 0# n () s4 + , (# sf0, bl #) <- unsafeFreezeByteArray# mbl sr + , (# sf1, bu #) <- unsafeFreezeByteArray# mbu sf0 + = (# sf1, (# bu, bl #) #) + + +-- | Solve @Ax = b@ problem given LU decomposition of A. +luSolve :: forall (t :: Type) (n :: Nat) + . ( KnownDim n, Ord t, Fractional t + , PrimBytes t, PrimArray t (Matrix t n n), PrimArray t (Vector t n)) + => LUFact t n -> Vector t n -> Vector t n +luSolve LUFact {..} b = x + where + -- Pb = LUx + pb = luPerm %* b + !n@(I# n#) = fromIntegral $ dimVal' @n + -- Ly = Pb + y :: Vector t n + y = runST $ do + my <- newDataFrame + let ixA (I# i) (I# j) = scalar $ ix# (i +# n# *# j) luLower + ixB (I# i) = scalar $ ix# i pb + forM_ [0..n-1] $ \i -> do + v <- foldM ( \v j -> do + dj <- readDataFrameOff my j + return $ v - dj * ixA i j + ) (ixB i) [0..i-1] + writeDataFrameOff my i v + unsafeFreezeDataFrame my + -- Ux = y + x = runST $ do + mx <- newDataFrame + let ixA (I# i) (I# j) = scalar $ ix# (i +# n# *# j) luUpper + ixB (I# i) = scalar $ ix# i y + forM_ [n-1, n-2 .. 0] $ \i -> do + v <- foldM ( \v j -> do + dj <- readDataFrameOff mx j + return $ v - dj * ixA i j + ) (ixB i) [i+1..n-1] + writeDataFrameOff mx i (v / ixA i i) + unsafeFreezeDataFrame mx + + +-- | Permute rows that the largest magnitude elements in columns are on diagonals. +-- +-- Invariants of result matrix: +-- * forall j >= i: |M[i,i]| >= M[j,i] +-- * if M[i,i] == 0 then forall j >= i: |M[i+1,i+1]| >= M[j,i+1] +pivotMat :: forall (t :: Type) (n :: k) + . (KnownDim n, PrimArray t (Matrix t n n), Ord t, Num t) + => Matrix t n n -> ( Matrix t n n -- permutated matrix + , Matrix t n n -- permutation matrix + , Scalar t -- sign of permutation matrix + ) +pivotMat m + = ( let f ( j, [] ) = f (j+1, rowOrder) + f ( j, i:is ) = (# (j, is), ix i j #) + in case gen# nn f (0,rowOrder) of + (# _, r #) -> r + , let f ( j, [] ) = f (j+1, rowOrder) + f ( j, x:xs ) + | j == x = (# ( j, xs), 1 #) + | otherwise = (# ( j, xs), 0 #) + in case gen# nn f (0,rowOrder) of + (# _, r #) -> r + , if countMisordered rowOrder `rem` 2 == 1 + then -1 else 1 + ) + where + -- permuted row ordering + rowOrder = uncurry fillPass $ searchPass 0 [0..n-1] + -- matrix size + !n@(I# n#) = fromIntegral $ dimVal' @n + -- sign of permutations + countMisordered :: [Int] -> Int + countMisordered [] = 0 + countMisordered (i:is) = foldl' (\c j -> if i > j then succ c else c) 0 is + + countMisordered is + nn = n# *# n# + ix (I# i) (I# j) = ix# (i +# j *# n#) m + findMax :: Int -> [Int] -> (t, Int) + findMax j = foldl' (\(ox, oi) i -> let x = abs (ix i j) + in if x > ox then (x, i) + else (ox, oi) + ) (0, 0) + -- search maximums, leaving Nothing where all rows are 0 + searchPass :: Int -> [Int] -> ([Int], [Maybe Int]) + searchPass j is + | j == n = (is, []) + | otherwise = case findMax j is of + (0, _) -> (Nothing:) <$> searchPass (j+1) is + (_, i) -> (Just i:) <$> searchPass (j+1) (delete i is) + -- replace Nothings with remaining row numbers + fillPass :: [Int] -> [Maybe Int] -> [Int] + fillPass _ [] = [] + fillPass js (Just i : is) = i : fillPass js is + fillPass (j:js) (Nothing : is) = j : fillPass js is + fillPass [] (Nothing : is) = 0 : fillPass [] is diff --git a/src/Numeric/Matrix/Class.hs b/src/Numeric/Matrix/Class.hs --- a/src/Numeric/Matrix/Class.hs +++ b/src/Numeric/Matrix/Class.hs @@ -2,11 +2,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Numeric.Matrix.Class - ( MatrixCalculus (..) - , SquareMatrixCalculus (..) + ( MatrixTranspose (..) + , SquareMatrix (..) + , MatrixDeterminant (..) , MatrixInverse (..) + , MatrixLU (..), LUFact (..) , Matrix , HomTransform4 (..) , Mat22f, Mat23f, Mat24f @@ -17,35 +22,59 @@ , Mat42d, Mat43d, Mat44d ) where -import Numeric.Commons -import Numeric.DataFrame.Type -import Numeric.Dimensions (Nat) +import Numeric.DataFrame.Family +import Numeric.Dimensions (Nat) import Numeric.Scalar import Numeric.Vector -- | Alias for DataFrames of rank 2 -type Matrix t (n :: Nat) (m :: Nat) = DataFrame t '[n,m] +type Matrix (t :: l) (n :: k) (m :: k) = DataFrame t '[n,m] -class MatrixCalculus t (n :: Nat) (m :: Nat) where +class MatrixTranspose t (n :: k) (m :: k) where -- | Transpose Mat - transpose :: (MatrixCalculus t m n, PrimBytes (Matrix t m n)) => Matrix t n m -> Matrix t m n - + transpose :: Matrix t n m -> Matrix t m n + -- (MatrixTranspose t m n, PrimBytes (Matrix t m n)) => -class SquareMatrixCalculus t (n :: Nat) where +class SquareMatrix t (n :: Nat) where -- | Mat with 1 on diagonal and 0 elsewhere eye :: Matrix t n n -- | Put the same value on the Mat diagonal, 0 otherwise diag :: Scalar t -> Matrix t n n - -- | Determinant of Mat - det :: Matrix t n n -> Scalar t -- | Sum of diagonal elements trace :: Matrix t n n -> Scalar t +class MatrixDeterminant t (n :: Nat) where + -- | Determinant of Mat + det :: Matrix t n n -> Scalar t + class MatrixInverse t (n :: Nat) where -- | Matrix inverse - inverse :: DataFrame t '[n,n] -> DataFrame t '[n,n] + inverse :: Matrix t n n -> Matrix t n n +-- | Result of LU factorization with Partial Pivoting +-- @ PA = LU @. +data LUFact t n + = LUFact + { luLower :: Matrix t n n + -- ^ Lower triangular matrix @L@. + -- All elements on the diagonal of @L@ equal @1@. + , luUpper :: Matrix t n n + -- ^ Upper triangular matrix @U@ + , luPerm :: Matrix t n n + -- ^ Row permutation matrix @P@ + , luPermSign :: Scalar t + -- ^ Sign of permutation @luPermSign == det . luPerm@ + } + +deriving instance (Show (Matrix t n n), Show t) => Show (LUFact t n) +deriving instance (Eq (Matrix t n n), Eq t) => Eq (LUFact t n) + +class MatrixLU t (n :: Nat) where + -- | Compute LU factorization with Partial Pivoting + lu :: Matrix t n n -> LUFact t n + + -- | Operations on 4x4 transformation matrices and vectors in homogeneous coordinates. -- All angles are specified in radians. class HomTransform4 t where @@ -63,25 +92,25 @@ rotate :: Vector t 3 -> t -> Matrix t 4 4 -- | Rotation matrix from the Euler angles yaw pitch and roll rotateEuler :: t -> t -> t -> Matrix t 4 4 - -- | Create a transform matrix using up direction, camera position and a point to look at. + -- | Create a transform matrix using up direction, camera position and a point to look at. -- Just the same as GluLookAt. lookAt :: Vector t 3 -- ^ The up direction, not necessary unit length or perpendicular to the view vector -> Vector t 3 -- ^ The viewers position -> Vector t 3 -- ^ The point to look at -> Matrix t 4 4 - -- | A perspective symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) + -- | A perspective symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) -- http://en.wikibooks.org/wiki/GLSL_Programming/Vertex_Transformations - perspective :: t -- ^ Near plane clipping distance (always positive) - -> t -- ^ Far plane clipping distance (always positive) - -> t -- ^ Field of view of the y axis, in radians - -> t -- ^ Aspect ratio, i.e. screen's width\/height + perspective :: t -- ^ Near plane clipping distance (always positive) + -> t -- ^ Far plane clipping distance (always positive) + -> t -- ^ Field of view of the y axis, in radians + -> t -- ^ Aspect ratio, i.e. screen's width\/height -> Matrix t 4 4 - -- | An orthogonal symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) + -- | An orthogonal symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) -- http://en.wikibooks.org/wiki/GLSL_Programming/Vertex_Transformations - orthogonal :: t -- ^ Near plane clipping distance - -> t -- ^ Far plane clipping distance - -> t -- ^ width - -> t -- ^ height + orthogonal :: t -- ^ Near plane clipping distance + -> t -- ^ Far plane clipping distance + -> t -- ^ width + -> t -- ^ height -> Matrix t 4 4 -- | Add one more dimension and set it to 1. toHomPoint :: Vector t 3 -> Vector t 4 diff --git a/src/Numeric/PrimBytes.hs b/src/Numeric/PrimBytes.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/PrimBytes.hs @@ -0,0 +1,1428 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +module Numeric.PrimBytes + ( PrimBytes + ( getBytes, fromBytes, readBytes, writeBytes, byteSize, byteAlign, byteOffset + , indexArray, readArray, writeArray, readAddr, writeAddr) + , PrimTag (..), primTag + ) where + +#include "MachDeps.h" + +import Data.Proxy (Proxy (..)) +import GHC.Exts +import GHC.Generics +import GHC.Int +import GHC.Word +import Numeric.Dimensions.Idxs +import qualified Numeric.Tuple.Lazy as TL +import qualified Numeric.Tuple.Strict as TS +import qualified Numeric.Type.List as L + +-- | Facilities to convert to and from raw byte array. +class PrimTagged a => PrimBytes a where + -- | Store content of a data type in a primitive byte array + -- Should be used together with @byteOffset@ function. + getBytes :: a -> ByteArray# + -- | Load content of a data type from a primitive byte array + fromBytes :: Int# -- ^ offset in bytes + -> ByteArray# + -> a + -- | Read data from a mutable byte array given an offset in bytes + readBytes :: MutableByteArray# s -- ^ source array + -> Int# -- ^ byte offset of the source array + -> State# s -> (# State# s, a #) + -- | Write data into a mutable byte array at a given position (offset in bytes) + writeBytes :: MutableByteArray# s -- ^ destination array + -> Int# -- ^ byte offset of the destination array + -> a -- ^ data to write into array + -> State# s -> State# s + -- | Read data from a specified address + readAddr :: Addr# -> State# s -> (# State# s, a #) + -- | Write data to a specified address + writeAddr :: a -> Addr# -> State# s -> State# s + -- | Size of a data type in bytes + byteSize :: a -> Int# + -- | Alignment of a data type in bytes. + -- @byteOffset@ should be multiple of this value. + byteAlign :: a -> Int# + -- | Offset of the data in a byte array used to store the data, + -- measured in bytes. + -- Should be used together with @getBytes@ function. + -- Unless in case of special data types represented by ByteArrays, + -- it is equal to zero. + byteOffset :: a -> Int# + + -- | Index array given an element offset. + -- + -- > indexArray arr i = fromBytes ( i *# byteSize t) arr + indexArray :: ByteArray# -> Int# -> a + indexArray ba i = fromBytes (i *# byteSize @a undefined) ba + {-# INLINE indexArray #-} + + -- | Read a mutable array given an element offset. + -- + -- > readArray arr i = readBytes arr ( i *# byteSize t) + readArray :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) + readArray ba i = readBytes ba (i *# byteSize @a undefined) + {-# INLINE readArray #-} + + -- | Write a mutable array given an element offset. + -- + -- > writeArray arr i = writeBytes arr ( i *# byteSize t) + writeArray :: MutableByteArray# s -> Int# -> a -> State# s -> State# s + writeArray ba i = writeBytes ba (i *# byteSize @a undefined) + {-# INLINE writeArray #-} + + + + default getBytes :: (Generic a, GPrimBytes (Rep a)) => a -> ByteArray# + getBytes a = ggetBytes (from a) + {-# INLINE getBytes #-} + + default fromBytes :: (Generic a, GPrimBytes (Rep a)) + => Int# -> ByteArray# -> a + fromBytes i arr = to (gfromBytes 0## i arr) + {-# INLINE fromBytes #-} + + default readBytes :: (Generic a, GPrimBytes (Rep a)) + => MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) + readBytes mba i s = case greadBytes 0## mba i s of + (# s', x #) -> (# s', to x #) + {-# INLINE readBytes #-} + + default writeBytes :: (Generic a, GPrimBytes (Rep a)) + => MutableByteArray# s -> Int# -> a -> State# s -> State# s + writeBytes mba i = gwriteBytes 0## mba i . from + {-# INLINE writeBytes #-} + + default readAddr :: (Generic a, GPrimBytes (Rep a)) + => Addr# -> State# s -> (# State# s, a #) + readAddr a s = case greadAddr 0## a s of + (# s', x #) -> (# s', to x #) + {-# INLINE readAddr #-} + + default writeAddr :: (Generic a, GPrimBytes (Rep a)) + => a -> Addr# -> State# s -> State# s + writeAddr = gwriteAddr 0## . from + {-# INLINE writeAddr #-} + + + default byteSize :: (Generic a, GPrimBytes (Rep a)) + => a -> Int# + byteSize a = gbyteSize (from a) + {-# INLINE byteSize #-} + + default byteAlign :: (Generic a, GPrimBytes (Rep a)) + => a -> Int# + byteAlign a = gbyteAlign (from a) + {-# INLINE byteAlign #-} + + default byteOffset :: (Generic a, GPrimBytes (Rep a)) + => a -> Int# + byteOffset a = gbyteOffset (from a) + {-# INLINE byteOffset #-} + + +-- | Deriving `PrimBytes` using generics +class GPrimBytes f where + ggetBytes :: f p -> ByteArray# + gfromBytes :: Word# -- ^ Starting value of a constructor tag + -> Int# -> ByteArray# -> f p + greadBytes :: Word# -- ^ Starting value of a constructor tag + -> MutableByteArray# s -> Int# -> State# s -> (# State# s, f p #) + gwriteBytes :: Word# -- ^ Starting value of a constructor tag + -> MutableByteArray# s -> Int# -> f p -> State# s -> State# s + greadAddr :: Word# -- ^ Starting value of a constructor tag + -> Addr# -> State# s -> (# State# s, f p #) + gwriteAddr :: Word# -- ^ Starting value of a constructor tag + -> f p -> Addr# -> State# s -> State# s + gbyteSize :: f p -> Int# + gbyteAlign :: f p -> Int# + gbyteOffset :: f p -> Int# + -- | Number of constructors in the tree of a sum type. + -- This is equal to one for all other types. + gconTags :: f p -> Word# + + +instance GPrimBytes V1 where + -- Probably, this is illegal due to zero size of the array. + -- There is no bottom to put here, but one should not call this anyway. + ggetBytes _ = case runRW# + ( \s0 -> case newByteArray# 0# s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr s1 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ _ _ = undefined + {-# INLINE gfromBytes #-} + greadBytes _ _ _ s = (# s, undefined #) + {-# INLINE greadBytes #-} + gwriteBytes _ _ _ _ s = s + {-# INLINE gwriteBytes #-} + greadAddr _ _ s = (# s, undefined #) + {-# INLINE greadAddr #-} + gwriteAddr _ _ _ s = s + {-# INLINE gwriteAddr #-} + gbyteSize _ = 0# + {-# INLINE gbyteSize #-} + gbyteAlign _ = 1# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 1## + {-# INLINE gconTags #-} + +instance GPrimBytes U1 where + -- Probably, this is illegal due to zero size of the array. + -- There is no bottom to put here, but one should not call this anyway. + ggetBytes _ = case runRW# + ( \s0 -> case newByteArray# 0# s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr s1 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ _ _ = U1 + {-# INLINE gfromBytes #-} + greadBytes _ _ _ s = (# s, U1 #) + {-# INLINE greadBytes #-} + gwriteBytes _ _ _ _ s = s + {-# INLINE gwriteBytes #-} + greadAddr _ _ s = (# s, U1 #) + {-# INLINE greadAddr #-} + gwriteAddr _ _ _ s = s + {-# INLINE gwriteAddr #-} + gbyteSize _ = 0# + {-# INLINE gbyteSize #-} + gbyteAlign _ = 1# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 1## + {-# INLINE gconTags #-} + +instance PrimBytes a => GPrimBytes (K1 i a) where + ggetBytes ~(K1 a) = getBytes a + {-# NOINLINE ggetBytes #-} + gfromBytes _ i ba = K1 (fromBytes i ba) + {-# INLINE gfromBytes #-} + greadBytes _ = unsafeCoerce# (readBytes @a) + {-# INLINE greadBytes #-} + gwriteBytes _ mba i ~(K1 a) = writeBytes mba i a + {-# INLINE gwriteBytes #-} + greadAddr _ = unsafeCoerce# (readAddr @a) + {-# INLINE greadAddr #-} + gwriteAddr _ ~(K1 a) = writeAddr a + {-# INLINE gwriteAddr #-} + gbyteSize ~(K1 a) = byteSize a + {-# INLINE gbyteSize #-} + gbyteAlign ~(K1 a) = byteAlign a + {-# INLINE gbyteAlign #-} + gbyteOffset ~(K1 a) = byteOffset a + {-# INLINE gbyteOffset #-} + gconTags _ = 1## + {-# INLINE gconTags #-} + +instance GPrimBytes f => GPrimBytes (M1 i c f) where + ggetBytes ~(M1 a) = ggetBytes a + {-# NOINLINE ggetBytes #-} + gfromBytes t i ba = M1 (gfromBytes t i ba) + {-# INLINE gfromBytes #-} + greadBytes = unsafeCoerce# (greadBytes @f) + {-# INLINE greadBytes #-} + gwriteBytes t mba i ~(M1 a) = gwriteBytes t mba i a + {-# INLINE gwriteBytes #-} + greadAddr = unsafeCoerce# (greadAddr @f) + {-# INLINE greadAddr #-} + gwriteAddr t ~(M1 a) = gwriteAddr t a + {-# INLINE gwriteAddr #-} + gbyteSize ~(M1 a) = gbyteSize a + {-# INLINE gbyteSize #-} + gbyteAlign ~(M1 a) = gbyteAlign a + {-# INLINE gbyteAlign #-} + gbyteOffset ~(M1 a) = gbyteOffset a + {-# INLINE gbyteOffset #-} + gconTags ~(M1 a) = gconTags a + {-# INLINE gconTags #-} + + +instance (GPrimBytes f, GPrimBytes g) => GPrimBytes (f :*: g) where + -- | This function return not pinned byte array, which is aligned to + -- @SIZEOF_HSWORD@. + -- Thus, it ignores alignment of the underlying data type if it is larger. + -- However, alignment calculation still makes sense for data types + -- that are smaller than @SIZEOF_HSWORD@ bytes: they are packed more densely. + ggetBytes xy = case runRW# + ( \s0 -> case newByteArray# (gbyteSize xy) s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr + (gwriteBytes 0## marr 0# xy s1) + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ i ba = x :*: y + where + x = gfromBytes 0## i ba + y = gfromBytes 0## (i +# roundUpInt# (gbyteSize x) (gbyteAlign y)) ba + {-# INLINE gfromBytes #-} + greadBytes _ mba i s0 = case greadBytes 0## mba i s0 of + (# s1, x #) -> case greadBytes 0## mba + (i +# roundUpInt# (gbyteSize x) + (gbyteAlign @g undefined) + ) s1 of + (# s2, y #) -> (# s2, x :*: y #) + {-# INLINE greadBytes #-} + gwriteBytes _ mba off ~(x :*: y) s = + gwriteBytes 0## mba (off +# roundUpInt# (gbyteSize x) (gbyteAlign y)) y + (gwriteBytes 0## mba off x s) + {-# INLINE gwriteBytes #-} + greadAddr _ addr s0 = case greadAddr 0## addr s0 of + (# s1, x #) -> case greadAddr 0## + (plusAddr# addr + (roundUpInt# (gbyteSize x) + (gbyteAlign @g undefined)) + ) s1 of + (# s2, y #) -> (# s2, x :*: y #) + {-# INLINE greadAddr #-} + gwriteAddr _ ~(x :*: y) addr s = + gwriteAddr 0## y (plusAddr# addr (roundUpInt# (gbyteSize x) (gbyteAlign y))) + (gwriteAddr 0## x addr s) + {-# INLINE gwriteAddr #-} + gbyteSize ~(x :*: y) + = gbyteSize y +# roundUpInt# (gbyteSize x) (gbyteAlign y) + {-# INLINE gbyteSize #-} + gbyteAlign ~(x :*: y) = maxInt# (gbyteAlign x) (gbyteAlign y) + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 1## + {-# INLINE gconTags #-} + + +-- | Reserve 4 bytes for tag and try to pack alternatives as good as possible. +instance (GPrimBytes f, GPrimBytes g) => GPrimBytes (f :+: g) where + ggetBytes xy = case runRW# + ( \s0 -> case newByteArray# (gbyteSize xy) s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr + (gwriteBytes 0## marr 0# xy s1) + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes toff off ba + = case (# gconTags (undefined :: f a) + , gconTags (undefined :: g a) + , indexWord32Array# ba (uncheckedIShiftRL# off 2#) + `minusWord#` toff + #) of + (# 1##, _ , 0## #) -> L1 (gfromBytes 0## (off +# 4#) ba) + (# cl , 1##, t #) + | isTrue# (eqWord# cl t) -> R1 (gfromBytes 0## (off +# 4#) ba) + (# cl , _ , t #) + | isTrue# (geWord# cl t) -> L1 (gfromBytes toff off ba) + | otherwise -> R1 (gfromBytes (plusWord# toff cl) off ba) + {-# INLINE gfromBytes #-} + greadBytes toff mba off s0 + = case readWord32Array# mba (uncheckedIShiftRL# off 2#) s0 of + (# s1, tval #) -> case (# gconTags (undefined :: f a) + , gconTags (undefined :: g a) + , tval `minusWord#` toff + #) of + (# 1##, _ , 0## #) -> case greadBytes 0## mba (off +# 4#) s1 of + (# s2, r #) -> (# s2, L1 r #) + (# cl , 1##, t #) + | isTrue# (eqWord# cl t) -> case greadBytes 0## mba (off +# 4#) s1 of + (# s2, r #) -> (# s2, R1 r #) + (# cl , _ , t #) + | isTrue# (geWord# cl t) -> case greadBytes toff mba off s1 of + (# s2, r #) -> (# s2, L1 r #) + | otherwise -> case greadBytes (plusWord# toff cl) mba off s1 of + (# s2, r #) -> (# s2, R1 r #) + {-# INLINE greadBytes #-} + gwriteBytes t mba off (L1 x) s + = case gconTags x of + 1## -> gwriteBytes 0## mba (off +# 4#) x + (writeWord32Array# mba (uncheckedIShiftRL# off 2#) t s) + _ -> gwriteBytes t mba off x s + gwriteBytes t mba off xy@(R1 y) s + = case (# gconTags y, plusWord# t (gconTags (undef1 @f xy)) #) of + (# 1## , t' #) -> gwriteBytes 0## mba (off +# 4#) y + (writeWord32Array# mba (uncheckedIShiftRL# off 2#) t' s) + (# _ , t' #) -> gwriteBytes t' mba off y s + {-# INLINE gwriteBytes #-} + greadAddr toff addr s0 + = case readWord32OffAddr# addr 0# s0 of + (# s1, tval #) -> case (# gconTags (undefined :: f a) + , gconTags (undefined :: g a) + , tval `minusWord#` toff + #) of + (# 1##, _ , 0## #) -> case greadAddr 0## (plusAddr# addr 4#) s1 of + (# s2, r #) -> (# s2, L1 r #) + (# cl , 1##, t #) + | isTrue# (eqWord# cl t) -> case greadAddr 0## (plusAddr# addr 4#) s1 of + (# s2, r #) -> (# s2, R1 r #) + (# cl , _ , t #) + | isTrue# (geWord# cl t) -> case greadAddr toff addr s1 of + (# s2, r #) -> (# s2, L1 r #) + | otherwise -> case greadAddr (plusWord# toff cl) addr s1 of + (# s2, r #) -> (# s2, R1 r #) + {-# INLINE greadAddr #-} + gwriteAddr t (L1 x) addr s + = case gconTags x of + 1## -> gwriteAddr 0## x (plusAddr# addr 4#) + (writeWord32OffAddr# addr 0# t s) + _ -> gwriteAddr t x addr s + gwriteAddr t xy@(R1 y) addr s + = case (# gconTags y, plusWord# t (gconTags (undef1 @f xy)) #) of + (# 1## , t' #) -> gwriteAddr 0## y (plusAddr# addr 4#) + (writeWord32OffAddr# addr 0# t' s) + (# _ , t' #) -> gwriteAddr t' y addr s + {-# INLINE gwriteAddr #-} + gbyteSize xy = maxInt# + (roundUpInt# 4# (gbyteAlign x) +# gbyteSize x) + (roundUpInt# 4# (gbyteAlign y) +# gbyteSize y) + where + x = undef1 @f xy + y = undef1 @g xy + {-# INLINE gbyteSize #-} + gbyteAlign xy = maxInt# 4# ( maxInt# (gbyteAlign (undef1 @f xy)) + (gbyteAlign (undef1 @g xy)) + ) + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags xy = gconTags (undef1 @f xy) `plusWord#` gconTags (undef1 @g xy) + {-# INLINE gconTags #-} + +maxInt# :: Int# -> Int# -> Int# +maxInt# a b | isTrue# (a ># b) = a + | otherwise = b + +roundUpInt# :: Int# -> Int# -> Int# +roundUpInt# a b = case remInt# a b of + 0# -> a + q -> a +# b -# q +{-# INLINE roundUpInt# #-} + +undef1 :: forall p q a . q a -> p a +undef1 = const undefined +{-# INLINE undef1 #-} + + + +#if SIZEOF_HSWORD == 4 +#define OFFSHIFT_W 2 +#else +#define OFFSHIFT_W 3 +#endif + +instance GPrimBytes (URec Word) where + ggetBytes x = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSWORD# s0 of + (# s1, marr #) -> case writeWordArray# marr 0# (uWord# x) s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ off ba + = UWord (indexWordArray# ba (uncheckedIShiftRL# off OFFSHIFT_W#)) + {-# INLINE gfromBytes #-} + greadBytes _ mba off s + = case readWordArray# mba (uncheckedIShiftRL# off OFFSHIFT_W#) s of + (# s1, r #) -> (# s1, UWord r #) + {-# INLINE greadBytes #-} + gwriteBytes _ mba off x + = writeWordArray# mba (uncheckedIShiftRL# off OFFSHIFT_W#) (uWord# x) + {-# INLINE gwriteBytes #-} + greadAddr _ a s + = case readWordOffAddr# a 0# s of (# s', x #) -> (# s', UWord x #) + {-# INLINE greadAddr #-} + gwriteAddr _ x a + = writeWordOffAddr# a 0# (uWord# x) + {-# INLINE gwriteAddr #-} + gbyteSize _ = SIZEOF_HSWORD# + {-# INLINE gbyteSize #-} + gbyteAlign _ = ALIGNMENT_HSWORD# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 0## + {-# INLINE gconTags #-} + +#if SIZEOF_HSINT == 4 +#define OFFSHIFT_I 2 +#else +#define OFFSHIFT_I 3 +#endif + +instance GPrimBytes (URec Int) where + ggetBytes x = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSINT# s0 of + (# s1, marr #) -> case writeIntArray# marr 0# (uInt# x) s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ off ba + = UInt (indexIntArray# ba (uncheckedIShiftRL# off OFFSHIFT_I#)) + {-# INLINE gfromBytes #-} + greadBytes _ mba off s + = case readIntArray# mba (uncheckedIShiftRL# off OFFSHIFT_I#) s of + (# s1, r #) -> (# s1, UInt r #) + {-# INLINE greadBytes #-} + gwriteBytes _ mba off x + = writeIntArray# mba (uncheckedIShiftRL# off OFFSHIFT_I#) (uInt# x) + {-# INLINE gwriteBytes #-} + greadAddr _ a s + = case readIntOffAddr# a 0# s of (# s', x #) -> (# s', UInt x #) + {-# INLINE greadAddr #-} + gwriteAddr _ x a + = writeIntOffAddr# a 0# (uInt# x) + {-# INLINE gwriteAddr #-} + gbyteSize _ = SIZEOF_HSINT# + {-# INLINE gbyteSize #-} + gbyteAlign _ = ALIGNMENT_HSINT# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 0## + {-# INLINE gconTags #-} + + +#if SIZEOF_HSFLOAT == 4 +#define OFFSHIFT_F 2 +#else +#define OFFSHIFT_F 3 +#endif + +instance GPrimBytes (URec Float) where + ggetBytes x = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSFLOAT# s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# (uFloat# x) s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ off ba + = UFloat (indexFloatArray# ba (uncheckedIShiftRL# off OFFSHIFT_F#)) + {-# INLINE gfromBytes #-} + greadBytes _ mba off s + = case readFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) s of + (# s1, r #) -> (# s1, UFloat r #) + {-# INLINE greadBytes #-} + gwriteBytes _ mba off x + = writeFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) (uFloat# x) + {-# INLINE gwriteBytes #-} + greadAddr _ a s + = case readFloatOffAddr# a 0# s of (# s', x #) -> (# s', UFloat x #) + {-# INLINE greadAddr #-} + gwriteAddr _ x a + = writeFloatOffAddr# a 0# (uFloat# x) + {-# INLINE gwriteAddr #-} + gbyteSize _ = SIZEOF_HSFLOAT# + {-# INLINE gbyteSize #-} + gbyteAlign _ = ALIGNMENT_HSFLOAT# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 0## + {-# INLINE gconTags #-} + +#if SIZEOF_HSDOUBLE == 4 +#define OFFSHIFT_D 2 +#else +#define OFFSHIFT_D 3 +#endif + +instance GPrimBytes (URec Double) where + ggetBytes x = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSDOUBLE# s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# (uDouble# x) s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ off ba + = UDouble (indexDoubleArray# ba (uncheckedIShiftRL# off OFFSHIFT_D#)) + {-# INLINE gfromBytes #-} + greadBytes _ mba off s + = case readDoubleArray# mba (uncheckedIShiftRL# off OFFSHIFT_D#) s of + (# s1, r #) -> (# s1, UDouble r #) + {-# INLINE greadBytes #-} + gwriteBytes _ mba off x + = writeDoubleArray# mba (uncheckedIShiftRL# off OFFSHIFT_D#) (uDouble# x) + {-# INLINE gwriteBytes #-} + greadAddr _ a s + = case readDoubleOffAddr# a 0# s of (# s', x #) -> (# s', UDouble x #) + {-# INLINE greadAddr #-} + gwriteAddr _ x a + = writeDoubleOffAddr# a 0# (uDouble# x) + {-# INLINE gwriteAddr #-} + gbyteSize _ = SIZEOF_HSDOUBLE# + {-# INLINE gbyteSize #-} + gbyteAlign _ = ALIGNMENT_HSDOUBLE# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 0## + {-# INLINE gconTags #-} + +#if SIZEOF_HSCHAR == 2 +#define OFFSHIFT_C 1 +#elif SIZEOF_HSCHAR == 4 +#define OFFSHIFT_C 2 +#else +#define OFFSHIFT_C 3 +#endif + +instance GPrimBytes (URec Char) where + ggetBytes x = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSCHAR# s0 of + (# s1, marr #) -> case writeCharArray# marr 0# (uChar# x) s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ off ba + = UChar (indexCharArray# ba (uncheckedIShiftRL# off OFFSHIFT_C#)) + {-# INLINE gfromBytes #-} + greadBytes _ mba off s + = case readCharArray# mba (uncheckedIShiftRL# off OFFSHIFT_C#) s of + (# s1, r #) -> (# s1, UChar r #) + {-# INLINE greadBytes #-} + gwriteBytes _ mba off x + = writeCharArray# mba (uncheckedIShiftRL# off OFFSHIFT_C#) (uChar# x) + {-# INLINE gwriteBytes #-} + greadAddr _ a s + = case readCharOffAddr# a 0# s of (# s', x #) -> (# s', UChar x #) + {-# INLINE greadAddr #-} + gwriteAddr _ x a + = writeCharOffAddr# a 0# (uChar# x) + {-# INLINE gwriteAddr #-} + gbyteSize _ = SIZEOF_HSCHAR# + {-# INLINE gbyteSize #-} + gbyteAlign _ = ALIGNMENT_HSCHAR# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 0## + {-# INLINE gconTags #-} + +#if SIZEOF_HSPTR == 4 +#define OFFSHIFT_P 2 +#else +#define OFFSHIFT_P 3 +#endif + +instance GPrimBytes (URec (Ptr ())) where + ggetBytes x = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSPTR# s0 of + (# s1, marr #) -> case writeAddrArray# marr 0# (uAddr# x) s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE ggetBytes #-} + gfromBytes _ off ba + = UAddr (indexAddrArray# ba (uncheckedIShiftRL# off OFFSHIFT_P#)) + {-# INLINE gfromBytes #-} + greadBytes _ mba off s + = case readAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) s of + (# s1, r #) -> (# s1, UAddr r #) + {-# INLINE greadBytes #-} + gwriteBytes _ mba off x + = writeAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) (uAddr# x) + {-# INLINE gwriteBytes #-} + greadAddr _ a s + = case readAddrOffAddr# a 0# s of (# s', x #) -> (# s', UAddr x #) + {-# INLINE greadAddr #-} + gwriteAddr _ x a + = writeAddrOffAddr# a 0# (uAddr# x) + {-# INLINE gwriteAddr #-} + gbyteSize _ = SIZEOF_HSPTR# + {-# INLINE gbyteSize #-} + gbyteAlign _ = ALIGNMENT_HSPTR# + {-# INLINE gbyteAlign #-} + gbyteOffset _ = 0# + {-# INLINE gbyteOffset #-} + gconTags _ = 0## + {-# INLINE gconTags #-} + + + + +-------------------------------------------------------------------------------- +-- Basic instances +-------------------------------------------------------------------------------- + + +instance PrimBytes Word where + getBytes (W# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSWORD# s0 of + (# s1, marr #) -> case writeWordArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = W# (indexWordArray# ba (uncheckedIShiftRL# off OFFSHIFT_W#)) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off OFFSHIFT_W#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_W#) + {-# INLINE writeBytes #-} + readAddr a s + = case readWordOffAddr# a 0# s of (# s', x #) -> (# s', W# x #) + {-# INLINE readAddr #-} + writeAddr (W# x) a + = writeWordOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSWORD# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSWORD# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = W# (indexWordArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWordArray# mba i s of (# s', x #) -> (# s', W# x #) + {-# INLINE readArray #-} + writeArray mba i (W# x) = writeWordArray# mba i x + {-# INLINE writeArray #-} + + +instance PrimBytes Int where + getBytes (I# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSINT# s0 of + (# s1, marr #) -> case writeIntArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = I# (indexIntArray# ba (uncheckedIShiftRL# off OFFSHIFT_I#)) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off OFFSHIFT_I#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_I#) + {-# INLINE writeBytes #-} + readAddr a s + = case readIntOffAddr# a 0# s of (# s', x #) -> (# s', I# x #) + {-# INLINE readAddr #-} + writeAddr (I# x) a + = writeIntOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSINT# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSINT# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = I# (indexIntArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readIntArray# mba i s of (# s', x #) -> (# s', I# x #) + {-# INLINE readArray #-} + writeArray mba i (I# x) = writeIntArray# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Float where + getBytes (F# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSFLOAT# s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = F# (indexFloatArray# ba (uncheckedIShiftRL# off OFFSHIFT_F#)) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off OFFSHIFT_F#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_F#) + {-# INLINE writeBytes #-} + readAddr a s + = case readFloatOffAddr# a 0# s of (# s', x #) -> (# s', F# x #) + {-# INLINE readAddr #-} + writeAddr (F# x) a + = writeFloatOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSFLOAT# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSFLOAT# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = F# (indexFloatArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readFloatArray# mba i s of (# s', x #) -> (# s', F# x #) + {-# INLINE readArray #-} + writeArray mba i (F# x) = writeFloatArray# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Double where + getBytes (D# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSDOUBLE# s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = D# (indexDoubleArray# ba (uncheckedIShiftRL# off OFFSHIFT_D#)) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off OFFSHIFT_D#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_D#) + {-# INLINE writeBytes #-} + readAddr a s + = case readDoubleOffAddr# a 0# s of (# s', x #) -> (# s', D# x #) + {-# INLINE readAddr #-} + writeAddr (D# x) a + = writeDoubleOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSDOUBLE# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSDOUBLE# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = D# (indexDoubleArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readDoubleArray# mba i s of (# s', x #) -> (# s', D# x #) + {-# INLINE readArray #-} + writeArray mba i (D# x) = writeDoubleArray# mba i x + {-# INLINE writeArray #-} + + +instance PrimBytes (Ptr a) where + getBytes (Ptr x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSPTR# s0 of + (# s1, marr #) -> case writeAddrArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = Ptr (indexAddrArray# ba (uncheckedIShiftRL# off OFFSHIFT_P#)) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off OFFSHIFT_P#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_P#) + {-# INLINE writeBytes #-} + readAddr a s + = case readAddrOffAddr# a 0# s of (# s', x #) -> (# s', Ptr x #) + {-# INLINE readAddr #-} + writeAddr (Ptr x) a + = writeAddrOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSPTR# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSPTR# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = Ptr (indexAddrArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readAddrArray# mba i s of (# s', x #) -> (# s', Ptr x #) + {-# INLINE readArray #-} + writeArray mba i (Ptr x) = writeAddrArray# mba i x + {-# INLINE writeArray #-} + + +instance PrimBytes Int8 where + getBytes (I8# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT8# s0 of + (# s1, marr #) -> case writeInt8Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba = indexArray ba off + {-# INLINE fromBytes #-} + readBytes = readArray + {-# INLINE readBytes #-} + writeBytes = writeArray + {-# INLINE writeBytes #-} + readAddr a s + = case readInt8OffAddr# a 0# s of (# s', x #) -> (# s', I8# x #) + {-# INLINE readAddr #-} + writeAddr (I8# x) a + = writeInt8OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT8# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT8# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = I8# (indexInt8Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt8Array# mba i s of (# s', x #) -> (# s', I8# x #) + {-# INLINE readArray #-} + writeArray mba i (I8# x) = writeInt8Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Int16 where + getBytes (I16# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT16# s0 of + (# s1, marr #) -> case writeInt16Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = indexArray ba (uncheckedIShiftRL# off 1#) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off 1#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off 1#) + {-# INLINE writeBytes #-} + readAddr a s + = case readInt16OffAddr# a 0# s of (# s', x #) -> (# s', I16# x #) + {-# INLINE readAddr #-} + writeAddr (I16# x) a + = writeInt16OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT16# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT16# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = I16# (indexInt16Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt16Array# mba i s of (# s', x #) -> (# s', I16# x #) + {-# INLINE readArray #-} + writeArray mba i (I16# x) = writeInt16Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Int32 where + getBytes (I32# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT32# s0 of + (# s1, marr #) -> case writeInt32Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = indexArray ba (uncheckedIShiftRL# off 2#) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off 2#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off 2#) + {-# INLINE writeBytes #-} + readAddr a s + = case readInt32OffAddr# a 0# s of (# s', x #) -> (# s', I32# x #) + {-# INLINE readAddr #-} + writeAddr (I32# x) a + = writeInt32OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT32# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT32# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = I32# (indexInt32Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt32Array# mba i s of (# s', x #) -> (# s', I32# x #) + {-# INLINE readArray #-} + writeArray mba i (I32# x) = writeInt32Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Int64 where + getBytes (I64# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT64# s0 of + (# s1, marr #) -> case writeInt64Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = indexArray ba (uncheckedIShiftRL# off 3#) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off 3#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off 3#) + {-# INLINE writeBytes #-} + readAddr a s + = case readInt64OffAddr# a 0# s of (# s', x #) -> (# s', I64# x #) + {-# INLINE readAddr #-} + writeAddr (I64# x) a + = writeInt64OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT64# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT64# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = I64# (indexInt64Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt64Array# mba i s of (# s', x #) -> (# s', I64# x #) + {-# INLINE readArray #-} + writeArray mba i (I64# x) = writeInt64Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word8 where + getBytes (W8# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD8# s0 of + (# s1, marr #) -> case writeWord8Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba = indexArray ba off + {-# INLINE fromBytes #-} + readBytes = readArray + {-# INLINE readBytes #-} + writeBytes = writeArray + {-# INLINE writeBytes #-} + readAddr a s + = case readWord8OffAddr# a 0# s of (# s', x #) -> (# s', W8# x #) + {-# INLINE readAddr #-} + writeAddr (W8# x) a + = writeWord8OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD8# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD8# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = W8# (indexWord8Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord8Array# mba i s of (# s', x #) -> (# s', W8# x #) + {-# INLINE readArray #-} + writeArray mba i (W8# x) = writeWord8Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word16 where + getBytes (W16# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD16# s0 of + (# s1, marr #) -> case writeWord16Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = indexArray ba (uncheckedIShiftRL# off 1#) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off 1#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off 1#) + {-# INLINE writeBytes #-} + readAddr a s + = case readWord16OffAddr# a 0# s of (# s', x #) -> (# s', W16# x #) + {-# INLINE readAddr #-} + writeAddr (W16# x) a + = writeWord16OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD16# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD16# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = W16# (indexWord16Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord16Array# mba i s of (# s', x #) -> (# s', W16# x #) + {-# INLINE readArray #-} + writeArray mba i (W16# x) = writeWord16Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word32 where + getBytes (W32# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD32# s0 of + (# s1, marr #) -> case writeWord32Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = indexArray ba (uncheckedIShiftRL# off 2#) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off 2#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off 2#) + {-# INLINE writeBytes #-} + readAddr a s + = case readWord32OffAddr# a 0# s of (# s', x #) -> (# s', W32# x #) + {-# INLINE readAddr #-} + writeAddr (W32# x) a + = writeWord32OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD32# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD32# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = W32# (indexWord32Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord32Array# mba i s of (# s', x #) -> (# s', W32# x #) + {-# INLINE readArray #-} + writeArray mba i (W32# x) = writeWord32Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word64 where + getBytes (W64# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD64# s0 of + (# s1, marr #) -> case writeWord64Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = indexArray ba (uncheckedIShiftRL# off 3#) + {-# INLINE fromBytes #-} + readBytes mba off + = readArray mba (uncheckedIShiftRL# off 3#) + {-# INLINE readBytes #-} + writeBytes mba off + = writeArray mba (uncheckedIShiftRL# off 3#) + {-# INLINE writeBytes #-} + readAddr a s + = case readWord64OffAddr# a 0# s of (# s', x #) -> (# s', W64# x #) + {-# INLINE readAddr #-} + writeAddr (W64# x) a + = writeWord64OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD64# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD64# + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba i = W64# (indexWord64Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord64Array# mba i s of (# s', x #) -> (# s', W64# x #) + {-# INLINE readArray #-} + writeArray mba i (W64# x) = writeWord64Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes (Idx x) where + getBytes = unsafeCoerce# (getBytes @Word) + {-# INLINE getBytes #-} + fromBytes = unsafeCoerce# (fromBytes @Word) + {-# INLINE fromBytes #-} + readBytes = unsafeCoerce# (readBytes @Word) + {-# INLINE readBytes #-} + writeBytes = unsafeCoerce# (writeBytes @Word) + {-# INLINE writeBytes #-} + readAddr = unsafeCoerce# (readAddr @Word) + {-# INLINE readAddr #-} + writeAddr = unsafeCoerce# (readAddr @Word) + {-# INLINE writeAddr #-} + byteSize = unsafeCoerce# (byteSize @Word) + {-# INLINE byteSize #-} + byteAlign = unsafeCoerce# (byteAlign @Word) + {-# INLINE byteAlign #-} + byteOffset = unsafeCoerce# (byteOffset @Word) + {-# INLINE byteOffset #-} + indexArray = unsafeCoerce# (indexArray @Word) + {-# INLINE indexArray #-} + readArray = unsafeCoerce# (readArray @Word) + {-# INLINE readArray #-} + writeArray = unsafeCoerce# (writeArray @Word) + {-# INLINE writeArray #-} + +instance RepresentableList xs => PrimBytes (Idxs xs) where + getBytes is = case runRW# + ( \s0 -> case newByteArray# (byteSize is) s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr + (writeBytes marr 0# is s1) + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + fromBytes off ba = unsafeCoerce# + (go (uncheckedIShiftRL# off OFFSHIFT_W#) (unsafeCoerce# (tList @_ @xs))) + where + go _ [] = [] + go i (Proxy : ls) = W# (indexWordArray# ba i) : go (i +# 1#) ls + {-# INLINE fromBytes #-} + readBytes mba off s = unsafeCoerce# + (go (uncheckedIShiftRL# off OFFSHIFT_W#) (unsafeCoerce# (tList @_ @xs)) s) + where + go _ [] s0 = (# s0, [] #) + go i (Proxy : ls) s0 = case readWordArray# mba off s0 of + (# s1, w #) -> case go (i +# 1#) ls s1 of + (# s2, xs #) -> (# s2, W# w : xs #) + {-# INLINE readBytes #-} + writeBytes mba off is + = go (uncheckedIShiftRL# off OFFSHIFT_W#) (listIdxs is) + where + go _ [] s = s + go i (W# x :xs) s = go (i +# 1#) xs (writeWordArray# mba i x s) + {-# INLINE writeBytes #-} + readAddr addr s = unsafeCoerce# + (go addr (unsafeCoerce# (tList @_ @xs)) s) + where + go _ [] s0 = (# s0, [] #) + go i (Proxy : ls) s0 = case readWordOffAddr# i 0# s0 of + (# s1, w #) -> case go (plusAddr# i SIZEOF_HSWORD#) ls s1 of + (# s2, xs #) -> (# s2, W# w : xs #) + {-# INLINE readAddr #-} + writeAddr is addr + = go addr (listIdxs is) + where + go _ [] s = s + go i (W# x :xs) s = go (plusAddr# i SIZEOF_HSWORD#) xs + (writeWordOffAddr# i 0# x s) + {-# INLINE writeAddr #-} + byteSize _ = case dimVal (order' @xs) of + W# n -> byteSize (undefined :: Idx x) *# word2Int# n + {-# INLINE byteSize #-} + byteAlign _ = byteAlign (undefined :: Idx x) + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + indexArray ba off + | n@(W# n#) <- dimVal (order' @xs) + = unsafeCoerce# (go (off *# word2Int# n#) n) + where + go _ 0 = [] + go i n = W# (indexWordArray# ba i) : go (i +# 1#) (n-1) + {-# INLINE indexArray #-} + readArray mba off s + | n@(W# n#) <- dimVal (order' @xs) + = unsafeCoerce# (go (off *# word2Int# n#) n s) + where + go _ 0 s0 = (# s0, [] #) + go i n s0 = case readWordArray# mba off s0 of + (# s1, w #) -> case go (i +# 1#) (n-1) s1 of + (# s2, xs #) -> (# s2, W# w : xs #) + {-# INLINE readArray #-} + writeArray mba off is + | W# n# <- dimVal (order' @xs) + = go (off *# word2Int# n#) (listIdxs is) + where + go _ [] s = s + go i (W# x :xs) s = go (i +# 1#) xs (writeWordArray# mba i x s) + {-# INLINE writeArray #-} + +instance ( RepresentableList xs + , L.All PrimBytes xs + ) => PrimBytes (TL.Tuple xs) where + getBytes = unsafeCoerce# (getBytes @(TS.Tuple xs)) + {-# INLINE getBytes #-} + fromBytes = unsafeCoerce# (fromBytes @(TS.Tuple xs)) + {-# INLINE fromBytes #-} + readBytes = unsafeCoerce# (readBytes @(TS.Tuple xs)) + {-# INLINE readBytes #-} + writeBytes = unsafeCoerce# (writeBytes @(TS.Tuple xs)) + {-# INLINE writeBytes #-} + readAddr = unsafeCoerce# (readAddr @(TS.Tuple xs)) + {-# INLINE readAddr #-} + writeAddr = unsafeCoerce# (writeAddr @(TS.Tuple xs)) + {-# INLINE writeAddr #-} + byteSize = unsafeCoerce# (byteSize @(TS.Tuple xs)) + {-# INLINE byteSize #-} + byteAlign = unsafeCoerce# (byteAlign @(TS.Tuple xs)) + {-# INLINE byteAlign #-} + byteOffset = unsafeCoerce# (byteOffset @(TS.Tuple xs)) + {-# INLINE byteOffset #-} + indexArray = unsafeCoerce# (indexArray @(TS.Tuple xs)) + {-# INLINE indexArray #-} + readArray = unsafeCoerce# (readArray @(TS.Tuple xs)) + {-# INLINE readArray #-} + writeArray = unsafeCoerce# (writeArray @(TS.Tuple xs)) + {-# INLINE writeArray #-} + +instance ( RepresentableList xs + , L.All PrimBytes xs + ) => PrimBytes (TS.Tuple xs) where + getBytes tup = case runRW# + ( \s0 -> case newByteArray# (byteSize tup) s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr + (go marr 0# tup (types tup) s1) + ) of (# _, a #) -> a + where + go :: L.All PrimBytes ds => MutableByteArray# s + -> Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s + go _ _ _ Empty s = s + go mb n (TS.Id x :* xs) (_ :* ts@TypeList) s + | n' <- roundUpInt# n (byteAlign x) + = go mb (n' +# byteSize x) xs ts (writeBytes mb n' x s) + {-# INLINE getBytes #-} + fromBytes off ba = go 0# (tList @_ @xs) + where + go :: L.All PrimBytes ds + => Int# -> TypeList ds -> TS.Tuple ds + go _ Empty = Empty + go n (t :* ts@TypeList) + | x <- undefP t + , n' <- roundUpInt# n (byteAlign x) + = TS.Id (fromBytes (off +# n') ba) :* go (n' +# byteSize x) ts + {-# INLINE fromBytes #-} + readBytes mb off = go mb 0# (tList @_ @xs) + where + go :: L.All PrimBytes ds + => MutableByteArray# s + -> Int# -> TypeList ds -> State# s -> (# State# s, TS.Tuple ds #) + go _ _ Empty s0 = (# s0, Empty #) + go mba n (t :* ts@TypeList) s0 + | x <- undefP t + , n' <- roundUpInt# n (byteAlign x) + = case readBytes mba (off +# n') s0 of + (# s1, r #) -> case go mba (n' +# byteSize x) ts s1 of + (# s2, rs #) -> (# s2, TS.Id r :* rs #) + {-# INLINE readBytes #-} + writeBytes mba off tup = go mba 0# tup (types tup) + where + go :: L.All PrimBytes ds => MutableByteArray# s + -> Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s + go _ _ _ Empty s = s + go mb n (TS.Id x :* xs) (_ :* ts@TypeList) s + | n' <- roundUpInt# n (byteAlign x) + = go mb (n' +# byteSize x) xs ts (writeBytes mb (off +# n') x s) + {-# INLINE writeBytes #-} + readAddr addr = go 0# (tList @_ @xs) + where + go :: L.All PrimBytes ds + => Int# -> TypeList ds -> State# s -> (# State# s, TS.Tuple ds #) + go _ Empty s0 = (# s0, Empty #) + go n (t :* ts@TypeList) s0 + | x <- undefP t + , n' <- roundUpInt# n (byteAlign x) + = case readAddr (plusAddr# addr n') s0 of + (# s1, r #) -> case go (n' +# byteSize x) ts s1 of + (# s2, rs #) -> (# s2, TS.Id r :* rs #) + {-# INLINE readAddr #-} + writeAddr tup addr = go 0# tup (types tup) + where + go :: L.All PrimBytes ds + => Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s + go _ _ Empty s = s + go n (TS.Id x :* xs) (_ :* ts@TypeList) s + | n' <- roundUpInt# n (byteAlign x) + = go (n' +# byteSize x) xs ts (writeAddr x (plusAddr# addr n') s) + {-# INLINE writeAddr #-} + byteSize _ = go 0# (tList @_ @xs) + where + go :: L.All PrimBytes ys => Int# -> TypeList ys -> Int# + go s Empty = s + go s (p :* ps) = let x = undefP p + in go (roundUpInt# s (byteAlign x) +# byteSize x) ps + {-# INLINE byteSize #-} + byteAlign _ = go (tList @_ @xs) + where + go :: L.All PrimBytes ys => TypeList ys -> Int# + go Empty = 0# + go (p :* ps) = maxInt# (byteAlign (undefP p)) (go ps) + {-# INLINE byteAlign #-} + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + +undefP :: Proxy p -> p +undefP = const undefined +{-# INLINE undefP #-} + + +instance PrimBytes a => PrimBytes (Maybe a) +instance (PrimBytes a, PrimBytes b) => PrimBytes (Either a b) +instance PrimBytes a => PrimBytes [a] -- ??? likely to give inf byteSize + + +data PrimTag a where + PTagFloat :: PrimTag Float + PTagDouble :: PrimTag Double + PTagInt :: PrimTag Int + PTagInt8 :: PrimTag Int8 + PTagInt16 :: PrimTag Int16 + PTagInt32 :: PrimTag Int32 + PTagInt64 :: PrimTag Int64 + PTagWord :: PrimTag Word + PTagWord8 :: PrimTag Word8 + PTagWord16 :: PrimTag Word16 + PTagWord32 :: PrimTag Word32 + PTagWord64 :: PrimTag Word64 + PTagPtr :: PrimTag (Ptr a) + PTagOther :: PrimTag a + +class PrimTagged a where + primTag' :: a -> PrimTag a + +-- | This function allows to find out a type by comparing its tag. +-- This is needed for array overloading, to infer array instances. +-- For non-basic types it defaults to `PTagOther` +primTag :: PrimBytes a => a -> PrimTag a +primTag = primTag' +{-# INLINE primTag #-} + +instance {-# OVERLAPPABLE #-} PrimTagged a where + primTag' = const PTagOther + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Float where + primTag' = const PTagFloat + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Double where + primTag' = const PTagDouble + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int where + primTag' = const PTagInt + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int8 where + primTag' = const PTagInt8 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int16 where + primTag' = const PTagInt16 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int32 where + primTag' = const PTagInt32 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int64 where + primTag' = const PTagInt64 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word where + primTag' = const PTagWord + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word8 where + primTag' = const PTagWord8 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word16 where + primTag' = const PTagWord16 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word32 where + primTag' = const PTagWord32 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word64 where + primTag' = const PTagWord64 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged (Ptr a) where + primTag' = const PTagPtr + {-# INLINE primTag' #-} diff --git a/src/Numeric/Quaternion/QDouble.hs b/src/Numeric/Quaternion/QDouble.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Quaternion/QDouble.hs @@ -0,0 +1,559 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Numeric.Quaternion.QDouble + ( QDouble, Quater (..) + ) where + +import Data.Coerce (coerce) +import GHC.Exts + +import qualified Control.Monad.ST as ST +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.Family.DoubleX3 +import Numeric.DataFrame.Internal.Array.Family.DoubleX4 +import qualified Numeric.DataFrame.ST as ST +import Numeric.DataFrame.Type +import Numeric.Dimensions +import qualified Numeric.Dimensions.Fold as ST +import Numeric.PrimBytes (PrimBytes) +import Numeric.Quaternion.Class +import Numeric.Scalar +import Numeric.Vector + + +type QDouble = Quater Double + +deriving instance PrimBytes (Quater Double) +deriving instance PrimArray Double (Quater Double) + +instance Quaternion Double where + newtype Quater Double = QDouble DoubleX4 + {-# INLINE packQ #-} + packQ (D# x) (D# y) (D# z) (D# w) = QDouble (DoubleX4# x y z w) + {-# INLINE unpackQ #-} + unpackQ (QDouble (DoubleX4# x y z w)) = (D# x, D# y, D# z, D# w) + {-# INLINE fromVecNum #-} + fromVecNum (SingleFrame (DoubleX3# x y z)) (D# w) = QDouble (DoubleX4# x y z w) + {-# INLINE fromVec4 #-} + fromVec4 = coerce + {-# INLINE toVec4 #-} + toVec4 = coerce + {-# INLINE square #-} + square q = D# (qdot q) + {-# INLINE im #-} + im (QDouble (DoubleX4# x y z _)) = QDouble (DoubleX4# x y z 0.0##) + {-# INLINE re #-} + re (QDouble (DoubleX4# _ _ _ w)) = QDouble (DoubleX4# 0.0## 0.0## 0.0## w) + {-# INLINE imVec #-} + imVec (QDouble (DoubleX4# x y z _)) = SingleFrame (DoubleX3# x y z) + {-# INLINE taker #-} + taker (QDouble (DoubleX4# _ _ _ w)) = D# w + {-# INLINE takei #-} + takei (QDouble (DoubleX4# x _ _ _)) = D# x + {-# INLINE takej #-} + takej (QDouble (DoubleX4# _ y _ _)) = D# y + {-# INLINE takek #-} + takek (QDouble (DoubleX4# _ _ z _)) = D# z + {-# INLINE conjugate #-} + conjugate (QDouble (DoubleX4# x y z w)) = QDouble (DoubleX4# + (negateDouble# x) + (negateDouble# y) + (negateDouble# z) w) + {-# INLINE rotScale #-} + rotScale (QDouble (DoubleX4# i j k t)) + (SingleFrame (DoubleX3# x y z)) + = let l = t*##t -## i*##i -## j*##j -## k*##k + d = 2.0## *## ( i*##x +## j*##y +## k*##z) + t2 = t *## 2.0## + in SingleFrame + ( DoubleX3# + (l*##x +## d*##i +## t2 *## (z*##j -## y*##k)) + (l*##y +## d*##j +## t2 *## (x*##k -## z*##i)) + (l*##z +## d*##k +## t2 *## (y*##i -## x*##j)) + ) + {-# INLINE getRotScale #-} + getRotScale _ (SingleFrame (DoubleX3# 0.0## 0.0## 0.0##)) + = QDouble (DoubleX4# 0.0## 0.0## 0.0## 0.0##) + getRotScale (SingleFrame (DoubleX3# 0.0## 0.0## 0.0##)) _ + = case infty of D# x -> QDouble (DoubleX4# x x x x) + getRotScale a@(SingleFrame (DoubleX3# a1 a2 a3)) + b@(SingleFrame (DoubleX3# b1 b2 b3)) + = let ma = sqrtDouble# (a1*##a1 +## a2*##a2 +## a3*##a3) + mb = sqrtDouble# (b1*##b1 +## b2*##b2 +## b3*##b3) + d = a1*##b1 +## a2*##b2 +## a3*##b3 + c = sqrtDouble# (ma*##mb +## d) + ma2 = ma *## sqrtDouble# 2.0## + r = 1.0## /## (ma2 *## c) + in case cross a b of + SingleFrame (DoubleX3# 0.0## 0.0## 0.0##) -> + if isTrue# (d >## 0.0##) + then QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# (mb /## ma))) + -- Shall we move result from k to i component? + else QDouble (DoubleX4# 0.0## 0.0## (sqrtDouble# (mb /## ma)) 0.0##) + SingleFrame (DoubleX3# t1 t2 t3) -> QDouble + ( DoubleX4# + (t1 *## r) + (t2 *## r) + (t3 *## r) + (c /## ma2) + ) + {-# INLINE axisRotation #-} + axisRotation (SingleFrame (DoubleX3# 0.0## 0.0## 0.0##)) _ + = QDouble (DoubleX4# 0.0## 0.0## 0.0## 1.0##) + axisRotation (SingleFrame (DoubleX3# x y z)) (D# a) + = let c = cosDouble# (a *## 0.5##) + s = sinDouble# (a *## 0.5##) + /## sqrtDouble# (x*##x +## y*##y +## z*##z) + in QDouble + ( DoubleX4# + (x *## s) + (y *## s) + (z *## s) + c + ) + {-# INLINE qArg #-} + qArg (QDouble (DoubleX4# x y z w)) + = case atan2 (D# (sqrtDouble# (x*##x +## y*##y +## z*##z))) + (D# w) of + D# a -> D# (a *## 2.0##) + {-# INLINE fromMatrix33 #-} + fromMatrix33 m + = let d = + ( ix 0# m *## ( ix 4# m *## ix 8# m -## ix 5# m *## ix 7# m ) + -## ix 1# m *## ( ix 3# m *## ix 8# m -## ix 5# m *## ix 6# m ) + +## ix 2# m *## ( ix 3# m *## ix 7# m -## ix 4# m *## ix 6# m ) + ) **## 0.33333333333333333333333333333333## + in QDouble + ( DoubleX4# + (sqrtDouble# (max# 0.0## (d +## ix 0# m -## ix 4# m -## ix 8# m )) *## sign# (ix 5# m -## ix 7# m) *## 0.5##) + (sqrtDouble# (max# 0.0## (d -## ix 0# m +## ix 4# m -## ix 8# m )) *## sign# (ix 6# m -## ix 2# m) *## 0.5##) + (sqrtDouble# (max# 0.0## (d -## ix 0# m -## ix 4# m +## ix 8# m )) *## sign# (ix 1# m -## ix 3# m) *## 0.5##) + (sqrtDouble# (max# 0.0## (d +## ix 0# m +## ix 4# m +## ix 8# m )) *## 0.5##) + ) + {-# INLINE fromMatrix44 #-} + fromMatrix44 m + = let d = + ( ix 0# m *## ( ix 5# m *## ix 10# m -## ix 6# m *## ix 9# m ) + -## ix 1# m *## ( ix 4# m *## ix 10# m -## ix 6# m *## ix 8# m ) + +## ix 2# m *## ( ix 4# m *## ix 9# m -## ix 5# m *## ix 8# m ) + ) **## 0.33333333333333333333333333333333## + c = 0.5## /## ix 15# m + in QDouble + ( DoubleX4# + (sqrtDouble# (max# 0.0## (d +## ix 0# m -## ix 5# m -## ix 10# m )) *## sign# (ix 6# m -## ix 9# m) *## c) + (sqrtDouble# (max# 0.0## (d -## ix 0# m +## ix 5# m -## ix 10# m )) *## sign# (ix 8# m -## ix 2# m) *## c) + (sqrtDouble# (max# 0.0## (d -## ix 0# m -## ix 5# m +## ix 10# m )) *## sign# (ix 1# m -## ix 4# m) *## c) + (sqrtDouble# (max# 0.0## (d +## ix 0# m +## ix 5# m +## ix 10# m )) *## c) + ) + {-# INLINE toMatrix33 #-} + toMatrix33 (QDouble (DoubleX4# 0.0## 0.0## 0.0## w)) + = let x = D# (w *## w) + f 0 = (# 3 :: Int , x #) + f k = (# k-1, 0 #) + in case gen# 9# f 0 of + (# _, m #) -> m -- diag (scalar (D# (w *## w))) + toMatrix33 (QDouble (DoubleX4# x' y' z' w')) = + let x = scalar (D# x') + y = scalar (D# y') + z = scalar (D# z') + w = scalar (D# w') + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) + ST.unsafeFreezeDataFrame df + {-# INLINE toMatrix44 #-} + toMatrix44 (QDouble (DoubleX4# 0.0## 0.0## 0.0## w)) = ST.runST $ do + df <- ST.newDataFrame + ST.overDimOff_ (dims :: Dims '[4,4]) (\i -> ST.writeDataFrameOff df i 0) 0 1 + let w2 = scalar (D# (w *## w)) + ST.writeDataFrameOff df 0 w2 + ST.writeDataFrameOff df 5 w2 + ST.writeDataFrameOff df 10 w2 + ST.writeDataFrameOff df 15 1 + ST.unsafeFreezeDataFrame df + toMatrix44 (QDouble (DoubleX4# x' y' z' w')) = + let x = scalar (D# x') + y = scalar (D# y') + z = scalar (D# z') + w = scalar (D# w') + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 0 + ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 7 0 + ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) + ST.writeDataFrameOff df 11 0 + ST.writeDataFrameOff df 12 0 + ST.writeDataFrameOff df 13 0 + ST.writeDataFrameOff df 14 0 + ST.writeDataFrameOff df 15 1 + ST.unsafeFreezeDataFrame df + +qdot :: QDouble -> Double# +qdot (QDouble (DoubleX4# x y z w)) = (x *## x) +## + (y *## y) +## + (z *## z) +## + (w *## w) +{-# INLINE qdot #-} + +infty :: Double +infty = read "Infinity" + +max# :: Double# -> Double# -> Double# +max# a b | isTrue# (a >## b) = a + | otherwise = b +{-# INLINE max# #-} + +sign# :: Double# -> Double# +sign# a | isTrue# (a >## 0.0##) = 1.0## + | isTrue# (a <## 0.0##) = negateDouble# 1.0## + | otherwise = 0.0## +{-# INLINE sign# #-} + +ix :: PrimArray Double a => Int# -> a -> Double# +ix i a = case ix# i a of D# r -> r +{-# INLINE ix #-} + +-------------------------------------------------------------------------- +-- Num +-------------------------------------------------------------------------- + +instance Num QDouble where + QDouble a + QDouble b + = QDouble (a + b) + {-# INLINE (+) #-} + QDouble a - QDouble b + = QDouble (a - b) + {-# INLINE (-) #-} + QDouble (DoubleX4# a1 a2 a3 a4) * QDouble (DoubleX4# b1 b2 b3 b4) + = QDouble + ( DoubleX4# + ((a4 *## b1) +## + (a1 *## b4) +## + (a2 *## b3) -## + (a3 *## b2) + ) + ((a4 *## b2) -## + (a1 *## b3) +## + (a2 *## b4) +## + (a3 *## b1) + ) + ((a4 *## b3) +## + (a1 *## b2) -## + (a2 *## b1) +## + (a3 *## b4) + ) + ((a4 *## b4) -## + (a1 *## b1) -## + (a2 *## b2) -## + (a3 *## b3) + ) + ) + {-# INLINE (*) #-} + negate (QDouble a) = QDouble (negate a) + {-# INLINE negate #-} + abs q = QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# (qdot q))) + {-# INLINE abs #-} + signum q@(QDouble (DoubleX4# x y z w)) + = case qdot q of + 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## 0.0##) + qd -> case 1.0## /## sqrtDouble# qd of + s -> QDouble + ( DoubleX4# + (x *## s) + (y *## s) + (z *## s) + (w *## s) + ) + {-# INLINE signum #-} + fromInteger n = case fromInteger n of + D# x -> QDouble (DoubleX4# 0.0## 0.0## 0.0## x) + {-# INLINE fromInteger #-} + + + +-------------------------------------------------------------------------- +-- Fractional +-------------------------------------------------------------------------- + +instance Fractional QDouble where + {-# INLINE recip #-} + recip q@(QDouble (DoubleX4# x y z w)) = case -1.0## /## qdot q of + c -> QDouble + ( DoubleX4# + (x *## c) + (y *## c) + (z *## c) + (negateDouble# (w *## c)) + ) + {-# INLINE (/) #-} + a / b = a * recip b + {-# INLINE fromRational #-} + fromRational q = case fromRational q of + D# x -> QDouble (DoubleX4# 0.0## 0.0## 0.0## x) + +-------------------------------------------------------------------------- +-- Doubleing +-------------------------------------------------------------------------- + +instance Floating QDouble where + {-# INLINE pi #-} + pi = QDouble (DoubleX4# 0.0## 0.0## 0.0## + 3.141592653589793##) + {-# INLINE exp #-} + exp (QDouble (DoubleX4# x y z w)) + = case (# (x *## x) +## + (y *## y) +## + (z *## z) + , expDouble# w + #) of + (# 0.0##, et #) -> QDouble (DoubleX4# 0.0## 0.0## 0.0## et) + (# mv2, et #) -> case sqrtDouble# mv2 of + mv -> case et *## sinDouble# mv + /## mv of + l -> QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (et *## cosDouble# mv) + ) + {-# INLINE log #-} + log (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> if isTrue# (w >=## 0.0##) + then QDouble (DoubleX4# 0.0## 0.0## 0.0## (logDouble# w)) + else QDouble (DoubleX4# 3.141592653589793## 0.0## 0.0## + (logDouble# (negateDouble# w))) + mv2 -> case (# sqrtDouble# (mv2 +## (w *## w)) + , sqrtDouble# mv2 + #) of + (# mq, mv #) -> case atan2 (D# mv) (D# w) / D# mv of + D# l -> QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (logDouble# mq) + ) + {-# INLINE sqrt #-} + sqrt (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> if isTrue# (w >=## 0.0##) + then QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# w)) + else QDouble (DoubleX4# (sqrtDouble# (negateDouble# w)) 0.0## 0.0## 0.0##) + mv2 -> + let mq = sqrtDouble# (mv2 +## w *## w) + l2 = sqrtDouble# mq + tq = w /## (mq *## 2.0##) + sina = sqrtDouble# (0.5## -## tq) *## l2 /## sqrtDouble# mv2 + in QDouble + ( DoubleX4# + (x *## sina) + (y *## sina) + (z *## sina) + (sqrtDouble# (0.5## +## tq) *## l2) + ) + {-# INLINE sin #-} + sin (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (sinDouble# w)) + mv2 -> case sqrtDouble# mv2 of + mv -> case cosDouble# w *## sinhDouble# mv + /## mv of + l -> QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (sinDouble# w *## coshDouble# mv) + ) + {-# INLINE cos #-} + cos (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (cosDouble# w)) + mv2 -> case sqrtDouble# mv2 of + mv -> case sinDouble# w *## sinhDouble# mv + /## negateDouble# mv of + l -> QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (cosDouble# w *## coshDouble# mv) + ) + {-# INLINE tan #-} + tan (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (tanDouble# w)) + mv2 -> + let mv = sqrtDouble# mv2 + chv = coshDouble# mv + shv = sinhDouble# mv + ct = cosDouble# w + st = sinDouble# w + cq = 1.0## /## + ( (ct *## ct *## chv *## chv) + +## + (st *## st *## shv *## shv) + ) + l = chv *## shv *## cq + /## mv + in QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (ct *## st *## cq) + ) + {-# INLINE sinh #-} + sinh (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (sinhDouble# w)) + mv2 -> case sqrtDouble# mv2 of + mv -> case coshDouble# w *## sinDouble# mv + /## mv of + l -> QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (sinhDouble# w *## cosDouble# mv) + ) + {-# INLINE cosh #-} + cosh (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (coshDouble# w)) + mv2 -> case sqrtDouble# mv2 of + mv -> case sinhDouble# w *## sinDouble# mv + /## mv of + l -> QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (coshDouble# w *## cosDouble# mv) + ) + {-# INLINE tanh #-} + tanh (QDouble (DoubleX4# x y z w)) + = case (x *## x) +## + (y *## y) +## + (z *## z) of + 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (tanhDouble# w)) + mv2 -> + let mv = sqrtDouble# mv2 + cv = cosDouble# mv + sv = sinDouble# mv + cht = coshDouble# w + sht = sinhDouble# w + cq = 1.0## /## + ( (cht *## cht *## cv *## cv) + +## + (sht *## sht *## sv *## sv) + ) + l = cv *## sv *## cq + /## mv + in QDouble + ( DoubleX4# + (x *## l) + (y *## l) + (z *## l) + (cht *## sht *## cq) + ) + {-# INLINE asin #-} + asin q = -i * log (i*q + sqrt (1 - q*q)) + where + i = case signum . im $ q of + 0 -> QDouble (DoubleX4# 1.0## 0.0## 0.0## 0.0##) + i' -> i' + {-# INLINE acos #-} + acos q = pi/2 - asin q + {-# INLINE atan #-} + atan q@(QDouble (DoubleX4# _ _ _ w)) + = if square imq == 0 + then QDouble (DoubleX4# 0.0## 0.0## 0.0## (atanDouble# w)) + else i / 2 * log ( (i + q) / (i - q) ) + where + i = signum imq + imq = im q + {-# INLINE asinh #-} + asinh q = log (q + sqrt (q*q + 1)) + {-# INLINE acosh #-} + acosh q = log (q + sqrt (q*q - 1)) + {-# INLINE atanh #-} + atanh q = 0.5 * log ((1+q)/(1-q)) + +-------------------------------------------------------------------------- +-- Eq +-------------------------------------------------------------------------- + +instance Eq QDouble where + {-# INLINE (==) #-} + QDouble a == QDouble b = a == b + {-# INLINE (/=) #-} + QDouble a /= QDouble b = a /= b + + + +-------------------------------------------------------------------------- +-- Show +-------------------------------------------------------------------------- + +instance Show QDouble where + show (QDouble (DoubleX4# x y z w)) = + show (D# w) ++ ss x ++ "i" + ++ ss y ++ "j" + ++ ss z ++ "k" + where + ss a# = case D# a# of + a -> if a >= 0 then " + " ++ show a + else " - " ++ show (negate a) diff --git a/src/Numeric/Quaternion/QFloat.hs b/src/Numeric/Quaternion/QFloat.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Quaternion/QFloat.hs @@ -0,0 +1,579 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Numeric.Quaternion.QFloat + ( QFloat, Quater (..) + ) where + +import Data.Coerce (coerce) +import GHC.Exts + +import qualified Control.Monad.ST as ST +import Numeric.DataFrame.Internal.Array.Class +import Numeric.DataFrame.Internal.Array.Family.FloatX3 +import Numeric.DataFrame.Internal.Array.Family.FloatX4 +import qualified Numeric.DataFrame.ST as ST +import Numeric.DataFrame.Type +import Numeric.Dimensions +import qualified Numeric.Dimensions.Fold as ST +import Numeric.PrimBytes (PrimBytes) +import Numeric.Quaternion.Class +import Numeric.Scalar +import Numeric.Vector + + +type QFloat = Quater Float + +deriving instance PrimBytes (Quater Float) +deriving instance PrimArray Float (Quater Float) + +instance Quaternion Float where + newtype Quater Float = QFloat FloatX4 + {-# INLINE packQ #-} + packQ (F# x) (F# y) (F# z) (F# w) = QFloat (FloatX4# x y z w) + {-# INLINE unpackQ #-} + unpackQ (QFloat (FloatX4# x y z w)) = (F# x, F# y, F# z, F# w) + {-# INLINE fromVecNum #-} + fromVecNum (SingleFrame (FloatX3# x y z)) (F# w) = QFloat (FloatX4# x y z w) + {-# INLINE fromVec4 #-} + fromVec4 = coerce + {-# INLINE toVec4 #-} + toVec4 = coerce + {-# INLINE square #-} + square q = F# (qdot q) + {-# INLINE im #-} + im (QFloat (FloatX4# x y z _)) = QFloat (FloatX4# x y z 0.0#) + {-# INLINE re #-} + re (QFloat (FloatX4# _ _ _ w)) = QFloat (FloatX4# 0.0# 0.0# 0.0# w) + {-# INLINE imVec #-} + imVec (QFloat (FloatX4# x y z _)) = SingleFrame (FloatX3# x y z) + {-# INLINE taker #-} + taker (QFloat (FloatX4# _ _ _ w)) = F# w + {-# INLINE takei #-} + takei (QFloat (FloatX4# x _ _ _)) = F# x + {-# INLINE takej #-} + takej (QFloat (FloatX4# _ y _ _)) = F# y + {-# INLINE takek #-} + takek (QFloat (FloatX4# _ _ z _)) = F# z + {-# INLINE conjugate #-} + conjugate (QFloat (FloatX4# x y z w)) = QFloat (FloatX4# + (negateFloat# x) + (negateFloat# y) + (negateFloat# z) w) + {-# INLINE rotScale #-} + rotScale (QFloat (FloatX4# i j k t)) + (SingleFrame (FloatX3# x y z)) + = let l = t*%t -% i*%i -% j*%j -% k*%k + d = 2.0# *% ( i*%x +% j*%y +% k*%z) + t2 = t *% 2.0# + in SingleFrame + ( FloatX3# + (l*%x +% d*%i +% t2 *% (z*%j -% y*%k)) + (l*%y +% d*%j +% t2 *% (x*%k -% z*%i)) + (l*%z +% d*%k +% t2 *% (y*%i -% x*%j)) + ) + {-# INLINE getRotScale #-} + getRotScale _ (SingleFrame (FloatX3# 0.0# 0.0# 0.0#)) + = QFloat (FloatX4# 0.0# 0.0# 0.0# 0.0#) + getRotScale (SingleFrame (FloatX3# 0.0# 0.0# 0.0#)) _ + = case infty of F# x -> QFloat (FloatX4# x x x x) + getRotScale a@(SingleFrame (FloatX3# a1 a2 a3)) + b@(SingleFrame (FloatX3# b1 b2 b3)) + = let ma = sqrtFloat# (a1*%a1 +% a2*%a2 +% a3*%a3) + mb = sqrtFloat# (b1*%b1 +% b2*%b2 +% b3*%b3) + d = a1*%b1 +% a2*%b2 +% a3*%b3 + c = sqrtFloat# (ma*%mb +% d) + ma2 = ma *% sqrtFloat# 2.0# + r = 1.0# /% (ma2 *% c) + in case cross a b of + SingleFrame (FloatX3# 0.0# 0.0# 0.0#) -> + if isTrue# (gtFloat# d 0.0#) + then QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# (mb /% ma))) + -- Shall we move result from k to i component? + else QFloat (FloatX4# 0.0# 0.0# (sqrtFloat# (mb /% ma)) 0.0#) + SingleFrame (FloatX3# t1 t2 t3) -> QFloat + ( FloatX4# + (t1 *% r) + (t2 *% r) + (t3 *% r) + (c /% ma2) + ) + {-# INLINE axisRotation #-} + axisRotation (SingleFrame (FloatX3# 0.0# 0.0# 0.0#)) _ + = QFloat (FloatX4# 0.0# 0.0# 0.0# 1.0#) + axisRotation (SingleFrame (FloatX3# x y z)) (F# a) + = let c = cosFloat# (a *% 0.5#) + s = sinFloat# (a *% 0.5#) + /% sqrtFloat# (x*%x +% y*%y +% z*%z) + in QFloat + ( FloatX4# + (x *% s) + (y *% s) + (z *% s) + c + ) + {-# INLINE qArg #-} + qArg (QFloat (FloatX4# x y z w)) + = case atan2 (F# (sqrtFloat# (x*%x +% y*%y +% z*%z))) + (F# w) of + F# a -> F# (a *% 2.0#) + {-# INLINE fromMatrix33 #-} + fromMatrix33 m + = let d = powerFloat# + ( ix 0# m *% ( ix 4# m *% ix 8# m -% ix 5# m *% ix 7# m ) + -% ix 1# m *% ( ix 3# m *% ix 8# m -% ix 5# m *% ix 6# m ) + +% ix 2# m *% ( ix 3# m *% ix 7# m -% ix 4# m *% ix 6# m ) + ) 0.33333333333333333333333333333333# + in QFloat + ( FloatX4# + (sqrtFloat# (max# 0.0# (d +% ix 0# m -% ix 4# m -% ix 8# m )) *% sign# (ix 5# m -% ix 7# m) *% 0.5#) + (sqrtFloat# (max# 0.0# (d -% ix 0# m +% ix 4# m -% ix 8# m )) *% sign# (ix 6# m -% ix 2# m) *% 0.5#) + (sqrtFloat# (max# 0.0# (d -% ix 0# m -% ix 4# m +% ix 8# m )) *% sign# (ix 1# m -% ix 3# m) *% 0.5#) + (sqrtFloat# (max# 0.0# (d +% ix 0# m +% ix 4# m +% ix 8# m )) *% 0.5#) + ) + {-# INLINE fromMatrix44 #-} + fromMatrix44 m + = let d = powerFloat# + ( ix 0# m *% ( ix 5# m *% ix 10# m -% ix 6# m *% ix 9# m ) + -% ix 1# m *% ( ix 4# m *% ix 10# m -% ix 6# m *% ix 8# m ) + +% ix 2# m *% ( ix 4# m *% ix 9# m -% ix 5# m *% ix 8# m ) + ) 0.33333333333333333333333333333333# + c = 0.5# /% ix 15# m + in QFloat + ( FloatX4# + (sqrtFloat# (max# 0.0# (d +% ix 0# m -% ix 5# m -% ix 10# m )) *% sign# (ix 6# m -% ix 9# m) *% c) + (sqrtFloat# (max# 0.0# (d -% ix 0# m +% ix 5# m -% ix 10# m )) *% sign# (ix 8# m -% ix 2# m) *% c) + (sqrtFloat# (max# 0.0# (d -% ix 0# m -% ix 5# m +% ix 10# m )) *% sign# (ix 1# m -% ix 4# m) *% c) + (sqrtFloat# (max# 0.0# (d +% ix 0# m +% ix 5# m +% ix 10# m )) *% c) + ) + {-# INLINE toMatrix33 #-} + toMatrix33 (QFloat (FloatX4# 0.0# 0.0# 0.0# w)) + = let x = F# (w *% w) + f 0 = (# 3 :: Int , x #) + f k = (# k-1, 0 #) + in case gen# 9# f 0 of + (# _, m #) -> m -- diag (scalar (F# (w *% w))) + toMatrix33 (QFloat (FloatX4# x' y' z' w')) = + let x = scalar (F# x') + y = scalar (F# y') + z = scalar (F# z') + w = scalar (F# w') + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) + ST.unsafeFreezeDataFrame df + {-# INLINE toMatrix44 #-} + toMatrix44 (QFloat (FloatX4# 0.0# 0.0# 0.0# w)) = ST.runST $ do + df <- ST.newDataFrame + ST.overDimOff_ (dims :: Dims '[4,4]) (\i -> ST.writeDataFrameOff df i 0) 0 1 + let w2 = scalar (F# (w *% w)) + ST.writeDataFrameOff df 0 w2 + ST.writeDataFrameOff df 5 w2 + ST.writeDataFrameOff df 10 w2 + ST.writeDataFrameOff df 15 1 + ST.unsafeFreezeDataFrame df + toMatrix44 (QFloat (FloatX4# x' y' z' w')) = + let x = scalar (F# x') + y = scalar (F# y') + z = scalar (F# z') + w = scalar (F# w') + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 0 + ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 7 0 + ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) + ST.writeDataFrameOff df 11 0 + ST.writeDataFrameOff df 12 0 + ST.writeDataFrameOff df 13 0 + ST.writeDataFrameOff df 14 0 + ST.writeDataFrameOff df 15 0 + ST.unsafeFreezeDataFrame df + +qdot :: QFloat -> Float# +qdot (QFloat (FloatX4# x y z w)) = (x *% x) +% + (y *% y) +% + (z *% z) +% + (w *% w) +{-# INLINE qdot #-} + +(*%) :: Float# -> Float# -> Float# +(*%) = timesFloat# +{-# INLINE (*%) #-} +infixl 7 *% + +(-%) :: Float# -> Float# -> Float# +(-%) = minusFloat# +{-# INLINE (-%) #-} +infixl 6 -% + +(+%) :: Float# -> Float# -> Float# +(+%) = plusFloat# +{-# INLINE (+%) #-} +infixl 6 +% + +(/%) :: Float# -> Float# -> Float# +(/%) = divideFloat# +{-# INLINE (/%) #-} +infixl 7 /% + +infty :: Float +infty = read "Infinity" + +max# :: Float# -> Float# -> Float# +max# a b | isTrue# (gtFloat# a b) = a + | otherwise = b +{-# INLINE max# #-} + +sign# :: Float# -> Float# +sign# a | isTrue# (gtFloat# a 0.0#) = 1.0# + | isTrue# (ltFloat# a 0.0#) = negateFloat# 1.0# + | otherwise = 0.0# +{-# INLINE sign# #-} + +ix :: PrimArray Float a => Int# -> a -> Float# +ix i a = case ix# i a of F# r -> r +{-# INLINE ix #-} + +-------------------------------------------------------------------------- +-- Num +-------------------------------------------------------------------------- + +instance Num QFloat where + QFloat a + QFloat b + = QFloat (a + b) + {-# INLINE (+) #-} + QFloat a - QFloat b + = QFloat (a - b) + {-# INLINE (-) #-} + QFloat (FloatX4# a1 a2 a3 a4) * QFloat (FloatX4# b1 b2 b3 b4) + = QFloat + ( FloatX4# + ((a4 *% b1) +% + (a1 *% b4) +% + (a2 *% b3) -% + (a3 *% b2) + ) + ((a4 *% b2) -% + (a1 *% b3) +% + (a2 *% b4) +% + (a3 *% b1) + ) + ((a4 *% b3) +% + (a1 *% b2) -% + (a2 *% b1) +% + (a3 *% b4) + ) + ((a4 *% b4) -% + (a1 *% b1) -% + (a2 *% b2) -% + (a3 *% b3) + ) + ) + {-# INLINE (*) #-} + negate (QFloat a) = QFloat (negate a) + {-# INLINE negate #-} + abs q = QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# (qdot q))) + {-# INLINE abs #-} + signum q@(QFloat (FloatX4# x y z w)) + = case qdot q of + 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# 0.0#) + qd -> case 1.0# /% sqrtFloat# qd of + s -> QFloat + ( FloatX4# + (x *% s) + (y *% s) + (z *% s) + (w *% s) + ) + {-# INLINE signum #-} + fromInteger n = case fromInteger n of + F# x -> QFloat (FloatX4# 0.0# 0.0# 0.0# x) + {-# INLINE fromInteger #-} + + + +-------------------------------------------------------------------------- +-- Fractional +-------------------------------------------------------------------------- + +instance Fractional QFloat where + {-# INLINE recip #-} + recip q@(QFloat (FloatX4# x y z w)) = case -1.0# /% qdot q of + c -> QFloat + ( FloatX4# + (x *% c) + (y *% c) + (z *% c) + (negateFloat# (w *% c)) + ) + {-# INLINE (/) #-} + a / b = a * recip b + {-# INLINE fromRational #-} + fromRational q = case fromRational q of + F# x -> QFloat (FloatX4# 0.0# 0.0# 0.0# x) + +-------------------------------------------------------------------------- +-- Floating +-------------------------------------------------------------------------- + +instance Floating QFloat where + {-# INLINE pi #-} + pi = QFloat (FloatX4# 0.0# 0.0# 0.0# + 3.141592653589793#) + {-# INLINE exp #-} + exp (QFloat (FloatX4# x y z w)) + = case (# (x *% x) +% + (y *% y) +% + (z *% z) + , expFloat# w + #) of + (# 0.0#, et #) -> QFloat (FloatX4# 0.0# 0.0# 0.0# et) + (# mv2, et #) -> case sqrtFloat# mv2 of + mv -> case et *% sinFloat# mv + /% mv of + l -> QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (et *% cosFloat# mv) + ) + {-# INLINE log #-} + log (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> if isTrue# (w `geFloat#` 0.0#) + then QFloat (FloatX4# 0.0# 0.0# 0.0# (logFloat# w)) + else QFloat (FloatX4# 3.141592653589793# 0.0# 0.0# + (logFloat# (negateFloat# w))) + mv2 -> case (# sqrtFloat# (mv2 +% (w *% w)) + , sqrtFloat# mv2 + #) of + (# mq, mv #) -> case atan2 (F# mv) (F# w) / F# mv of + F# l -> QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (logFloat# mq) + ) + {-# INLINE sqrt #-} + sqrt (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> if isTrue# (w `geFloat#` 0.0#) + then QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# w)) + else QFloat (FloatX4# (sqrtFloat# (negateFloat# w)) 0.0# 0.0# 0.0#) + mv2 -> + let mq = sqrtFloat# (mv2 +% w *% w) + l2 = sqrtFloat# mq + tq = w /% (mq *% 2.0#) + sina = sqrtFloat# (0.5# -% tq) *% l2 /% sqrtFloat# mv2 + in QFloat + ( FloatX4# + (x *% sina) + (y *% sina) + (z *% sina) + (sqrtFloat# (0.5# +% tq) *% l2) + ) + {-# INLINE sin #-} + sin (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (sinFloat# w)) + mv2 -> case sqrtFloat# mv2 of + mv -> case cosFloat# w *% sinhFloat# mv + /% mv of + l -> QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (sinFloat# w *% coshFloat# mv) + ) + {-# INLINE cos #-} + cos (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (cosFloat# w)) + mv2 -> case sqrtFloat# mv2 of + mv -> case sinFloat# w *% sinhFloat# mv + /% negateFloat# mv of + l -> QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (cosFloat# w *% coshFloat# mv) + ) + {-# INLINE tan #-} + tan (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (tanFloat# w)) + mv2 -> + let mv = sqrtFloat# mv2 + chv = coshFloat# mv + shv = sinhFloat# mv + ct = cosFloat# w + st = sinFloat# w + cq = 1.0# /% + ( (ct *% ct *% chv *% chv) + +% + (st *% st *% shv *% shv) + ) + l = chv *% shv *% cq + /% mv + in QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (ct *% st *% cq) + ) + {-# INLINE sinh #-} + sinh (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (sinhFloat# w)) + mv2 -> case sqrtFloat# mv2 of + mv -> case coshFloat# w *% sinFloat# mv + /% mv of + l -> QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (sinhFloat# w *% cosFloat# mv) + ) + {-# INLINE cosh #-} + cosh (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (coshFloat# w)) + mv2 -> case sqrtFloat# mv2 of + mv -> case sinhFloat# w *% sinFloat# mv + /% mv of + l -> QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (coshFloat# w *% cosFloat# mv) + ) + {-# INLINE tanh #-} + tanh (QFloat (FloatX4# x y z w)) + = case (x *% x) +% + (y *% y) +% + (z *% z) of + 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (tanhFloat# w)) + mv2 -> + let mv = sqrtFloat# mv2 + cv = cosFloat# mv + sv = sinFloat# mv + cht = coshFloat# w + sht = sinhFloat# w + cq = 1.0# /% + ( (cht *% cht *% cv *% cv) + +% + (sht *% sht *% sv *% sv) + ) + l = cv *% sv *% cq + /% mv + in QFloat + ( FloatX4# + (x *% l) + (y *% l) + (z *% l) + (cht *% sht *% cq) + ) + {-# INLINE asin #-} + asin q = -i * log (i*q + sqrt (1 - q*q)) + where + i = case signum . im $ q of + 0 -> QFloat (FloatX4# 1.0# 0.0# 0.0# 0.0#) + i' -> i' + {-# INLINE acos #-} + acos q = pi/2 - asin q + {-# INLINE atan #-} + atan q@(QFloat (FloatX4# _ _ _ w)) + = if square imq == 0 + then QFloat (FloatX4# 0.0# 0.0# 0.0# (atanFloat# w)) + else i / 2 * log ( (i + q) / (i - q) ) + where + i = signum imq + imq = im q + {-# INLINE asinh #-} + asinh q = log (q + sqrt (q*q + 1)) + {-# INLINE acosh #-} + acosh q = log (q + sqrt (q*q - 1)) + {-# INLINE atanh #-} + atanh q = 0.5 * log ((1+q)/(1-q)) + +-------------------------------------------------------------------------- +-- Eq +-------------------------------------------------------------------------- + +instance Eq QFloat where + {-# INLINE (==) #-} + QFloat a == QFloat b = a == b + {-# INLINE (/=) #-} + QFloat a /= QFloat b = a /= b + + + +-------------------------------------------------------------------------- +-- Show +-------------------------------------------------------------------------- + +instance Show QFloat where + show (QFloat (FloatX4# x y z w)) = + show (F# w) ++ ss x ++ "i" + ++ ss y ++ "j" + ++ ss z ++ "k" + where + ss a# = case F# a# of + a -> if a >= 0 then " + " ++ show a + else " - " ++ show (negate a) diff --git a/src/Numeric/Scalar.hs b/src/Numeric/Scalar.hs --- a/src/Numeric/Scalar.hs +++ b/src/Numeric/Scalar.hs @@ -1,35 +1,41 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Scalar --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonoLocalBinds #-} +-- | Scalar is an alias to zero-dimensional DataFrame module Numeric.Scalar - ( Scalar, unScalar, scalar - , Scf, Scd + ( Scalar, unScalar, scalar, fromScalar + , Scf, Scd, Sci, Scw ) where -import qualified Numeric.Array.Family as AFam -import Numeric.DataFrame.Type -import Numeric.Dimensions (Nat) +import GHC.Base (unsafeCoerce#) +import Numeric.DataFrame.Family (DataFrame) +import Numeric.DataFrame.SubSpace (SubSpace (ewgen)) +import Numeric.Dim (Nat) -- | Alias for zero-dimensional DataFrame type Scalar t = DataFrame t ('[] :: [Nat]) type Scf = Scalar Float type Scd = Scalar Double +type Sci = Scalar Int +type Scw = Scalar Word -- | Convert scalar back to ordinary type unScalar :: Scalar t -> t -unScalar = AFam._unScalar . _getDF +-- rely on that Scalar is just two times newtype alias to t +unScalar = unsafeCoerce# +{-# INLINE unScalar #-} -- | Convert any type to scalar wrapper scalar :: t -> Scalar t -scalar = KnownDataFrame . AFam.Scalar +-- rely on that Scalar is just two times newtype alias to t +scalar = unsafeCoerce# +{-# INLINE scalar #-} + +-- | Broadcast scalar value onto a whole data frame +fromScalar :: SubSpace t '[] ds ds + => Scalar t -> DataFrame t ds +fromScalar = ewgen +{-# INLINE fromScalar #-} diff --git a/src/Numeric/Tuple.hs b/src/Numeric/Tuple.hs deleted file mode 100644 --- a/src/Numeric/Tuple.hs +++ /dev/null @@ -1,566 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Tuple --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- This module defines a set of tuple data types to substitute normal Haskell tuples. --- The reason is that @Monoid@ instances of normal tuples are lazy, --- which makes folds with arithmetic operations leak memory. --- @Semigroup@ and @Monoid@ instances of tuples in this module are strict in all their arguments. --- --- Using tuple types defined here together with @Numeric.Semigroup.foldMap'@, --- one can combine multiple monoidal fold structures in a single pass over a foldable container: --- --- >> foldMap' (T3 <$> Max <*> Sum <*> Min) $ take 100000000 ([1..] :: [Int]) --- --- The example above runs in constant space, which would not happen with normal --- GHC tuples due to strictness properties of their `mappend` implementations --- (tuple arguments are not enforced). --- --- ------------------------------------------------------------------------------ -module Numeric.Tuple - ( T0 (..), T1 (..), T2 (..), T3 (..), T4 (..) - , T5 (..), T6 (..), T7 (..), T8 (..), T9 (..) - , AsTuple (..) - , foldMap' - ) where - -import Data.Bifunctor -import Data.Coerce (coerce) -import Data.Data -import GHC.Generics -import Numeric.Semigroup - -data T0 = T0 - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic) -newtype T1 a = T1 a - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T2 a b = T2 a b - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T3 a b c = T3 a b c - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T4 a b c d = T4 a b c d - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T5 a b c d e = T5 a b c d e - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T6 a b c d e f = T6 a b c d e f - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T7 a b c d e f g = T7 a b c d e f g - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T8 a b c d e f g h = T8 a b c d e f g h - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) -data T9 a b c d e f g h i = T9 a b c d e f g h i - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic, Generic1) - - --- | This function is exactly the same as @($!)@ defined in GHC.Base, --- but it is left-associative, which makes it possible to apply --- several arguments to one function strictly. -(!$) :: (a -> b) -> a -> b -f !$ x = let !vx = x in f vx -infixl 1 !$ -{-# INLINE (!$) #-} - -instance Semigroup T0 where - _ <> _ = T0 -instance Semigroup a => Semigroup (T1 a) where - (<>) = coerce ((<>) :: a -> a -> a) -instance ( Semigroup a - , Semigroup b - ) => Semigroup (T2 a b) where - (T2 !ax !bx) <> (T2 !ay !by) = T2 !$ ax <> ay !$ bx <> by -instance ( Semigroup a - , Semigroup b - , Semigroup c - ) => Semigroup (T3 a b c) where - (T3 !ax !bx !cx) <> (T3 !ay !by !cy) - = T3 !$ ax <> ay !$ bx <> by !$ cx <> cy -instance ( Semigroup a - , Semigroup b - , Semigroup c - , Semigroup d - ) => Semigroup (T4 a b c d) where - (T4 !ax !bx !cx !dx) <> (T4 !ay !by !cy !dy) - = T4 !$ ax <> ay !$ bx <> by !$ cx <> cy !$ dx <> dy -instance ( Semigroup a - , Semigroup b - , Semigroup c - , Semigroup d - , Semigroup e - ) => Semigroup (T5 a b c d e) where - (T5 !ax !bx !cx !dx !ex) <> (T5 !ay !by !cy !dy !ey) - = T5 !$ ax <> ay !$ bx <> by !$ cx <> cy !$ dx <> dy !$ ex <> ey -instance ( Semigroup a - , Semigroup b - , Semigroup c - , Semigroup d - , Semigroup e - , Semigroup f - ) => Semigroup (T6 a b c d e f) where - (T6 !ax !bx !cx !dx !ex !fx) <> (T6 !ay !by !cy !dy !ey !fy) - = T6 !$ ax <> ay !$ bx <> by !$ cx <> cy !$ dx <> dy !$ ex <> ey !$ fx <> fy -instance ( Semigroup a - , Semigroup b - , Semigroup c - , Semigroup d - , Semigroup e - , Semigroup f - , Semigroup g - ) => Semigroup (T7 a b c d e f g) where - (T7 !ax !bx !cx !dx !ex !fx !gx) <> (T7 !ay !by !cy !dy !ey !fy !gy) - = T7 !$ ax <> ay !$ bx <> by !$ cx <> cy !$ dx <> dy !$ ex <> ey !$ fx <> fy !$ gx <> gy -instance ( Semigroup a - , Semigroup b - , Semigroup c - , Semigroup d - , Semigroup e - , Semigroup f - , Semigroup g - , Semigroup h - ) => Semigroup (T8 a b c d e f g h) where - (T8 !ax !bx !cx !dx !ex !fx !gx !hx) <> (T8 !ay !by !cy !dy !ey !fy !gy !hy) - = T8 !$ ax <> ay !$ bx <> by !$ cx <> cy !$ dx <> dy !$ ex <> ey !$ fx <> fy !$ gx <> gy !$ hx <> hy -instance ( Semigroup a - , Semigroup b - , Semigroup c - , Semigroup d - , Semigroup e - , Semigroup f - , Semigroup g - , Semigroup h - , Semigroup i - ) => Semigroup (T9 a b c d e f g h i) where - (T9 !ax !bx !cx !dx !ex !fx !gx !hx !ix) <> (T9 !ay !by !cy !dy !ey !fy !gy !hy !iy) - = T9 !$ ax <> ay !$ bx <> by !$ cx <> cy !$ dx <> dy !$ ex <> ey !$ fx <> fy !$ gx <> gy !$ hx <> hy !$ ix <> iy - - - -instance Monoid T0 where - mempty = T0 - mappend _ _ = T0 -instance Monoid a => Monoid (T1 a) where - mempty = T1 !$ mempty - mappend = coerce (mappend :: a -> a -> a) -instance ( Monoid a - , Monoid b - ) => Monoid (T2 a b) where - mempty = T2 !$ mempty !$ mempty - mappend (T2 !ax !bx) (T2 !ay !by) = T2 !$ mappend ax ay !$ mappend bx by -instance ( Monoid a - , Monoid b - , Monoid c - ) => Monoid (T3 a b c) where - mempty = T3 !$ mempty !$ mempty !$ mempty - mappend (T3 !ax !bx !cx) (T3 !ay !by !cy) - = T3 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - ) => Monoid (T4 a b c d) where - mempty = T4 !$ mempty !$ mempty !$ mempty !$ mempty - mappend (T4 !ax !bx !cx !dx) (T4 !ay !by !cy !dy) - = T4 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - ) => Monoid (T5 a b c d e) where - mempty = T5 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - mappend (T5 !ax !bx !cx !dx !ex) (T5 !ay !by !cy !dy !ey) - = T5 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy !$ mappend ex ey -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - , Monoid f - ) => Monoid (T6 a b c d e f) where - mempty = T6 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - mappend (T6 !ax !bx !cx !dx !ex !fx) (T6 !ay !by !cy !dy !ey !fy) - = T6 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy !$ mappend ex ey !$ mappend fx fy -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - , Monoid f - , Monoid g - ) => Monoid (T7 a b c d e f g) where - mempty = T7 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - mappend (T7 !ax !bx !cx !dx !ex !fx !gx) (T7 !ay !by !cy !dy !ey !fy !gy) - = T7 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy !$ mappend ex ey - !$ mappend fx fy !$ mappend gx gy -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - , Monoid f - , Monoid g - , Monoid h - ) => Monoid (T8 a b c d e f g h) where - mempty = T8 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - mappend (T8 !ax !bx !cx !dx !ex !fx !gx !hx) (T8 !ay !by !cy !dy !ey !fy !gy !hy) - = T8 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy !$ mappend ex ey - !$ mappend fx fy !$ mappend gx gy !$ mappend hx hy -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - , Monoid f - , Monoid g - , Monoid h - , Monoid i - ) => Monoid (T9 a b c d e f g h i) where - mempty = T9 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - mappend (T9 !ax !bx !cx !dx !ex !fx !gx !hx !ix) (T9 !ay !by !cy !dy !ey !fy !gy !hy !iy) - = T9 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy !$ mappend ex ey - !$ mappend fx fy !$ mappend gx gy !$ mappend hx hy !$ mappend ix iy - - -instance Functor T1 where - fmap = coerce -instance Functor (T2 a) where - fmap fun ~(T2 a b) = T2 a (fun b) -instance Functor (T3 a b) where - fmap fun ~(T3 a b c) = T3 a b (fun c) -instance Functor (T4 a b c) where - fmap fun ~(T4 a b c d) = T4 a b c (fun d) -instance Functor (T5 a b c d) where - fmap fun ~(T5 a b c d e) = T5 a b c d (fun e) -instance Functor (T6 a b c d e) where - fmap fun ~(T6 a b c d e f) = T6 a b c d e (fun f) -instance Functor (T7 a b c d e f) where - fmap fun ~(T7 a b c d e f g) = T7 a b c d e f (fun g) -instance Functor (T8 a b c d e f g) where - fmap fun ~(T8 a b c d e f g h) = T8 a b c d e f g (fun h) -instance Functor (T9 a b c d e f g h) where - fmap fun ~(T9 a b c d e f g h i) = T9 a b c d e f g h (fun i) - -instance Applicative T1 where - pure = T1 - (<*>) = coerce -instance ( Monoid a - ) => Applicative (T2 a) where - pure = T2 !$ mempty - ~(T2 !ax fun) <*> ~(T2 !ay val) - = T2 !$ mappend ax ay $ fun val -instance ( Monoid a - , Monoid b - ) => Applicative (T3 a b) where - pure = T3 !$ mempty !$ mempty - ~(T3 !ax !bx fun) <*> ~(T3 !ay !by val) - = T3 !$ mappend ax ay !$ mappend bx by $ fun val -instance ( Monoid a - , Monoid b - , Monoid c - ) => Applicative (T4 a b c) where - pure = T4 !$ mempty !$ mempty !$ mempty - ~(T4 !ax !bx !cx fun) <*> ~(T4 !ay !by !cy val) - = T4 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy $ fun val -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - ) => Applicative (T5 a b c d) where - pure = T5 !$ mempty !$ mempty !$ mempty !$ mempty - ~(T5 !ax !bx !cx !dx fun) <*> ~(T5 !ay !by !cy !dy val) - = T5 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy $ fun val -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - ) => Applicative (T6 a b c d e) where - pure = T6 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - ~(T6 !ax !bx !cx !dx !ex fun) <*> ~(T6 !ay !by !cy !dy !ey val) - = T6 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey $ fun val -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - , Monoid f - ) => Applicative (T7 a b c d e f) where - pure = T7 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - ~(T7 !ax !bx !cx !dx !ex !fx fun) <*> ~(T7 !ay !by !cy !dy !ey !fy val) - = T7 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey !$ mappend fx fy $ fun val -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - , Monoid f - , Monoid g - ) => Applicative (T8 a b c d e f g) where - pure = T8 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - ~(T8 !ax !bx !cx !dx !ex !fx !gx fun) <*> ~(T8 !ay !by !cy !dy !ey !fy !gy val) - = T8 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey !$ mappend fx fy !$ mappend gx gy $ fun val -instance ( Monoid a - , Monoid b - , Monoid c - , Monoid d - , Monoid e - , Monoid f - , Monoid g - , Monoid h - ) => Applicative (T9 a b c d e f g h) where - pure = T9 !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty !$ mempty - ~(T9 !ax !bx !cx !dx !ex !fx !gx !hx fun) <*> ~(T9 !ay !by !cy !dy !ey !fy !gy !hy val) - = T9 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey !$ mappend fx fy !$ mappend gx gy !$ mappend hx hy $ fun val - - - -instance Monad T1 where - m >>= k = k (coerce m) -instance ( Monoid a - ) => Monad (T2 a) where - ~(T2 !ax x) >>= k = - T2 !$ mappend ax ay $ val - where - ~(T2 !ay val) = k x -instance ( Monoid a, Monoid b - ) => Monad (T3 a b) where - ~(T3 !ax !bx x) >>= k = - T3 !$ mappend ax ay !$ mappend bx by $ val - where - ~(T3 !ay !by val) = k x -instance ( Monoid a, Monoid b, Monoid c - ) => Monad (T4 a b c) where - ~(T4 !ax !bx !cx x) >>= k = - T4 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy $ val - where - ~(T4 !ay !by !cy val) = k x -instance ( Monoid a, Monoid b, Monoid c, Monoid d - ) => Monad (T5 a b c d) where - ~(T5 !ax !bx !cx !dx x) >>= k = - T5 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy $ val - where - ~(T5 !ay !by !cy !dy val) = k x -instance ( Monoid a, Monoid b, Monoid c, Monoid d - , Monoid e - ) => Monad (T6 a b c d e) where - ~(T6 !ax !bx !cx !dx !ex x) >>= k = - T6 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey $ val - where - ~(T6 !ay !by !cy !dy !ey val) = k x -instance ( Monoid a, Monoid b, Monoid c, Monoid d - , Monoid e, Monoid f - ) => Monad (T7 a b c d e f) where - ~(T7 !ax !bx !cx !dx !ex !fx x) >>= k = - T7 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey !$ mappend fx fy $ val - where - ~(T7 !ay !by !cy !dy !ey !fy val) = k x -instance ( Monoid a, Monoid b, Monoid c, Monoid d - , Monoid e, Monoid f, Monoid g - ) => Monad (T8 a b c d e f g) where - ~(T8 !ax !bx !cx !dx !ex !fx !gx x) >>= k = - T8 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey !$ mappend fx fy !$ mappend gx gy $ val - where - ~(T8 !ay !by !cy !dy !ey !fy !gy val) = k x -instance ( Monoid a, Monoid b, Monoid c, Monoid d - , Monoid e, Monoid f, Monoid g, Monoid h - ) => Monad (T9 a b c d e f g h) where - ~(T9 !ax !bx !cx !dx !ex !fx !gx !hx x) >>= k = - T9 !$ mappend ax ay !$ mappend bx by !$ mappend cx cy !$ mappend dx dy - !$ mappend ex ey !$ mappend fx fy !$ mappend gx gy !$ mappend hx hy $ val - where - ~(T9 !ay !by !cy !dy !ey !fy !gy !hy val) = k x - -instance Bounded T0 where - minBound = T0 - maxBound = T0 -instance ( Bounded a - ) => Bounded (T1 a) where - minBound = T1 !$ minBound - maxBound = T1 !$ maxBound -instance ( Bounded a, Bounded b - ) => Bounded (T2 a b) where - minBound = T2 !$ minBound !$ minBound - maxBound = T2 !$ maxBound !$ maxBound -instance ( Bounded a, Bounded b, Bounded c - ) => Bounded (T3 a b c) where - minBound = T3 !$ minBound !$ minBound !$ minBound - maxBound = T3 !$ maxBound !$ maxBound !$ maxBound -instance ( Bounded a, Bounded b, Bounded c, Bounded d - ) => Bounded (T4 a b c d) where - minBound = T4 !$ minBound !$ minBound !$ minBound !$ minBound - maxBound = T4 !$ maxBound !$ maxBound !$ maxBound !$ maxBound -instance ( Bounded a, Bounded b, Bounded c, Bounded d - , Bounded e - ) => Bounded (T5 a b c d e) where - minBound = T5 !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound - maxBound = T5 !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound -instance ( Bounded a, Bounded b, Bounded c, Bounded d - , Bounded e, Bounded f - ) => Bounded (T6 a b c d e f) where - minBound = T6 !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound - maxBound = T6 !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound -instance ( Bounded a, Bounded b, Bounded c, Bounded d - , Bounded e, Bounded f, Bounded g - ) => Bounded (T7 a b c d e f g) where - minBound = T7 !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound - maxBound = T7 !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound -instance ( Bounded a, Bounded b, Bounded c, Bounded d - , Bounded e, Bounded f, Bounded g, Bounded h - ) => Bounded (T8 a b c d e f g h) where - minBound = T8 !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound - maxBound = T8 !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound -instance ( Bounded a, Bounded b, Bounded c, Bounded d - , Bounded e, Bounded f, Bounded g, Bounded h, Bounded i - ) => Bounded (T9 a b c d e f g h i) where - minBound = T9 !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound !$ minBound - maxBound = T9 !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound !$ maxBound - -instance Foldable T1 where - foldMap = coerce - foldr f z y = f (coerce y) z -instance Foldable (T2 a) where - foldMap f ~(T2 _ x) = f x - foldr f z ~(T2 _ x) = f x z - length _ = 1 - null _ = False -instance Foldable (T3 a b) where - foldMap f ~(T3 _ _ x) = f x - foldr f z ~(T3 _ _ x) = f x z - length _ = 1 - null _ = False -instance Foldable (T4 a b c) where - foldMap f ~(T4 _ _ _ x) = f x - foldr f z ~(T4 _ _ _ x) = f x z - length _ = 1 - null _ = False -instance Foldable (T5 a b c e) where - foldMap f ~(T5 _ _ _ _ x) = f x - foldr f z ~(T5 _ _ _ _ x) = f x z - length _ = 1 - null _ = False -instance Foldable (T6 a b c d e) where - foldMap f ~(T6 _ _ _ _ _ x) = f x - foldr f z ~(T6 _ _ _ _ _ x) = f x z - length _ = 1 - null _ = False -instance Foldable (T7 a b c d e f) where - foldMap f ~(T7 _ _ _ _ _ _ x) = f x - foldr f z ~(T7 _ _ _ _ _ _ x) = f x z - length _ = 1 - null _ = False -instance Foldable (T8 a b c d e f g) where - foldMap f ~(T8 _ _ _ _ _ _ _ x) = f x - foldr f z ~(T8 _ _ _ _ _ _ _ x) = f x z - length _ = 1 - null _ = False -instance Foldable (T9 a b c d e f g h) where - foldMap f ~(T9 _ _ _ _ _ _ _ _ x) = f x - foldr f z ~(T9 _ _ _ _ _ _ _ _ x) = f x z - length _ = 1 - null _ = False - -instance Traversable T1 where - traverse f = fmap T1 . coerce f -instance Traversable (T2 a) where - traverse fun ~(T2 a b) = T2 a <$> fun b -instance Traversable (T3 a b) where - traverse fun ~(T3 a b c) = T3 a b <$> fun c -instance Traversable (T4 a b c) where - traverse fun ~(T4 a b c d) = T4 a b c <$> fun d -instance Traversable (T5 a b c d) where - traverse fun ~(T5 a b c d e) = T5 a b c d <$> fun e -instance Traversable (T6 a b c d e) where - traverse fun ~(T6 a b c d e f) = T6 a b c d e <$> fun f -instance Traversable (T7 a b c d e f) where - traverse fun ~(T7 a b c d e f g) = T7 a b c d e f <$> fun g -instance Traversable (T8 a b c d e f g) where - traverse fun ~(T8 a b c d e f g h) = T8 a b c d e f g <$> fun h -instance Traversable (T9 a b c d e f g h) where - traverse fun ~(T9 a b c d e f g h i) = T9 a b c d e f g h <$> fun i - - -instance Bifunctor T2 where - first funA ~(T2 a b) = T2 (funA a) b - second funB ~(T2 a b) = T2 a (funB b) - bimap funA funB ~(T2 a b) = T2 (funA a) (funB b) -instance Bifunctor (T3 a) where - first funA ~(T3 a b c) = T3 a (funA b) c - second funB ~(T3 a b c) = T3 a b (funB c) - bimap funA funB ~(T3 a b c) = T3 a (funA b) (funB c) -instance Bifunctor (T4 a b) where - first funA ~(T4 a b c d) = T4 a b (funA c) d - second funB ~(T4 a b c d) = T4 a b c (funB d) - bimap funA funB ~(T4 a b c d) = T4 a b (funA c) (funB d) -instance Bifunctor (T5 a b c) where - first funA ~(T5 a b c d e) = T5 a b c (funA d) e - second funB ~(T5 a b c d e) = T5 a b c d (funB e) - bimap funA funB ~(T5 a b c d e) = T5 a b c (funA d) (funB e) -instance Bifunctor (T6 a b c d) where - first funA ~(T6 a b c d e f) = T6 a b c d (funA e) f - second funB ~(T6 a b c d e f) = T6 a b c d e (funB f) - bimap funA funB ~(T6 a b c d e f) = T6 a b c d (funA e) (funB f) -instance Bifunctor (T7 a b c d e) where - first funA ~(T7 a b c d e f g) = T7 a b c d e (funA f) g - second funB ~(T7 a b c d e f g) = T7 a b c d e f (funB g) - bimap funA funB ~(T7 a b c d e f g) = T7 a b c d e (funA f) (funB g) -instance Bifunctor (T8 a b c d e f) where - first funA ~(T8 a b c d e f g h) = T8 a b c d e f (funA g) h - second funB ~(T8 a b c d e f g h) = T8 a b c d e f g (funB h) - bimap funA funB ~(T8 a b c d e f g h) = T8 a b c d e f (funA g) (funB h) -instance Bifunctor (T9 a b c d e f g) where - first funA ~(T9 a b c d e f g h i) = T9 a b c d e f g (funA h) i - second funB ~(T9 a b c d e f g h i) = T9 a b c d e f g h (funB i) - bimap funA funB ~(T9 a b c d e f g h i) = T9 a b c d e f g (funA h) (funB i) - - -class AsTuple a b | a -> b, b -> a where - toTuple :: a -> b - fromTuple :: b -> a - -instance AsTuple () T0 where - toTuple () = T0 - fromTuple T0 = () --- instance StrictTuple a (T1 a) where --- toTuple a = T1 a --- fromTuple (T1 a) = a -instance AsTuple (a,b) (T2 a b) where - toTuple (a,b) = T2 a b - fromTuple (T2 a b) = (a,b) -instance AsTuple (a,b,c) (T3 a b c) where - toTuple (a,b,c) = T3 a b c - fromTuple (T3 a b c)= (a,b,c) -instance AsTuple (a,b,c,d) (T4 a b c d) where - toTuple (a,b,c,d) = T4 a b c d - fromTuple (T4 a b c d) = (a,b,c,d) -instance AsTuple (a,b,c,d,e) (T5 a b c d e) where - toTuple (a,b,c,d,e) = T5 a b c d e - fromTuple (T5 a b c d e) = (a,b,c,d,e) -instance AsTuple (a,b,c,d,e,f) (T6 a b c d e f) where - toTuple (a,b,c,d,e,f) = T6 a b c d e f - fromTuple (T6 a b c d e f) = (a,b,c,d,e,f) -instance AsTuple (a,b,c,d,e,f,g) (T7 a b c d e f g) where - toTuple (a,b,c,d,e,f,g) = T7 a b c d e f g - fromTuple (T7 a b c d e f g) = (a,b,c,d,e,f,g) -instance AsTuple (a,b,c,d,e,f,g,h) (T8 a b c d e f g h) where - toTuple (a,b,c,d,e,f,g,h) = T8 a b c d e f g h - fromTuple (T8 a b c d e f g h) = (a,b,c,d,e,f,g,h) -instance AsTuple (a,b,c,d,e,f,g,h,i) (T9 a b c d e f g h i) where - toTuple (a,b,c,d,e,f,g,h,i) = T9 a b c d e f g h i - fromTuple (T9 a b c d e f g h i) = (a,b,c,d,e,f,g,h,i) diff --git a/src/Numeric/Vector.hs b/src/Numeric/Vector.hs --- a/src/Numeric/Vector.hs +++ b/src/Numeric/Vector.hs @@ -1,22 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Vector --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +-- | Vector is an alias to a DataFrame with order 1. module Numeric.Vector ( -- * Type aliases Vector , Vec2f, Vec3f, Vec4f, Vec2d, Vec3d, Vec4d + , Vec2i, Vec3i, Vec4i, Vec2w, Vec3w, Vec4w -- * Common operations , (.*.), dot, (·) , normL1, normL2, normLPInf, normLNInf, normLP @@ -26,16 +18,15 @@ , unpackV2, unpackV3, unpackV4 ) where -import Numeric.Array.ElementWise +import Numeric.DataFrame.SubSpace import Numeric.DataFrame.Type -import Numeric.Dimensions import Numeric.Scalar -------------------------------------------------------------------------------- -- * Vector type -------------------------------------------------------------------------------- -type Vector t (n :: Nat) = DataFrame t '[n] +type Vector (t :: l) (n :: k) = DataFrame t '[n] type Vec2f = Vector Float 2 type Vec3f = Vector Float 3 @@ -43,31 +34,37 @@ type Vec2d = Vector Double 2 type Vec3d = Vector Double 3 type Vec4d = Vector Double 4 +type Vec2i = Vector Int 2 +type Vec3i = Vector Int 3 +type Vec4i = Vector Int 4 +type Vec2w = Vector Word 2 +type Vec3w = Vector Word 3 +type Vec4w = Vector Word 4 -- | Scalar product -- sum of Vecs' components products, -- propagated into whole Vec (.*.) :: ( Num t , Num (Vector t n) - , ElementWise (Idx '[n]) t (Vector t n) + , SubSpace t '[] '[n] '[n] ) => Vector t n -> Vector t n -> Vector t n -(.*.) a b = broadcast . ewfoldl (const (+)) 0 $ a * b +(.*.) a b = fromScalar . ewfoldl (+) 0 $ a * b infixl 7 .*. -- | Scalar product -- sum of Vecs' components products -- a scalar dot :: ( Num t , Num (Vector t n) - , ElementWise (Idx '[n]) t (Vector t n) + , SubSpace t '[] '[n] '[n] ) => Vector t n -> Vector t n -> Scalar t -dot a b = scalar . ewfoldl (const (+)) 0 $ a * b +dot a b = ewfoldl (+) 0 $ a * b -- | Dot product of two vectors infixl 7 · (·) :: ( Num t , Num (Vector t n) - , ElementWise (Idx '[n]) t (Vector t n) + , SubSpace t '[] '[n] '[n] ) => Vector t n -> Vector t n -> Scalar t (·) = dot @@ -75,50 +72,36 @@ -- | Sum of absolute values -normL1 :: ( Num t - , ElementWise (Idx '[n]) t (Vector t n) - ) +normL1 :: ( Num t, SubSpace t '[] '[n] '[n] ) => Vector t n -> Scalar t -normL1 = scalar . ewfoldr (const (\a -> (abs a +))) 0 +normL1 = ewfoldr (\a -> (abs a +)) 0 -- | hypot function (square root of squares) -normL2 :: ( Floating t - , ElementWise (Idx '[n]) t (Vector t n) - ) +normL2 :: ( Floating t , SubSpace t '[] '[n] '[n] ) => Vector t n -> Scalar t -normL2 = scalar . sqrt . ewfoldr (const (\a -> (a*a +))) 0 +normL2 = sqrt . ewfoldr (\a -> (a*a +)) 0 -- | Normalize vector w.r.t. Euclidean metric (L2). -normalized :: ( Floating t - , Fractional (Vector t n) - , ElementWise (Idx '[n]) t (Vector t n) - ) +normalized :: ( Floating t , Fractional (Vector t n), SubSpace t '[] '[n] '[n] ) => Vector t n -> Vector t n normalized v = v / n where - n = broadcast . sqrt $ ewfoldr (const (\a -> (a*a +))) 0 v + n = fromScalar . sqrt $ ewfoldr (\a -> (a*a +)) 0 v -- | Maximum of absolute values -normLPInf :: ( Ord t, Num t - , ElementWise (Idx '[n]) t (Vector t n) - ) +normLPInf :: ( Ord t, Num t , SubSpace t '[] '[n] '[n] ) => Vector t n -> Scalar t -normLPInf = scalar . ewfoldr (const (max . abs)) 0 +normLPInf = ewfoldr (max . abs) 0 -- | Minimum of absolute values -normLNInf :: ( Ord t, Num t - , ElementWise (Idx '[n]) t (Vector t n) - ) +normLNInf :: ( Ord t, Num t , SubSpace t '[] '[n] '[n] ) => Vector t n -> Scalar t -normLNInf x = scalar $ ewfoldr (const (min . abs)) - (abs $ x ! (1 :! Z)) x +normLNInf x = ewfoldr (min . abs) (abs $ x ! Idx 1 :* U) x -- | Norm in Lp space -normLP :: ( Floating t - , ElementWise (Idx '[n]) t (Vector t n) - ) +normLP :: ( Floating t , SubSpace t '[] '[n] '[n] ) => Int -> Vector t n -> Scalar t -normLP i' = scalar . (**ri) . ewfoldr (const (\a -> (a**i +))) 0 +normLP i' = (**ri) . ewfoldr (\a -> (a**i +)) 0 where i = fromIntegral i' ri = recip i @@ -129,73 +112,73 @@ #-} -- | Compose a 2D vector -vec2 :: ElementWise (Idx '[2]) t (Vector t 2) => t -> t -> Vector t 2 -vec2 a b = ewgen f +vec2 :: SubSpace t '[] '[2] '[2] => t -> t -> Vector t 2 +vec2 a b = iwgen f where - f (1 :! Z) = a - f _ = b + f (1 :* U) = scalar a + f _ = scalar b -- | Take a determinant of a matrix composed from two 2D vectors. -- Like a cross product in 2D. -det2 :: ( ElementWise (Idx '[2]) t (Vector t 2) - , Num t - ) => Vector t 2 -> Vector t 2 -> Scalar t -det2 a b = scalar $ a ! (1 :! Z) * b ! (2 :! Z) - - a ! (2 :! Z) * b ! (1 :! Z) +det2 :: ( Num t, SubSpace t '[] '[2] '[2] ) + => Vector t 2 -> Vector t 2 -> Scalar t +det2 a b = (a ! 1 :* U) * (b ! 2 :* U) + - (a ! 2 :* U) * (b ! 1 :* U) -- | Compose a 3D vector -vec3 :: ElementWise (Idx '[3]) t (Vector t 3) => t -> t -> t -> Vector t 3 -vec3 a b c = ewgen f +vec3 :: SubSpace t '[] '[3] '[3] => t -> t -> t -> Vector t 3 +vec3 a b c = iwgen f where - f (1 :! Z) = a - f (2 :! Z) = b - f _ = c + f (1 :* U) = scalar a + f (2 :* U) = scalar b + f _ = scalar c -- | Cross product -cross :: ( ElementWise (Idx '[3]) t (Vector t 3) - , Num t - ) => Vector t 3 -> Vector t 3 -> Vector t 3 -cross a b = vec3 ( a ! (2 :! Z) * b ! (3 :! Z) - - a ! (3 :! Z) * b ! (2 :! Z) ) - ( a ! (3 :! Z) * b ! (1 :! Z) - - a ! (1 :! Z) * b ! (3 :! Z) ) - ( a ! (1 :! Z) * b ! (2 :! Z) - - a ! (2 :! Z) * b ! (1 :! Z) ) +cross :: ( Num t, SubSpace t '[] '[3] '[3] ) + => Vector t 3 -> Vector t 3 -> Vector t 3 +cross a b = vec3 ( unScalar + $ (a ! 2 :* U) * (b ! 3 :* U) + - (a ! 3 :* U) * (b ! 2 :* U) ) + ( unScalar + $ (a ! 3 :* U) * (b ! 1 :* U) + - (a ! 1 :* U) * (b ! 3 :* U) ) + ( unScalar + $ (a ! 1 :* U) * (b ! 2 :* U) + - (a ! 2 :* U) * (b ! 1 :* U) ) -- | Cross product for two vectors in 3D infixl 7 × -(×) :: ( ElementWise (Idx '[3]) t (Vector t 3) - , Num t - ) => Vector t 3 -> Vector t 3 -> Vector t 3 +(×) :: ( Num t, SubSpace t '[] '[3] '[3] ) + => Vector t 3 -> Vector t 3 -> Vector t 3 (×) = cross {-# INLINE (×) #-} --- | Compose a 3D vector -vec4 :: ElementWise (Idx '[4]) t (Vector t 4) +-- | Compose a 4D vector +vec4 :: SubSpace t '[] '[4] '[4] => t -> t -> t -> t -> Vector t 4 -vec4 a b c d = ewgen f +vec4 a b c d = iwgen f where - f (1 :! Z) = a - f (2 :! Z) = b - f (3 :! Z) = c - f _ = d + f (1 :* U) = scalar a + f (2 :* U) = scalar b + f (3 :* U) = scalar c + f _ = scalar d -unpackV2 :: ElementWise (Idx '[2]) t (Vector t 2) +unpackV2 :: SubSpace t '[] '[2] '[2] => Vector t 2 -> (t, t) -unpackV2 v = (v ! 1, v ! 2) +unpackV2 v = (unScalar $ v ! 1, unScalar $ v ! 2) {-# INLINE unpackV2 #-} -unpackV3 :: ElementWise (Idx '[3]) t (Vector t 3) +unpackV3 :: SubSpace t '[] '[3] '[3] => Vector t 3 -> (t, t, t) -unpackV3 v = (v ! 1, v ! 2, v ! 3) +unpackV3 v = (unScalar $ v ! 1, unScalar $ v ! 2, unScalar $ v ! 3) {-# INLINE unpackV3 #-} -unpackV4 :: ElementWise (Idx '[4]) t (Vector t 4) +unpackV4 :: SubSpace t '[] '[4] '[4] => Vector t 4 -> (t, t, t, t) -unpackV4 v = (v ! 1, v ! 2, v ! 3, v ! 4) +unpackV4 v = (unScalar $ v ! 1, unScalar $ v ! 2, unScalar $ v ! 3, unScalar $ v ! 4) {-# INLINE unpackV4 #-} diff --git a/test/Numeric/DataFrame/Arbitraries.hs b/test/Numeric/DataFrame/Arbitraries.hs --- a/test/Numeric/DataFrame/Arbitraries.hs +++ b/test/Numeric/DataFrame/Arbitraries.hs @@ -1,140 +1,158 @@ ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.BasicTest --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- A set of basic validity tests for DataFrame type. --- Num, Ord, Fractional, Floating, etc --- ------------------------------------------------------------------------------ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Provide instance of Arbitrary for all DataFrame types. +-- Also, this module is an example of fancy type inference and DataFrame +-- traversals with monadic actions. module Numeric.DataFrame.Arbitraries where -import Data.Type.Equality import Test.QuickCheck -import Unsafe.Coerce -import Numeric.Commons import Numeric.DataFrame import Numeric.Dimensions +import Numeric.PrimBytes +instance (Arbitrary t, PrimBytes t, Dimensions ds) + => Arbitrary (DataFrame t (ds :: [Nat])) where + arbitrary + | -- First, we need to find out exact array implementation to use + -- inside this DataFrame. + -- We need to do that whenever exact value of ds is not known + E <- inferASing' @t @ds + -- Then, we need to get basic byte manipulation type classes, such as + -- PrimBytes and PrimArray. + , E <- inferPrim' @t @ds + -- After that, GHC can infer all necessary fancy things like SubSpace + -- to do complex operations on sub-dimensions of a DataFrame. + -- + -- Note, we could put SubSpace into constraints of this instance as well. + -- That would render the above lines unnecessary, but would make + -- inference more difficult later. + = arbitrary >>= elementWise @_ @_ @ds f . ewgen . scalar + where + f :: Arbitrary a => Scalar a -> Gen (Scalar a) + f _ = scalar <$> arbitrary + shrink + | E <- inferASing' @t @ds + , E <- inferPrim' @t @ds + = elementWise @_ @_ @ds f + where + -- Unfortunately, Scalar is not a proper second-rank data type + -- (it is just type alias for DataFrame t []). + -- So it cannot be functor or traversable. + f :: Arbitrary a => Scalar a -> [Scalar a] + f = fmap scalar . shrink . unScalar +instance (All Arbitrary ts, All PrimBytes ts, RepresentableList ts, Dimensions ds) + => Arbitrary (DataFrame ts (ds :: [Nat])) where + -- We create arbitrary MultiFrame by combining several SingleFrames. + -- SingleFrames are "variables" or "columns" of a MultiFrame that are + -- independent byte arrays bounded by a common dimensions type signature. + arbitrary = -- Use RepresentableList to find out how many columns are there. + case tList @_ @ts of + -- Zero columns, empty MultiFrame + U -> return Z + -- Cons-like construction. + -- Note, pattern matching TypeList brings RepresentableList evidence + -- for Tail ts. + _ :* (TypeList :: TypeList ts') -> do + at <- arbitrary + ats' <- arbitrary @(DataFrame ts' ds) + return (at :*: ats') + shrink Z = [] + -- MultiFrame is a newtype wrapper on a TypedList. + -- Thus, we can always recover RepresentableList ts by using function @types@ + shrink (at :*: ats@(MultiFrame ats')) + | TypeList <- types ats' + = (:*:) <$> shrink at <*> shrink ats -maxDims :: Int + +maxDims :: Word maxDims = 5 -maxDimSize :: Int +maxDimSize :: Word maxDimSize = 7 --- | Fool typechecker by saying that a ~ b -unsafeEqProof :: forall (a :: k) (b :: k) . a :~: b -unsafeEqProof = unsafeCoerce Refl - - - --- | Generating random DataFrames -newtype SimpleDF (ds :: [Nat] ) = SDF { getDF :: DataFrame Float ds} -data SomeSimpleDF = forall (ds :: [Nat]) - . NumericFrame Float ds - => SSDF !(SimpleDF ds) -data SomeSimpleDFNonScalar - = forall (ds :: [Nat]) (a :: Nat) (as :: [Nat]) - . ( Dimensions ds, FiniteList ds, KnownDims ds - , NumericFrame Float ds - , ds ~ (a :+ as) - ) - => SSDFN !(SimpleDF ds) -data SomeSimpleDFPair = forall (ds :: [Nat]) - . NumericFrame Float ds - => SSDFP !(SimpleDF ds) !(SimpleDF ds) - -instance ( Dimensions ds - , NumericFrame Float ds - , PrimBytes (DataFrame Float ds) - ) => Arbitrary (SimpleDF (ds :: [Nat])) where - arbitrary = SDF <$> elementWise @_ @_ @ds f 0 - where - f :: Scalar Float -> Gen (Scalar Float) - f _ = scalar <$> choose (-10000,100000) - shrink sdf = SDF <$> elementWise @_ @_ @ds f (getDF sdf) - where - f :: Scalar Float -> [Scalar Float] - f = fmap scalar . shrink . unScalar +instance KnownDim a => Arbitrary (Dim (N a)) where + arbitrary = return $ Dn (dim @_ @a) + shrink _ = [] +instance KnownDim m => Arbitrary (Dim (XN m)) where + arbitrary = do + dimN <- choose (dimVal' @m, maxDims) + case constrain @m (someDimVal dimN) of + Nothing -> error "impossible argument" + Just d -> return d + shrink _ = [] -instance Arbitrary SomeSimpleDF where - arbitrary = do - dimN <- choose (0, maxDims) :: Gen Int - intDims <- mapM (\_ -> choose (2, maxDimSize) :: Gen Int) [1..dimN] - let eGen = case someDimsVal intDims of - Just (SomeDims (dds :: Dim ds)) -> case inferGoodDims dds of - Evidence -> Right $ SSDF <$> (arbitrary :: Gen (SimpleDF ds)) - Nothing -> Left "cannot construct Dim value." - case eGen of - Left s -> error $ "Cannot generate arbitrary SomeSimpleDF: " ++ s - Right v -> v - shrink (SSDF x) = SSDF <$> shrink x +instance Arbitrary SomeDims where + arbitrary = do + dimN <- choose (0, maxDims) :: Gen Word + wdims <- mapM (\_ -> choose (2, maxDimSize) :: Gen Word) [1..dimN] + return $ someDimsVal wdims + shrink (SomeDims U) = [] + shrink (SomeDims (_ :* ds)) = [SomeDims ds] +instance Arbitrary (Dims '[]) where + arbitrary = return U + shrink _ = [] -instance Arbitrary SomeSimpleDFNonScalar where - arbitrary = do - dimN <- choose (1, maxDims) :: Gen Int - intDims <- mapM (\_ -> choose (2, maxDimSize) :: Gen Int) [1..dimN] - let eGen = case someDimsVal intDims of - Just (SomeDims (dds :: Dim ds)) -> case inferGoodDims dds of - Evidence -> case ( unsafeEqProof :: ds :~: (Head ds :+ Tail ds) - , unsafeEqProof :: ds :~: (Init ds +: Last ds) - ) of - (Refl, Refl) -> Right $ SSDFN <$> (arbitrary :: Gen (SimpleDF ds)) - Nothing -> Left "cannot construct Dim value." - case eGen of - Left s -> error $ "Cannot generate arbitrary SomeSimpleDF: " ++ s - Right v -> v - shrink (SSDFN x) = SSDFN <$> shrink x +instance (KnownDim n, Arbitrary (Dims xs)) => Arbitrary (Dims (N n ': xs)) where + arbitrary = (:*) <$> arbitrary <*> arbitrary + shrink _ = [] +instance (KnownDim m, Arbitrary (Dims xs)) => Arbitrary (Dims (XN m ': xs)) where + arbitrary = (:*) <$> arbitrary <*> arbitrary + shrink _ = [] -instance Arbitrary SomeSimpleDFPair where - arbitrary = do - dimN <- choose (0, maxDims) :: Gen Int - intDims <- mapM (\_ -> choose (2, maxDimSize) :: Gen Int) [1..dimN] - let eGen = case someDimsVal intDims of - Just (SomeDims (dds :: Dim ds)) -> case inferGoodDims dds of - Evidence -> Right $ SSDFP - <$> (arbitrary :: Gen (SimpleDF ds)) - <*> (arbitrary :: Gen (SimpleDF ds)) - Nothing -> Left "cannot construct Dim value." - case eGen of - Left s -> error $ "Cannot generate arbitrary SomeSimpleDF: " ++ s - Right v -> v - shrink (SSDFP x y) = SSDFP <$> shrink x <*> shrink y +instance (Arbitrary t, PrimBytes t) + => Arbitrary (SomeDataFrame t) where + arbitrary = do + -- Generate random dimension list + -- and pattern-match against it with Dims pattern. + -- This gives Dimensions ds evidence immediately. + SomeDims (Dims :: Dims ds) <- arbitrary + -- We also need to figure out an array implementation... + case inferASing' @t @ds of + -- ... and generating a random DataFrame becomes a one-liner + E -> SomeDataFrame <$> arbitrary @(DataFrame t ds) + shrink _ = [] +-- All same as above, just change constraints a bit +instance (All Arbitrary ts, All PrimBytes ts, RepresentableList ts) + => Arbitrary (SomeDataFrame ts) where + arbitrary = do + SomeDims (Dims :: Dims ds) <- arbitrary + case inferASing' @ts @ds of + E -> SomeDataFrame <$> arbitrary @(DataFrame ts ds) + shrink _ = [] -inferGoodDims :: forall (ds :: [Nat]) . Dim ds -> Evidence (Dimensions ds, FiniteList ds, KnownDims ds, NumericFrame Float ds) -inferGoodDims ds = case reifyDimensions ds of - Evidence -> case inferDimKnownDims @ds `sumEvs` inferDimFiniteList @ds of - Evidence -> case inferArrayInstance @Float @ds of - Evidence -> case inferNumericFrame @Float @ds of - Evidence -> Evidence +instance ( Arbitrary t, PrimBytes t + , Arbitrary (Dims xs), All KnownXNatType xs) + => Arbitrary (DataFrame t (xs :: [XNat])) where + arbitrary = do + XDims (_ :: Dims ds) <- arbitrary @(Dims xs) + case inferASing' @t @ds of + E -> XFrame <$> arbitrary @(DataFrame t ds) + shrink (XFrame df) = XFrame <$> shrink df -instance Show (DataFrame Float ds) => Show (SimpleDF ds) where - show (SDF sdf) = show sdf -instance Show SomeSimpleDF where - show (SSDF sdf) = show sdf -instance Show SomeSimpleDFNonScalar where - show (SSDFN sdf) = show sdf -instance Show SomeSimpleDFPair where - show (SSDFP x y) = "Pair:\n" ++ show (x,y) +instance ( All Arbitrary ts, All PrimBytes ts, RepresentableList ts + , Arbitrary (Dims xs), All KnownXNatType xs) + => Arbitrary (DataFrame ts (xs :: [XNat])) where + arbitrary = do + XDims (_ :: Dims ds) <- arbitrary @(Dims xs) + case inferASing' @ts @ds of + E -> XFrame <$> arbitrary @(DataFrame ts ds) + shrink (XFrame df) = XFrame <$> shrink df diff --git a/test/Numeric/DataFrame/BasicTest.hs b/test/Numeric/DataFrame/BasicTest.hs --- a/test/Numeric/DataFrame/BasicTest.hs +++ b/test/Numeric/DataFrame/BasicTest.hs @@ -21,18 +21,20 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Numeric.DataFrame.BasicTest (runTests) where -import Numeric.DataFrame.Arbitraries +import Numeric.DataFrame +import Numeric.DataFrame.Arbitraries () +import Numeric.Dimensions import Test.QuickCheck - - -{-# ANN prop_Comparisons "HLint: ignore" #-} -prop_Comparisons :: SomeSimpleDFPair -> Bool -prop_Comparisons (SSDFP (SDF x) (SDF y)) +prop_Comparisons :: SomeDataFrame '[Float, Float] -> Bool +prop_Comparisons (SomeDataFrame (x :*: y :*: Z)) + | E <- inferOrd x + , E <- inferFractional x = and [ abs x >= abs x / 2 , abs x <= abs x + abs y @@ -52,22 +54,27 @@ a ===> b = not a || b infix 2 ===> - -prop_Numeric :: SomeSimpleDFPair -> Bool -prop_Numeric (SSDFP (SDF x) (SDF y)) +prop_Numeric :: SomeDataFrame '[Int, Int] -> Bool +prop_Numeric (SomeDataFrame (x :*: y :*: Z)) + | E <- inferOrd x + , E <- inferNum x = and [ x + x == 2 * x , x + y == y + x , x + y == max x y + min x y , abs x * signum x == x - , x / 2 + x / 2 == x , x * y == y * x , x * 0 + y == y ] -prop_Floating :: SomeSimpleDFPair -> Bool -prop_Floating (SSDFP (SDF x) (SDF y)) +prop_Floating :: SomeDataFrame '[Double, Double] -> Bool +prop_Floating (SomeDataFrame (x :*: y :*: Z)) + | E <- inferOrd x + , E <- inferFloating x + , lx <- log (0.01 + abs x) + , ly <- log (0.01 + abs y) + , eps <- 0.001 = all ((eps >=) . abs) [ sin x * sin x + cos x * cos x - 1 , exp lx * exp ly / exp (lx + ly) - 1 @@ -75,10 +82,6 @@ , sin (asin (sin y)) - sin y , cos (acos (cos x)) - cos x ] - where - lx = log (0.01 + abs x) - ly = log (0.01 + abs y) - eps = 0.001 return [] diff --git a/test/Numeric/DataFrame/SubSpaceTest.hs b/test/Numeric/DataFrame/SubSpaceTest.hs --- a/test/Numeric/DataFrame/SubSpaceTest.hs +++ b/test/Numeric/DataFrame/SubSpaceTest.hs @@ -1,13 +1,3 @@ ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.SubSpaceTest --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} @@ -19,58 +9,47 @@ module Numeric.DataFrame.SubSpaceTest (runTests) where import Numeric.DataFrame -import Numeric.DataFrame.Arbitraries +import Numeric.DataFrame.Arbitraries () import Numeric.Dimensions -import Numeric.TypeLits (Proxy (..)) import Test.QuickCheck - - - -prop_Dims :: SomeSimpleDF -> SomeSimpleDF -> Bool -prop_Dims (SSDF (SDF (x :: DataFrame Float xs))) (SSDF (SDF (y :: DataFrame Float ys))) - | Evidence <- inferConcatDimensions @xs @ys - , Evidence <- inferConcatFiniteList @xs @ys - = order @_ @(xs ++ ys) == order @_ @xs + order @_ @ys - && totalDim (Proxy @(xs ++ ys)) == totalDim x * totalDim y - -prop_Eye :: SomeSimpleDFNonScalar -> Bool -prop_Eye (SSDFN (SDF (x :: DataFrame Float ds))) - | Just Evidence <- sumEvs <$> inferUnConsDimensions @ds - <*> inferUnSnocDimensions @ds - = eye %* x == x && x == x %* eye - | otherwise = False - +type SFull = '[2,5,4,3,7] +type SPref = '[2,5,4] +type SSuff = '[3,7] -prop_IndexDimMax :: SimpleDF '[2,5,4] -> SimpleDF '[3,7] -> Bool -prop_IndexDimMax (SDF x) (SDF y) = +prop_IndexDimMax :: DataFrame Int SPref -> DataFrame Int SSuff -> Bool +prop_IndexDimMax x y = ((maxBound `inSpaceOf` y) !. z) == x where - z = ewgen x :: DataFrame Float '[2,5,4,3,7] + z = ewgen x :: DataFrame Int SFull -prop_IndexCustom1 :: SimpleDF '[2,5,4] -> SimpleDF '[3,7] -> Bool -prop_IndexCustom1 (SDF x) (SDF _) = (1:!3 !. z) == x +prop_IndexCustom1 :: DataFrame Word SPref -> Bool +prop_IndexCustom1 x = (1:*3 !. z) == x where - z = ewgen x :: DataFrame Float '[2,5,4,3,7] + z = ewgen x :: DataFrame Word SFull -prop_IndexCustom2 :: SimpleDF '[2,5,4] -> SimpleDF '[3,7] -> Bool -prop_IndexCustom2 (SDF x) (SDF _) = (2:!2 !. z) %* eye == x +prop_IndexCustom2 :: DataFrame Double SPref -> Bool +prop_IndexCustom2 x = (2:*2 !. z) %* eye == x where - z = ewgen x :: DataFrame Float '[2,5,4,3,7] - + z = ewgen x :: DataFrame Double SFull -prop_Foldlr :: SimpleDF '[2,5,4] -> SimpleDF '[3,7] -> Bool -prop_Foldlr (SDF x) (SDF _) = - abs (ewfoldl (+) 10 z - ewfoldr @_ @'[2,5,4] (+) 0 z - 10) <= fromScalar (zmax * 0.0001) +prop_Foldlr :: DataFrame Double SPref -> Bool +prop_Foldlr x = + abs (ewfoldl (+) 10 z - ewfoldr @_ @SPref (+) 0 z - 10) + <= fromScalar (zmax * 0.0001) where - z = ewgen x :: DataFrame Float '[2,5,4,3,7] - zmax = ewfoldl @Float @'[] @'[2,5,4,3,7] (max . abs) 0.001 z + z = ewgen x :: DataFrame Double SFull + zmax = ewfoldl @Double @'[] @SFull (max . abs) 0.001 z -prop_Ewmap :: SimpleDF '[2,5,4] -> SimpleDF '[3,7] -> Bool -prop_Ewmap (SDF _) (SDF y) = - y * 2 == ewmap @_ @'[3] (*2) y +prop_Ewmap :: DataFrame Double SFull -> Bool +prop_Ewmap x = x * 2 == ewmap @_ @'[Head SFull] (*2) x +prop_ProdTranspose :: DataFrame Double '[2,6] -> DataFrame Double '[6,7] -> Bool +prop_ProdTranspose x y = transpose (x %* y) == transpose y %* transpose x + +prop_Eye :: DataFrame Double SFull -> Bool +prop_Eye x = eye %* x == x && x %* eye == x return [] runTests :: IO Bool diff --git a/test/Numeric/MatrixTest.hs b/test/Numeric/MatrixTest.hs new file mode 100644 --- /dev/null +++ b/test/Numeric/MatrixTest.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Numeric.MatrixTest (runTests) where + + +import Numeric.DataFrame +import Numeric.DataFrame.Arbitraries () +import Numeric.Dimensions +import Test.QuickCheck + +eps :: Scd +eps = 0.0000001 + +prop_detTranspose :: Matrix '[Double, Double] (XN 2) (XN 2) -> Bool +prop_detTranspose (XFrame (x :*: y :*: Z)) + | -- infer KnownDim for both dimensions of matrix x (and y) + KnownDims <- dims `inSpaceOf` x + = let m = diag (ewfoldl max 0 $ abs x) + x %* transpose y + a = det m + b = det $ transpose m + in abs (a - b) / (abs a + abs b + 1) <= eps + +prop_inverse :: Matrix '[Double, Double] (XN 2) (XN 2) -> Bool +prop_inverse (XFrame (x :*: y :*: Z)) + | -- infer KnownDim for both dimensions of matrix x (and y) + (KnownDims :: Dims ns) <- dims `inSpaceOf` x + -- cumbersose inverse instance requires PrimBytes (Vector t n) + , E <- inferASing' @Double @'[Head ns] + , E <- inferPrim' @Double @'[Head ns] + = let m = diag base + x %* transpose y + mi = inverse m + err a b = ewfoldl max 0 (abs (b - a)) / base + base = ewfoldl max 0.5 (abs x) + ewfoldl max 0.5 (abs y) + in err eye (m %* mi) <= eps + && err eye (mi %* m) <= eps + +prop_LU :: Matrix '[Double, Double] (XN 2) (XN 2) -> Bool +prop_LU (XFrame (x :*: y :*: Z)) + | -- infer KnownDim for both dimensions of matrix x (and y) + (KnownDims :: Dims ns) <- dims `inSpaceOf` x + -- cumbersose inverse instance requires PrimBytes (Vector t n) + , E <- inferASing' @Double @'[Head ns] + , E <- inferPrim' @Double @'[Head ns] + = let m = diag base + x %* transpose y + f = lu m + err a b = ewfoldl max 0 (abs (b - a)) / base + base = ewfoldl max 0.5 (abs x) + ewfoldl max 0.5 (abs y) + in err (luPerm f %* m) (luLower f %* luUpper f) <= eps + + +return [] +runTests :: IO Bool +runTests = $quickCheckAll diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,11 @@ module Main (tests, main) where -import System.Exit import Distribution.TestSuite +import System.Exit import qualified Numeric.DataFrame.BasicTest import qualified Numeric.DataFrame.SubSpaceTest +import qualified Numeric.MatrixTest import qualified Numeric.QuaternionTest @@ -13,6 +14,7 @@ tests = return [ test "DataFrame.Basic" Numeric.DataFrame.BasicTest.runTests , test "DataFrame.SubSpace" Numeric.DataFrame.SubSpaceTest.runTests + , test "Matrix" Numeric.MatrixTest.runTests , test "Quaternion" Numeric.QuaternionTest.runTests ] @@ -31,7 +33,7 @@ exitFailure where isGood (_, Finished Pass) = True - isGood _ = False + isGood _ = False -- | Convert QuickCheck props into Cabal tests