diff --git a/bench/subspacefolds.hs b/bench/subspacefolds.hs --- a/bench/subspacefolds.hs +++ b/bench/subspacefolds.hs @@ -12,7 +12,7 @@ import Numeric.Dimensions -type DList = [6,8,10,7,35,8,12] -- [6,26,8,10,35,8,12] +type DList = [6,4,10,7,35,8,12] -- [6,26,8,10,35,8,12] main :: IO () main = do @@ -23,45 +23,55 @@ seq t1 putStrLn $ "Created DataFrame, elapsed time is " ++ show (diffUTCTime t1 t0) putStrLn "\nRunning a ewfoldl on scalar elements..." - let rezEwf = ewfoldl @Float @'[] @DList (\a x -> let z = fromMaybe x a + fromMaybe 0 a / (x+1) in z `seq` return z) (Just 1) df + let rezEwf = ewfoldl @Float @'[] @DList (\a x -> return $! fromMaybe x a + fromMaybe 0 a / (x+1)) (Just 1) df t2 <- rezEwf `seq` getCurrentTime - print rezEwf seq t2 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t2 t1) + print rezEwf putStrLn "\nRunning a iwfoldl on scalar elements (not using idx)..." let rezIwf = iwfoldl @Float @'[] @DList (\_ a x -> a + a / (x+1)) 1 df t3 <- rezIwf `seq` getCurrentTime - print rezIwf seq t3 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t3 t2) + print rezIwf putStrLn "\nRunning a iwfoldr on scalar elements (using fromEnum idx)..." - let rezIwf2 = iwfoldr @Float @'[] @DList (\i x a -> let z = fromMaybe 0 a + x / ((1+) . fromIntegral $ fromEnum i) in z `seq` return z) (Just 0) df + let rezIwf2 = iwfoldr @Float @'[] @DList (\i x a -> return $! fromMaybe 0 a + x / ((1+) . fromIntegral $ fromEnum i)) (Just 0) df t4 <- rezIwf2 `seq` getCurrentTime - print rezIwf2 seq t4 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t4 t3) + print rezIwf2 putStrLn "\nRunning a iwfoldl on scalar elements (enforcing idx)..." - let rezIwf3 = iwfoldl @Float @'[] @DList (\i a x -> i `seq` let z = fromMaybe 0 a + fromMaybe x a / (x+1) in z `seq` return z) (Just 1) df + let rezIwf3 = iwfoldl @Float @'[] @DList (\i a x -> i `seq` return $! fromMaybe 0 a + fromMaybe x a / (x+1)) (Just 1) df t5 <- rezIwf3 `seq` getCurrentTime - print rezIwf3 seq t5 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t5 t4) + print rezIwf3 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 )) ) (Just (3 :: DataFrame Float '[5])) df t6 <- rezEwv1 `seq` getCurrentTime - print rezEwv1 seq t6 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t6 t5) + print rezEwv1 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 ))) (Just (3 :: DataFrame Float '[3])) df t7 <- rezEwv2 `seq` getCurrentTime - print rezEwv2 seq t7 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t7 t6) + print rezEwv2 + putStrLn "\nRunning a ewfoldr with matrix products..." + let rezEwm = ewfoldr @Float @(Take 3 DList) @(Drop 3 DList) + (\x a -> a + x %* (1 <::> 0.5 <:> 0.1) ) + (1 :: DataFrame Float (Take 2 DList +: 3)) df + t8 <- rezEwm `seq` getCurrentTime + seq t8 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t8 t7) + print rezEwm + + + putStrLn "Checking indexes" - print $ 1:!1:!3:!1:!Z !. df + print $ 2:!1:!1:!3:!1:!Z !. df diff --git a/easytensor.cabal b/easytensor.cabal --- a/easytensor.cabal +++ b/easytensor.cabal @@ -1,5 +1,5 @@ name: easytensor -version: 0.2.0.0 +version: 0.3.0.0 cabal-version: >=1.20 build-type: Simple license: MIT @@ -7,16 +7,16 @@ copyright: (c) Artem Chirkin maintainer: chirkin@arch.ethz.ch homepage: https://github.com/achirkin/easytensor#readme -synopsis: Initial project template from stack +synopsis: Pure, type-indexed haskell vector, matrix, and tensor library. description: - Pure haskell vector/matrix/tensor library. + Pure, type-indexed haskell vector, matrix, and tensor library. Features dimensionality type-checking for all operations. Generic n-dimensional versions are implemented using low-level prim ops. 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/Numeric/Array/Family/Array.h + src-base/Numeric/Array/Family/Array.h source-repository head type: git @@ -46,9 +46,31 @@ base >=4.9 && <5, ghc-prim >=0.5, dimensions -any + if impl(ghcjs) + build-depends: + ghcjs-base >= 0.2.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.Type + if impl(ghcjs) + other-modules: + Numeric.Array.Family.ArrayT + else + other-modules: Numeric.Array.Family.ArrayF Numeric.Array.Family.ArrayD Numeric.Array.Family.ArrayI @@ -64,16 +86,8 @@ Numeric.Array.Family.FloatX2 Numeric.Array.Family.FloatX3 Numeric.Array.Family.FloatX4 - 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.Type + js-sources: + src-ghcjs/Numeric/Array/Family/ArrayT.js ghc-options: -Wall -fwarn-tabs -O2 test-suite et-test diff --git a/src-base/Numeric/Array.hs b/src-base/Numeric/Array.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- 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 () diff --git a/src-base/Numeric/Array/Family.hs b/src-base/Numeric/Array/Family.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family.hs @@ -0,0 +1,429 @@ +{-# 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 (..) + , ArrayInstanceInference, ElemType (..), ArraySize (..) + , ElemTypeInference (..), ArraySizeInference (..), ArrayInstanceEvidence + , getArrayInstance, ArrayInstance (..), inferArrayInstance + ) where + + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Type.Equality ((:~:) (..)) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Prim (ByteArray#, Double#, Float#, Int#, + Word#, unsafeCoerce#) + +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 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 ( Bounded, Enum, Eq, Integral + , Num, Fractional, Floating, Ord, Read, Real, RealFrac, RealFloat) +instance Show t => Show (Scalar t) where + show (Scalar t) = "{ " ++ show t ++ " }" + +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 Int64 ) = 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 Word64) = Word# + +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# +data ArrayI64 (ds :: [Nat]) = ArrayI64# Int# Int# ByteArray# + | FromScalarI64# Int# +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# +data ArrayW64 (ds :: [Nat]) = ArrayW64# Int# Int# ByteArray# + | FromScalarW64# Word# + +-- * 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# + +-- * 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 + +-- | 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) -> AIArrayD + (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) -> AIArrayD + (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) -> AIArrayD + (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) -> AIArrayD + (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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/Array.h @@ -0,0 +1,308 @@ + +-------------------------------------------------------------------------------- +-- * 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayD.hs @@ -0,0 +1,408 @@ +{-# 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.Type + + +#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 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayF.hs @@ -0,0 +1,412 @@ +{-# 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.Type + +#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 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayI.hs @@ -0,0 +1,95 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayI16.hs @@ -0,0 +1,96 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayI32.hs @@ -0,0 +1,96 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayI64.hs @@ -0,0 +1,96 @@ +{-# 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 + +import GHC.Base (runRW#) +import GHC.Prim +import GHC.Types (Int (..), RuntimeRep (..), isTrue#) +import GHC.Int (Int64 (..)) + +import Numeric.Array.ElementWise +import Numeric.Array.Family +import Numeric.Commons +import Numeric.Dimensions +import Numeric.Dimensions.Traverse + + +#include "MachDeps.h" +#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# +#include "Array.h" + + +instance Num (ArrayI64 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 (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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayI8.hs @@ -0,0 +1,96 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayW.hs @@ -0,0 +1,89 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayW16.hs @@ -0,0 +1,90 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayW32.hs @@ -0,0 +1,90 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayW64.hs @@ -0,0 +1,90 @@ +{-# 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 + +import GHC.Base (runRW#) +import GHC.Prim +import GHC.Types (Int (..), RuntimeRep (..), isTrue#) +import GHC.Word (Word64 (..)) + +import Numeric.Array.ElementWise +import Numeric.Array.Family +import Numeric.Commons +import Numeric.Dimensions +import Numeric.Dimensions.Traverse + + +#include "MachDeps.h" +#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 EL_MINUS_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# +#include "Array.h" + +instance Num (ArrayW64 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 (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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/ArrayW8.hs @@ -0,0 +1,90 @@ +{-# 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/FloatX2.hs b/src-base/Numeric/Array/Family/FloatX2.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/FloatX2.hs @@ -0,0 +1,325 @@ +{-# 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 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/FloatX3.hs @@ -0,0 +1,299 @@ +{-# 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 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/Array/Family/FloatX4.hs @@ -0,0 +1,335 @@ +{-# 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 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Contraction.hs @@ -0,0 +1,509 @@ +{-# 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 + + +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) + , 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# + = 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) + , 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# + = prodW64 n m k x y + where + getM :: forall m p . p (m ': bs) -> Proxy m + getM _ = Proxy + + + +prodF :: (FloatBytes a, FloatBytes b, PrimBytes c) => 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 :: (DoubleBytes a, DoubleBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => Int# -> Int# -> Int# -> a -> b -> c +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 #-} + + +prodW :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => Int# -> Int# -> Int# -> a -> b -> c +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 #-} + +-- | 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 new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Inference.hs @@ -0,0 +1,140 @@ +{-# 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 + +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 + + +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 + 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-ghcjs/Numeric/Array.hs b/src-ghcjs/Numeric/Array.hs new file mode 100644 --- /dev/null +++ b/src-ghcjs/Numeric/Array.hs @@ -0,0 +1,18 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src-ghcjs/Numeric/Array/Family.hs @@ -0,0 +1,345 @@ +{-# 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 #-} +----------------------------------------------------------------------------- +-- | +-- 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#) +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 ( Bounded, Enum, Eq, Integral + , Num, Fractional, Floating, Ord, Read, Real, RealFrac, RealFloat, IsJSVal) +instance Show t => Show (Scalar t) where + show (Scalar t) = "{ " ++ show t ++ " }" + + + +-- | 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 (Clamped i) = toBytes (fromIntegral (min 0 (max 255 i)) :: Word8) + {-# INLINE toBytes #-} + fromBytes bs = fromIntegral (fromBytes bs :: Word8) + {-# INLINE fromBytes #-} + byteSize _ = 1# + {-# INLINE byteSize #-} + byteAlign _ = 1# + {-# INLINE byteAlign #-} + elementByteSize _ = 1# + {-# INLINE elementByteSize #-} + ix _ (Clamped (I# x)) = x + {-# INLINE ix #-} + +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 new file mode 100644 --- /dev/null +++ b/src-ghcjs/Numeric/Array/Family/ArrayT.hs @@ -0,0 +1,1642 @@ +{-# 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 GeneralizedNewtypeDeriving #-} +{-# 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.Type + + +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 +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 + + +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 new file mode 100644 --- /dev/null +++ b/src-ghcjs/Numeric/Array/Family/ArrayT.js @@ -0,0 +1,444 @@ + +// 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) { + 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) { + var mat = new Float32Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeFloat64(n) { + var mat = new Float64Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeInt8(n) { + var mat = new Int8Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeInt16(n) { + var mat = new Int16Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeInt32(n) { + var mat = new Int32Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeUint8(n) { + var mat = new Uint8Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeUint8Clamped(n) { + var mat = new Uint8ClampedArray(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeUint16(n) { + var mat = new Uint16Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} +function h$easytensor_eyeUint32(n) { + var mat = new Uint32Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=1;} + return mat; +} + + +function h$easytensor_diagFloat32(n,x) { + var mat = new Float32Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagFloat64(n,x) { + var mat = new Float64Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagInt8(n,x) { + var mat = new Int8Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagInt16(n,x) { + var mat = new Int16Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagInt32(n,x) { + var mat = new Int32Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagUint8(n,x) { + var mat = new Uint8Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagUint8Clamped(n,x) { + var mat = new Uint8ClampedArray(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagUint16(n,x) { + var mat = new Uint16Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} +function h$easytensor_diagUint32(n,x) { + var mat = new Uint32Array(n*n).fill(0); + for(var i = 0; i < n*n; i += n + 1){mat[i]=x;} + return mat; +} + +function h$easytensor_trace(mat, n) { + var r = 0; + for(var i = 0; i < n*n; i += n + 1){r+=mat[i];} + return r; +} + + +function h$easytensor_det(mat, n) { + 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) { + return (mat[0]*mat[3] - mat[1]*mat[2]); +} + +function h$easytensor_detJSMat3(mat) { + 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) { + 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) { + 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) { + 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) { + 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) { + 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) { + 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; +} diff --git a/src-ghcjs/Numeric/DataFrame/Contraction.hs b/src-ghcjs/Numeric/DataFrame/Contraction.hs new file mode 100644 --- /dev/null +++ b/src-ghcjs/Numeric/DataFrame/Contraction.hs @@ -0,0 +1,78 @@ +{-# 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 + +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 ( ConcatList as bs asbs + , Dimensions as + , Dimensions bs + ) => 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 asbs :~: ArrayT t asbs + , Refl <- unsafeCoerce Refl :: Array t (as +: m) :~: ArrayT t (as +: m) + , Evidence <- inferConcatDimensions @as @bs + = KnownDataFrame $ js_conctract @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_conctract :: forall t as m bs . Int -> Int -> Int -> ArrayT t (as +: m) -> ArrayT t (m :+ bs) -> ArrayT t (as ++ bs) diff --git a/src-ghcjs/Numeric/DataFrame/Inference.hs b/src-ghcjs/Numeric/DataFrame/Inference.hs new file mode 100644 --- /dev/null +++ b/src-ghcjs/Numeric/DataFrame/Inference.hs @@ -0,0 +1,127 @@ +{-# 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/Numeric/Array.hs b/src/Numeric/Array.hs deleted file mode 100644 --- a/src/Numeric/Array.hs +++ /dev/null @@ -1,33 +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 () diff --git a/src/Numeric/Array/ElementWise.hs b/src/Numeric/Array/ElementWise.hs --- a/src/Numeric/Array/ElementWise.hs +++ b/src/Numeric/Array/ElementWise.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE Strict #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Strict #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Array.ElementWise @@ -17,15 +19,23 @@ ( 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 a container + -- | 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 @@ -49,6 +59,8 @@ instance ElementWise Int Float Float where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -73,6 +85,8 @@ instance ElementWise Int Double Double where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -95,6 +109,8 @@ instance ElementWise Int Int Int where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -117,6 +133,8 @@ instance ElementWise Int Int8 Int8 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -138,6 +156,8 @@ {-# INLINE update #-} instance ElementWise Int Int16 Int16 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -159,6 +179,8 @@ {-# INLINE update #-} instance ElementWise Int Int32 Int32 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -180,7 +202,10 @@ {-# INLINE update #-} +#ifndef ghcjs_HOST_OS instance ElementWise Int Int64 Int64 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -200,9 +225,11 @@ {-# 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 @@ -225,6 +252,8 @@ instance ElementWise Int Word8 Word8 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -247,6 +276,8 @@ instance ElementWise Int Word16 Word16 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -269,6 +300,8 @@ instance ElementWise Int Word32 Word32 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -290,7 +323,10 @@ {-# INLINE update #-} +#ifndef ghcjs_HOST_OS instance ElementWise Int Word64 Word64 where + indexOffset# x _ = x + {-# INLINE indexOffset# #-} (!) x _ = x {-# INLINE (!) #-} ewmap f = f 1 @@ -310,3 +346,4 @@ {-# INLINE broadcast #-} update _ = const {-# INLINE update #-} +#endif diff --git a/src/Numeric/Array/Family.hs b/src/Numeric/Array/Family.hs deleted file mode 100644 --- a/src/Numeric/Array/Family.hs +++ /dev/null @@ -1,422 +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 #-} ------------------------------------------------------------------------------ --- | --- 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 (..) - , ArrayInstanceInference, ElemType (..), ArraySize (..) - , ElemTypeInference (..), ArraySizeInference (..), ArrayInstanceEvidence - , getArrayInstance, ArrayInstance (..), inferArrayInstance - ) where - - -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Type.Equality ((:~:) (..)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Prim (ByteArray#, Double#, Float#, Int#, - Word#, unsafeCoerce#) - -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 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 ( Bounded, Enum, Eq, Integral - , Num, Fractional, Floating, Ord, Read, Real, RealFrac, RealFloat) -instance Show t => Show (Scalar t) where - show (Scalar t) = "{ " ++ show t ++ " }" - -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 Int64 ) = 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 Word64) = Word# - -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 - (!) 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# -data ArrayI64 (ds :: [Nat]) = ArrayI64# Int# Int# ByteArray# - | FromScalarI64# Int# -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# -data ArrayW64 (ds :: [Nat]) = ArrayW64# Int# Int# ByteArray# - | FromScalarW64# Word# - --- * 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# - --- * 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 -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 -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 -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 - --- | 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) -> AIArrayD - (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) -> AIArrayD - (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) -> AIArrayD - (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) -> AIArrayD - (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/Numeric/Array/Family/Array.h b/src/Numeric/Array/Family/Array.h deleted file mode 100644 --- a/src/Numeric/Array/Family/Array.h +++ /dev/null @@ -1,305 +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 - (!) (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/Numeric/Array/Family/ArrayD.hs b/src/Numeric/Array/Family/ArrayD.hs deleted file mode 100644 --- a/src/Numeric/Array/Family/ArrayD.hs +++ /dev/null @@ -1,408 +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.Type - - -#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 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 #) -> 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/Numeric/Array/Family/ArrayF.hs b/src/Numeric/Array/Family/ArrayF.hs deleted file mode 100644 --- a/src/Numeric/Array/Family/ArrayF.hs +++ /dev/null @@ -1,412 +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.Type - -#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 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 #) -> 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/Numeric/Array/Family/ArrayI.hs b/src/Numeric/Array/Family/ArrayI.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/ArrayI16.hs b/src/Numeric/Array/Family/ArrayI16.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/ArrayI32.hs b/src/Numeric/Array/Family/ArrayI32.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/ArrayI64.hs b/src/Numeric/Array/Family/ArrayI64.hs deleted file mode 100644 --- a/src/Numeric/Array/Family/ArrayI64.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.ArrayI64 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayI64 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Int (Int64 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#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# -#include "Array.h" - - -instance Num (ArrayI64 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 (ArrayI64 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src/Numeric/Array/Family/ArrayI8.hs b/src/Numeric/Array/Family/ArrayI8.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/ArrayW.hs b/src/Numeric/Array/Family/ArrayW.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/ArrayW16.hs b/src/Numeric/Array/Family/ArrayW16.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/ArrayW32.hs b/src/Numeric/Array/Family/ArrayW32.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/ArrayW64.hs b/src/Numeric/Array/Family/ArrayW64.hs deleted file mode 100644 --- a/src/Numeric/Array/Family/ArrayW64.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.ArrayW64 --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.Array.Family.ArrayW64 () where - -import GHC.Base (runRW#) -import GHC.Prim -import GHC.Types (Int (..), RuntimeRep (..), isTrue#) -import GHC.Word (Word64 (..)) - -import Numeric.Array.ElementWise -import Numeric.Array.Family -import Numeric.Commons -import Numeric.Dimensions -import Numeric.Dimensions.Traverse - - -#include "MachDeps.h" -#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 EL_MINUS_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# -#include "Array.h" - -instance Num (ArrayW64 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 (ArrayW64 ds) where - minBound = broadcastArray minBound - maxBound = broadcastArray maxBound diff --git a/src/Numeric/Array/Family/ArrayW8.hs b/src/Numeric/Array/Family/ArrayW8.hs deleted file mode 100644 --- a/src/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/Numeric/Array/Family/FloatX2.hs b/src/Numeric/Array/Family/FloatX2.hs deleted file mode 100644 --- a/src/Numeric/Array/Family/FloatX2.hs +++ /dev/null @@ -1,321 +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 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 - - (!) (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/Numeric/Array/Family/FloatX3.hs b/src/Numeric/Array/Family/FloatX3.hs deleted file mode 100644 --- a/src/Numeric/Array/Family/FloatX3.hs +++ /dev/null @@ -1,294 +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 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 - - (!) (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/Numeric/Array/Family/FloatX4.hs b/src/Numeric/Array/Family/FloatX4.hs deleted file mode 100644 --- a/src/Numeric/Array/Family/FloatX4.hs +++ /dev/null @@ -1,329 +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 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 - - (!) (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/Numeric/Commons.hs b/src/Numeric/Commons.hs --- a/src/Numeric/Commons.hs +++ b/src/Numeric/Commons.hs @@ -36,6 +36,7 @@ import GHC.Prim import GHC.Types (Double (..), Float (..), Int (..), RuntimeRep (..), Type, Word (..)) + import GHC.Word (Word16 (..), Word32 (..), Word64 (..), Word8 (..)) @@ -46,12 +47,20 @@ type instance ElemRep Int8 = 'IntRep type instance ElemRep Int16 = 'IntRep type instance ElemRep Int32 = 'IntRep +#if SIZEOF_HSWORD < 8 +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 SIZEOF_HSWORD < 8 +type instance ElemRep Word64 = 'Word64Rep +#else type instance ElemRep Word64 = 'WordRep +#endif type family ElemPrim a :: TYPE (r :: RuntimeRep) type instance ElemPrim Float = Float# @@ -60,13 +69,22 @@ type instance ElemPrim Int8 = Int# type instance ElemPrim Int16 = Int# type instance ElemPrim Int32 = Int# +#if SIZEOF_HSWORD < 8 +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 SIZEOF_HSWORD < 8 +type instance ElemPrim Word64 = Word64# +#else type instance ElemPrim Word64 = Word# +#endif + type FloatBytes a = (PrimBytes a, ElemRep a ~ 'FloatRep , ElemPrim a ~ Float#) type DoubleBytes a = (PrimBytes a, ElemRep a ~ 'DoubleRep, ElemPrim a ~ Double#) type IntBytes a = (PrimBytes a, ElemRep a ~ 'IntRep , ElemPrim a ~ Int#) @@ -200,6 +218,7 @@ 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 @@ -217,6 +236,7 @@ {-# INLINE elementByteSize #-} ix _ (I64# x) = x {-# INLINE ix #-} +#endif instance PrimBytes Word where toBytes v@(W# x) = case runRW# @@ -291,6 +311,7 @@ {-# INLINE ix #-} +#ifndef ghcjs_HOST_OS instance PrimBytes Word64 where toBytes v@(W64# x) = case runRW# ( \s0 -> case newByteArray# (byteSize v) s0 of @@ -308,3 +329,5 @@ {-# INLINE elementByteSize #-} ix _ (W64# x) = x {-# INLINE ix #-} +#endif + diff --git a/src/Numeric/DataFrame/Contraction.hs b/src/Numeric/DataFrame/Contraction.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Contraction.hs +++ /dev/null @@ -1,535 +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 #-} ------------------------------------------------------------------------------ --- | --- 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.Int (Int16, Int32, Int64, Int8) -import Data.Type.Equality ((:~:) (..)) -import Data.Word (Word16, Word32, Word64, Word8) -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) - , 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# - = 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) - , 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# - = prodW64 n m k x y - where - getM :: forall m p . p (m ': bs) -> Proxy m - getM _ = Proxy - - - - - -prodF :: (FloatBytes a, FloatBytes b, PrimBytes c) => 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 :: (DoubleBytes a, DoubleBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => 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 :: (IntBytes a, IntBytes b, PrimBytes c) => Int# -> Int# -> Int# -> a -> b -> c -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 #-} - -prodW :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => 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 :: (WordBytes a, WordBytes b, PrimBytes c) => Int# -> Int# -> Int# -> a -> b -> c -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 #-} - - --- | 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# #-} - - --- contract' :: forall (t :: Type) (m :: Nat) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) --- . ( ToList asbs ~ SimplifyList ('Concat (ToList as) (ToList bs)) --- , ToList as ~ SimplifyList ('Prefix (ToList bs) (ToList asbs)) --- , ToList bs ~ SimplifyList ('Suffix (ToList as) (ToList asbs)) --- , Dimensions asbs --- , Dimensions (as +: m) --- , Dimensions (m :+ bs) --- , KnownDim m --- , ElementDataType t --- ) --- => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs --- contract' x y = case dim @asbs of --- D -> case ( unsafeCoerce Refl :: as :~: '[] --- , unsafeCoerce Refl :: bs :~: '[] --- ) of --- (Refl, Refl) -> case edtRefl (Proxy @t) of --- EDTFloat -> contract x y --- _ :* (sbs :: Dim (sbs :: [Nat])) -> case edtRefl (Proxy @t) of --- EDTFloat -> contract x y - -- case ( unsafeCoerce Refl :: EvalConsNat (SimplifyList (ToListNat sbs)) :~: sbs - -- , unsafeCoerce Refl :: SimplifyList (ToListNat bs) :~: ToListNat bs - -- , unsafeCoerce Refl :: ToList (as +: m) :~: SimplifyList (ToList (as +: m)) - -- ) of - -- (Refl, Refl, Refl) -> case edtRefl (Proxy @t) of - -- EDTFloat -> contract x y diff --git a/src/Numeric/DataFrame/Inference.hs b/src/Numeric/DataFrame/Inference.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Inference.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# 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 - -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 - - -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 - 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/Numeric/DataFrame/SubSpace.hs b/src/Numeric/DataFrame/SubSpace.hs --- a/src/Numeric/DataFrame/SubSpace.hs +++ b/src/Numeric/DataFrame/SubSpace.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,6 +15,10 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} +#ifdef ghcjs_HOST_OS +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE UnliftedFFITypes #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Numeric.DataFrame.SubSpace @@ -35,6 +40,10 @@ import GHC.Prim import GHC.Types (Int (..), Type) +#ifdef ghcjs_HOST_OS +import GHCJS.Types (JSVal) +import Unsafe.Coerce (unsafeCoerce) +#endif import qualified Numeric.Array.ElementWise as EW import Numeric.Commons @@ -45,18 +54,31 @@ import Numeric.Scalar -- | Operations on DataFrames --- as is an element dimensionality --- bs is an indexing dimensionality --- t is an underlying data type (i.e. Float, Int, Double) -- +-- @as@ is an element dimensionality +-- +-- @bs@ is an indexing dimensionality +-- +-- @t@ is an underlying data type (i.e. Float, Int, Double) +-- class ( ConcatList as bs asbs , Dimensions as , Dimensions bs , Dimensions asbs ) => SubSpace (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) | asbs as -> bs, asbs bs -> as, as bs -> asbs where - -- | Get an element + -- | Unsafely get a sub-dataframe by its primitive element subset. + -- The offset is not checked to be aligned to the space structure or for bounds. + -- Arguments are zero-based element offset and 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 (!.) #-} -- | Set a new value to an element update :: Idx bs -> DataFrame t as -> DataFrame t asbs -> DataFrame t asbs -- | Map a function over each element of DataFrame @@ -174,6 +196,9 @@ {-# 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 @@ -185,15 +210,28 @@ , as ~ (a'' ': as'') , asbs ~ (a'' ': asbs'') ) => SubSpace t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) where - - i !. d = r - where - r = case (# toBytes d, fromEnum i, totalDim r #) of - (# (# off, _, arr #), I# i#, I# l# #) - -> fromBytes (# off +# i# *# l#, l#, arr #) - {-# INLINE (!.) #-} +#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# #-} - ewmap = iwmap . const + ewmap f df + | elS <- elementByteSize (undefined :: DataFrame t asbs) + , I# lenBS <- totalDim (Proxy @bs) + , I# lenAS <- totalDim (Proxy @as) + , lenASB <- lenAS *# elS + = case runRW# + ( \s0 -> case newByteArray# (lenAS *# lenBS *# elS) s0 of + (# s1, marr #) -> case overDimOff_# + (dim @bs) + ( \pos s -> case toBytes $ f (indexOffset# pos lenAS df) of + (# offX, _, arrX #) -> copyByteArray# arrX (offX *# elS) marr (pos *# elS) lenASB s + ) 0# lenAS s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, r #) -> fromBytes (# 0#, lenAS *# lenBS, r #) {-# INLINE ewmap #-} iwmap f df @@ -205,9 +243,9 @@ ( \s0 -> case newByteArray# (lenAS *# lenBS *# elS) s0 of (# s1, marr #) -> case overDim_# (dim @bs) - ( \i pos s -> case toBytes $ f i (i !. df) of - (# offX, _, arrX #) -> copyByteArray# arrX (offX *# elS) marr pos lenASB s - ) 0# lenASB s1 of + ( \i pos s -> case toBytes $ f i (indexOffset# pos lenAS df) of + (# offX, _, arrX #) -> copyByteArray# arrX (offX *# elS) marr (pos *# elS) lenASB s + ) 0# lenAS s1 of s2 -> unsafeFreezeByteArray# marr s2 ) of (# _, r #) -> fromBytes (# 0#, lenAS *# lenBS, r #) @@ -334,6 +372,8 @@ , 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 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -147,6 +148,8 @@ 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 @@ -206,12 +209,18 @@ 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 type instance ElemPrim (DataFrame Int64 ds) = Int# +#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 type instance ElemPrim (DataFrame Word64 ds) = Word# +#endif deriving instance ( PrimBytes (Array Float ds) , ElemPrim (Array Float ds) ~ Float# , ElemRep (Array Float ds) ~ 'FloatRep) => PrimBytes (DataFrame Float ds) @@ -230,9 +239,11 @@ 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) , ElemPrim (Array Int64 ds) ~ Int# , ElemRep (Array Int64 ds) ~ 'IntRep) => 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) @@ -245,9 +256,15 @@ 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) , ElemPrim (Array Word64 ds) ~ Word# , ElemRep (Array Word64 ds) ~ 'WordRep) => PrimBytes (DataFrame Word64 ds) +#endif diff --git a/src/Numeric/Matrix/Type.hs b/src/Numeric/Matrix/Type.hs --- a/src/Numeric/Matrix/Type.hs +++ b/src/Numeric/Matrix/Type.hs @@ -40,7 +40,7 @@ -- | 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 -> t + det :: Matrix t n n -> Scalar t -- | Sum of diagonal elements trace :: Matrix t n n -> Scalar t