diff --git a/bench/misc.hs b/bench/misc.hs --- a/bench/misc.hs +++ b/bench/misc.hs @@ -5,70 +5,73 @@ module Main (main) where -import Numeric.DataFrame -import Numeric.Dimensions +import Numeric.DataFrame +import Numeric.Dimensions -import qualified Control.Monad.ST as ST +import qualified Control.Monad.ST as ST import qualified Numeric.DataFrame.ST as ST --- import qualified Numeric.Dimensions.Traverse.ST as ST main :: IO () main = do putStrLn "Hello world!" - print (D @3 :* D @2 :* U) + print (D3 :* D2 :* U) - print (fromList D [vec2 1 0, vec2 2 3, vec2 3 4, vec2 5 6] - :: Maybe (DataFrame Int '[N 2, XN 2])) - print (fromList D [vec4 1 0 2 11, vec4 2 22 3 0, vec4 3 4 0 0] - :: Maybe (DataFrame Double '[N 4, XN 0])) - print (fromList D [vec2 0 0, vec2 2 22, vec2 2 22] - :: Maybe (DataFrame Float '[N 2, XN 4])) - print $ fromList (D @3) [0 :: Scf, 1, 3, 5, 7] - print ( fromList D [9, 13, 2] - :: Maybe (DataFrame Float '[N 5, N 2, XN 2])) + print (fromList [vec2 1 0, vec2 2 3, vec2 3 4, vec2 5 6] + :: DataFrame Int '[XN 0, N 2]) + print (fromList [vec4 1 0 2 11, vec4 2 22 3 0, vec4 3 4 0 0] + :: DataFrame Double '[XN 0, N 4]) + print (fromList [vec2 0 0, vec2 2 22, vec2 2 22] + :: DataFrame Float '[XN 0, N 2]) + print $ fromList [0 :: Scf, 1, 3, 5, 7] + print ( fromList [9, 13, 2] + :: DataFrame Float '[XN 0, N 5, N 2]) print $ vec2 1 1 %* mat22 1 (vec2 2 (3 :: Float)) - print (toList (42 :: DataFrame Int '[4,3,2])) + -- Seems like I have to specify known dimension explicitly, -- because the inference process within the pattern match -- cannot escape the case expression. -- On the other hand, if I type wrong dimension it will throw a nice type-level error. - () <- case fromList D [10, 100, 1000] :: Maybe (DataFrame Double '[N 4, N 2, XN 2]) of - Just (XFrame m) + () <- case (fromList [10, 100, 1000] :: DataFrame Double '[XN 0, N 2, N 4]) of + XFrame m | KnownDims <- dims `inSpaceOf` m -- Amazing inference! - -- m :: KnownNat k => DataFrame '[4,2,k] - -> print $ vec4 1 2.25 3 0.162 %* m - Nothing -> print "Failed to construct a DataFrame!" + -- m :: KnownNat k => DataFrame '[k,2,4] + -> print $ m %* vec4 1 2.25 3 0.162 + _ -> print "Failed to construct a DataFrame!" putStrLn "Constructing larger matrices" - let x :: DataFrame Double '[2,5,4] - x = transpose ( (56707.4 <::> 73558.41 <+:> 47950.074 <+:> 83394.61 <+:> 25611.629 ) - <::> (53704.516 <::> -3277.478 <+:> 99479.92 <+:> 18915.17 <+:> 59666.938 ) ) - <::> transpose ( (-3035.543 <::> 15831.447 <+:> 73256.625 <+:> 80709.38 <+:> 72695.04 ) - <::> (50932.49 <::> 7865.496 <+:> -4050.5957 <+:> 99839.41 <+:> 10834.297 ) ) - <+:> transpose ( (21961.227 <::> 29640.914 <+:> 39657.19 <+:> 81469.64 <+:> 17815.506 ) - <::> (-8484.239 <::> 16877.531 <+:> 65145.742 <+:> 80219.67 <+:> 81508.87 ) ) - <+:> transpose ( (53105.71 <::> 16255.646 <+:> 23324.957 <+:> -4438.164 <+:> 35369.824 ) - <::> (67930.45 <::> 8950.834 <+:> 64451.71 <+:> 76685.57 <+:> 6728.465 ) ) - y :: DataFrame Double '[3,7] - y = transpose $ - (70096.85 <::> 34332.492 <+:> 3642.8867 <+:> 25242.25 <+:> 59776.234 <+:> 12092.57 <+:> 10708.498) - <::> (46447.965 <::> 37145.668 <+:> 56899.656 <+:> 85367.56 <+:> 15872.262 <+:> 87466.24 <+:> 82506.76 ) - <+:> (50458.848 <::> 31650.453 <+:> 71432.78 <+:> 53073.203 <+:> 59267.883 <+:> 82369.89 <+:> 78171.56 ) - z = ewgen x :: DataFrame Double '[2,5,4,3,7] - print $ ewfoldl @_ @'[2] (+) 10 z - print $ ewfoldr @_ @'[2,5] (+) 0 z + 10 - print $ ewfoldl (+) 10 z - ewfoldr @_ @'[2,5,4] (+) 0 z - 10 + let x :: DataFrame Double '[4,5,2] + x = DF4 (transpose $ DF2 + (DF5 56707.4 73558.41 47950.074 83394.61 25611.629) + (DF5 53704.516 (-3277.478) 99479.92 18915.17 59666.938)) + (transpose $ DF2 + (DF5 (-3035.543) 15831.447 73256.625 80709.38 72695.04) + (DF5 50932.49 7865.496 (-4050.5957) 99839.41 10834.297)) + (transpose $ DF2 + (DF5 21961.227 29640.914 39657.19 81469.64 17815.506 ) + (DF5 (-8484.239) 16877.531 65145.742 80219.67 81508.87 )) + (transpose $ DF2 + (DF5 53105.71 16255.646 23324.957 (-4438.164) 35369.824 ) + (DF5 67930.45 8950.834 64451.71 76685.57 6728.465 )) + y :: DataFrame Double '[7,3] + y = transpose $ DF3 + (DF7 70096.85 34332.492 3642.8867 25242.25 59776.234 12092.57 10708.498) + (DF7 46447.965 37145.668 56899.656 85367.56 15872.262 87466.24 82506.76 ) + (DF7 50458.848 31650.453 71432.78 53073.203 59267.883 82369.89 78171.56 ) + z = ewgen x :: DataFrame Double '[7,3,4,5,2] + print $ ewfoldl @_ @_ @'[2] (+) 10 z + print $ ewfoldr @_ @_ @'[5,2] (+) 0 z + 10 + print $ ewfoldl (+) 10 z - ewfoldr @_ @_ @'[4,5,2] (+) 0 z - 10 - -- We can map arbitrary prefix dimension over the dataframe, - -- indexing by suffix dimensions. + -- We can map arbitrary suffix dimension over the dataframe, + -- indexing by prefix dimensions. -- At the same time, we can transform underlying element type - -- or prefix dimensionality. + -- or suffix dimensionality. -- For example, we can do tensor produt of every sub-tensor. putStrLn "\nConversions between element types and frame sizes." - print $ iwmap @Int @'[2,2] @'[7] @_ - (\(Idx i:*U) v -> fromScalar . (scalar (fromIntegral i) +) . round + print $ iwmap @Int @'[7] @'[2,2] @_ + (\(i:*U) v -> fromScalar . (scalar (fromIntegral i) +) . round $ vec3 0.02 (-0.01) 0.001 %* v ) y @@ -77,27 +80,27 @@ -- This means we can even do arbitrary IO for each subtensor -- indexed by suffix dimensions. putStrLn "\nWelement-wise IO!" - rVec <- elementWise @Double @_ @'[4] @_ + rVec <- elementWise @Double @'[4] @_ @_ (\v -> print v >> return (sqrt . trace $ v %* transpose v)) x putStrLn "\nTraces for each matrix element:" print rVec -- Updating existing frames print $ update (2:*U) (scalar 777) rVec - print $ update (2:*3:*U) (vec2 999 999) x + print $ update (1:*3:*U) (vec2 999 555) x - let matX = iwgen (scalar . fromEnum) :: DataFrame Int '[2,5,4] + let matX = iwgen (scalar . fromEnum) :: DataFrame Int '[2,6,4] matY = iwgen (scalar . fromEnum) :: DataFrame Int '[5,4] putStrLn "Check carefully that this returns no garbage" print matX - print (ewmap (<+:> scalar 111) matX :: DataFrame Int '[3,5,4]) + print (ewmap @_ @'[2,6] (`snocDF` scalar 111) matX :: DataFrame Int '[2,6,5]) print matY - print (ewmap fromScalar matY :: DataFrame Int '[3,5,4]) + print (ewmap fromScalar matY :: DataFrame Int '[5,4,3]) -- Working with mutable frames print $ ST.runST $ do sdf <- ST.thawDataFrame matY - ST.writeDataFrame sdf (1:*1:*U) 900101 - ST.writeDataFrame sdf (3:*3:*U) 900303 - ST.writeDataFrame sdf (5:*3:*U) 900503 + ST.writeDataFrame sdf (0:*0:*U) 900101 + ST.writeDataFrame sdf (2:*2:*U) 900303 + ST.writeDataFrame sdf (4:*2:*U) 900503 ST.unsafeFreezeDataFrame sdf diff --git a/bench/subspacefolds.hs b/bench/subspacefolds.hs --- a/bench/subspacefolds.hs +++ b/bench/subspacefolds.hs @@ -5,58 +5,58 @@ module Main (main) where -import Data.Maybe (fromMaybe) -import Data.Time.Clock +import Data.Maybe (fromMaybe) +import Data.Time.Clock -import Numeric.DataFrame -import Numeric.Dimensions +import Numeric.DataFrame +import Numeric.Dimensions -type DList = [6,4,10,7,35,8,12] -- [6,26,8,10,35,8,12] +type DList = [6,14,10,7,2,8,5] main :: IO () main = do t0 <- getCurrentTime putStrLn $ "\nStarting benchmarks, current time is " ++ show t0 - let df = iwgen @Float @'[] @DList (fromIntegral . fromEnum) + let df = iwgen @Float @DList @'[] (fromIntegral . fromEnum) t1 <- df `seq` getCurrentTime 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 -> return $! fromMaybe x a + fromMaybe 0 a / (x+1)) (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 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 + let rezIwf = iwfoldl @Float @DList @'[] (\_ a x -> a + a / (x+1)) 1 df t3 <- rezIwf `seq` getCurrentTime 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 -> return $! fromMaybe 0 a + x / ((1+) . fromIntegral $ fromEnum i)) (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 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` return $! fromMaybe 0 a + fromMaybe x a / (x+1)) (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 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 @_ @'[] (\(Idx i:*U) -> Idx (i+1) :* U !. x )) ) - (Just (3 :: DataFrame Float '[5])) df + putStrLn "\nRunning a ewfoldl on vector4 elements..." + let rezEwv1 = ewfoldl @Float @(Init DList) @'[Last DList] + (\a x -> return $! fromMaybe 2 a + fromMaybe 0 a / (1 + iwgen @_ @_ @'[] (\(Idx i:*U) -> x ! Idx (i+1) :* U )) ) + (Just (3 :: DataFrame Float '[4])) df t6 <- rezEwv1 `seq` getCurrentTime 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 @_ @'[] (\(Idx i:*U) -> Idx (i+1):* U !. x ))) + let rezEwv2 = ewfoldr @Float @(Init DList) @'[Last DList] + (\x a -> return $! fromMaybe 2 a + fromMaybe 1 a / (1 + iwgen @_ @_ @'[] (\(Idx i:*U) -> x ! Idx (i+1):* U ))) (Just (3 :: DataFrame Float '[3])) df t7 <- rezEwv2 `seq` getCurrentTime seq t7 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t7 t6) @@ -64,8 +64,8 @@ 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 + (\x a -> a + x %* (DF5 1 0.5 0.1 0.01 0.001) ) + (1 :: DataFrame Float (Init (Drop 3 DList) +: 3)) df t8 <- rezEwm `seq` getCurrentTime seq t8 putStrLn $ "Done; elapsed time = " ++ show (diffUTCTime t8 t7) print rezEwm @@ -74,4 +74,4 @@ putStrLn "Checking indexes" - print $ 2:*1:*1:*3:*1:*U !. df + print $ df ! (2:*1:*1:*3:*1:*U :: Idxs (Take 5 DList)) diff --git a/easytensor.cabal b/easytensor.cabal --- a/easytensor.cabal +++ b/easytensor.cabal @@ -1,136 +1,139 @@ -name: easytensor -version: 1.0.1.0 -cabal-version: >=1.22 -build-type: Simple -license: BSD3 -license-file: LICENSE -copyright: (c) Artem Chirkin -maintainer: chirkin@arch.ethz.ch -homepage: https://github.com/achirkin/easytensor#readme -synopsis: Pure, type-indexed haskell vector, matrix, and tensor library. -description: - 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 +cabal-version: 1.12 -source-repository head - type: git - location: https://github.com/achirkin/easytensor.git - subdir: easytensor +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 295fd017e3f09157b9e9a28d1db9beb6ecb080f0612228ac49f18e78ee08d01b +name: easytensor +version: 2.0.0.0 +synopsis: Pure, type-indexed haskell vector, matrix, and tensor library. +description: 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. Please see the README on GitHub at +category: math, geometry +homepage: https://github.com/achirkin/easytensor#readme +bug-reports: https://github.com/achirkin/easytensor/issues +author: Artem Chirkin +maintainer: achirkin@users.noreply.github.com +copyright: Copyright: (c) 2019 Artem Chirkin +license: BSD3 +license-file: LICENSE +build-type: Simple -flag unsafeindices - description: - Disable bound checks when accessing elements of a tensor, matrix, or vector. - default: False +source-repository head + type: git + location: https://github.com/achirkin/easytensor + subdir: easytensor +flag unsafeindices + description: Disable bound checks when accessing elements of a tensor, matrix, or vector. + manual: True + default: False library - - if flag(unsafeindices) - cpp-options: -DUNSAFE_INDICES - exposed-modules: - Numeric.DataFrame - Numeric.DataFrame.IO - Numeric.DataFrame.ST - Numeric.Matrix - Numeric.Matrix.Class - Numeric.Vector - Numeric.Scalar - Numeric.Quaternion - Numeric.Semigroup - Numeric.PrimBytes - Numeric.DataFrame.Type - Numeric.DataFrame.Family - Numeric.DataFrame.Shape - Numeric.DataFrame.SubSpace - Numeric.DataFrame.Contraction - Numeric.DataFrame.Internal.Mutable - Numeric.DataFrame.Internal.Array - Numeric.DataFrame.Internal.Array.Class - Numeric.DataFrame.Internal.Array.Family - Numeric.DataFrame.Internal.Array.Family.ArrayBase - Numeric.DataFrame.Internal.Array.Family.ScalarBase - Numeric.DataFrame.Internal.Array.Family.FloatX2 - Numeric.DataFrame.Internal.Array.Family.FloatX3 - Numeric.DataFrame.Internal.Array.Family.FloatX4 - Numeric.DataFrame.Internal.Array.Family.DoubleX2 - Numeric.DataFrame.Internal.Array.Family.DoubleX3 - Numeric.DataFrame.Internal.Array.Family.DoubleX4 - Numeric.DataFrame.Internal.Array.PrimOps - build-depends: - base >=4.10 && <5, - dimensions >=1.0.0.0 - default-language: Haskell2010 - if impl(ghc >= 8.6) - default-extensions: NoStarIsType - hs-source-dirs: src - other-modules: - Numeric.Matrix.Mat44d - Numeric.Matrix.Mat44f - Numeric.Quaternion.Class - Numeric.Quaternion.QDouble - Numeric.Quaternion.QFloat - ghc-options: - -Wall - -fwarn-tabs - -fwarn-unused-do-bind - -fwarn-monomorphism-restriction - + exposed-modules: + Numeric.DataFrame + Numeric.DataFrame.Contraction + Numeric.DataFrame.Internal.Backend + Numeric.DataFrame.Internal.Mutable + Numeric.DataFrame.Internal.PrimArray + Numeric.DataFrame.IO + Numeric.DataFrame.ST + Numeric.DataFrame.SubSpace + Numeric.DataFrame.Type + Numeric.Matrix + Numeric.PrimBytes + Numeric.ProductOrd + Numeric.ProductOrd.NonTransitive + Numeric.ProductOrd.Partial + Numeric.Quaternion + Numeric.Scalar + Numeric.Vector + other-modules: + Numeric.Matrix.Internal + Numeric.Matrix.Internal.Mat44d + Numeric.Matrix.Internal.Mat44f + Numeric.Scalar.Internal + Numeric.Vector.Internal + Numeric.Quaternion.Internal + Numeric.Quaternion.Internal.QDouble + Numeric.Quaternion.Internal.QFloat + Numeric.DataFrame.Internal.Backend.Family + Numeric.DataFrame.Internal.Backend.Family.ArrayBase + Numeric.DataFrame.Internal.Backend.Family.DoubleX2 + Numeric.DataFrame.Internal.Backend.Family.DoubleX3 + Numeric.DataFrame.Internal.Backend.Family.DoubleX4 + Numeric.DataFrame.Internal.Backend.Family.FloatX2 + Numeric.DataFrame.Internal.Backend.Family.FloatX3 + Numeric.DataFrame.Internal.Backend.Family.FloatX4 + Numeric.DataFrame.Internal.Backend.Family.ScalarBase + Numeric.DataFrame.Internal.BackendI + hs-source-dirs: + src + src-base + ghc-options: -Wall -Wcompat -Wtabs -Wmonomorphism-restriction -Wmissing-local-signatures -Wmissing-home-modules -Widentities -Wredundant-constraints + build-depends: + base >=4.11 && <5 + , constraints-deriving >=1.0.4.0 && <2 + , dimensions >=2 && <3 + if flag(unsafeindices) + cpp-options: -DUNSAFE_INDICES + default-language: Haskell2010 test-suite et-test - - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Numeric.DataFrame.Arbitraries - Numeric.DataFrame.SubSpaceTest - Numeric.DataFrame.BasicTest - Numeric.MatrixDoubleTest - Numeric.MatrixFloatTest - Numeric.QuaternionTest - build-depends: - base -any, - Cabal -any, - QuickCheck -any, - easytensor -any, - dimensions -any - default-language: Haskell2010 - if impl(ghc >= 8.6) - default-extensions: NoStarIsType, NoMonadFailDesugaring - hs-source-dirs: test - ghc-options: -Wall -fwarn-tabs -O2 - + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Numeric.DataFrame.Arbitraries + Numeric.DataFrame.BasicTest + Numeric.DataFrame.SubSpaceTest + Numeric.MatrixDoubleTest + Numeric.MatrixFloatTest + Numeric.PrimBytesTest + Numeric.QuaterDoubleTest + Numeric.QuaterFloatTest + Spec.Util + Paths_easytensor + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Wtabs -Wmonomorphism-restriction -Wmissing-local-signatures -Wmissing-home-modules -Widentities -Wredundant-constraints + build-depends: + Cabal + , QuickCheck + , base >=4.11 && <5 + , constraints-deriving >=1.0.4.0 && <2 + , dimensions >=2 && <3 + , easytensor + , template-haskell + default-language: Haskell2010 benchmark et-bench-misc - - type: exitcode-stdio-1.0 - main-is: misc.hs - build-depends: - base -any, - easytensor -any, - dimensions -any - default-language: Haskell2010 - if impl(ghc >= 8.6) - default-extensions: NoStarIsType, NoMonadFailDesugaring - hs-source-dirs: bench - ghc-options: -Wall -fwarn-tabs -O2 - + type: exitcode-stdio-1.0 + main-is: misc.hs + other-modules: + Paths_easytensor + hs-source-dirs: + bench + ghc-options: -Wall -Wcompat -Wtabs -Wmonomorphism-restriction -Wmissing-local-signatures -Wmissing-home-modules -Widentities -Wredundant-constraints + build-depends: + base >=4.11 && <5 + , constraints-deriving >=1.0.4.0 && <2 + , dimensions >=2 && <3 + , easytensor + default-language: Haskell2010 benchmark et-bench-spfolds - - type: exitcode-stdio-1.0 - main-is: subspacefolds.hs - build-depends: - base -any, - easytensor -any, - dimensions -any, - time -any - default-language: Haskell2010 - if impl(ghc >= 8.6) - default-extensions: NoStarIsType, NoMonadFailDesugaring - hs-source-dirs: bench - ghc-options: -Wall -fwarn-tabs -O2 + type: exitcode-stdio-1.0 + main-is: subspacefolds.hs + other-modules: + Paths_easytensor + hs-source-dirs: + bench + ghc-options: -Wall -Wcompat -Wtabs -Wmonomorphism-restriction -Wmissing-local-signatures -Wmissing-home-modules -Widentities -Wredundant-constraints + build-depends: + base >=4.11 && <5 + , constraints-deriving >=1.0.4.0 && <2 + , dimensions >=2 && <3 + , easytensor + , time + default-language: Haskell2010 diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +-- Constraints @b ~ BackendFamily t ds@ is not redundant; they allows to avoid AllowAmbigousTypes. +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{- | +This module is to be reimplemented multiple times based on a platform capabilities. +For example, I can add a SIMD implementation in a separate folder and use AVX +processsor extensions to make faster 4D vector operations. + +Various implementations would be picked by activating corresponding cabal flags. + +The following export list must be the same for every implementation + -} +module Numeric.DataFrame.Internal.Backend.Family + ( BackendFamily, KnownBackend () + , inferKnownBackend, inferPrimElem, inferPrimArray, inferBackendInstance + ) where + + +import Data.Constraint +import GHC.Base + +import Numeric.DataFrame.Internal.Backend.Family.ArrayBase +import Numeric.DataFrame.Internal.Backend.Family.DoubleX2 +import Numeric.DataFrame.Internal.Backend.Family.DoubleX3 +import Numeric.DataFrame.Internal.Backend.Family.DoubleX4 +import Numeric.DataFrame.Internal.Backend.Family.FloatX2 +import Numeric.DataFrame.Internal.Backend.Family.FloatX3 +import Numeric.DataFrame.Internal.Backend.Family.FloatX4 +import Numeric.DataFrame.Internal.Backend.Family.ScalarBase +import Numeric.DataFrame.Internal.PrimArray +import Numeric.Dimensions +import Numeric.PrimBytes + + +-- | This type family aggregates all types used for arrays with different +-- dimensioinality. +-- The family is injective; thus, it is possible to get type family instance +-- given the data constructor (and vice versa). +-- If GHC knows the dimensionality of a backend at compile time, it chooses +-- a more efficient specialized instance of @BackendFamily@, e.g. Scalar newtype wrapper. +-- Otherwise, it falls back to the generic ArrayBase implementation. +-- +-- Data family would not work here, because it would give overlapping instances. +type family BackendFamily (t :: Type) (ds :: [Nat]) = (v :: Type) | v -> t ds where + BackendFamily t '[] = ScalarBase t + BackendFamily Float '[2] = FloatX2 + BackendFamily Float '[3] = FloatX3 + BackendFamily Float '[4] = FloatX4 + BackendFamily Double '[2] = DoubleX2 + BackendFamily Double '[3] = DoubleX3 + BackendFamily Double '[4] = DoubleX4 + BackendFamily t ds = ArrayBase t ds + +-- | Promise that we are sure the backend is ArrayBase. +unsafeDefault :: forall t ds . Dict (BackendFamily t ds ~ ArrayBase t ds) +unsafeDefault = unsafeCoerce# (Dict @(ArrayBase t ds ~ ArrayBase t ds)) + +-- | Singleton type used to determine the currently used DataFrame backend; +-- establishes a good bijection @b <~> t ds@ (better than just using @BackendFamily@ everywhere). +data BackendSing (t :: Type) (ds :: [Nat]) (backend :: Type) where + BSC :: BackendSing t '[] (ScalarBase t) + BF2 :: BackendSing Float '[2] FloatX2 + BF3 :: BackendSing Float '[3] FloatX3 + BF4 :: BackendSing Float '[4] FloatX4 + BD2 :: BackendSing Double '[2] DoubleX2 + BD3 :: BackendSing Double '[3] DoubleX3 + BD4 :: BackendSing Double '[4] DoubleX4 + BPB :: ( PrimBytes t, BackendFamily t ds ~ ArrayBase t ds ) + => BackendSing t ds (ArrayBase t ds) + +-- | A framework for using DataFrame type family instances. +class KnownBackend (t :: Type) (ds :: [Nat]) (backend :: Type) where + -- | Get DataFrame backend type family instance + bSing :: BackendSing t ds backend + +-- When compiled for haddock, some of the modules complain about missing KnownBackend +-- instance. To workaround this, I add an instance stub. +-- +-- Also note, these may be related issues: +-- +-- https://github.com/haskell/haddock/issues/680 +-- https://github.com/haskell/cabal/issues/4513 +-- +#if defined(__HADDOCK__) || defined(__HADDOCK_VERSION__) +instance KnownBackend t ds b where bSing = undefined +#else +instance KnownBackend t '[] (ScalarBase t) where bSing = BSC +instance KnownBackend Float '[2] FloatX2 where bSing = BF2 +instance KnownBackend Float '[3] FloatX3 where bSing = BF3 +instance KnownBackend Float '[4] FloatX4 where bSing = BF4 +instance KnownBackend Double '[2] DoubleX2 where bSing = BD2 +instance KnownBackend Double '[3] DoubleX3 where bSing = BD3 +instance KnownBackend Double '[4] DoubleX4 where bSing = BD4 +instance PrimBytes t + => KnownBackend t ds (ArrayBase t ds) where + bSing = case unsafeDefault @t @ds of Dict -> BPB +#endif + +-- | Find an instance of `KnownBackend` class using `PrimBytes` and `Dimensions`. +inferKnownBackend :: forall t ds b + . (PrimBytes t, Dimensions ds, b ~ BackendFamily t ds) + => Dict (KnownBackend t ds b) +inferKnownBackend = case (dims @ds, primTag @t undefined) of + (U, _) -> Dict + (d :* U, PTagFloat) + | Just Dict <- sameDim (D @2) d -> Dict + | Just Dict <- sameDim (D @3) d -> Dict + | Just Dict <- sameDim (D @4) d -> Dict + (d :* U, PTagDouble) + | Just Dict <- sameDim (D @2) d -> Dict + | Just Dict <- sameDim (D @3) d -> Dict + | Just Dict <- sameDim (D @4) d -> Dict + _ -> case unsafeDefault @t @ds of Dict -> Dict +{-# INLINE inferKnownBackend #-} + + +-- This function determines the logic of instance selection +-- for the type family +inferBackendInstance + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) (c :: Type -> Constraint) + . ( KnownBackend t ds b + , c (ScalarBase t) + , c FloatX2, c FloatX3, c FloatX4 + , c DoubleX2, c DoubleX3, c DoubleX4 + , c (ArrayBase t ds) + , b ~ BackendFamily t ds + ) + => Dict (c b) +inferBackendInstance = case bSing @t @ds @b of + BSC -> Dict + BF2 -> Dict + BF3 -> Dict + BF4 -> Dict + BD2 -> Dict + BD3 -> Dict + BD4 -> Dict + BPB -> Dict +{-# INLINE inferBackendInstance #-} + +inferPrimElem :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) (b :: Type) + . ( KnownBackend t (d ': ds) b + , b ~ BackendFamily t (d ': ds) + ) + => b -> Dict (PrimBytes t) +inferPrimElem _ = case bSing @t @(d ': ds) @b of + BF2 -> Dict + BF3 -> Dict + BF4 -> Dict + BD2 -> Dict + BD3 -> Dict + BD4 -> Dict + BPB -> Dict + +-- Need a separate function for this one due to a functional dependency +inferPrimArray + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (PrimBytes t, KnownBackend t ds b, b ~ BackendFamily t ds) + => Dict (PrimArray t b) +inferPrimArray = case bSing @t @ds @b of + BSC -> Dict + BF2 -> Dict + BF3 -> Dict + BF4 -> Dict + BD2 -> Dict + BD3 -> Dict + BD4 -> Dict + BPB -> Dict +{-# INLINE inferPrimArray #-} diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family.hs-boot b/src-base/Numeric/DataFrame/Internal/Backend/Family.hs-boot new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family.hs-boot @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module Numeric.DataFrame.Internal.Backend.Family + ( BackendFamily, KnownBackend () + ) where + +import Data.Kind (Type) +import GHC.TypeLits (Nat) + + +type family BackendFamily (t :: Type) (ds :: [Nat]) = (v :: Type) | v -> t ds where .. +class KnownBackend (t :: Type) (ds :: [Nat]) (backend :: Type) + +-- When compiled for haddock, some of the modules complain about missing KnownBackend +-- instance. To workaround this, I add an instance stub. +-- +-- Also note, these may be related issues: +-- +-- https://github.com/haskell/haddock/issues/680 +-- https://github.com/haskell/cabal/issues/4513 +-- +#if defined(__HADDOCK__) || defined(__HADDOCK_VERSION__) +instance KnownBackend t ds b +#endif diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/ArrayBase.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/ArrayBase.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/ArrayBase.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +module Numeric.DataFrame.Internal.Backend.Family.ArrayBase + ( ArrayBase (..) + ) where + +import Data.Coerce +import Data.Int +import Data.Word +import GHC.Base hiding (foldr) +import Numeric.DataFrame.Internal.PrimArray +import Numeric.Dimensions +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + +-- | Generic Array implementation. +-- This array can reside in plain `ByteArray#` and can share the @ByteArray#@ +-- with other arrays. +-- However, byte offset in the @ByteArray#@ must be multiple of the element size. +data ArrayBase (t :: Type) (ds :: [Nat]) + = ArrayBase + (# t -- Same value for each element; + -- this is the cheapest way to initialize an array. + -- It is also used for Num instances to avoid dependency on Dimensions. + | (# Int# -- Offset in Content array (measured in elements) + , ByteArray# -- Content; + -- elements are stored row-by-row, plane-by-plane; + -- (C-style, rather than Fortran-style); + -- similar to C, OpenCV, etc. + -- The data must be contiguous! + -- (i.e. stride must be the same size as the element size). + , CumulDims -- Steps array; [Word] + -- similar to steps in OpenCV::Mat, but counted in elements + -- rather than in bytes. + -- e.g. 0th element is the size of the content in elements + -- (data must be contiguous) + -- 1th element is the size of subspace data minus outer dim. + , Dict (PrimBytes t) + #) + #) + + +instance (PrimBytes t, Dimensions ds) => PrimBytes (ArrayBase t ds) where + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word64 ds) #-} + + getBytes (ArrayBase a ) = case a of + (# t | #) + | W# nw <- totalDim' @ds + , n <- word2Int# nw + , tbs <- byteSize t -> go tbs (tbs *# n) t + (# | (# _, arr, _, _ #) #) -> + -- very weird trick with touch# allows to workaround GHC bug + -- "internal error: ARR_WORDS object entered!" + -- TODO: report this + case runRW# (\s -> (# touch# arr s, arr #)) of (# _, ba #) -> ba + where + go :: Int# -> Int# -> t -> ByteArray# + go tbs bsize t = case runRW# + ( \s0 -> case newByteArray# bsize s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop# 0# tbs bsize (\i -> writeBytes mba i t) s1 ) + ) of (# _, ba #) -> ba + {-# NOINLINE go #-} + {-# INLINE getBytes #-} + + getBytesPinned (ArrayBase a) = case a of + (# t | #) + | W# nw <- totalDim' @ds + , n <- word2Int# nw + , tbs <- byteSize t -> go tbs (tbs *# n) t + (# | (# off, arr, steps, _ #) #) -> + if isTrue# (isByteArrayPinned# arr) + then case runRW# (\s -> (# touch# arr s, arr #)) of (# _, ba #) -> ba + else case runRW# + ( \s0 -> case (# cdTotalDim# steps + , byteSize @t undefined + , byteAlign @t undefined + #) of + (# n, tbs, tba #) + | bsize <- tbs *# n + , (# s1, mba #) <- newAlignedPinnedByteArray# bsize tba s0 + , s2 <- copyByteArray# arr off mba 0# bsize s1 + -> unsafeFreezeByteArray# mba s2 + ) of (# _, ba #) -> ba + where + go :: Int# -> Int# -> t -> ByteArray# + go tbs bsize t = case runRW# + ( \s0 -> case newAlignedPinnedByteArray# bsize (byteAlign t) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop# 0# tbs bsize (\i -> writeBytes mba i t) s1 ) + ) of (# _, ba #) -> ba + {-# NOINLINE go #-} + {-# INLINE getBytesPinned #-} + + + fromBytes bOff ba + | tbs <- byteSize (undefined :: t) + , (# offN, offRem #) <- quotRemInt# bOff tbs + = case offRem of + 0# -> ArrayBase (# | (# offN, ba, steps, Dict #) #) + _ -> case cdTotalDim# steps of n -> go (tbs *# n) + where + steps = cumulDims $ dims @ds + go bsize = case runRW# + ( \s0 -> case ( if isTrue# (isByteArrayPinned# ba) + then newAlignedPinnedByteArray# bsize + (byteAlign @t undefined) + else newByteArray# bsize + ) s0 + of + (# s1, mba #) -> unsafeFreezeByteArray# mba + (copyByteArray# ba bOff mba 0# bsize s1) + ) of (# _, r #) -> ArrayBase (# | (# 0#, r, steps, Dict #) #) + {-# NOINLINE go #-} + {-# INLINE fromBytes #-} + + readBytes mba bOff s0 + | steps <- cumulDims $ dims @ds + , n <- cdTotalDim# steps + , tbs <- byteSize (undefined :: t) + , bsize <- tbs *# n + = case newByteArray# bsize s0 of + (# s1, mba1 #) -> case unsafeFreezeByteArray# mba1 + (copyMutableByteArray# mba bOff mba1 0# bsize s1) of + (# s2, ba #) -> (# s2, ArrayBase (# | (# 0#, ba, steps, Dict #) #) #) + {-# INLINE readBytes #-} + + writeBytes mba bOff (ArrayBase c) + | tbs <- byteSize (undefined :: t) = case c of + (# t | #) | W# n <- totalDim' @ds -> + loop# bOff tbs (bOff +# word2Int# n *# tbs) (\i -> writeBytes mba i t) + (# | (# offContent, arrContent, steps, _ #) #) + | n <- cdTotalDim# steps-> + copyByteArray# arrContent (offContent *# tbs) mba bOff (n *# tbs) + {-# INLINE writeBytes #-} + + readAddr addr s0 + | steps <- cumulDims $ dims @ds + , n <- cdTotalDim# steps + , tbs <- byteSize (undefined :: t) + , bsize <- tbs *# n + = case newByteArray# bsize s0 of + (# s1, mba1 #) -> case unsafeFreezeByteArray# mba1 + (copyAddrToByteArray# addr mba1 0# bsize s1) of + (# s2, ba #) -> (# s2, ArrayBase (# | (# 0# , ba, steps, Dict #) #) #) + {-# INLINE readAddr #-} + + writeAddr (ArrayBase c) addr + | tbs <- byteSize (undefined :: t) = case c of + (# t | #) | W# n <- totalDim' @ds -> + loop# 0# tbs (word2Int# n *# tbs) (\i -> writeAddr t (plusAddr# addr i)) + (# | (# offContent, arrContent, steps, _ #) #) + | n <- cdTotalDim# steps -> + copyByteArrayToAddr# arrContent (offContent *# tbs) addr (n *# tbs) + {-# INLINE writeAddr #-} + + + byteSize _ = case totalDim' @ds of -- WARNING: slow! + W# n -> byteSize (undefined :: t) *# word2Int# n + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign (undefined :: t) + {-# INLINE byteAlign #-} + + byteOffset (ArrayBase a) = case a of + (# _ | #) -> 0# + (# | (# off, _, _, _ #) #) -> off *# byteSize (undefined :: t) + {-# INLINE byteOffset #-} + + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + indexArray ba off + | steps <- cumulDims $ dims @ds + , n <- cdTotalDim# steps + = ArrayBase (# | (# off *# n, ba, steps, Dict #) #) + {-# INLINE indexArray #-} + + + +-- | Accumulates only idempotent operations! +-- Being applied to FromScalars, executes only once! +-- Here, idempotance means: assuming @f a b = g x@, @g (g x) = g x@ +-- +-- Also, I assume the sizes of arrays are the same. +-- +-- Inside, this function uses foldr; thus, if the combining function is +-- lazy in the second argument, it may avoid some unnecessary work. +accumV2Idempotent :: a + -> (t -> t -> a) + -> (a -> a -> a) + -> ArrayBase t ds -> ArrayBase t ds -> a +accumV2Idempotent x f comb + (ArrayBase (# a | #)) + (ArrayBase (# b | #)) + = comb x (f a b) +accumV2Idempotent x f comb + a@(ArrayBase (# | (# _, _, steps, Dict #) #)) + b@(ArrayBase (# | _ #)) + = foldr (comb . (\i -> f (ixOff i a) (ixOff i b))) x + [0 .. fromIntegral (cdTotalDim steps) - 1] +accumV2Idempotent x f comb + (ArrayBase (# a | #)) + b@(ArrayBase (# | (# _, _, steps, Dict #) #)) + = foldr (comb . (\i -> f a (ixOff i b))) x + [0 .. fromIntegral (cdTotalDim steps) - 1] +accumV2Idempotent x f comb + a@(ArrayBase (# | (# _, _, steps, Dict #) #)) + (ArrayBase (# b | #)) + = foldr (comb . (\i -> f (ixOff i a) b)) x + [0 .. fromIntegral (cdTotalDim steps) - 1] +{-# INLINE accumV2Idempotent #-} + + +mapV :: (t -> t) -> ArrayBase t ds -> ArrayBase t ds +mapV f (ArrayBase (# t | #)) + = ArrayBase (# f t | #) +mapV f x@(ArrayBase (# | (# offN, ba, steps, Dict #) #)) + | tbs <- byteSize (undefEl x) + , n <- cdTotalDim# steps + = case runRW# + ( \s0 -> case newByteArray# (tbs *# n) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop1# n + (\i -> writeArray mba i (f (indexArray ba (offN +# i)))) s1 + ) + ) of (# _, r #) -> ArrayBase (# | (# 0#, r, steps, Dict #) #) +{-# INLINE mapV #-} + + +zipV :: (t -> t -> t) + -> ArrayBase t ds -> ArrayBase t ds -> ArrayBase t ds +zipV f (ArrayBase (# x | #)) b = mapV (f x) b +zipV f a (ArrayBase (# y | #)) = mapV (`f` y) a +zipV f a@(ArrayBase (# | (# oa, ba, steps, Dict #) #)) + (ArrayBase (# | (# ob, bb, _, _ #) #)) + | n <- cdTotalDim# steps + = case runRW# + ( \s0 -> case newByteArray# (byteSize (undefEl a) *# n) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( loop1# n + (\i -> writeArray mba i + (f (indexArray ba (oa +# i)) + (indexArray bb (ob +# i)) + ) + ) s1 + ) + ) of (# _, r #) -> ArrayBase (# | (# 0#, r, steps, Dict #) #) +{-# INLINE zipV #-} + + +-- TODO: to improve performance, I can either compare bytearrays using memcmp +-- or implement early termination if the first elements do not match. +-- On the other hand, hopefully @(&&)@ and @(||)@ ops take care of that. +instance Eq t => Eq (ArrayBase t ds) where + {-# SPECIALIZE instance Eq (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Eq (ArrayBase Word64 ds) #-} + (==) = accumV2Idempotent True (==) (&&) + (/=) = accumV2Idempotent False (/=) (||) + +instance Ord t => ProductOrder (ArrayBase t ds) where + {-# SPECIALIZE instance ProductOrder (ArrayBase Float ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Double ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Int ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Word ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance ProductOrder (ArrayBase Word64 ds) #-} + cmp = accumV2Idempotent PEQ (\x y -> fromOrdering (compare x y)) (<>) + {-# INLINE cmp #-} + +instance Ord t => Ord (NonTransitive.ProductOrd (ArrayBase t ds)) where + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Float ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Double ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Int ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Word ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Int8 ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Int16 ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Int32 ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Int64 ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Word8 ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Word16 ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Word32 ds)) #-} + {-# SPECIALIZE instance Ord (NonTransitive.ProductOrd (ArrayBase Word64 ds)) #-} + NonTransitive.ProductOrd x > NonTransitive.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + NonTransitive.ProductOrd x < NonTransitive.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) = coerce (accumV2Idempotent True (>=) (&&)) + {-# INLINE (>=) #-} + (<=) = coerce (accumV2Idempotent True (<=) (&&)) + {-# INLINE (<=) #-} + compare (NonTransitive.ProductOrd a) (NonTransitive.ProductOrd b) + = NonTransitive.toOrdering $ cmp a b + {-# INLINE compare #-} + min = coerce (zipV min) + {-# INLINE min #-} + max = coerce (zipV max) + {-# INLINE max #-} + +instance Ord t => Ord (Partial.ProductOrd (ArrayBase t ds)) where + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Float ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Double ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Int ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Word ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Int8 ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Int16 ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Int32 ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Int64 ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Word8 ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Word16 ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Word32 ds)) #-} + {-# SPECIALIZE instance Ord (Partial.ProductOrd (ArrayBase Word64 ds)) #-} + Partial.ProductOrd x > Partial.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + Partial.ProductOrd x < Partial.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) = coerce (accumV2Idempotent True (>=) (&&)) + {-# INLINE (>=) #-} + (<=) = coerce (accumV2Idempotent True (<=) (&&)) + {-# INLINE (<=) #-} + compare (Partial.ProductOrd a) (Partial.ProductOrd b) + = Partial.toOrdering $ cmp a b + {-# INLINE compare #-} + min = coerce (zipV min) + {-# INLINE min #-} + max = coerce (zipV max) + {-# INLINE max #-} + +-- | Lexicographical ordering +instance Ord t => Ord (ArrayBase t ds) where + {-# SPECIALIZE instance Ord (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Ord (ArrayBase Word64 ds) #-} + compare = accumV2Idempotent EQ compare (<>) + {-# INLINE compare #-} + +instance Bounded t => Bounded (ArrayBase t ds) where + {-# SPECIALIZE instance Bounded (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Bounded (ArrayBase Word64 ds) #-} + maxBound = ArrayBase (# maxBound | #) + minBound = ArrayBase (# minBound | #) + +instance Num t => Num (ArrayBase t ds) where + {-# SPECIALIZE instance Num (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Double ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance Num (ArrayBase Word64 ds) #-} + (+) = zipV (+) + {-# INLINE (+) #-} + (-) = zipV (-) + {-# INLINE (-) #-} + (*) = zipV (*) + {-# INLINE (*) #-} + negate = mapV negate + {-# INLINE negate #-} + abs = mapV abs + {-# INLINE abs #-} + signum = mapV signum + {-# INLINE signum #-} + fromInteger i = ArrayBase (# fromInteger i | #) + {-# INLINE fromInteger #-} + +instance Fractional t => Fractional (ArrayBase t ds) where + {-# SPECIALIZE instance Fractional (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Fractional (ArrayBase Double ds) #-} + (/) = zipV (/) + {-# INLINE (/) #-} + recip = mapV recip + {-# INLINE recip #-} + fromRational r = ArrayBase (# fromRational r | #) + {-# INLINE fromRational #-} + + +instance Floating t => Floating (ArrayBase t ds) where + {-# SPECIALIZE instance Floating (ArrayBase Float ds) #-} + {-# SPECIALIZE instance Floating (ArrayBase Double ds) #-} + pi = ArrayBase (# pi | #) + {-# INLINE pi #-} + exp = mapV exp + {-# INLINE exp #-} + log = mapV log + {-# INLINE log #-} + sqrt = mapV sqrt + {-# INLINE sqrt #-} + sin = mapV sin + {-# INLINE sin #-} + cos = mapV cos + {-# INLINE cos #-} + tan = mapV tan + {-# INLINE tan #-} + asin = mapV asin + {-# INLINE asin #-} + acos = mapV acos + {-# INLINE acos #-} + atan = mapV atan + {-# INLINE atan #-} + sinh = mapV sinh + {-# INLINE sinh #-} + cosh = mapV cosh + {-# INLINE cosh #-} + tanh = mapV tanh + {-# INLINE tanh #-} + (**) = zipV (**) + {-# INLINE (**) #-} + logBase = zipV logBase + {-# INLINE logBase #-} + asinh = mapV asinh + {-# INLINE asinh #-} + acosh = mapV acosh + {-# INLINE acosh #-} + atanh = mapV atanh + {-# INLINE atanh #-} + +instance PrimBytes t => PrimArray t (ArrayBase t ds) where + {-# SPECIALIZE instance PrimArray Float (ArrayBase Float ds) #-} + {-# SPECIALIZE instance PrimArray Double (ArrayBase Double ds) #-} + {-# SPECIALIZE instance PrimArray Int (ArrayBase Int ds) #-} + {-# SPECIALIZE instance PrimArray Word (ArrayBase Word ds) #-} + {-# SPECIALIZE instance PrimArray Int8 (ArrayBase Int8 ds) #-} + {-# SPECIALIZE instance PrimArray Int16 (ArrayBase Int16 ds) #-} + {-# SPECIALIZE instance PrimArray Int32 (ArrayBase Int32 ds) #-} + {-# SPECIALIZE instance PrimArray Int64 (ArrayBase Int64 ds) #-} + {-# SPECIALIZE instance PrimArray Word8 (ArrayBase Word8 ds) #-} + {-# SPECIALIZE instance PrimArray Word16 (ArrayBase Word16 ds) #-} + {-# SPECIALIZE instance PrimArray Word32 (ArrayBase Word32 ds) #-} + {-# SPECIALIZE instance PrimArray Word64 (ArrayBase Word64 ds) #-} + + broadcast t = ArrayBase (# t | #) + {-# INLINE broadcast #-} + + ix# i (ArrayBase a) = case a of + (# t | #) -> t + (# | (# off, arr, _, _ #) #) -> indexArray arr (off +# i) + {-# INLINE ix# #-} + + gen# steps f z0 = go (byteSize @t undefined *# n) + where + n = cdTotalDim# steps + go bsize = case runRW# + ( \s0 -> case newByteArray# bsize s0 of + (# s1, mba #) -> case loop0 mba 0# z0 s1 of + (# s2, z1 #) -> case unsafeFreezeByteArray# mba s2 of + (# s3, ba #) -> (# s3, (# z1, ba #) #) + ) of (# _, (# z1, ba #) #) + -> (# z1, ArrayBase (# | (# 0# , ba, steps, Dict #) #) #) + {-# NOINLINE go #-} + loop0 mba i z s + | isTrue# (i ==# n) = (# s, z #) + | otherwise = case f z of + (# z', x #) -> loop0 mba (i +# 1#) z' (writeArray mba i x s) + {-# INLINE gen# #-} + + upd# steps i x (ArrayBase (# a | #)) = go (byteSize x) + where + n = cdTotalDim# steps + go tbs = case runRW# + ( \s0 -> case newByteArray# (tbs *# n) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + (writeArray mba i x + (loop1# n (\j -> writeArray mba j a) s1) + ) + ) of (# _, r #) -> ArrayBase (# | (# 0# , r, steps, Dict #) #) + {-# NOINLINE go #-} + upd# _ i x (ArrayBase (# | (# offN, ba, steps, Dict #) #)) + = go (byteSize x) + where + n = cdTotalDim# steps + go tbs = case runRW# + ( \s0 -> case newByteArray# (tbs *# n) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + (writeArray mba i x + (copyByteArray# ba (offN *# tbs) mba 0# (tbs *# n) s1) + ) + ) of (# _, r #) -> ArrayBase (# | (# 0#, r, steps, Dict #) #) + {-# NOINLINE go #-} + {-# INLINE upd# #-} + + arrayContent# (ArrayBase a) = case a of + (# x | #) -> (# x | #) + (# | (# off, arr, cd, _ #) #) -> (# | (# cd, off, arr #) #) + {-# INLINE arrayContent# #-} + + offsetElems (ArrayBase a) = case a of + (# _ | #) -> 0# + (# | (# off, _, _, _ #) #) -> off + {-# INLINE offsetElems #-} + + uniqueOrCumulDims (ArrayBase a) = case a of + (# t | #) -> Left t + (# | (# _, _, steps, _ #) #) -> Right steps + {-# INLINE uniqueOrCumulDims #-} + + fromElems steps off ba = ArrayBase (# | (# off, ba, steps, Dict #) #) + {-# INLINE fromElems #-} + + +loop# :: Int# -- ^ initial value + -> Int# -- ^ step + -> Int# -- ^ final value (LESS THAN condition) + -> (Int# -> State# s -> State# s) -> State# s -> State# s +loop# n0 di n1 f = loop0 n0 + where + loop0 i s | isTrue# (i >=# n1) = s + | otherwise = loop0 (i +# di) (f i s) +{-# INLINE loop# #-} + + +-- | Do something in a loop for int i from 0 to (n-1) +loop1# :: Int# -> (Int# -> State# s -> State# s) -> State# s -> State# s +loop1# n f = loop0 0# + where + loop0 i s | isTrue# (i ==# n) = s + | otherwise = loop0 (i +# 1#) (f i s) +{-# INLINE loop1# #-} + +undefEl :: ArrayBase t ds -> t +undefEl = const undefined diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX2.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX2.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX2.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.DataFrame.Internal.Backend.Family.DoubleX2 (DoubleX2 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + + +data DoubleX2 = DoubleX2# Double# Double# + +-- | Since @Bounded@ is not implemented for floating point types, this instance +-- has an unresolvable constraint. +-- Nevetheless, it is good to have it here for nicer error messages. +instance Bounded Double => Bounded DoubleX2 where + maxBound = case maxBound of D# x -> DoubleX2# x x + minBound = case minBound of D# x -> DoubleX2# x x + + +instance Eq DoubleX2 where + + DoubleX2# a1 a2 == DoubleX2# b1 b2 = + isTrue# + ( (a1 ==## b1) + `andI#` (a2 ==## b2) + ) + {-# INLINE (==) #-} + + DoubleX2# a1 a2 /= DoubleX2# b1 b2 = + isTrue# + ( (a1 /=## b1) + `orI#` (a2 /=## b2) + ) + {-# INLINE (/=) #-} + + + +cmp' :: Double# -> Double# -> PartialOrdering +cmp' a b + | isTrue# (a >## b) = PGT + | isTrue# (a <## b) = PLT + | otherwise = PEQ + +instance ProductOrder DoubleX2 where + cmp (DoubleX2# a1 a2) (DoubleX2# b1 b2) + = cmp' a1 b1 <> cmp' a2 b2 + {-# INLINE cmp #-} + +instance Ord (NonTransitive.ProductOrd DoubleX2) where + NonTransitive.ProductOrd x > NonTransitive.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + NonTransitive.ProductOrd x < NonTransitive.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (NonTransitive.ProductOrd (DoubleX2# a1 a2)) + (NonTransitive.ProductOrd (DoubleX2# b1 b2)) = isTrue# + ((a1 >=## b1) `andI#` (a2 >=## b2)) + {-# INLINE (>=) #-} + (<=) (NonTransitive.ProductOrd (DoubleX2# a1 a2)) + (NonTransitive.ProductOrd (DoubleX2# b1 b2)) = isTrue# + ((a1 <=## b1) `andI#` (a2 <=## b2)) + {-# INLINE (<=) #-} + compare (NonTransitive.ProductOrd a) (NonTransitive.ProductOrd b) + = NonTransitive.toOrdering $ cmp a b + {-# INLINE compare #-} + min (NonTransitive.ProductOrd (DoubleX2# a1 a2)) + (NonTransitive.ProductOrd (DoubleX2# b1 b2)) + = NonTransitive.ProductOrd + ( DoubleX2# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + ) + {-# INLINE min #-} + max (NonTransitive.ProductOrd (DoubleX2# a1 a2)) + (NonTransitive.ProductOrd (DoubleX2# b1 b2)) + = NonTransitive.ProductOrd + ( DoubleX2# + (if isTrue# (a1 <## b1) then b1 else a1) + (if isTrue# (a2 <## b2) then b2 else a2) + ) + {-# INLINE max #-} + +instance Ord (Partial.ProductOrd DoubleX2) where + Partial.ProductOrd x > Partial.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + Partial.ProductOrd x < Partial.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (Partial.ProductOrd (DoubleX2# a1 a2)) + (Partial.ProductOrd (DoubleX2# b1 b2)) = isTrue# + ((a1 >=## b1) `andI#` (a2 >=## b2)) + {-# INLINE (>=) #-} + (<=) (Partial.ProductOrd (DoubleX2# a1 a2)) + (Partial.ProductOrd (DoubleX2# b1 b2)) = isTrue# + ((a1 <=## b1) `andI#` (a2 <=## b2)) + {-# INLINE (<=) #-} + compare (Partial.ProductOrd a) (Partial.ProductOrd b) + = Partial.toOrdering $ cmp a b + {-# INLINE compare #-} + min (Partial.ProductOrd (DoubleX2# a1 a2)) + (Partial.ProductOrd (DoubleX2# b1 b2)) + = Partial.ProductOrd + ( DoubleX2# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + ) + {-# INLINE min #-} + max (Partial.ProductOrd (DoubleX2# a1 a2)) + (Partial.ProductOrd (DoubleX2# b1 b2)) + = Partial.ProductOrd + ( DoubleX2# + (if isTrue# (a1 <## b1) then b1 else a1) + (if isTrue# (a2 <## b2) then b2 else a2) + ) + {-# INLINE max #-} + +instance Ord DoubleX2 where + DoubleX2# a1 a2 > DoubleX2# b1 b2 + | isTrue# (a1 >## b1) = True + | isTrue# (a1 <## b1) = False + | isTrue# (a2 >## b2) = True + | otherwise = False + {-# INLINE (>) #-} + + DoubleX2# a1 a2 < DoubleX2# b1 b2 + | isTrue# (a1 <## b1) = True + | isTrue# (a1 >## b1) = False + | isTrue# (a2 <## b2) = True + | otherwise = False + {-# INLINE (<) #-} + + DoubleX2# a1 a2 >= DoubleX2# b1 b2 + | isTrue# (a1 <## b1) = False + | isTrue# (a1 >## b1) = True + | isTrue# (a2 <## b2) = False + | otherwise = True + {-# INLINE (>=) #-} + + DoubleX2# a1 a2 <= DoubleX2# b1 b2 + | isTrue# (a1 >## b1) = False + | isTrue# (a1 <## b1) = True + | isTrue# (a2 >## b2) = False + | otherwise = True + {-# INLINE (<=) #-} + + compare (DoubleX2# a1 a2) (DoubleX2# b1 b2) + | isTrue# (a1 >## b1) = GT + | isTrue# (a1 <## b1) = LT + | isTrue# (a2 >## b2) = GT + | isTrue# (a2 <## b2) = LT + | otherwise = EQ + {-# INLINE compare #-} + + + +-- | element-wise operations for vectors +instance Num DoubleX2 where + + DoubleX2# a1 a2 + DoubleX2# b1 b2 + = DoubleX2# ((+##) a1 b1) ((+##) a2 b2) + {-# INLINE (+) #-} + + DoubleX2# a1 a2 - DoubleX2# b1 b2 + = DoubleX2# ((-##) a1 b1) ((-##) a2 b2) + {-# INLINE (-) #-} + + DoubleX2# a1 a2 * DoubleX2# b1 b2 + = DoubleX2# ((*##) a1 b1) ((*##) a2 b2) + {-# INLINE (*) #-} + + negate (DoubleX2# a1 a2) = DoubleX2# + (negateDouble# a1) (negateDouble# a2) + {-# INLINE negate #-} + + abs (DoubleX2# a1 a2) + = DoubleX2# + (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) + (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) + {-# INLINE abs #-} + + signum (DoubleX2# a1 a2) + = DoubleX2# (if isTrue# (a1 >## 0.0##) + then 1.0## + else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a2 >## 0.0##) + then 1.0## + else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of D# x -> DoubleX2# x x + {-# INLINE fromInteger #-} + + + +instance Fractional DoubleX2 where + + DoubleX2# a1 a2 / DoubleX2# b1 b2 = DoubleX2# + ((/##) a1 b1) ((/##) a2 b2) + {-# INLINE (/) #-} + + recip (DoubleX2# a1 a2) = DoubleX2# + ((/##) 1.0## a1) ((/##) 1.0## a2) + {-# INLINE recip #-} + + fromRational r = case fromRational r of D# x -> DoubleX2# x x + {-# INLINE fromRational #-} + + + +instance Floating DoubleX2 where + + pi = DoubleX2# + 3.141592653589793238## + 3.141592653589793238## + {-# INLINE pi #-} + + exp (DoubleX2# a1 a2) = DoubleX2# + (expDouble# a1) (expDouble# a2) + {-# INLINE exp #-} + + log (DoubleX2# a1 a2) = DoubleX2# + (logDouble# a1) (logDouble# a2) + {-# INLINE log #-} + + sqrt (DoubleX2# a1 a2) = DoubleX2# + (sqrtDouble# a1) (sqrtDouble# a2) + {-# INLINE sqrt #-} + + sin (DoubleX2# a1 a2) = DoubleX2# + (sinDouble# a1) (sinDouble# a2) + {-# INLINE sin #-} + + cos (DoubleX2# a1 a2) = DoubleX2# + (cosDouble# a1) (cosDouble# a2) + {-# INLINE cos #-} + + tan (DoubleX2# a1 a2) = DoubleX2# + (tanDouble# a1) (tanDouble# a2) + {-# INLINE tan #-} + + asin (DoubleX2# a1 a2) = DoubleX2# + (asinDouble# a1) (asinDouble# a2) + {-# INLINE asin #-} + + acos (DoubleX2# a1 a2) = DoubleX2# + (acosDouble# a1) (acosDouble# a2) + {-# INLINE acos #-} + + atan (DoubleX2# a1 a2) = DoubleX2# + (atanDouble# a1) (atanDouble# a2) + {-# INLINE atan #-} + + sinh (DoubleX2# a1 a2) = DoubleX2# + (sinhDouble# a1) (sinhDouble# a2) + {-# INLINE sinh #-} + + cosh (DoubleX2# a1 a2) = DoubleX2# + (coshDouble# a1) (coshDouble# a2) + {-# INLINE cosh #-} + + tanh (DoubleX2# a1 a2) = DoubleX2# + (tanhDouble# a1) (tanhDouble# a2) + {-# INLINE tanh #-} + + DoubleX2# a1 a2 ** DoubleX2# b1 b2 = DoubleX2# + ((**##) a1 b1) ((**##) a2 b2) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# +#define ELEM_N 2 + +instance PrimBytes DoubleX2 where + + getBytes (DoubleX2# a1 a2) = case runRW# + ( \s0 -> case newByteArray# (byteSize @DoubleX2 undefined) s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of + s2 -> case writeDoubleArray# marr 1# a2 s2 of + s3 -> unsafeFreezeByteArray# marr s3 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = DoubleX2# + (indexDoubleArray# arr i) + (indexDoubleArray# arr (i +# 1#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) + {-# INLINE readBytes #-} + + writeBytes mba off (DoubleX2# a1 a2) s + | i <- BOFF_TO_PRIMOFF(off) + = writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readDoubleOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of + (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) + {-# INLINE readAddr #-} + + writeAddr (DoubleX2# a1 a2) addr s + = writeDoubleOffAddr# addr 1# a2 + ( writeDoubleOffAddr# addr 0# a1 s ) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Double undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Double undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = DoubleX2# + (indexDoubleArray# ba i) + (indexDoubleArray# ba (i +# 1#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) + {-# INLINE readArray #-} + + writeArray mba off (DoubleX2# a1 a2) s + | i <- off *# ELEM_N# + = writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ) + {-# INLINE writeArray #-} + + +instance PrimArray Double DoubleX2 where + + broadcast (D# x) = DoubleX2# x x + {-# INLINE broadcast #-} + + ix# 0# (DoubleX2# a1 _) = D# a1 + ix# 1# (DoubleX2# _ a2) = D# a2 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, D# a1 #) -> case f s1 of + (# s2, D# a2 #) -> (# s2, DoubleX2# a1 a2 #) + + + upd# _ 0# (D# q) (DoubleX2# _ y) = DoubleX2# q y + upd# _ 1# (D# q) (DoubleX2# x _) = DoubleX2# x q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + arrayContent# x = (# | (# CumulDims [ELEM_N, 1], 0#, getBytes x #) #) + {-# INLINE arrayContent# #-} + + offsetElems _ = 0# + {-# INLINE offsetElems #-} + + uniqueOrCumulDims _ = Right (CumulDims [ELEM_N, 1]) + {-# INLINE uniqueOrCumulDims #-} + + fromElems _ off ba = DoubleX2# + (indexDoubleArray# ba off) + (indexDoubleArray# ba (off +# 1#)) + {-# INLINE fromElems #-} diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX3.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX3.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX3.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.DataFrame.Internal.Backend.Family.DoubleX3 (DoubleX3 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + + +data DoubleX3 = DoubleX3# Double# Double# Double# + +-- | Since @Bounded@ is not implemented for floating point types, this instance +-- has an unresolvable constraint. +-- Nevetheless, it is good to have it here for nicer error messages. +instance Bounded Double => Bounded DoubleX3 where + maxBound = case maxBound of D# x -> DoubleX3# x x x + minBound = case minBound of D# x -> DoubleX3# x x x + + +instance Eq DoubleX3 where + + DoubleX3# a1 a2 a3 == DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 ==## b1) + `andI#` (a2 ==## b2) + `andI#` (a3 ==## b3) + ) + {-# INLINE (==) #-} + + DoubleX3# a1 a2 a3 /= DoubleX3# b1 b2 b3 = + isTrue# + ( (a1 /=## b1) + `orI#` (a2 /=## b2) + `orI#` (a3 /=## b3) + ) + {-# INLINE (/=) #-} + + + +cmp' :: Double# -> Double# -> PartialOrdering +cmp' a b + | isTrue# (a >## b) = PGT + | isTrue# (a <## b) = PLT + | otherwise = PEQ + +instance ProductOrder DoubleX3 where + cmp (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + {-# INLINE cmp #-} + +instance Ord (NonTransitive.ProductOrd DoubleX3) where + NonTransitive.ProductOrd x > NonTransitive.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + NonTransitive.ProductOrd x < NonTransitive.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (NonTransitive.ProductOrd (DoubleX3# a1 a2 a3)) + (NonTransitive.ProductOrd (DoubleX3# b1 b2 b3)) = isTrue# + ((a1 >=## b1) `andI#` (a2 >=## b2) `andI#` (a3 >=## b3)) + {-# INLINE (>=) #-} + (<=) (NonTransitive.ProductOrd (DoubleX3# a1 a2 a3)) + (NonTransitive.ProductOrd (DoubleX3# b1 b2 b3)) = isTrue# + ((a1 <=## b1) `andI#` (a2 <=## b2) `andI#` (a3 <=## b3)) + {-# INLINE (<=) #-} + compare (NonTransitive.ProductOrd a) (NonTransitive.ProductOrd b) + = NonTransitive.toOrdering $ cmp a b + {-# INLINE compare #-} + min (NonTransitive.ProductOrd (DoubleX3# a1 a2 a3)) + (NonTransitive.ProductOrd (DoubleX3# b1 b2 b3)) + = NonTransitive.ProductOrd + ( DoubleX3# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + (if isTrue# (a3 >## b3) then b3 else a3) + ) + {-# INLINE min #-} + max (NonTransitive.ProductOrd (DoubleX3# a1 a2 a3)) + (NonTransitive.ProductOrd (DoubleX3# b1 b2 b3)) + = NonTransitive.ProductOrd + ( DoubleX3# + (if isTrue# (a1 <## b1) then b1 else a1) + (if isTrue# (a2 <## b2) then b2 else a2) + (if isTrue# (a3 <## b3) then b3 else a3) + ) + {-# INLINE max #-} + +instance Ord (Partial.ProductOrd DoubleX3) where + Partial.ProductOrd x > Partial.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + Partial.ProductOrd x < Partial.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (Partial.ProductOrd (DoubleX3# a1 a2 a3)) + (Partial.ProductOrd (DoubleX3# b1 b2 b3)) = isTrue# + ((a1 >=## b1) `andI#` (a2 >=## b2) `andI#` (a3 >=## b3)) + {-# INLINE (>=) #-} + (<=) (Partial.ProductOrd (DoubleX3# a1 a2 a3)) + (Partial.ProductOrd (DoubleX3# b1 b2 b3)) = isTrue# + ((a1 <=## b1) `andI#` (a2 <=## b2) `andI#` (a3 <=## b3)) + {-# INLINE (<=) #-} + compare (Partial.ProductOrd a) (Partial.ProductOrd b) + = Partial.toOrdering $ cmp a b + {-# INLINE compare #-} + min (Partial.ProductOrd (DoubleX3# a1 a2 a3)) + (Partial.ProductOrd (DoubleX3# b1 b2 b3)) + = Partial.ProductOrd + ( DoubleX3# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + (if isTrue# (a3 >## b3) then b3 else a3) + ) + {-# INLINE min #-} + max (Partial.ProductOrd (DoubleX3# a1 a2 a3)) + (Partial.ProductOrd (DoubleX3# b1 b2 b3)) + = Partial.ProductOrd + ( DoubleX3# + (if isTrue# (a1 <## b1) then b1 else a1) + (if isTrue# (a2 <## b2) then b2 else a2) + (if isTrue# (a3 <## b3) then b3 else a3) + ) + {-# INLINE max #-} + +instance Ord DoubleX3 where + DoubleX3# a1 a2 a3 > DoubleX3# b1 b2 b3 + | isTrue# (a1 >## b1) = True + | isTrue# (a1 <## b1) = False + | isTrue# (a2 >## b2) = True + | isTrue# (a2 <## b2) = False + | isTrue# (a3 >## b3) = True + | otherwise = False + {-# INLINE (>) #-} + + DoubleX3# a1 a2 a3 < DoubleX3# b1 b2 b3 + | isTrue# (a1 <## b1) = True + | isTrue# (a1 >## b1) = False + | isTrue# (a2 <## b2) = True + | isTrue# (a2 >## b2) = False + | isTrue# (a3 <## b3) = True + | otherwise = False + {-# INLINE (<) #-} + + DoubleX3# a1 a2 a3 >= DoubleX3# b1 b2 b3 + | isTrue# (a1 <## b1) = False + | isTrue# (a1 >## b1) = True + | isTrue# (a2 <## b2) = False + | isTrue# (a2 >## b2) = True + | isTrue# (a3 <## b3) = False + | otherwise = True + {-# INLINE (>=) #-} + + DoubleX3# a1 a2 a3 <= DoubleX3# b1 b2 b3 + | isTrue# (a1 >## b1) = False + | isTrue# (a1 <## b1) = True + | isTrue# (a2 >## b2) = False + | isTrue# (a2 <## b2) = True + | isTrue# (a3 >## b3) = False + | otherwise = True + {-# INLINE (<=) #-} + + compare (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) + | isTrue# (a1 >## b1) = GT + | isTrue# (a1 <## b1) = LT + | isTrue# (a2 >## b2) = GT + | isTrue# (a2 <## b2) = LT + | isTrue# (a3 >## b3) = GT + | isTrue# (a3 <## b3) = LT + | otherwise = EQ + {-# INLINE compare #-} + + + + +-- | element-wise operations for vectors +instance Num DoubleX3 where + + DoubleX3# a1 a2 a3 + DoubleX3# b1 b2 b3 + = DoubleX3# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) + {-# INLINE (+) #-} + + DoubleX3# a1 a2 a3 - DoubleX3# b1 b2 b3 + = DoubleX3# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) + {-# INLINE (-) #-} + + DoubleX3# a1 a2 a3 * DoubleX3# b1 b2 b3 + = DoubleX3# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) + {-# INLINE (*) #-} + + negate (DoubleX3# a1 a2 a3) = DoubleX3# + (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) + {-# INLINE negate #-} + + abs (DoubleX3# a1 a2 a3) + = DoubleX3# + (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) + (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) + (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) + {-# INLINE abs #-} + + signum (DoubleX3# a1 a2 a3) + = DoubleX3# (if isTrue# (a1 >## 0.0##) + then 1.0## + else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a2 >## 0.0##) + then 1.0## + else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a3 >## 0.0##) + then 1.0## + else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of D# x -> DoubleX3# x x x + {-# INLINE fromInteger #-} + + + +instance Fractional DoubleX3 where + + DoubleX3# a1 a2 a3 / DoubleX3# b1 b2 b3 = DoubleX3# + ((/##) a1 b1) ((/##) a2 b2) ((/##) a3 b3) + {-# INLINE (/) #-} + + recip (DoubleX3# a1 a2 a3) = DoubleX3# + ((/##) 1.0## a1) ((/##) 1.0## a2) ((/##) 1.0## a3) + {-# INLINE recip #-} + + fromRational r = case fromRational r of D# x -> DoubleX3# x x x + {-# INLINE fromRational #-} + + + +instance Floating DoubleX3 where + + pi = DoubleX3# + 3.141592653589793238## + 3.141592653589793238## + 3.141592653589793238## + {-# INLINE pi #-} + + exp (DoubleX3# a1 a2 a3) = DoubleX3# + (expDouble# a1) (expDouble# a2) (expDouble# a3) + {-# INLINE exp #-} + + log (DoubleX3# a1 a2 a3) = DoubleX3# + (logDouble# a1) (logDouble# a2) (logDouble# a3) + {-# INLINE log #-} + + sqrt (DoubleX3# a1 a2 a3) = DoubleX3# + (sqrtDouble# a1) (sqrtDouble# a2) (sqrtDouble# a3) + {-# INLINE sqrt #-} + + sin (DoubleX3# a1 a2 a3) = DoubleX3# + (sinDouble# a1) (sinDouble# a2) (sinDouble# a3) + {-# INLINE sin #-} + + cos (DoubleX3# a1 a2 a3) = DoubleX3# + (cosDouble# a1) (cosDouble# a2) (cosDouble# a3) + {-# INLINE cos #-} + + tan (DoubleX3# a1 a2 a3) = DoubleX3# + (tanDouble# a1) (tanDouble# a2) (tanDouble# a3) + {-# INLINE tan #-} + + asin (DoubleX3# a1 a2 a3) = DoubleX3# + (asinDouble# a1) (asinDouble# a2) (asinDouble# a3) + {-# INLINE asin #-} + + acos (DoubleX3# a1 a2 a3) = DoubleX3# + (acosDouble# a1) (acosDouble# a2) (acosDouble# a3) + {-# INLINE acos #-} + + atan (DoubleX3# a1 a2 a3) = DoubleX3# + (atanDouble# a1) (atanDouble# a2) (atanDouble# a3) + {-# INLINE atan #-} + + sinh (DoubleX3# a1 a2 a3) = DoubleX3# + (sinhDouble# a1) (sinhDouble# a2) (sinhDouble# a3) + {-# INLINE sinh #-} + + cosh (DoubleX3# a1 a2 a3) = DoubleX3# + (coshDouble# a1) (coshDouble# a2) (coshDouble# a3) + {-# INLINE cosh #-} + + tanh (DoubleX3# a1 a2 a3) = DoubleX3# + (tanhDouble# a1) (tanhDouble# a2) (tanhDouble# a3) + {-# INLINE tanh #-} + + DoubleX3# a1 a2 a3 ** DoubleX3# b1 b2 b3 = DoubleX3# + ((**##) a1 b1) ((**##) a2 b2) ((**##) a3 b3) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# +#define ELEM_N 3 + +instance PrimBytes DoubleX3 where + + getBytes (DoubleX3# a1 a2 a3) = case runRW# + ( \s0 -> case newByteArray# (byteSize @DoubleX3 undefined) s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of + s2 -> case writeDoubleArray# marr 1# a2 s2 of + s3 -> case writeDoubleArray# marr 2# a3 s3 of + s4 -> unsafeFreezeByteArray# marr s4 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = DoubleX3# + (indexDoubleArray# arr i) + (indexDoubleArray# arr (i +# 1#)) + (indexDoubleArray# arr (i +# 2#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + {-# INLINE readBytes #-} + + writeBytes mba off (DoubleX3# a1 a2 a3) s + | i <- BOFF_TO_PRIMOFF(off) + = writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s )) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readDoubleOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readDoubleOffAddr# addr 2# s2 of + (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + {-# INLINE readAddr #-} + + writeAddr (DoubleX3# a1 a2 a3) addr s + = writeDoubleOffAddr# addr 2# a3 + ( writeDoubleOffAddr# addr 1# a2 + ( writeDoubleOffAddr# addr 0# a1 s )) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Double undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Double undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = DoubleX3# + (indexDoubleArray# ba i) + (indexDoubleArray# ba (i +# 1#)) + (indexDoubleArray# ba (i +# 2#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + {-# INLINE readArray #-} + + writeArray mba off (DoubleX3# a1 a2 a3) s + | i <- off *# ELEM_N# + = writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s )) + {-# INLINE writeArray #-} + + +instance PrimArray Double DoubleX3 where + + broadcast (D# x) = DoubleX3# x x x + {-# INLINE broadcast #-} + + ix# 0# (DoubleX3# a1 _ _) = D# a1 + ix# 1# (DoubleX3# _ a2 _) = D# a2 + ix# 2# (DoubleX3# _ _ a3) = D# a3 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, D# a1 #) -> case f s1 of + (# s2, D# a2 #) -> case f s2 of + (# s3, D# a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) + + + upd# _ 0# (D# q) (DoubleX3# _ y z) = DoubleX3# q y z + upd# _ 1# (D# q) (DoubleX3# x _ z) = DoubleX3# x q z + upd# _ 2# (D# q) (DoubleX3# x y _) = DoubleX3# x y q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + arrayContent# x = (# | (# CumulDims [ELEM_N, 1], 0#, getBytes x #) #) + {-# INLINE arrayContent# #-} + + offsetElems _ = 0# + {-# INLINE offsetElems #-} + + uniqueOrCumulDims _ = Right (CumulDims [ELEM_N, 1]) + {-# INLINE uniqueOrCumulDims #-} + + fromElems _ off ba = DoubleX3# + (indexDoubleArray# ba off) + (indexDoubleArray# ba (off +# 1#)) + (indexDoubleArray# ba (off +# 2#)) + {-# INLINE fromElems #-} diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX4.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX4.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/DoubleX4.hs @@ -0,0 +1,467 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.DataFrame.Internal.Backend.Family.DoubleX4 (DoubleX4 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + + +data DoubleX4 = DoubleX4# Double# Double# Double# Double# + +-- | Since @Bounded@ is not implemented for floating point types, this instance +-- has an unresolvable constraint. +-- Nevetheless, it is good to have it here for nicer error messages. +instance Bounded Double => Bounded DoubleX4 where + maxBound = case maxBound of D# x -> DoubleX4# x x x x + minBound = case minBound of D# x -> DoubleX4# x x x x + + +instance Eq DoubleX4 where + + DoubleX4# a1 a2 a3 a4 == DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 ==## b1) + `andI#` (a2 ==## b2) + `andI#` (a3 ==## b3) + `andI#` (a4 ==## b4) + ) + {-# INLINE (==) #-} + + DoubleX4# a1 a2 a3 a4 /= DoubleX4# b1 b2 b3 b4 = + isTrue# + ( (a1 /=## b1) + `orI#` (a2 /=## b2) + `orI#` (a3 /=## b3) + `orI#` (a4 /=## b4) + ) + {-# INLINE (/=) #-} + +cmp' :: Double# -> Double# -> PartialOrdering +cmp' a b + | isTrue# (a >## b) = PGT + | isTrue# (a <## b) = PLT + | otherwise = PEQ + +instance ProductOrder DoubleX4 where + cmp (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 <> cmp' a4 b4 + {-# INLINE cmp #-} + +instance Ord (NonTransitive.ProductOrd DoubleX4) where + NonTransitive.ProductOrd x > NonTransitive.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + NonTransitive.ProductOrd x < NonTransitive.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (NonTransitive.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (DoubleX4# b1 b2 b3 b4)) = isTrue# + ((a1 >=## b1) `andI#` (a2 >=## b2) `andI#` (a3 >=## b3) `andI#` (a4 >=## b4)) + {-# INLINE (>=) #-} + (<=) (NonTransitive.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (DoubleX4# b1 b2 b3 b4)) = isTrue# + ((a1 <=## b1) `andI#` (a2 <=## b2) `andI#` (a3 <=## b3) `andI#` (a4 <=## b4)) + {-# INLINE (<=) #-} + compare (NonTransitive.ProductOrd a) (NonTransitive.ProductOrd b) + = NonTransitive.toOrdering $ cmp a b + {-# INLINE compare #-} + min (NonTransitive.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (DoubleX4# b1 b2 b3 b4)) + = NonTransitive.ProductOrd + ( DoubleX4# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + (if isTrue# (a3 >## b3) then b3 else a3) + (if isTrue# (a4 >## b4) then b4 else a4) + ) + {-# INLINE min #-} + max (NonTransitive.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (DoubleX4# b1 b2 b3 b4)) + = NonTransitive.ProductOrd + ( DoubleX4# + (if isTrue# (a1 <## b1) then b1 else a1) + (if isTrue# (a2 <## b2) then b2 else a2) + (if isTrue# (a3 <## b3) then b3 else a3) + (if isTrue# (a4 <## b4) then b4 else a4) + ) + {-# INLINE max #-} + +instance Ord (Partial.ProductOrd DoubleX4) where + Partial.ProductOrd x > Partial.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + Partial.ProductOrd x < Partial.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (Partial.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (Partial.ProductOrd (DoubleX4# b1 b2 b3 b4)) = isTrue# + ((a1 >=## b1) `andI#` (a2 >=## b2) `andI#` (a3 >=## b3) `andI#` (a4 >=## b4)) + {-# INLINE (>=) #-} + (<=) (Partial.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (Partial.ProductOrd (DoubleX4# b1 b2 b3 b4)) = isTrue# + ((a1 <=## b1) `andI#` (a2 <=## b2) `andI#` (a3 <=## b3) `andI#` (a4 <=## b4)) + {-# INLINE (<=) #-} + compare (Partial.ProductOrd a) (Partial.ProductOrd b) + = Partial.toOrdering $ cmp a b + {-# INLINE compare #-} + min (Partial.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (Partial.ProductOrd (DoubleX4# b1 b2 b3 b4)) + = Partial.ProductOrd + ( DoubleX4# + (if isTrue# (a1 >## b1) then b1 else a1) + (if isTrue# (a2 >## b2) then b2 else a2) + (if isTrue# (a3 >## b3) then b3 else a3) + (if isTrue# (a4 >## b4) then b4 else a4) + ) + {-# INLINE min #-} + max (Partial.ProductOrd (DoubleX4# a1 a2 a3 a4)) + (Partial.ProductOrd (DoubleX4# b1 b2 b3 b4)) + = Partial.ProductOrd + ( DoubleX4# + (if isTrue# (a1 <## b1) then b1 else a1) + (if isTrue# (a2 <## b2) then b2 else a2) + (if isTrue# (a3 <## b3) then b3 else a3) + (if isTrue# (a4 <## b4) then b4 else a4) + ) + {-# INLINE max #-} + +instance Ord DoubleX4 where + DoubleX4# a1 a2 a3 a4 > DoubleX4# b1 b2 b3 b4 + | isTrue# (a1 >## b1) = True + | isTrue# (a1 <## b1) = False + | isTrue# (a2 >## b2) = True + | isTrue# (a2 <## b2) = False + | isTrue# (a3 >## b3) = True + | isTrue# (a3 <## b3) = False + | isTrue# (a4 >## b4) = True + | otherwise = False + {-# INLINE (>) #-} + + DoubleX4# a1 a2 a3 a4 < DoubleX4# b1 b2 b3 b4 + | isTrue# (a1 <## b1) = True + | isTrue# (a1 >## b1) = False + | isTrue# (a2 <## b2) = True + | isTrue# (a2 >## b2) = False + | isTrue# (a3 <## b3) = True + | isTrue# (a3 >## b3) = False + | isTrue# (a4 <## b4) = True + | otherwise = False + {-# INLINE (<) #-} + + DoubleX4# a1 a2 a3 a4 >= DoubleX4# b1 b2 b3 b4 + | isTrue# (a1 <## b1) = False + | isTrue# (a1 >## b1) = True + | isTrue# (a2 <## b2) = False + | isTrue# (a2 >## b2) = True + | isTrue# (a3 <## b3) = False + | isTrue# (a3 >## b3) = True + | isTrue# (a4 <## b4) = False + | otherwise = True + {-# INLINE (>=) #-} + + DoubleX4# a1 a2 a3 a4 <= DoubleX4# b1 b2 b3 b4 + | isTrue# (a1 >## b1) = False + | isTrue# (a1 <## b1) = True + | isTrue# (a2 >## b2) = False + | isTrue# (a2 <## b2) = True + | isTrue# (a3 >## b3) = False + | isTrue# (a3 <## b3) = True + | isTrue# (a4 >## b4) = False + | otherwise = True + {-# INLINE (<=) #-} + + compare (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) + | isTrue# (a1 >## b1) = GT + | isTrue# (a1 <## b1) = LT + | isTrue# (a2 >## b2) = GT + | isTrue# (a2 <## b2) = LT + | isTrue# (a3 >## b3) = GT + | isTrue# (a3 <## b3) = LT + | isTrue# (a4 >## b4) = GT + | isTrue# (a4 <## b4) = LT + | otherwise = EQ + {-# INLINE compare #-} + + + +-- | element-wise operations for vectors +instance Num DoubleX4 where + + DoubleX4# a1 a2 a3 a4 + DoubleX4# b1 b2 b3 b4 + = DoubleX4# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) ((+##) a4 b4) + {-# INLINE (+) #-} + + DoubleX4# a1 a2 a3 a4 - DoubleX4# b1 b2 b3 b4 + = DoubleX4# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) ((-##) a4 b4) + {-# INLINE (-) #-} + + DoubleX4# a1 a2 a3 a4 * DoubleX4# b1 b2 b3 b4 + = DoubleX4# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) ((*##) a4 b4) + {-# INLINE (*) #-} + + negate (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) (negateDouble# a4) + {-# INLINE negate #-} + + abs (DoubleX4# a1 a2 a3 a4) + = DoubleX4# + (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) + (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) + (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) + (if isTrue# (a4 >=## 0.0##) then a4 else negateDouble# a4) + {-# INLINE abs #-} + + signum (DoubleX4# a1 a2 a3 a4) + = DoubleX4# (if isTrue# (a1 >## 0.0##) + then 1.0## + else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a2 >## 0.0##) + then 1.0## + else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a3 >## 0.0##) + then 1.0## + else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) + (if isTrue# (a4 >## 0.0##) + then 1.0## + else if isTrue# (a4 <## 0.0##) then -1.0## else 0.0## ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of D# x -> DoubleX4# x x x x + {-# INLINE fromInteger #-} + + + +instance Fractional DoubleX4 where + + DoubleX4# a1 a2 a3 a4 / DoubleX4# b1 b2 b3 b4 = DoubleX4# + ((/##) a1 b1) ((/##) a2 b2) ((/##) a3 b3) ((/##) a4 b4) + {-# INLINE (/) #-} + + recip (DoubleX4# a1 a2 a3 a4) = DoubleX4# + ((/##) 1.0## a1) ((/##) 1.0## a2) ((/##) 1.0## a3) ((/##) 1.0## a4) + {-# INLINE recip #-} + + fromRational r = case fromRational r of D# x -> DoubleX4# x x x x + {-# INLINE fromRational #-} + + + +instance Floating DoubleX4 where + + pi = DoubleX4# + 3.141592653589793238## + 3.141592653589793238## + 3.141592653589793238## + 3.141592653589793238## + {-# INLINE pi #-} + + exp (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (expDouble# a1) (expDouble# a2) (expDouble# a3) (expDouble# a4) + {-# INLINE exp #-} + + log (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (logDouble# a1) (logDouble# a2) (logDouble# a3) (logDouble# a4) + {-# INLINE log #-} + + sqrt (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (sqrtDouble# a1) (sqrtDouble# a2) (sqrtDouble# a3) (sqrtDouble# a4) + {-# INLINE sqrt #-} + + sin (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (sinDouble# a1) (sinDouble# a2) (sinDouble# a3) (sinDouble# a4) + {-# INLINE sin #-} + + cos (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (cosDouble# a1) (cosDouble# a2) (cosDouble# a3) (cosDouble# a4) + {-# INLINE cos #-} + + tan (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (tanDouble# a1) (tanDouble# a2) (tanDouble# a3) (tanDouble# a4) + {-# INLINE tan #-} + + asin (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (asinDouble# a1) (asinDouble# a2) (asinDouble# a3) (asinDouble# a4) + {-# INLINE asin #-} + + acos (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (acosDouble# a1) (acosDouble# a2) (acosDouble# a3) (acosDouble# a4) + {-# INLINE acos #-} + + atan (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (atanDouble# a1) (atanDouble# a2) (atanDouble# a3) (atanDouble# a4) + {-# INLINE atan #-} + + sinh (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (sinhDouble# a1) (sinhDouble# a2) (sinhDouble# a3) (sinhDouble# a4) + {-# INLINE sinh #-} + + cosh (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (coshDouble# a1) (coshDouble# a2) (coshDouble# a3) (coshDouble# a4) + {-# INLINE cosh #-} + + tanh (DoubleX4# a1 a2 a3 a4) = DoubleX4# + (tanhDouble# a1) (tanhDouble# a2) (tanhDouble# a3) (tanhDouble# a4) + {-# INLINE tanh #-} + + DoubleX4# a1 a2 a3 a4 ** DoubleX4# b1 b2 b3 b4 = DoubleX4# + ((**##) a1 b1) ((**##) a2 b2) ((**##) a3 b3) ((**##) a4 b4) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# +#define ELEM_N 4 + +instance PrimBytes DoubleX4 where + + getBytes (DoubleX4# a1 a2 a3 a4) = case runRW# + ( \s0 -> case newByteArray# (byteSize @DoubleX4 undefined) s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of + s2 -> case writeDoubleArray# marr 1# a2 s2 of + s3 -> case writeDoubleArray# marr 2# a3 s3 of + s4 -> case writeDoubleArray# marr 3# a4 s4 of + s5 -> unsafeFreezeByteArray# marr s5 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = DoubleX4# + (indexDoubleArray# arr i) + (indexDoubleArray# arr (i +# 1#)) + (indexDoubleArray# arr (i +# 2#)) + (indexDoubleArray# arr (i +# 3#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readDoubleArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + {-# INLINE readBytes #-} + + writeBytes mba off (DoubleX4# a1 a2 a3 a4) s + | i <- BOFF_TO_PRIMOFF(off) + = writeDoubleArray# mba (i +# 3#) a4 + ( writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ))) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readDoubleOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readDoubleOffAddr# addr 2# s2 of + (# s3, a3 #) -> case readDoubleOffAddr# addr 3# s3 of + (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + {-# INLINE readAddr #-} + + writeAddr (DoubleX4# a1 a2 a3 a4) addr s + = writeDoubleOffAddr# addr 3# a4 + ( writeDoubleOffAddr# addr 2# a3 + ( writeDoubleOffAddr# addr 1# a2 + ( writeDoubleOffAddr# addr 0# a1 s ))) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Double undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Double undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = DoubleX4# + (indexDoubleArray# ba i) + (indexDoubleArray# ba (i +# 1#)) + (indexDoubleArray# ba (i +# 2#)) + (indexDoubleArray# ba (i +# 3#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readDoubleArray# mba i s0 of + (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readDoubleArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + {-# INLINE readArray #-} + + writeArray mba off (DoubleX4# a1 a2 a3 a4) s + | i <- off *# ELEM_N# + = writeDoubleArray# mba (i +# 3#) a4 + ( writeDoubleArray# mba (i +# 2#) a3 + ( writeDoubleArray# mba (i +# 1#) a2 + ( writeDoubleArray# mba i a1 s ))) + {-# INLINE writeArray #-} + + +instance PrimArray Double DoubleX4 where + + broadcast (D# x) = DoubleX4# x x x x + {-# INLINE broadcast #-} + + ix# 0# (DoubleX4# a1 _ _ _) = D# a1 + ix# 1# (DoubleX4# _ a2 _ _) = D# a2 + ix# 2# (DoubleX4# _ _ a3 _) = D# a3 + ix# 3# (DoubleX4# _ _ _ a4) = D# a4 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, D# a1 #) -> case f s1 of + (# s2, D# a2 #) -> case f s2 of + (# s3, D# a3 #) -> case f s3 of + (# s4, D# a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) + + + upd# _ 0# (D# q) (DoubleX4# _ y z w) = DoubleX4# q y z w + upd# _ 1# (D# q) (DoubleX4# x _ z w) = DoubleX4# x q z w + upd# _ 2# (D# q) (DoubleX4# x y _ w) = DoubleX4# x y q w + upd# _ 3# (D# q) (DoubleX4# x y z _) = DoubleX4# x y z q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + arrayContent# x = (# | (# CumulDims [ELEM_N, 1], 0#, getBytes x #) #) + {-# INLINE arrayContent# #-} + + offsetElems _ = 0# + {-# INLINE offsetElems #-} + + uniqueOrCumulDims _ = Right (CumulDims [ELEM_N, 1]) + {-# INLINE uniqueOrCumulDims #-} + + fromElems _ off ba = DoubleX4# + (indexDoubleArray# ba off) + (indexDoubleArray# ba (off +# 1#)) + (indexDoubleArray# ba (off +# 2#)) + (indexDoubleArray# ba (off +# 3#)) + {-# INLINE fromElems #-} diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX2.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX2.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX2.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.DataFrame.Internal.Backend.Family.FloatX2 (FloatX2 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + + +data FloatX2 = FloatX2# Float# Float# + +-- | Since @Bounded@ is not implemented for floating point types, this instance +-- has an unresolvable constraint. +-- Nevetheless, it is good to have it here for nicer error messages. +instance Bounded Float => Bounded FloatX2 where + maxBound = case maxBound of F# x -> FloatX2# x x + minBound = case minBound of F# x -> FloatX2# x x + + +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 (/=) #-} + + + +cmp' :: Float# -> Float# -> PartialOrdering +cmp' a b + | isTrue# (a `gtFloat#` b) = PGT + | isTrue# (a `ltFloat#` b) = PLT + | otherwise = PEQ + +instance ProductOrder FloatX2 where + cmp (FloatX2# a1 a2) (FloatX2# b1 b2) + = cmp' a1 b1 <> cmp' a2 b2 + {-# INLINE cmp #-} + +instance Ord (NonTransitive.ProductOrd FloatX2) where + NonTransitive.ProductOrd x > NonTransitive.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + NonTransitive.ProductOrd x < NonTransitive.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (NonTransitive.ProductOrd (FloatX2# a1 a2)) + (NonTransitive.ProductOrd (FloatX2# b1 b2)) = isTrue# + ((a1 `geFloat#` b1) `andI#` (a2 `geFloat#` b2)) + {-# INLINE (>=) #-} + (<=) (NonTransitive.ProductOrd (FloatX2# a1 a2)) + (NonTransitive.ProductOrd (FloatX2# b1 b2)) = isTrue# + ((a1 `leFloat#` b1) `andI#` (a2 `leFloat#` b2)) + {-# INLINE (<=) #-} + compare (NonTransitive.ProductOrd a) (NonTransitive.ProductOrd b) + = NonTransitive.toOrdering $ cmp a b + {-# INLINE compare #-} + min (NonTransitive.ProductOrd (FloatX2# a1 a2)) + (NonTransitive.ProductOrd (FloatX2# b1 b2)) + = NonTransitive.ProductOrd + ( FloatX2# + (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) + (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) + ) + {-# INLINE min #-} + max (NonTransitive.ProductOrd (FloatX2# a1 a2)) + (NonTransitive.ProductOrd (FloatX2# b1 b2)) + = NonTransitive.ProductOrd + ( FloatX2# + (if isTrue# (a1 `ltFloat#` b1) then b1 else a1) + (if isTrue# (a2 `ltFloat#` b2) then b2 else a2) + ) + {-# INLINE max #-} + +instance Ord (Partial.ProductOrd FloatX2) where + Partial.ProductOrd x > Partial.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + Partial.ProductOrd x < Partial.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (Partial.ProductOrd (FloatX2# a1 a2)) + (Partial.ProductOrd (FloatX2# b1 b2)) = isTrue# + ((a1 `geFloat#` b1) `andI#` (a2 `geFloat#` b2)) + {-# INLINE (>=) #-} + (<=) (Partial.ProductOrd (FloatX2# a1 a2)) + (Partial.ProductOrd (FloatX2# b1 b2)) = isTrue# + ((a1 `leFloat#` b1) `andI#` (a2 `leFloat#` b2)) + {-# INLINE (<=) #-} + compare (Partial.ProductOrd a) (Partial.ProductOrd b) + = Partial.toOrdering $ cmp a b + {-# INLINE compare #-} + min (Partial.ProductOrd (FloatX2# a1 a2)) + (Partial.ProductOrd (FloatX2# b1 b2)) + = Partial.ProductOrd + ( FloatX2# + (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) + (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) + ) + {-# INLINE min #-} + max (Partial.ProductOrd (FloatX2# a1 a2)) + (Partial.ProductOrd (FloatX2# b1 b2)) + = Partial.ProductOrd + ( FloatX2# + (if isTrue# (a1 `ltFloat#` b1) then b1 else a1) + (if isTrue# (a2 `ltFloat#` b2) then b2 else a2) + ) + {-# INLINE max #-} + +instance Ord FloatX2 where + FloatX2# a1 a2 > FloatX2# b1 b2 + | isTrue# (a1 `gtFloat#` b1) = True + | isTrue# (a1 `ltFloat#` b1) = False + | isTrue# (a2 `gtFloat#` b2) = True + | otherwise = False + {-# INLINE (>) #-} + + FloatX2# a1 a2 < FloatX2# b1 b2 + | isTrue# (a1 `ltFloat#` b1) = True + | isTrue# (a1 `gtFloat#` b1) = False + | isTrue# (a2 `ltFloat#` b2) = True + | otherwise = False + {-# INLINE (<) #-} + + FloatX2# a1 a2 >= FloatX2# b1 b2 + | isTrue# (a1 `ltFloat#` b1) = False + | isTrue# (a1 `gtFloat#` b1) = True + | isTrue# (a2 `ltFloat#` b2) = False + | otherwise = True + {-# INLINE (>=) #-} + + FloatX2# a1 a2 <= FloatX2# b1 b2 + | isTrue# (a1 `gtFloat#` b1) = False + | isTrue# (a1 `ltFloat#` b1) = True + | isTrue# (a2 `gtFloat#` b2) = False + | otherwise = True + {-# INLINE (<=) #-} + + 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 operations for vectors +instance Num FloatX2 where + + FloatX2# a1 a2 + FloatX2# b1 b2 + = FloatX2# (plusFloat# a1 b1) (plusFloat# a2 b2) + {-# INLINE (+) #-} + + FloatX2# a1 a2 - FloatX2# b1 b2 + = FloatX2# (minusFloat# a1 b1) (minusFloat# a2 b2) + {-# INLINE (-) #-} + + FloatX2# a1 a2 * FloatX2# b1 b2 + = FloatX2# (timesFloat# a1 b1) (timesFloat# a2 b2) + {-# INLINE (*) #-} + + negate (FloatX2# a1 a2) = FloatX2# + (negateFloat# a1) (negateFloat# a2) + {-# INLINE negate #-} + + abs (FloatX2# a1 a2) + = FloatX2# + (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) + (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) + {-# INLINE abs #-} + + signum (FloatX2# a1 a2) + = FloatX2# (if isTrue# (a1 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a2 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of F# x -> FloatX2# x x + {-# INLINE fromInteger #-} + + + +instance Fractional FloatX2 where + + FloatX2# a1 a2 / FloatX2# b1 b2 = FloatX2# + (divideFloat# a1 b1) (divideFloat# a2 b2) + {-# INLINE (/) #-} + + recip (FloatX2# a1 a2) = FloatX2# + (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) + {-# INLINE recip #-} + + fromRational r = case fromRational r of F# x -> FloatX2# x x + {-# INLINE fromRational #-} + + + +instance Floating FloatX2 where + + pi = FloatX2# + 3.141592653589793238# + 3.141592653589793238# + {-# INLINE pi #-} + + exp (FloatX2# a1 a2) = FloatX2# + (expFloat# a1) (expFloat# a2) + {-# INLINE exp #-} + + log (FloatX2# a1 a2) = FloatX2# + (logFloat# a1) (logFloat# a2) + {-# INLINE log #-} + + sqrt (FloatX2# a1 a2) = FloatX2# + (sqrtFloat# a1) (sqrtFloat# a2) + {-# INLINE sqrt #-} + + sin (FloatX2# a1 a2) = FloatX2# + (sinFloat# a1) (sinFloat# a2) + {-# INLINE sin #-} + + cos (FloatX2# a1 a2) = FloatX2# + (cosFloat# a1) (cosFloat# a2) + {-# INLINE cos #-} + + tan (FloatX2# a1 a2) = FloatX2# + (tanFloat# a1) (tanFloat# a2) + {-# INLINE tan #-} + + asin (FloatX2# a1 a2) = FloatX2# + (asinFloat# a1) (asinFloat# a2) + {-# INLINE asin #-} + + acos (FloatX2# a1 a2) = FloatX2# + (acosFloat# a1) (acosFloat# a2) + {-# INLINE acos #-} + + atan (FloatX2# a1 a2) = FloatX2# + (atanFloat# a1) (atanFloat# a2) + {-# INLINE atan #-} + + sinh (FloatX2# a1 a2) = FloatX2# + (sinhFloat# a1) (sinhFloat# a2) + {-# INLINE sinh #-} + + cosh (FloatX2# a1 a2) = FloatX2# + (coshFloat# a1) (coshFloat# a2) + {-# INLINE cosh #-} + + tanh (FloatX2# a1 a2) = FloatX2# + (tanhFloat# a1) (tanhFloat# a2) + {-# INLINE tanh #-} + + FloatX2# a1 a2 ** FloatX2# b1 b2 = FloatX2# + (powerFloat# a1 b1) (powerFloat# a2 b2) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# +#define ELEM_N 2 + +instance PrimBytes FloatX2 where + + getBytes (FloatX2# a1 a2) = case runRW# + ( \s0 -> case newByteArray# (byteSize @FloatX2 undefined) s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of + s2 -> case writeFloatArray# marr 1# a2 s2 of + s3 -> unsafeFreezeByteArray# marr s3 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = FloatX2# + (indexFloatArray# arr i) + (indexFloatArray# arr (i +# 1#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) + {-# INLINE readBytes #-} + + writeBytes mba off (FloatX2# a1 a2) s + | i <- BOFF_TO_PRIMOFF(off) + = writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readFloatOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of + (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) + {-# INLINE readAddr #-} + + writeAddr (FloatX2# a1 a2) addr s + = writeFloatOffAddr# addr 1# a2 + ( writeFloatOffAddr# addr 0# a1 s ) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Float undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Float undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = FloatX2# + (indexFloatArray# ba i) + (indexFloatArray# ba (i +# 1#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) + {-# INLINE readArray #-} + + writeArray mba off (FloatX2# a1 a2) s + | i <- off *# ELEM_N# + = writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ) + {-# INLINE writeArray #-} + + +instance PrimArray Float FloatX2 where + + broadcast (F# x) = FloatX2# x x + {-# INLINE broadcast #-} + + ix# 0# (FloatX2# a1 _) = F# a1 + ix# 1# (FloatX2# _ a2) = F# a2 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, F# a1 #) -> case f s1 of + (# s2, F# a2 #) -> (# s2, FloatX2# a1 a2 #) + + + upd# _ 0# (F# q) (FloatX2# _ y) = FloatX2# q y + upd# _ 1# (F# q) (FloatX2# x _) = FloatX2# x q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + arrayContent# x = (# | (# CumulDims [ELEM_N, 1], 0#, getBytes x #) #) + {-# INLINE arrayContent# #-} + + offsetElems _ = 0# + {-# INLINE offsetElems #-} + + uniqueOrCumulDims _ = Right (CumulDims [ELEM_N, 1]) + {-# INLINE uniqueOrCumulDims #-} + + fromElems _ off ba = FloatX2# + (indexFloatArray# ba off) + (indexFloatArray# ba (off +# 1#)) + {-# INLINE fromElems #-} diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX3.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX3.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX3.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.DataFrame.Internal.Backend.Family.FloatX3 (FloatX3 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + + +data FloatX3 = FloatX3# Float# Float# Float# + +-- | Since @Bounded@ is not implemented for floating point types, this instance +-- has an unresolvable constraint. +-- Nevetheless, it is good to have it here for nicer error messages. +instance Bounded Float => Bounded FloatX3 where + maxBound = case maxBound of F# x -> FloatX3# x x x + minBound = case minBound of F# x -> FloatX3# x x x + + +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 (/=) #-} + + + + +cmp' :: Float# -> Float# -> PartialOrdering +cmp' a b + | isTrue# (a `gtFloat#` b) = PGT + | isTrue# (a `ltFloat#` b) = PLT + | otherwise = PEQ + +instance ProductOrder FloatX3 where + cmp (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + {-# INLINE cmp #-} + +instance Ord (NonTransitive.ProductOrd FloatX3) where + NonTransitive.ProductOrd x > NonTransitive.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + NonTransitive.ProductOrd x < NonTransitive.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (NonTransitive.ProductOrd (FloatX3# a1 a2 a3)) + (NonTransitive.ProductOrd (FloatX3# b1 b2 b3)) = isTrue# + ((a1 `geFloat#` b1) `andI#` (a2 `geFloat#` b2) `andI#` (a3 `geFloat#` b3)) + {-# INLINE (>=) #-} + (<=) (NonTransitive.ProductOrd (FloatX3# a1 a2 a3)) + (NonTransitive.ProductOrd (FloatX3# b1 b2 b3)) = isTrue# + ((a1 `leFloat#` b1) `andI#` (a2 `leFloat#` b2) `andI#` (a3 `leFloat#` b3)) + {-# INLINE (<=) #-} + compare (NonTransitive.ProductOrd a) (NonTransitive.ProductOrd b) + = NonTransitive.toOrdering $ cmp a b + {-# INLINE compare #-} + min (NonTransitive.ProductOrd (FloatX3# a1 a2 a3)) + (NonTransitive.ProductOrd (FloatX3# b1 b2 b3)) + = NonTransitive.ProductOrd + ( 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 #-} + max (NonTransitive.ProductOrd (FloatX3# a1 a2 a3)) + (NonTransitive.ProductOrd (FloatX3# b1 b2 b3)) + = NonTransitive.ProductOrd + ( FloatX3# + (if isTrue# (a1 `ltFloat#` b1) then b1 else a1) + (if isTrue# (a2 `ltFloat#` b2) then b2 else a2) + (if isTrue# (a3 `ltFloat#` b3) then b3 else a3) + ) + {-# INLINE max #-} + +instance Ord (Partial.ProductOrd FloatX3) where + Partial.ProductOrd x > Partial.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + Partial.ProductOrd x < Partial.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (Partial.ProductOrd (FloatX3# a1 a2 a3)) + (Partial.ProductOrd (FloatX3# b1 b2 b3)) = isTrue# + ((a1 `geFloat#` b1) `andI#` (a2 `geFloat#` b2) `andI#` (a3 `geFloat#` b3)) + {-# INLINE (>=) #-} + (<=) (Partial.ProductOrd (FloatX3# a1 a2 a3)) + (Partial.ProductOrd (FloatX3# b1 b2 b3)) = isTrue# + ((a1 `leFloat#` b1) `andI#` (a2 `leFloat#` b2) `andI#` (a3 `leFloat#` b3)) + {-# INLINE (<=) #-} + compare (Partial.ProductOrd a) (Partial.ProductOrd b) + = Partial.toOrdering $ cmp a b + {-# INLINE compare #-} + min (Partial.ProductOrd (FloatX3# a1 a2 a3)) + (Partial.ProductOrd (FloatX3# b1 b2 b3)) + = Partial.ProductOrd + ( 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 #-} + max (Partial.ProductOrd (FloatX3# a1 a2 a3)) + (Partial.ProductOrd (FloatX3# b1 b2 b3)) + = Partial.ProductOrd + ( FloatX3# + (if isTrue# (a1 `ltFloat#` b1) then b1 else a1) + (if isTrue# (a2 `ltFloat#` b2) then b2 else a2) + (if isTrue# (a3 `ltFloat#` b3) then b3 else a3) + ) + {-# INLINE max #-} + +instance Ord FloatX3 where + FloatX3# a1 a2 a3 > FloatX3# b1 b2 b3 + | isTrue# (a1 `gtFloat#` b1) = True + | isTrue# (a1 `ltFloat#` b1) = False + | isTrue# (a2 `gtFloat#` b2) = True + | isTrue# (a2 `ltFloat#` b2) = False + | isTrue# (a3 `gtFloat#` b3) = True + | otherwise = False + {-# INLINE (>) #-} + + FloatX3# a1 a2 a3 < FloatX3# b1 b2 b3 + | isTrue# (a1 `ltFloat#` b1) = True + | isTrue# (a1 `gtFloat#` b1) = False + | isTrue# (a2 `ltFloat#` b2) = True + | isTrue# (a2 `gtFloat#` b2) = False + | isTrue# (a3 `ltFloat#` b3) = True + | otherwise = False + {-# INLINE (<) #-} + + FloatX3# a1 a2 a3 >= FloatX3# b1 b2 b3 + | isTrue# (a1 `ltFloat#` b1) = False + | isTrue# (a1 `gtFloat#` b1) = True + | isTrue# (a2 `ltFloat#` b2) = False + | isTrue# (a2 `gtFloat#` b2) = True + | isTrue# (a3 `ltFloat#` b3) = False + | otherwise = True + {-# INLINE (>=) #-} + + FloatX3# a1 a2 a3 <= FloatX3# b1 b2 b3 + | isTrue# (a1 `gtFloat#` b1) = False + | isTrue# (a1 `ltFloat#` b1) = True + | isTrue# (a2 `gtFloat#` b2) = False + | isTrue# (a2 `ltFloat#` b2) = True + | isTrue# (a3 `gtFloat#` b3) = False + | otherwise = True + {-# INLINE (<=) #-} + + 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 operations for vectors +instance Num FloatX3 where + + FloatX3# a1 a2 a3 + FloatX3# b1 b2 b3 + = FloatX3# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) + {-# INLINE (+) #-} + + FloatX3# a1 a2 a3 - FloatX3# b1 b2 b3 + = FloatX3# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) + {-# INLINE (-) #-} + + FloatX3# a1 a2 a3 * FloatX3# b1 b2 b3 + = FloatX3# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) + {-# INLINE (*) #-} + + negate (FloatX3# a1 a2 a3) = FloatX3# + (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) + {-# INLINE negate #-} + + abs (FloatX3# a1 a2 a3) + = FloatX3# + (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) + (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) + (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) + {-# INLINE abs #-} + + signum (FloatX3# a1 a2 a3) + = FloatX3# (if isTrue# (a1 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a2 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a3 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of F# x -> FloatX3# x x x + {-# INLINE fromInteger #-} + + + +instance Fractional FloatX3 where + + FloatX3# a1 a2 a3 / FloatX3# b1 b2 b3 = FloatX3# + (divideFloat# a1 b1) (divideFloat# a2 b2) (divideFloat# a3 b3) + {-# INLINE (/) #-} + + recip (FloatX3# a1 a2 a3) = FloatX3# + (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) (divideFloat# 1.0# a3) + {-# INLINE recip #-} + + fromRational r = case fromRational r of F# x -> FloatX3# x x x + {-# INLINE fromRational #-} + + + +instance Floating FloatX3 where + + pi = FloatX3# + 3.141592653589793238# + 3.141592653589793238# + 3.141592653589793238# + {-# INLINE pi #-} + + exp (FloatX3# a1 a2 a3) = FloatX3# + (expFloat# a1) (expFloat# a2) (expFloat# a3) + {-# INLINE exp #-} + + log (FloatX3# a1 a2 a3) = FloatX3# + (logFloat# a1) (logFloat# a2) (logFloat# a3) + {-# INLINE log #-} + + sqrt (FloatX3# a1 a2 a3) = FloatX3# + (sqrtFloat# a1) (sqrtFloat# a2) (sqrtFloat# a3) + {-# INLINE sqrt #-} + + sin (FloatX3# a1 a2 a3) = FloatX3# + (sinFloat# a1) (sinFloat# a2) (sinFloat# a3) + {-# INLINE sin #-} + + cos (FloatX3# a1 a2 a3) = FloatX3# + (cosFloat# a1) (cosFloat# a2) (cosFloat# a3) + {-# INLINE cos #-} + + tan (FloatX3# a1 a2 a3) = FloatX3# + (tanFloat# a1) (tanFloat# a2) (tanFloat# a3) + {-# INLINE tan #-} + + asin (FloatX3# a1 a2 a3) = FloatX3# + (asinFloat# a1) (asinFloat# a2) (asinFloat# a3) + {-# INLINE asin #-} + + acos (FloatX3# a1 a2 a3) = FloatX3# + (acosFloat# a1) (acosFloat# a2) (acosFloat# a3) + {-# INLINE acos #-} + + atan (FloatX3# a1 a2 a3) = FloatX3# + (atanFloat# a1) (atanFloat# a2) (atanFloat# a3) + {-# INLINE atan #-} + + sinh (FloatX3# a1 a2 a3) = FloatX3# + (sinhFloat# a1) (sinhFloat# a2) (sinhFloat# a3) + {-# INLINE sinh #-} + + cosh (FloatX3# a1 a2 a3) = FloatX3# + (coshFloat# a1) (coshFloat# a2) (coshFloat# a3) + {-# INLINE cosh #-} + + tanh (FloatX3# a1 a2 a3) = FloatX3# + (tanhFloat# a1) (tanhFloat# a2) (tanhFloat# a3) + {-# INLINE tanh #-} + + FloatX3# a1 a2 a3 ** FloatX3# b1 b2 b3 = FloatX3# + (powerFloat# a1 b1) (powerFloat# a2 b2) (powerFloat# a3 b3) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# +#define ELEM_N 3 + +instance PrimBytes FloatX3 where + + getBytes (FloatX3# a1 a2 a3) = case runRW# + ( \s0 -> case newByteArray# (byteSize @FloatX3 undefined) s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of + s2 -> case writeFloatArray# marr 1# a2 s2 of + s3 -> case writeFloatArray# marr 2# a3 s3 of + s4 -> unsafeFreezeByteArray# marr s4 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = FloatX3# + (indexFloatArray# arr i) + (indexFloatArray# arr (i +# 1#)) + (indexFloatArray# arr (i +# 2#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + {-# INLINE readBytes #-} + + writeBytes mba off (FloatX3# a1 a2 a3) s + | i <- BOFF_TO_PRIMOFF(off) + = writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s )) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readFloatOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readFloatOffAddr# addr 2# s2 of + (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + {-# INLINE readAddr #-} + + writeAddr (FloatX3# a1 a2 a3) addr s + = writeFloatOffAddr# addr 2# a3 + ( writeFloatOffAddr# addr 1# a2 + ( writeFloatOffAddr# addr 0# a1 s )) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Float undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Float undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = FloatX3# + (indexFloatArray# ba i) + (indexFloatArray# ba (i +# 1#)) + (indexFloatArray# ba (i +# 2#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + {-# INLINE readArray #-} + + writeArray mba off (FloatX3# a1 a2 a3) s + | i <- off *# ELEM_N# + = writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s )) + {-# INLINE writeArray #-} + + +instance PrimArray Float FloatX3 where + + broadcast (F# x) = FloatX3# x x x + {-# INLINE broadcast #-} + + ix# 0# (FloatX3# a1 _ _) = F# a1 + ix# 1# (FloatX3# _ a2 _) = F# a2 + ix# 2# (FloatX3# _ _ a3) = F# a3 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, F# a1 #) -> case f s1 of + (# s2, F# a2 #) -> case f s2 of + (# s3, F# a3 #) -> (# s3, FloatX3# a1 a2 a3 #) + + + upd# _ 0# (F# q) (FloatX3# _ y z) = FloatX3# q y z + upd# _ 1# (F# q) (FloatX3# x _ z) = FloatX3# x q z + upd# _ 2# (F# q) (FloatX3# x y _) = FloatX3# x y q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + arrayContent# x = (# | (# CumulDims [ELEM_N, 1], 0#, getBytes x #) #) + {-# INLINE arrayContent# #-} + + offsetElems _ = 0# + {-# INLINE offsetElems #-} + + uniqueOrCumulDims _ = Right (CumulDims [ELEM_N, 1]) + {-# INLINE uniqueOrCumulDims #-} + + fromElems _ off ba = FloatX3# + (indexFloatArray# ba off) + (indexFloatArray# ba (off +# 1#)) + (indexFloatArray# ba (off +# 2#)) + {-# INLINE fromElems #-} diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX4.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX4.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/FloatX4.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Numeric.DataFrame.Internal.Backend.Family.FloatX4 (FloatX4 (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.DataFrame.SubSpace +import Numeric.Dimensions +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + + +data FloatX4 = FloatX4# Float# Float# Float# Float# + +-- | Since @Bounded@ is not implemented for floating point types, this instance +-- has an unresolvable constraint. +-- Nevetheless, it is good to have it here for nicer error messages. +instance Bounded Float => Bounded FloatX4 where + maxBound = case maxBound of F# x -> FloatX4# x x x x + minBound = case minBound of F# x -> FloatX4# x x x x + + +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 (/=) #-} + + + + +cmp' :: Float# -> Float# -> PartialOrdering +cmp' a b + | isTrue# (a `gtFloat#` b) = PGT + | isTrue# (a `ltFloat#` b) = PLT + | otherwise = PEQ + +instance ProductOrder FloatX4 where + cmp (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 <> cmp' a4 b4 + {-# INLINE cmp #-} + +instance Ord (NonTransitive.ProductOrd FloatX4) where + NonTransitive.ProductOrd x > NonTransitive.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + NonTransitive.ProductOrd x < NonTransitive.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (NonTransitive.ProductOrd (FloatX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (FloatX4# b1 b2 b3 b4)) = isTrue# + ((a1 `geFloat#` b1) `andI#` (a2 `geFloat#` b2) `andI#` (a3 `geFloat#` b3) `andI#` (a4 `geFloat#` b4)) + {-# INLINE (>=) #-} + (<=) (NonTransitive.ProductOrd (FloatX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (FloatX4# b1 b2 b3 b4)) = isTrue# + ((a1 `leFloat#` b1) `andI#` (a2 `leFloat#` b2) `andI#` (a3 `leFloat#` b3) `andI#` (a4 `leFloat#` b4)) + {-# INLINE (<=) #-} + compare (NonTransitive.ProductOrd a) (NonTransitive.ProductOrd b) + = NonTransitive.toOrdering $ cmp a b + {-# INLINE compare #-} + min (NonTransitive.ProductOrd (FloatX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (FloatX4# b1 b2 b3 b4)) + = NonTransitive.ProductOrd + ( 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 #-} + max (NonTransitive.ProductOrd (FloatX4# a1 a2 a3 a4)) + (NonTransitive.ProductOrd (FloatX4# b1 b2 b3 b4)) + = NonTransitive.ProductOrd + ( FloatX4# + (if isTrue# (a1 `ltFloat#` b1) then b1 else a1) + (if isTrue# (a2 `ltFloat#` b2) then b2 else a2) + (if isTrue# (a3 `ltFloat#` b3) then b3 else a3) + (if isTrue# (a4 `ltFloat#` b4) then b4 else a4) + ) + {-# INLINE max #-} + +instance Ord (Partial.ProductOrd FloatX4) where + Partial.ProductOrd x > Partial.ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + Partial.ProductOrd x < Partial.ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + (>=) (Partial.ProductOrd (FloatX4# a1 a2 a3 a4)) + (Partial.ProductOrd (FloatX4# b1 b2 b3 b4)) = isTrue# + ((a1 `geFloat#` b1) `andI#` (a2 `geFloat#` b2) `andI#` (a3 `geFloat#` b3) `andI#` (a4 `geFloat#` b4)) + {-# INLINE (>=) #-} + (<=) (Partial.ProductOrd (FloatX4# a1 a2 a3 a4)) + (Partial.ProductOrd (FloatX4# b1 b2 b3 b4)) = isTrue# + ((a1 `leFloat#` b1) `andI#` (a2 `leFloat#` b2) `andI#` (a3 `leFloat#` b3) `andI#` (a4 `leFloat#` b4)) + {-# INLINE (<=) #-} + compare (Partial.ProductOrd a) (Partial.ProductOrd b) + = Partial.toOrdering $ cmp a b + {-# INLINE compare #-} + min (Partial.ProductOrd (FloatX4# a1 a2 a3 a4)) + (Partial.ProductOrd (FloatX4# b1 b2 b3 b4)) + = Partial.ProductOrd + ( 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 #-} + max (Partial.ProductOrd (FloatX4# a1 a2 a3 a4)) + (Partial.ProductOrd (FloatX4# b1 b2 b3 b4)) + = Partial.ProductOrd + ( FloatX4# + (if isTrue# (a1 `ltFloat#` b1) then b1 else a1) + (if isTrue# (a2 `ltFloat#` b2) then b2 else a2) + (if isTrue# (a3 `ltFloat#` b3) then b3 else a3) + (if isTrue# (a4 `ltFloat#` b4) then b4 else a4) + ) + {-# INLINE max #-} + +instance Ord FloatX4 where + FloatX4# a1 a2 a3 a4 > FloatX4# b1 b2 b3 b4 + | isTrue# (a1 `gtFloat#` b1) = True + | isTrue# (a1 `ltFloat#` b1) = False + | isTrue# (a2 `gtFloat#` b2) = True + | isTrue# (a2 `ltFloat#` b2) = False + | isTrue# (a3 `gtFloat#` b3) = True + | isTrue# (a3 `ltFloat#` b3) = False + | isTrue# (a4 `gtFloat#` b4) = True + | otherwise = False + {-# INLINE (>) #-} + + FloatX4# a1 a2 a3 a4 < FloatX4# b1 b2 b3 b4 + | isTrue# (a1 `ltFloat#` b1) = True + | isTrue# (a1 `gtFloat#` b1) = False + | isTrue# (a2 `ltFloat#` b2) = True + | isTrue# (a2 `gtFloat#` b2) = False + | isTrue# (a3 `ltFloat#` b3) = True + | isTrue# (a3 `gtFloat#` b3) = False + | isTrue# (a4 `ltFloat#` b4) = True + | otherwise = False + {-# INLINE (<) #-} + + FloatX4# a1 a2 a3 a4 >= FloatX4# b1 b2 b3 b4 + | isTrue# (a1 `ltFloat#` b1) = False + | isTrue# (a1 `gtFloat#` b1) = True + | isTrue# (a2 `ltFloat#` b2) = False + | isTrue# (a2 `gtFloat#` b2) = True + | isTrue# (a3 `ltFloat#` b3) = False + | isTrue# (a3 `gtFloat#` b3) = True + | isTrue# (a4 `ltFloat#` b4) = False + | otherwise = True + {-# INLINE (>=) #-} + + FloatX4# a1 a2 a3 a4 <= FloatX4# b1 b2 b3 b4 + | isTrue# (a1 `gtFloat#` b1) = False + | isTrue# (a1 `ltFloat#` b1) = True + | isTrue# (a2 `gtFloat#` b2) = False + | isTrue# (a2 `ltFloat#` b2) = True + | isTrue# (a3 `gtFloat#` b3) = False + | isTrue# (a3 `ltFloat#` b3) = True + | isTrue# (a4 `gtFloat#` b4) = False + | otherwise = True + {-# INLINE (<=) #-} + + 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 operations for vectors +instance Num FloatX4 where + + FloatX4# a1 a2 a3 a4 + FloatX4# b1 b2 b3 b4 + = FloatX4# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) (plusFloat# a4 b4) + {-# INLINE (+) #-} + + FloatX4# a1 a2 a3 a4 - FloatX4# b1 b2 b3 b4 + = FloatX4# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) (minusFloat# a4 b4) + {-# INLINE (-) #-} + + FloatX4# a1 a2 a3 a4 * FloatX4# b1 b2 b3 b4 + = FloatX4# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) (timesFloat# a4 b4) + {-# INLINE (*) #-} + + negate (FloatX4# a1 a2 a3 a4) = FloatX4# + (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) (negateFloat# a4) + {-# INLINE negate #-} + + abs (FloatX4# a1 a2 a3 a4) + = FloatX4# + (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) + (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) + (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) + (if isTrue# (a4 `geFloat#` 0.0#) then a4 else negateFloat# a4) + {-# INLINE abs #-} + + signum (FloatX4# a1 a2 a3 a4) + = FloatX4# (if isTrue# (a1 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a2 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a3 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + (if isTrue# (a4 `gtFloat#` 0.0#) + then 1.0# + else if isTrue# (a4 `ltFloat#` 0.0#) then -1.0# else 0.0# ) + {-# INLINE signum #-} + + fromInteger n = case fromInteger n of F# x -> FloatX4# x x x x + {-# INLINE fromInteger #-} + + + +instance Fractional FloatX4 where + + FloatX4# a1 a2 a3 a4 / FloatX4# b1 b2 b3 b4 = FloatX4# + (divideFloat# a1 b1) (divideFloat# a2 b2) (divideFloat# a3 b3) (divideFloat# a4 b4) + {-# INLINE (/) #-} + + recip (FloatX4# a1 a2 a3 a4) = FloatX4# + (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) (divideFloat# 1.0# a3) (divideFloat# 1.0# a4) + {-# INLINE recip #-} + + fromRational r = case fromRational r of F# x -> FloatX4# x x x x + {-# INLINE fromRational #-} + + + +instance Floating FloatX4 where + + pi = FloatX4# + 3.141592653589793238# + 3.141592653589793238# + 3.141592653589793238# + 3.141592653589793238# + {-# INLINE pi #-} + + exp (FloatX4# a1 a2 a3 a4) = FloatX4# + (expFloat# a1) (expFloat# a2) (expFloat# a3) (expFloat# a4) + {-# INLINE exp #-} + + log (FloatX4# a1 a2 a3 a4) = FloatX4# + (logFloat# a1) (logFloat# a2) (logFloat# a3) (logFloat# a4) + {-# INLINE log #-} + + sqrt (FloatX4# a1 a2 a3 a4) = FloatX4# + (sqrtFloat# a1) (sqrtFloat# a2) (sqrtFloat# a3) (sqrtFloat# a4) + {-# INLINE sqrt #-} + + sin (FloatX4# a1 a2 a3 a4) = FloatX4# + (sinFloat# a1) (sinFloat# a2) (sinFloat# a3) (sinFloat# a4) + {-# INLINE sin #-} + + cos (FloatX4# a1 a2 a3 a4) = FloatX4# + (cosFloat# a1) (cosFloat# a2) (cosFloat# a3) (cosFloat# a4) + {-# INLINE cos #-} + + tan (FloatX4# a1 a2 a3 a4) = FloatX4# + (tanFloat# a1) (tanFloat# a2) (tanFloat# a3) (tanFloat# a4) + {-# INLINE tan #-} + + asin (FloatX4# a1 a2 a3 a4) = FloatX4# + (asinFloat# a1) (asinFloat# a2) (asinFloat# a3) (asinFloat# a4) + {-# INLINE asin #-} + + acos (FloatX4# a1 a2 a3 a4) = FloatX4# + (acosFloat# a1) (acosFloat# a2) (acosFloat# a3) (acosFloat# a4) + {-# INLINE acos #-} + + atan (FloatX4# a1 a2 a3 a4) = FloatX4# + (atanFloat# a1) (atanFloat# a2) (atanFloat# a3) (atanFloat# a4) + {-# INLINE atan #-} + + sinh (FloatX4# a1 a2 a3 a4) = FloatX4# + (sinhFloat# a1) (sinhFloat# a2) (sinhFloat# a3) (sinhFloat# a4) + {-# INLINE sinh #-} + + cosh (FloatX4# a1 a2 a3 a4) = FloatX4# + (coshFloat# a1) (coshFloat# a2) (coshFloat# a3) (coshFloat# a4) + {-# INLINE cosh #-} + + tanh (FloatX4# a1 a2 a3 a4) = FloatX4# + (tanhFloat# a1) (tanhFloat# a2) (tanhFloat# a3) (tanhFloat# a4) + {-# INLINE tanh #-} + + FloatX4# a1 a2 a3 a4 ** FloatX4# b1 b2 b3 b4 = FloatX4# + (powerFloat# a1 b1) (powerFloat# a2 b2) (powerFloat# a3 b3) (powerFloat# a4 b4) + {-# INLINE (**) #-} + + logBase x y = log y / log x + {-# INLINE logBase #-} + + asinh x = log (x + sqrt (1.0+x*x)) + {-# INLINE asinh #-} + + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + {-# INLINE acosh #-} + + atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + {-# INLINE atanh #-} + +-- offset in bytes is S times bigger than offset in prim elements, +-- when S is power of two, this is equal to shift +#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# +#define ELEM_N 4 + +instance PrimBytes FloatX4 where + + getBytes (FloatX4# a1 a2 a3 a4) = case runRW# + ( \s0 -> case newByteArray# (byteSize @FloatX4 undefined) s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of + s2 -> case writeFloatArray# marr 1# a2 s2 of + s3 -> case writeFloatArray# marr 2# a3 s3 of + s4 -> case writeFloatArray# marr 3# a4 s4 of + s5 -> unsafeFreezeByteArray# marr s5 + ) of (# _, a #) -> a + {-# INLINE getBytes #-} + + fromBytes off arr + | i <- BOFF_TO_PRIMOFF(off) + = FloatX4# + (indexFloatArray# arr i) + (indexFloatArray# arr (i +# 1#)) + (indexFloatArray# arr (i +# 2#)) + (indexFloatArray# arr (i +# 3#)) + {-# INLINE fromBytes #-} + + readBytes mba off s0 + | i <- BOFF_TO_PRIMOFF(off) + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readFloatArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + {-# INLINE readBytes #-} + + writeBytes mba off (FloatX4# a1 a2 a3 a4) s + | i <- BOFF_TO_PRIMOFF(off) + = writeFloatArray# mba (i +# 3#) a4 + ( writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ))) + {-# INLINE writeBytes #-} + + readAddr addr s0 + = case readFloatOffAddr# addr 0# s0 of + (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of + (# s2, a2 #) -> case readFloatOffAddr# addr 2# s2 of + (# s3, a3 #) -> case readFloatOffAddr# addr 3# s3 of + (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + {-# INLINE readAddr #-} + + writeAddr (FloatX4# a1 a2 a3 a4) addr s + = writeFloatOffAddr# addr 3# a4 + ( writeFloatOffAddr# addr 2# a3 + ( writeFloatOffAddr# addr 1# a2 + ( writeFloatOffAddr# addr 0# a1 s ))) + {-# INLINE writeAddr #-} + + byteSize _ = byteSize @Float undefined *# ELEM_N# + {-# INLINE byteSize #-} + + byteAlign _ = byteAlign @Float undefined + {-# INLINE byteAlign #-} + + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + indexArray ba off + | i <- off *# ELEM_N# + = FloatX4# + (indexFloatArray# ba i) + (indexFloatArray# ba (i +# 1#)) + (indexFloatArray# ba (i +# 2#)) + (indexFloatArray# ba (i +# 3#)) + {-# INLINE indexArray #-} + + readArray mba off s0 + | i <- off *# ELEM_N# + = case readFloatArray# mba i s0 of + (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of + (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of + (# s3, a3 #) -> case readFloatArray# mba (i +# 3#) s3 of + (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + {-# INLINE readArray #-} + + writeArray mba off (FloatX4# a1 a2 a3 a4) s + | i <- off *# ELEM_N# + = writeFloatArray# mba (i +# 3#) a4 + ( writeFloatArray# mba (i +# 2#) a3 + ( writeFloatArray# mba (i +# 1#) a2 + ( writeFloatArray# mba i a1 s ))) + {-# INLINE writeArray #-} + + +instance PrimArray Float FloatX4 where + + broadcast (F# x) = FloatX4# x x x x + {-# INLINE broadcast #-} + + ix# 0# (FloatX4# a1 _ _ _) = F# a1 + ix# 1# (FloatX4# _ a2 _ _) = F# a2 + ix# 2# (FloatX4# _ _ a3 _) = F# a3 + ix# 3# (FloatX4# _ _ _ a4) = F# a4 + ix# _ _ = undefined + {-# INLINE ix# #-} + + gen# _ f s0 = case f s0 of + (# s1, F# a1 #) -> case f s1 of + (# s2, F# a2 #) -> case f s2 of + (# s3, F# a3 #) -> case f s3 of + (# s4, F# a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) + + + upd# _ 0# (F# q) (FloatX4# _ y z w) = FloatX4# q y z w + upd# _ 1# (F# q) (FloatX4# x _ z w) = FloatX4# x q z w + upd# _ 2# (F# q) (FloatX4# x y _ w) = FloatX4# x y q w + upd# _ 3# (F# q) (FloatX4# x y z _) = FloatX4# x y z q + upd# _ _ _ x = x + {-# INLINE upd# #-} + + arrayContent# x = (# | (# CumulDims [ELEM_N, 1], 0#, getBytes x #) #) + {-# INLINE arrayContent# #-} + + offsetElems _ = 0# + {-# INLINE offsetElems #-} + + uniqueOrCumulDims _ = Right (CumulDims [ELEM_N, 1]) + {-# INLINE uniqueOrCumulDims #-} + + fromElems _ off ba = FloatX4# + (indexFloatArray# ba off) + (indexFloatArray# ba (off +# 1#)) + (indexFloatArray# ba (off +# 2#)) + (indexFloatArray# ba (off +# 3#)) + {-# INLINE fromElems #-} + + +-------------------------------------------------------------------------------- +-- Rewrite rules to improve efficiency of algorithms +-- +-- Here we don't have access to DataFrame constructors, because we cannot import +-- Numeric.DataFrame.Type module. +-- However, we know that all DataFrame instances are just newtype wrappers +-- (as well as Scalar). Thus, we can use unsafeCoerce# to get access to Arrays +-- inside DataFrames. +-- +-------------------------------------------------------------------------------- + +getIdxOffset :: Idxs '[4] -> Int# +getIdxOffset is = case unsafeCoerce# is of + [W# i] -> word2Int# i + _ -> 0# +{-# INLINE getIdxOffset #-} + + +{-# RULES +"index/FloatX4" forall i . index @Float @'[4] i + = unsafeCoerce# (ix# @Float @FloatX4 (getIdxOffset i)) + + #-} diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family/ScalarBase.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family/ScalarBase.hs new file mode 100644 --- /dev/null +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family/ScalarBase.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.Backend.Family.ScalarBase (ScalarBase (..)) where + + +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + +-- | Specialize ScalarBase type without any arrays +newtype ScalarBase t = ScalarBase { _unScalarBase :: t } + deriving ( Enum, Eq, Bounded, Integral + , Num, Fractional, Floating, Ord, Real, RealFrac, RealFloat + , PrimBytes) + +instance Ord t => ProductOrder (ScalarBase t) where + cmp a b = fromOrdering (compare (_unScalarBase a) (_unScalarBase b)) +deriving instance Ord t => Ord (NonTransitive.ProductOrd (ScalarBase t)) +deriving instance Ord t => Ord (Partial.ProductOrd (ScalarBase t)) + +instance PrimBytes t => PrimArray t (ScalarBase t) where + broadcast = unsafeCoerce# + {-# INLINE broadcast #-} + ix# _ = unsafeCoerce# + {-# INLINE ix# #-} + gen# _ = unsafeCoerce# + {-# INLINE gen# #-} + upd# _ 0# = const . ScalarBase + upd# _ _ = const id + {-# INLINE upd# #-} + arrayContent# x = (# _unScalarBase x | #) + {-# INLINE arrayContent# #-} + offsetElems _ = 0# + {-# INLINE offsetElems #-} + uniqueOrCumulDims = Left . _unScalarBase + {-# INLINE uniqueOrCumulDims #-} + fromElems _ off ba = indexArray ba off + {-# INLINE fromElems #-} + +_suppressHlintUnboxedTuplesWarning :: () -> (# (), () #) +_suppressHlintUnboxedTuplesWarning = undefined diff --git a/src/Numeric/DataFrame.hs b/src/Numeric/DataFrame.hs --- a/src/Numeric/DataFrame.hs +++ b/src/Numeric/DataFrame.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternSynonyms #-} - module Numeric.DataFrame ( module Numeric.DataFrame.Type -- * Simplified type aliases @@ -9,16 +7,14 @@ -- * Functionality , module Numeric.DataFrame.SubSpace , module Numeric.DataFrame.Contraction - , module Numeric.DataFrame.Shape ) where -import Numeric.DataFrame.Internal.Array () +import Numeric.DataFrame.Internal.Backend () -import Numeric.DataFrame.Contraction -import Numeric.DataFrame.Shape -import Numeric.DataFrame.SubSpace -import Numeric.DataFrame.Type +import Numeric.DataFrame.Contraction +import Numeric.DataFrame.SubSpace +import Numeric.DataFrame.Type -import Numeric.Matrix -import Numeric.Scalar -import Numeric.Vector +import Numeric.Matrix +import Numeric.Scalar +import Numeric.Vector diff --git a/src/Numeric/DataFrame/Contraction.hs b/src/Numeric/DataFrame/Contraction.hs --- a/src/Numeric/DataFrame/Contraction.hs +++ b/src/Numeric/DataFrame/Contraction.hs @@ -30,11 +30,11 @@ ( Contraction (..), (%*) ) where -import GHC.Base +import GHC.Base -import Numeric.DataFrame.Family -import Numeric.DataFrame.Internal.Array.Class -import Numeric.Dimensions +import Numeric.DataFrame.Internal.PrimArray +import Numeric.DataFrame.Type +import Numeric.Dimensions @@ -55,13 +55,12 @@ -- 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 +(%*) :: ( Contraction t as bs asbs , KnownDim m , PrimArray t (DataFrame t (as +: m)) , PrimArray t (DataFrame t (m :+ bs)) - , PrimArray t (DataFrame t (as ++ bs)) - ) => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t (as ++ bs) + , PrimArray t (DataFrame t asbs) + ) => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs (%*) = contract {-# INLINE (%*) #-} infixl 7 %* @@ -73,6 +72,7 @@ , Dimensions bs , Num t ) => Contraction t as bs asbs where + contract :: forall m . ( KnownDim m , PrimArray t (DataFrame t (as +: m)) @@ -80,19 +80,40 @@ , PrimArray t (DataFrame t asbs) ) => DataFrame t (as +: m) -> DataFrame t (m :+ bs) -> DataFrame t asbs - contract x y - | I# m <- fromIntegral $ dimVal' @m - , I# n <- fromIntegral $ totalDim' @as - , I# k <- fromIntegral $ totalDim' @bs - , nk <- n *# k - = let loop i j l r | isTrue# (l ==# m) = r + contract x y = case (# uniqueOrCumulDims x, uniqueOrCumulDims y #) of + (# Left x0, Left y0 #) -> broadcast (x0 * y0) + (# ux, uy #) + | dm <- dim @m + , (ixX, xs) <- getStepsAndIx (Snoc dims dm) x ux + , (ixY, ys) <- getStepsAndIx (Cons dm dims) y uy + , (# n, m, k, steps #) <- conSteps xs ys -> + 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) + (r + ixX (i *# m +# l) * ixY (l *# k +# j)) - loop2 (T# i j) | isTrue# (j ==# k) = (# T# i j, 0 #) - | isTrue# (i ==# n) = loop2 (T# 0# (j +# 1#)) - | otherwise = (# T# (i +# 1#) j, loop i j 0# 0 #) - in case gen# nk loop2 (T# 0# 0#) of + loop2 (T# i j) | isTrue# (i ==# n) = (# T# i j, 0 #) + | isTrue# (j ==# k) = loop2 (T# (i +# 1#) 0#) + | otherwise = (# T# i (j +# 1#), loop i j 0# 0 #) + in case gen# steps loop2 (T# 0# 0#) of (# _, r #) -> r + where + getStepsAndIx :: forall (ns :: [Nat]) + . PrimArray t (DataFrame t ns) + => Dims ns + -> DataFrame t ns + -> Either t CumulDims + -> (Int# -> t, CumulDims) + getStepsAndIx _ df (Right cds) = ((`ix#` df), cds) + getStepsAndIx ds _ (Left e) = (\_ -> e, cumulDims ds) + conSteps (CumulDims xs) (CumulDims ys) = case conSteps' xs ys of + (W# n, W# m, W# k, zs) + -> (# word2Int# n, word2Int# m, word2Int# k, CumulDims zs #) + conSteps' :: [Word] -> [Word] -> (Word, Word, Word, [Word]) + conSteps' [m, _] (_:ys@(k:_)) = (1, m, k, ys) + conSteps' (nm:ns) cys + | (_, m, k, ys) <- conSteps' ns cys + , n <- nm `quot` m + = (n, m, k, n*k : ys ) + conSteps' _ _ = error "Numeric.DataFrame.Contraction: impossible match" data T# = T# Int# Int# diff --git a/src/Numeric/DataFrame/Family.hs b/src/Numeric/DataFrame/Family.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Family.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} --- | The very core of DataFrame: definition of the data family. -module Numeric.DataFrame.Family ( DataFrame ) where - --- | Keep data in a primitive data frame --- and maintain information about Dimensions in the type system -data family DataFrame (t :: l) (xs :: [k]) diff --git a/src/Numeric/DataFrame/IO.hs b/src/Numeric/DataFrame/IO.hs --- a/src/Numeric/DataFrame/IO.hs +++ b/src/Numeric/DataFrame/IO.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} @@ -17,8 +16,6 @@ -- Copyright : (c) Artem Chirkin -- License : BSD3 -- --- Maintainer : chirkin@arch.ethz.ch --- -- Mutable DataFrames living in IO. -- ----------------------------------------------------------------------------- @@ -27,6 +24,7 @@ ( IODataFrame (XIOFrame), SomeIODataFrame (..) , newDataFrame, newPinnedDataFrame , copyDataFrame, copyMutableDataFrame + , copyDataFrame', copyMutableDataFrame' , freezeDataFrame, unsafeFreezeDataFrame , thawDataFrame, thawPinDataFrame, unsafeThawDataFrame , writeDataFrame, writeDataFrameOff @@ -35,15 +33,14 @@ ) where -import GHC.Base -import GHC.IO (IO (..)) -import GHC.Ptr (Ptr (..)) +import GHC.Base +import GHC.IO (IO (..)) +import GHC.Ptr (Ptr (..)) -import Numeric.DataFrame.Family -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Mutable -import Numeric.Dimensions -import Numeric.PrimBytes +import Numeric.DataFrame.Internal.Mutable +import Numeric.DataFrame.Internal.PrimArray +import Numeric.DataFrame.Type +import Numeric.Dimensions -- | Mutable DataFrame that lives in IO. @@ -80,31 +77,69 @@ -- | Copy one DataFrame into another mutable DataFrame at specified position. -copyDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) - (bs :: [Nat]) (asbs :: [Nat]) - . ( PrimBytes t - , PrimBytes (DataFrame t (as +: b')) +-- +-- In contrast to @copyMDataFrame'@, this function allows to copy over a range of contiguous +-- indices over a single dimension. +-- For example, you can write a 3x4 matrix into a 7x4 matrix, starting at indices 0..3. +copyDataFrame :: forall (t :: Type) + (b :: Nat) (bi :: Nat) (bd :: Nat) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) + . ( b ~ (bi + bd - 1) + , PrimBytes t + , PrimBytes (DataFrame t (bd :+ bs)) , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) ) - => DataFrame t (as +: b') -> Idxs (b :+ bs) -> IODataFrame t asbs -> IO () -copyDataFrame df ei (IODataFrame mdf) = IO (copyDataFrame# df ei mdf) + => Idxs (as +: bi) -> DataFrame t (bd :+ bs) + -> IODataFrame t asbs -> IO () +copyDataFrame ei df (IODataFrame mdf) = IO (copyDataFrame# ei df mdf) {-# INLINE copyDataFrame #-} -- | Copy one mutable DataFrame into another mutable DataFrame at specified position. -copyMutableDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) - (bs :: [Nat]) (asbs :: [Nat]) - . ( PrimBytes t +-- +-- In contrast to @copyMDataFrame'@, this function allows to copy over a range of contiguous +-- indices over a single dimension. +-- For example, you can write a 3x4 matrix into a 7x4 matrix, starting at indices 0..3. +copyMutableDataFrame :: forall (t :: Type) + (b :: Nat) (bi :: Nat) (bd :: Nat) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) + . ( b ~ (bi + bd - 1) + , PrimBytes t , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) ) - => IODataFrame t (as +: b') -> Idxs (b :+ bs) + => Idxs (as +: bi) -> IODataFrame t (bd :+ bs) -> IODataFrame t asbs -> IO () -copyMutableDataFrame (IODataFrame mdfA) ei (IODataFrame mdfB) - = IO (copyMDataFrame# mdfA ei mdfB) +copyMutableDataFrame ei (IODataFrame mdfA) (IODataFrame mdfB) + = IO (copyMDataFrame# ei mdfA mdfB) {-# INLINE copyMutableDataFrame #-} +-- | Copy one DataFrame into another mutable DataFrame at specified position. +-- +-- This is a simpler version of @copyDataFrame@ that allows to copy over one index at a time. +copyDataFrame' :: forall (t :: Type) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) + . ( PrimBytes t + , PrimBytes (DataFrame t bs) + , ConcatList as bs asbs + ) + => Idxs as -> DataFrame t bs + -> IODataFrame t asbs -> IO () +copyDataFrame' ei df (IODataFrame mdf) = IO (copyDataFrame'# ei df mdf) +{-# INLINE copyDataFrame' #-} +-- | Copy one mutable DataFrame into another mutable DataFrame at specified position. +-- +-- This is a simpler version of @copyDataFrame@ that allows to copy over one index at a time. +copyMutableDataFrame' :: forall (t :: Type) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) + . ( PrimBytes t + , ConcatList as bs asbs + ) + => Idxs as -> IODataFrame t bs + -> IODataFrame t asbs -> IO () +copyMutableDataFrame' ei (IODataFrame mdfA) (IODataFrame mdfB) + = IO (copyMDataFrame'# ei mdfA mdfB) +{-# INLINE copyMutableDataFrame' #-} + -- | Make a mutable DataFrame immutable, without copying. unsafeFreezeDataFrame :: forall (t :: Type) (ns :: [Nat]) . PrimArray t (DataFrame t ns) @@ -122,7 +157,7 @@ -- | Create a new mutable DataFrame and copy content of immutable one in there. thawDataFrame :: forall (t :: Type) (ns :: [Nat]) - . (PrimBytes (DataFrame t ns), PrimBytes t) + . (Dimensions ns, PrimBytes (DataFrame t ns)) => DataFrame t ns -> IO (IODataFrame t ns) thawDataFrame df = IODataFrame <$> IO (thawDataFrame# df) {-# INLINE thawDataFrame #-} @@ -130,14 +165,15 @@ -- | Create a new mutable DataFrame and copy content of immutable one in there. -- The result array is pinned and aligned. thawPinDataFrame :: forall (t :: Type) (ns :: [Nat]) - . (PrimBytes (DataFrame t ns), PrimBytes t) + . (Dimensions ns, PrimBytes (DataFrame t ns)) => DataFrame t ns -> IO (IODataFrame t ns) thawPinDataFrame df = IODataFrame <$> IO (thawPinDataFrame# df) {-# INLINE thawPinDataFrame #-} -- | UnsafeCoerces an underlying byte array. unsafeThawDataFrame :: forall (t :: Type) (ns :: [Nat]) - . (PrimBytes (DataFrame t ns), PrimBytes t) + . ( Dimensions ns + , PrimBytes (DataFrame t ns), PrimBytes t) => DataFrame t ns -> IO (IODataFrame t ns) unsafeThawDataFrame df = IODataFrame <$> IO (unsafeThawDataFrame# df) {-# INLINE unsafeThawDataFrame #-} @@ -145,7 +181,7 @@ -- | Write a single element at the specified index writeDataFrame :: forall t (ns :: [Nat]) - . ( PrimBytes t, Dimensions ns ) + . PrimBytes t => IODataFrame t ns -> Idxs ns -> DataFrame t ('[] :: [Nat]) -> IO () writeDataFrame (IODataFrame mdf) ei = IO . writeDataFrame# mdf ei . unsafeCoerce# {-# INLINE writeDataFrame #-} @@ -153,7 +189,7 @@ -- | Read a single element at the specified index readDataFrame :: forall (t :: Type) (ns :: [Nat]) - . ( PrimBytes t, Dimensions ns ) + . PrimBytes t => IODataFrame t ns -> Idxs ns -> IO (DataFrame t ('[] :: [Nat])) readDataFrame (IODataFrame mdf) = unsafeCoerce# . IO . readDataFrame# mdf {-# INLINE readDataFrame #-} @@ -177,6 +213,18 @@ {-# INLINE readDataFrameOff #-} +-- | Check if the byte array wrapped by this DataFrame is pinned, +-- which means cannot be relocated by GC. +isDataFramePinned :: forall (k :: Type) (t :: Type) (ns :: [k]) + . KnownDimKind k + => IODataFrame t ns -> Bool +isDataFramePinned df = case dimKind @k of + DimNat -> case df of + IODataFrame x -> isDataFramePinned# x + DimXNat -> case df of + XIOFrame (IODataFrame x) -> isDataFramePinned# x + + -- | Allow arbitrary IO operations on a pointer to the beginning of the data -- keeping the data from garbage collecting until the arg function returns. -- @@ -185,7 +233,7 @@ -- -- Warning: use this function on a pinned DataFrame only; -- otherwise, the data may be relocated before the arg fun finishes. -withDataFramePtr :: forall (t :: Type) (ns :: [k]) (r :: Type) +withDataFramePtr :: forall (k :: Type) (t :: Type) (ns :: [k]) (r :: Type) . (PrimBytes t, KnownDimKind k) => IODataFrame t ns -> ( Ptr t -> IO r ) @@ -197,15 +245,3 @@ DimXNat -> case df of XIOFrame (IODataFrame x) -> IO $ withDataFramePtr# x (\p -> case k (Ptr p) of IO f -> f) - - --- | Check if the byte array wrapped by this DataFrame is pinned, --- which means cannot be relocated by GC. -isDataFramePinned :: forall (t :: Type) (ns :: [k]) - . KnownDimKind k - => IODataFrame t ns -> Bool -isDataFramePinned df = case dimKind @k of - DimNat -> case df of - IODataFrame x -> isDataFramePinned# x - DimXNat -> case df of - XIOFrame (IODataFrame x) -> isDataFramePinned# x diff --git a/src/Numeric/DataFrame/Internal/Array.hs b/src/Numeric/DataFrame/Internal/Array.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Internal.Array --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- Low-level implementations of data frames --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Internal.Array - ( module Numeric.DataFrame.Internal.Array.Family - ) where - -import Numeric.DataFrame.Internal.Array.Family --- import Numeric.DataFrame.Internal.Array.Family.ArrayBase () - --- import Numeric.DataFrame.Internal.Array.Family.FloatX2 () --- import Numeric.DataFrame.Internal.Array.Family.FloatX3 () --- import Numeric.DataFrame.Internal.Array.Family.FloatX4 () --- --- import Numeric.DataFrame.Internal.Array.Family.DoubleX2 () --- import Numeric.DataFrame.Internal.Array.Family.DoubleX3 () --- import Numeric.DataFrame.Internal.Array.Family.DoubleX4 () diff --git a/src/Numeric/DataFrame/Internal/Array/Class.hs b/src/Numeric/DataFrame/Internal/Array/Class.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Class.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UnboxedTuples #-} -module Numeric.DataFrame.Internal.Array.Class - ( PrimArray (..) - , ixOff, unsafeFromFlatList - ) where - -import GHC.Base (ByteArray#, Int#, Int (..)) -import Numeric.PrimBytes - - -class PrimBytes t => PrimArray t a | a -> t where - -- | Broadcast element into array - broadcast :: t -> a - -- | Index an array given an offset - ix# :: Int# -> a -> t - -- | Generate an array using an accumulator funtion - gen# :: Int# -- ^ number of elements, not checked! - -- Avoid using this argument if possible. - -> (s -> (# s, t #)) - -> s -> (# s, a #) - -- | update a single element in an array given an offset - upd# :: Int# -- ^ number of elements, not checked! - -- Avoid using this argument if possible. - -> Int# -> t -> a -> a - - -- | Offset of an array in number of elements - elemOffset :: a -> Int# - - -- | Number of elements in an array. - -- Returns zero if this information is not available at runtime. - -- This is possible only if all elements are same in an array. - elemSize0 :: a -> Int# - - -- | Get array by its offset and size in a ByteArray. - -- Both offset and size are given in element number. - fromElems :: Int# -> Int# -> ByteArray# -> a - --- | Index array by an integer offset (starting from 0). -ixOff :: PrimArray t a => Int -> a -> t -ixOff (I# i) = ix# i - --- | Construct an array from a flat list and length -unsafeFromFlatList :: PrimArray t a => Int -> [t] -> a -unsafeFromFlatList (I# n) vs = case gen# n f vs of (# _, r #) -> r - where - f [] = (# [], undefined #) - f (x:xs) = (# xs, x #) diff --git a/src/Numeric/DataFrame/Internal/Array/Family.hs b/src/Numeric/DataFrame/Internal/Array/Family.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Internal.Array.Family --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Internal.Array.Family - ( Array, ScalarBase (..), ArrayBase (..) - , ArraySingleton (..) - , ArraySing (..), aSingEv, inferASing - , inferPrimElem, inferPrim, inferEq, inferShow, inferOrd, inferNum - , inferFractional, inferFloating - ) where - - -import GHC.Base - - -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.Family.ArrayBase -import Numeric.DataFrame.Internal.Array.Family.DoubleX2 -import Numeric.DataFrame.Internal.Array.Family.DoubleX3 -import Numeric.DataFrame.Internal.Array.Family.DoubleX4 -import Numeric.DataFrame.Internal.Array.Family.FloatX2 -import Numeric.DataFrame.Internal.Array.Family.FloatX3 -import Numeric.DataFrame.Internal.Array.Family.FloatX4 -import Numeric.DataFrame.Internal.Array.Family.ScalarBase -import Numeric.Dimensions -import Numeric.PrimBytes - - --- | This type family aggregates all types used for arrays with different --- dimensioinality. --- The family is injective; thus, it is possible to get type family instance --- given the data constructor (and vice versa). --- If GHC knows the dimensionality of an array at compile time, it chooses --- a more efficient specialized instance of Array, e.g. Scalar newtype wrapper. --- Otherwise, it falls back to the generic ArrayBase implementation. --- --- Data family would not work here, because it would give overlapping instances. -type family Array (t :: Type) (ds :: [Nat]) = (v :: Type) | v -> t ds where - Array t '[] = ScalarBase t - Array Float '[2] = FloatX2 - Array Float '[3] = FloatX3 - Array Float '[4] = FloatX4 - Array Double '[2] = DoubleX2 - Array Double '[3] = DoubleX3 - Array Double '[4] = DoubleX4 - Array t ds = ArrayBase t ds - --- | A framework for using Array type family instances. -class ArraySingleton (t :: Type) (ds :: [Nat]) where - -- | Get Array type family instance - aSing :: ArraySing t ds - -data ArraySing t (ds :: [Nat]) where - AScalar :: (Array t ds ~ ScalarBase t) => ArraySing t '[] - AF2 :: (Array t ds ~ FloatX2) => ArraySing Float '[2] - AF3 :: (Array t ds ~ FloatX3) => ArraySing Float '[3] - AF4 :: (Array t ds ~ FloatX4) => ArraySing Float '[4] - AD2 :: (Array t ds ~ DoubleX2) => ArraySing Double '[2] - AD3 :: (Array t ds ~ DoubleX3) => ArraySing Double '[3] - AD4 :: (Array t ds ~ DoubleX4) => ArraySing Double '[4] - ABase :: ( Array t ds ~ ArrayBase t ds - , PrimBytes t - ) => ArraySing t ds - -deriving instance Eq (ArraySing t ds) -deriving instance Ord (ArraySing t ds) -deriving instance Show (ArraySing t ds) - - - --- | This function does GHC's magic to convert user-supplied `aSing` function --- to create an instance of `ArraySingleton` typeclass at runtime. --- The trick is taken from Edward Kmett's reflection library explained --- in https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection -reifyArraySing :: forall r t ds - . ArraySing t ds -> ( ArraySingleton t ds => r) -> r -reifyArraySing as k - = unsafeCoerce# (MagicArraySing k :: MagicArraySing t ds r) as -{-# INLINE reifyArraySing #-} -newtype MagicArraySing t (ds :: [Nat]) r - = MagicArraySing (ArraySingleton t ds => r) - --- | Use `ArraySing` GADT to construct an `ArraySingleton` dictionary. --- In other words, bring an evidence of `ArraySingleton` instance into --- a scope at runtime. -aSingEv :: ArraySing t ds -> Evidence (ArraySingleton t ds) -aSingEv ds = reifyArraySing ds E -{-# INLINE aSingEv #-} - --- | Use `ArraySing` GADT to construct an `ArraySingleton` dictionary. --- The same as `aSingEv`, but relies on `PrimBytes` and `Dimensions`. -inferASing :: forall t ds - . (PrimBytes t, Dimensions ds) - => Evidence (ArraySingleton t ds) -inferASing = case (dims @_ @ds, primTag @t undefined) of - (U, _) -> E - (d :* U, PTagFloat) - | Just E <- sameDim (D @2) d -> E - | Just E <- sameDim (D @3) d -> E - | Just E <- sameDim (D @4) d -> E - (d :* U, PTagDouble) - | Just E <- sameDim (D @2) d -> E - | Just E <- sameDim (D @3) d -> E - | Just E <- sameDim (D @4) d -> E - _ -> case (unsafeCoerce# (E @(ds ~ ds)) :: Evidence (ds ~ '[0])) of E -> E -{-# INLINE inferASing #-} - - -instance {-# OVERLAPPABLE #-} - (Array t ds ~ ArrayBase t ds, PrimBytes t) - => ArraySingleton t ds where - aSing = ABase -instance {-# OVERLAPPING #-} ArraySingleton t '[] where - aSing = AScalar -instance {-# OVERLAPPING #-} ArraySingleton Float '[2] where - aSing = AF2 -instance {-# OVERLAPPING #-} ArraySingleton Float '[3] where - aSing = AF3 -instance {-# OVERLAPPING #-} ArraySingleton Float '[4] where - aSing = AF4 -instance {-# OVERLAPPING #-} ArraySingleton Double '[2] where - aSing = AD2 -instance {-# OVERLAPPING #-} ArraySingleton Double '[3] where - aSing = AD3 -instance {-# OVERLAPPING #-} ArraySingleton Double '[4] where - aSing = AD4 - --- | This is a special function, because Scalar does not require PrimBytes. --- That is why the dimension list in the argument is not empty. -inferPrimElem :: forall t d ds - . ArraySingleton t (d ': ds) - => Evidence (PrimBytes t) -inferPrimElem = case (aSing :: ArraySing t (d ': ds)) of - AF2 -> E - AF3 -> E - AF4 -> E - AD2 -> E - AD3 -> E - AD4 -> E - ABase -> E - --- Rather verbose way to show that there is an instance of a required type class --- for every instance of the type family. -#define WITNESS case (aSing :: ArraySing t ds) of {\ - AScalar -> E;\ - AF2 -> E;\ - AF3 -> E;\ - AF4 -> E;\ - AD2 -> E;\ - AD3 -> E;\ - AD4 -> E;\ - ABase -> E} - -inferPrim :: forall t ds - . ( PrimBytes t - , ArraySingleton t ds - , Dimensions ds - ) - => Evidence (PrimBytes (Array t ds), PrimArray t (Array t ds)) -inferPrim = WITNESS - -inferEq :: forall t ds - . (Eq t, ArraySingleton t ds) - => Evidence (Eq (Array t ds)) -inferEq = WITNESS - -inferOrd :: forall t ds - . (Ord t, ArraySingleton t ds) - => Evidence (Ord (Array t ds)) -inferOrd = WITNESS - -inferNum :: forall t ds - . (Num t, ArraySingleton t ds) - => Evidence (Num (Array t ds)) -inferNum = WITNESS - -inferFractional :: forall t ds - . (Fractional t, ArraySingleton t ds) - => Evidence (Fractional (Array t ds)) -inferFractional = WITNESS - -inferFloating :: forall t ds - . (Floating t, ArraySingleton t ds) - => Evidence (Floating (Array t ds)) -inferFloating = WITNESS - -inferShow :: forall t ds - . (Show t, Dimensions ds, ArraySingleton t ds) - => Evidence (Show (Array t ds)) -inferShow = WITNESS diff --git a/src/Numeric/DataFrame/Internal/Array/Family/ArrayBase.hs b/src/Numeric/DataFrame/Internal/Array/Family/ArrayBase.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/ArrayBase.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedSums #-} -{-# LANGUAGE UnboxedTuples #-} - -module Numeric.DataFrame.Internal.Array.Family.ArrayBase - ( ArrayBase (..) - ) where - -import Data.Int -import Data.Word -import GHC.Base hiding (foldr) -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.Dimensions -import Numeric.PrimBytes - --- | Generic Array implementation. --- This array can reside in plain `ByteArray#` and can share the @ByteArray#@ --- with other arrays. --- However, byte offset in the @ByteArray#@ must be multiple of the element size. -data ArrayBase (t :: Type) (ds :: [Nat]) - = ArrayBase - (# t - -- Same value for each element; - -- this is the cheapest way to initialize an array. - -- It is also used for Num instances to avoid dependency on Dimensions. - | (# Int# -- Offset measured in elements. - , Int# -- Number of elements. - , ByteArray# -- Content. - , Evidence (PrimBytes t) - #) - #) - - -instance (PrimBytes t, Dimensions ds) => PrimBytes (ArrayBase t ds) where - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Float ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Double ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int8 ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int16 ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int32 ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Int64 ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word8 ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word16 ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word32 ds) #-} - {-# SPECIALIZE instance Dimensions ds => PrimBytes (ArrayBase Word64 ds) #-} - - getBytes (ArrayBase a ) = case a of - (# t | #) - | W# nw <- totalDim' @ds - , n <- word2Int# nw - , tbs <- byteSize t -> go tbs (tbs *# n) t - (# | (# _, _, arr, _ #) #) -> - -- very weird trick with touch# allows to workaround GHC bug - -- "internal error: ARR_WORDS object entered!" - -- TODO: report this - case runRW# (\s -> (# touch# arr s, arr #)) of (# _, ba #) -> ba - where - go tbs bsize t = case runRW# - ( \s0 -> case newByteArray# bsize s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( loop# 0# tbs bsize (\i -> writeBytes mba i t) s1 ) - ) of (# _, ba #) -> ba - {-# NOINLINE go #-} - {-# INLINE getBytes #-} - - fromBytes bOff ba - | W# nw <- totalDim' @ds - , n <- word2Int# nw - , tbs <- byteSize (undefined :: t) - , (# offN, offRem #) <- quotRemInt# bOff tbs - = case offRem of - 0# -> ArrayBase (# | (# offN, n , ba, E #) #) - _ -> go n (tbs *# n) - where - go n bsize = case runRW# - ( \s0 -> case ( if isTrue# (isByteArrayPinned# ba) - then newAlignedPinnedByteArray# bsize - (byteAlign @t undefined) - else newByteArray# bsize - ) s0 - of - (# s1, mba #) -> unsafeFreezeByteArray# mba - (copyByteArray# ba bOff mba 0# bsize s1) - ) of (# _, r #) -> ArrayBase (# | (# 0# , n , r, E #) #) - {-# NOINLINE go #-} - {-# INLINE fromBytes #-} - - readBytes mba bOff s0 - | W# nw <- totalDim' @ds - , n <- word2Int# nw - , tbs <- byteSize (undefined :: t) - , bsize <- tbs *# n - = case newByteArray# bsize s0 of - (# s1, mba1 #) -> case unsafeFreezeByteArray# mba1 - (copyMutableByteArray# mba bOff mba1 0# bsize s1) of - (# s2, ba #) -> (# s2, ArrayBase (# | (# 0# , n , ba, E #) #) #) - {-# INLINE readBytes #-} - - writeBytes mba bOff (ArrayBase c) - | tbs <- byteSize (undefined :: t) = case c of - (# t | #) | W# n <- totalDim' @ds -> - loop# bOff tbs (bOff +# word2Int# n *# tbs) (\i -> writeBytes mba i t) - (# | (# offN, n, arr, _ #) #) -> - copyByteArray# arr (offN *# tbs) mba bOff (n *# tbs) - {-# INLINE writeBytes #-} - - readAddr addr s0 - | W# nw <- totalDim' @ds - , n <- word2Int# nw - , tbs <- byteSize (undefined :: t) - , bsize <- tbs *# n - = case newByteArray# bsize s0 of - (# s1, mba1 #) -> case unsafeFreezeByteArray# mba1 - (copyAddrToByteArray# addr mba1 0# bsize s1) of - (# s2, ba #) -> (# s2, ArrayBase (# | (# 0# , n , ba, E #) #) #) - {-# INLINE readAddr #-} - - writeAddr (ArrayBase c) addr - | tbs <- byteSize (undefined :: t) = case c of - (# t | #) | W# n <- totalDim' @ds -> - loop# 0# tbs (word2Int# n *# tbs) (\i -> writeAddr t (plusAddr# addr i)) - (# | (# offN, n, arr, _ #) #) -> - copyByteArrayToAddr# arr (offN *# tbs) addr (n *# tbs) - {-# INLINE writeAddr #-} - - - byteSize _ = case totalDim' @ds of -- WARNING: slow! - W# n -> byteSize (undefined :: t) *# word2Int# n - {-# INLINE byteSize #-} - - byteAlign _ = byteAlign (undefined :: t) - {-# INLINE byteAlign #-} - - byteOffset (ArrayBase a) = case a of - (# _ | #) -> 0# - (# | (# off, _, _, _ #) #) -> off *# byteSize (undefined :: t) - {-# INLINE byteOffset #-} - - indexArray ba off - | W# nw <- totalDim' @ds - , n <- word2Int# nw - = ArrayBase (# | (# off *# n, n, ba, E #) #) - {-# INLINE indexArray #-} - - - --- | Accumulates only idempotent operations! --- Being applied to FromScalars, executes only once! --- Here, idempotance means: assuming @f a b = g x@, @g (g x) = g x@ --- --- Also, I assume the sizes of arrays are the same -accumV2Idempotent :: a - -> (t -> t -> a -> a) - -> ArrayBase t ds -> ArrayBase t ds -> a -accumV2Idempotent x f - (ArrayBase (# a | #)) - (ArrayBase (# b | #)) - = f a b x -accumV2Idempotent x f - a@(ArrayBase (# | (# _, nA, _, E #) #)) - b@(ArrayBase (# | (# _, nB, _, _ #) #)) - = loop1a# (minInt# nA nB) (\i -> f (ix# i a) (ix# i b)) x -accumV2Idempotent x f - (ArrayBase (# a | #)) - b@(ArrayBase (# | (# _, n, _, E #) #)) - = loop1a# n (\i -> f a (ix# i b)) x -accumV2Idempotent x f - a@(ArrayBase (# | (# _, n, _, E #) #)) - (ArrayBase (# b | #)) - = loop1a# n (\i -> f (ix# i a) b) x -{-# INLINE accumV2Idempotent #-} - -mapV :: (t -> t) -> ArrayBase t ds -> ArrayBase t ds -mapV f (ArrayBase (# t | #)) - = ArrayBase (# f t | #) -mapV f x@(ArrayBase (# | (# offN, n, ba, E #) #)) - | tbs <- byteSize (undefEl x) - = go (tbs *# n) - where - go bsize = case runRW# - ( \s0 -> case newByteArray# bsize s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( loop1# n - (\i -> writeArray mba i (f (indexArray ba (offN +# i)))) s1 - ) - ) of (# _, r #) -> ArrayBase (# | (# 0#, n, r, E #) #) - {-# NOINLINE go #-} -{-# INLINE mapV #-} - - -zipV :: (t -> t -> t) - -> ArrayBase t ds -> ArrayBase t ds -> ArrayBase t ds -zipV f (ArrayBase (# x | #)) b = mapV (f x) b -zipV f a (ArrayBase (# y | #)) = mapV (`f` y) a -zipV f a@(ArrayBase (# | (# oa, na, ba, E #) #)) - (ArrayBase (# | (# ob, nb, bb, _ #) #)) - | n <- minInt# na nb - = go n (byteSize (undefEl a) *# n) - where - go n bsize = case runRW# - ( \s0 -> case newByteArray# bsize s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( loop1# n - (\i -> writeArray mba i - (f (indexArray ba (oa +# i)) - (indexArray bb (ob +# i)) - ) - ) s1 - ) - ) of (# _, r #) -> ArrayBase (# | (# 0#, n, r, E #) #) - {-# NOINLINE go #-} -{-# INLINE zipV #-} - - --- TODO: to improve performance, I can either compare bytearrays using memcmp --- or implement early termination if the first elements do not match. --- On the other hand, hopefully @(&&)@ and @(||)@ ops take care of that. -instance Eq t => Eq (ArrayBase t ds) where - {-# SPECIALIZE instance Eq (ArrayBase Float ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Double ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Int ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Word ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Int8 ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Int16 ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Int32 ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Int64 ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Word8 ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Word16 ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Word32 ds) #-} - {-# SPECIALIZE instance Eq (ArrayBase Word64 ds) #-} - (==) = accumV2Idempotent True (\x y r -> r && x == y) - (/=) = accumV2Idempotent False (\x y r -> r || x /= y) - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord t => Ord (ArrayBase t ds) where - {-# SPECIALIZE instance Ord (ArrayBase Float ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Double ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Int ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Word ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Int8 ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Int16 ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Int32 ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Int64 ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Word8 ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Word16 ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Word32 ds) #-} - {-# SPECIALIZE instance Ord (ArrayBase Word64 ds) #-} - -- | Partiall ordering: all elements GT - (>) = accumV2Idempotent True (\x y r -> r && x > y) - {-# INLINE (>) #-} - -- | Partiall ordering: all elements LT - (<) = accumV2Idempotent True (\x y r -> r && x < y) - {-# INLINE (<) #-} - -- | Partiall ordering: all elements GE - (>=) = accumV2Idempotent True (\x y r -> r && x >= y) - {-# INLINE (>=) #-} - -- | Partiall ordering: all elements LE - (<=) = accumV2Idempotent True (\x y r -> r && x <= y) - {-# INLINE (<=) #-} - -- | Compare lexicographically - compare = accumV2Idempotent EQ (\x y -> flip mappend (compare x y)) - {-# INLINE compare #-} - -- | Element-wise minimum - min = zipV min - {-# INLINE min #-} - -- | Element-wise maximum - max = zipV max - {-# INLINE max #-} - -instance (Dimensions ds, Show t) - => Show (ArrayBase t ds) where - show x = case dims @_ @ds of - U -> "{ " ++ show (ix U x) ++ " }" - Dim :* U -> ('{' :) . drop 1 $ - foldr (\i s -> ", " ++ show (ix i x) ++ s) " }" - [minBound .. maxBound] - (Dim :: Dim n) :* (Dim :: Dim m) :* (Dims :: Dims dss) -> - let loopInner :: Idxs dss -> Idxs '[n,m] -> String - loopInner ods (n:*m:*_) = ('{' :) . drop 2 $ - foldr (\i ss -> '\n': - foldr (\j s -> - ", " ++ show (ix (i :* j :* ods) x) ++ s - ) ss [1..m] - ) " }" [1..n] - loopOuter :: Idxs dss -> String -> String - loopOuter U s = "\n" ++ loopInner U maxBound ++ s - loopOuter ds s = "\n(i j" ++ drop 4 (show ds) ++ "):\n" - ++ loopInner ds maxBound ++ s - in drop 1 $ foldr loopOuter "" [minBound..maxBound] - -instance {-# OVERLAPPING #-} Bounded (ArrayBase Double ds) where - maxBound = ArrayBase (# inftyD | #) - minBound = ArrayBase (# negate inftyD | #) - -instance {-# OVERLAPPING #-} Bounded (ArrayBase Float ds) where - maxBound = ArrayBase (# inftyF | #) - minBound = ArrayBase (# negate inftyF | #) - -instance {-# OVERLAPPABLE #-} Bounded t => Bounded (ArrayBase t ds) where - {-# SPECIALIZE instance Bounded (ArrayBase Int ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Word ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Int8 ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Int16 ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Int32 ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Int64 ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Word8 ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Word16 ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Word32 ds) #-} - {-# SPECIALIZE instance Bounded (ArrayBase Word64 ds) #-} - maxBound = ArrayBase (# maxBound | #) - minBound = ArrayBase (# minBound | #) - -instance Num t => Num (ArrayBase t ds) where - {-# SPECIALIZE instance Num (ArrayBase Float ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Double ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Int ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Word ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Int8 ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Int16 ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Int32 ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Int64 ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Word8 ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Word16 ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Word32 ds) #-} - {-# SPECIALIZE instance Num (ArrayBase Word64 ds) #-} - (+) = zipV (+) - {-# INLINE (+) #-} - (-) = zipV (-) - {-# INLINE (-) #-} - (*) = zipV (*) - {-# INLINE (*) #-} - negate = mapV negate - {-# INLINE negate #-} - abs = mapV abs - {-# INLINE abs #-} - signum = mapV signum - {-# INLINE signum #-} - fromInteger i = ArrayBase (# fromInteger i | #) - {-# INLINE fromInteger #-} - -instance Fractional t => Fractional (ArrayBase t ds) where - {-# SPECIALIZE instance Fractional (ArrayBase Float ds) #-} - {-# SPECIALIZE instance Fractional (ArrayBase Double ds) #-} - (/) = zipV (/) - {-# INLINE (/) #-} - recip = mapV recip - {-# INLINE recip #-} - fromRational r = ArrayBase (# fromRational r | #) - {-# INLINE fromRational #-} - - -instance Floating t => Floating (ArrayBase t ds) where - {-# SPECIALIZE instance Floating (ArrayBase Float ds) #-} - {-# SPECIALIZE instance Floating (ArrayBase Double ds) #-} - pi = ArrayBase (# pi | #) - {-# INLINE pi #-} - exp = mapV exp - {-# INLINE exp #-} - log = mapV log - {-# INLINE log #-} - sqrt = mapV sqrt - {-# INLINE sqrt #-} - sin = mapV sin - {-# INLINE sin #-} - cos = mapV cos - {-# INLINE cos #-} - tan = mapV tan - {-# INLINE tan #-} - asin = mapV asin - {-# INLINE asin #-} - acos = mapV acos - {-# INLINE acos #-} - atan = mapV atan - {-# INLINE atan #-} - sinh = mapV sinh - {-# INLINE sinh #-} - cosh = mapV cosh - {-# INLINE cosh #-} - tanh = mapV tanh - {-# INLINE tanh #-} - (**) = zipV (**) - {-# INLINE (**) #-} - logBase = zipV logBase - {-# INLINE logBase #-} - asinh = mapV asinh - {-# INLINE asinh #-} - acosh = mapV acosh - {-# INLINE acosh #-} - atanh = mapV atanh - {-# INLINE atanh #-} - -instance PrimBytes t => PrimArray t (ArrayBase t ds) where - {-# SPECIALIZE instance PrimArray Float (ArrayBase Float ds) #-} - {-# SPECIALIZE instance PrimArray Double (ArrayBase Double ds) #-} - {-# SPECIALIZE instance PrimArray Int (ArrayBase Int ds) #-} - {-# SPECIALIZE instance PrimArray Word (ArrayBase Word ds) #-} - {-# SPECIALIZE instance PrimArray Int8 (ArrayBase Int8 ds) #-} - {-# SPECIALIZE instance PrimArray Int16 (ArrayBase Int16 ds) #-} - {-# SPECIALIZE instance PrimArray Int32 (ArrayBase Int32 ds) #-} - {-# SPECIALIZE instance PrimArray Int64 (ArrayBase Int64 ds) #-} - {-# SPECIALIZE instance PrimArray Word8 (ArrayBase Word8 ds) #-} - {-# SPECIALIZE instance PrimArray Word16 (ArrayBase Word16 ds) #-} - {-# SPECIALIZE instance PrimArray Word32 (ArrayBase Word32 ds) #-} - {-# SPECIALIZE instance PrimArray Word64 (ArrayBase Word64 ds) #-} - - broadcast t = ArrayBase (# t | #) - {-# INLINE broadcast #-} - - ix# i (ArrayBase a) = case a of - (# t | #) -> t - (# | (# off, _, arr, _ #) #) -> indexArray arr (off +# i) - {-# INLINE ix# #-} - - gen# n f z0 = go (byteSize @t undefined *# n) - where - go bsize = case runRW# - ( \s0 -> case newByteArray# bsize s0 of - (# s1, mba #) -> case loop0 mba 0# z0 s1 of - (# s2, z1 #) -> case unsafeFreezeByteArray# mba s2 of - (# s3, ba #) -> (# s3, (# z1, ba #) #) - ) of (# _, (# z1, ba #) #) -> (# z1, ArrayBase (# | (# 0# , n , ba, E #) #) #) - {-# NOINLINE go #-} - loop0 mba i z s - | isTrue# (i ==# n) = (# s, z #) - | otherwise = case f z of - (# z', x #) -> loop0 mba (i +# 1#) z' (writeArray mba i x s) - {-# INLINE gen# #-} - - upd# n i x (ArrayBase (# a | #)) = go (byteSize x) - where - go tbs = case runRW# - ( \s0 -> case newByteArray# (tbs *# n) s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - (writeArray mba i x - (loop1# n (\j -> writeArray mba j a) s1) - ) - ) of (# _, r #) -> ArrayBase (# | (# 0# , n , r, E #) #) - {-# NOINLINE go #-} - upd# _ i x (ArrayBase (# | (# offN , n , ba, E #) #)) = go (byteSize x) - where - go tbs = case runRW# - ( \s0 -> case newByteArray# (tbs *# n) s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - (writeArray mba i x - (copyByteArray# ba (offN *# tbs) mba 0# (tbs *# n) s1) - ) - ) of (# _, r #) -> ArrayBase (# | (# 0# , n , r, E #) #) - {-# NOINLINE go #-} - {-# INLINE upd# #-} - - elemOffset (ArrayBase a) = case a of - (# _ | #) -> 0# - (# | (# off, _, _, _ #) #) -> off - {-# INLINE elemOffset #-} - - elemSize0 (ArrayBase a) = case a of - (# _ | #) -> 0# - (# | (# _, n, _, _ #) #) -> n - {-# INLINE elemSize0 #-} - - fromElems off n ba = ArrayBase (# | (# off , n , ba, E #) #) - {-# INLINE fromElems #-} - - - --------------------------------------------------------------------------------- --- * Utility functions --------------------------------------------------------------------------------- - - -ix :: Dimensions ds => Idxs ds -> ArrayBase t ds -> t -ix i (ArrayBase a) = case a of - (# t | #) -> t - (# | (# off, _, arr, E #) #) -> case fromEnum i of - I# i# -> indexArray arr (off +# i#) -{-# INLINE ix #-} - - -undefEl :: ArrayBase t ds -> t -undefEl = const undefined diff --git a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX2.hs b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX2.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX2.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -module Numeric.DataFrame.Internal.Array.Family.DoubleX2 (DoubleX2 (..)) where - - -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.PrimBytes - - -data DoubleX2 = DoubleX2# Double# Double# - - -instance Bounded DoubleX2 where - maxBound = case inftyD of D# x -> DoubleX2# x x - minBound = case negate inftyD of D# x -> DoubleX2# x x - - -instance Show DoubleX2 where - show (DoubleX2# a1 a2) - = "{ " ++ show (D# a1) - ++ ", " ++ show (D# a2) - ++ " }" - - - -instance Eq DoubleX2 where - - DoubleX2# a1 a2 == DoubleX2# b1 b2 = - isTrue# - ( (a1 ==## b1) - `andI#` (a2 ==## b2) - ) - {-# INLINE (==) #-} - - DoubleX2# a1 a2 /= DoubleX2# b1 b2 = - isTrue# - ( (a1 /=## b1) - `orI#` (a2 /=## b2) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord DoubleX2 where - DoubleX2# a1 a2 > DoubleX2# b1 b2 = - isTrue# - ( (a1 >## b1) - `andI#` (a2 >## b2) - ) - {-# INLINE (>) #-} - - DoubleX2# a1 a2 < DoubleX2# b1 b2 = - isTrue# - ( (a1 <## b1) - `andI#` (a2 <## b2) - ) - {-# INLINE (<) #-} - - DoubleX2# a1 a2 >= DoubleX2# b1 b2 = - isTrue# - ( (a1 >=## b1) - `andI#` (a2 >=## b2) - ) - {-# INLINE (>=) #-} - - DoubleX2# a1 a2 <= DoubleX2# b1 b2 = - isTrue# - ( (a1 <=## b1) - `andI#` (a2 <=## b2) - ) - {-# INLINE (<=) #-} - - -- | Compare lexicographically - compare (DoubleX2# a1 a2) (DoubleX2# b1 b2) - | isTrue# (a1 >## b1) = GT - | isTrue# (a1 <## b1) = LT - | isTrue# (a2 >## b2) = GT - | isTrue# (a2 <## b2) = LT - | otherwise = EQ - {-# INLINE compare #-} - - -- | Element-wise minimum - min (DoubleX2# a1 a2) (DoubleX2# b1 b2) = DoubleX2# - (if isTrue# (a1 >## b1) then b1 else a1) - (if isTrue# (a2 >## b2) then b2 else a2) - {-# INLINE min #-} - - -- | Element-wise maximum - max (DoubleX2# a1 a2) (DoubleX2# b1 b2) = DoubleX2# - (if isTrue# (a1 >## b1) then a1 else b1) - (if isTrue# (a2 >## b2) then a2 else b2) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num DoubleX2 where - - DoubleX2# a1 a2 + DoubleX2# b1 b2 - = DoubleX2# ((+##) a1 b1) ((+##) a2 b2) - {-# INLINE (+) #-} - - DoubleX2# a1 a2 - DoubleX2# b1 b2 - = DoubleX2# ((-##) a1 b1) ((-##) a2 b2) - {-# INLINE (-) #-} - - DoubleX2# a1 a2 * DoubleX2# b1 b2 - = DoubleX2# ((*##) a1 b1) ((*##) a2 b2) - {-# INLINE (*) #-} - - negate (DoubleX2# a1 a2) = DoubleX2# - (negateDouble# a1) (negateDouble# a2) - {-# INLINE negate #-} - - abs (DoubleX2# a1 a2) - = DoubleX2# - (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) - (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) - {-# INLINE abs #-} - - signum (DoubleX2# a1 a2) - = DoubleX2# (if isTrue# (a1 >## 0.0##) - then 1.0## - else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a2 >## 0.0##) - then 1.0## - else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) - {-# INLINE signum #-} - - fromInteger n = case fromInteger n of D# x -> DoubleX2# x x - {-# INLINE fromInteger #-} - - - -instance Fractional DoubleX2 where - - DoubleX2# a1 a2 / DoubleX2# b1 b2 = DoubleX2# - ((/##) a1 b1) ((/##) a2 b2) - {-# INLINE (/) #-} - - recip (DoubleX2# a1 a2) = DoubleX2# - ((/##) 1.0## a1) ((/##) 1.0## a2) - {-# INLINE recip #-} - - fromRational r = case fromRational r of D# x -> DoubleX2# x x - {-# INLINE fromRational #-} - - - -instance Floating DoubleX2 where - - pi = DoubleX2# - 3.141592653589793238## - 3.141592653589793238## - {-# INLINE pi #-} - - exp (DoubleX2# a1 a2) = DoubleX2# - (expDouble# a1) (expDouble# a2) - {-# INLINE exp #-} - - log (DoubleX2# a1 a2) = DoubleX2# - (logDouble# a1) (logDouble# a2) - {-# INLINE log #-} - - sqrt (DoubleX2# a1 a2) = DoubleX2# - (sqrtDouble# a1) (sqrtDouble# a2) - {-# INLINE sqrt #-} - - sin (DoubleX2# a1 a2) = DoubleX2# - (sinDouble# a1) (sinDouble# a2) - {-# INLINE sin #-} - - cos (DoubleX2# a1 a2) = DoubleX2# - (cosDouble# a1) (cosDouble# a2) - {-# INLINE cos #-} - - tan (DoubleX2# a1 a2) = DoubleX2# - (tanDouble# a1) (tanDouble# a2) - {-# INLINE tan #-} - - asin (DoubleX2# a1 a2) = DoubleX2# - (asinDouble# a1) (asinDouble# a2) - {-# INLINE asin #-} - - acos (DoubleX2# a1 a2) = DoubleX2# - (acosDouble# a1) (acosDouble# a2) - {-# INLINE acos #-} - - atan (DoubleX2# a1 a2) = DoubleX2# - (atanDouble# a1) (atanDouble# a2) - {-# INLINE atan #-} - - sinh (DoubleX2# a1 a2) = DoubleX2# - (sinhDouble# a1) (sinhDouble# a2) - {-# INLINE sinh #-} - - cosh (DoubleX2# a1 a2) = DoubleX2# - (coshDouble# a1) (coshDouble# a2) - {-# INLINE cosh #-} - - tanh (DoubleX2# a1 a2) = DoubleX2# - (tanhDouble# a1) (tanhDouble# a2) - {-# INLINE tanh #-} - - DoubleX2# a1 a2 ** DoubleX2# b1 b2 = DoubleX2# - ((**##) a1 b1) ((**##) a2 b2) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - --- offset in bytes is S times bigger than offset in prim elements, --- when S is power of two, this is equal to shift -#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# -#define ELEM_N 2 - -instance PrimBytes DoubleX2 where - - getBytes (DoubleX2# a1 a2) = case runRW# - ( \s0 -> case newByteArray# (byteSize @DoubleX2 undefined) s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of - s2 -> case writeDoubleArray# marr 1# a2 s2 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, a #) -> a - {-# INLINE getBytes #-} - - fromBytes off arr - | i <- BOFF_TO_PRIMOFF(off) - = DoubleX2# - (indexDoubleArray# arr i) - (indexDoubleArray# arr (i +# 1#)) - {-# INLINE fromBytes #-} - - readBytes mba off s0 - | i <- BOFF_TO_PRIMOFF(off) - = case readDoubleArray# mba i s0 of - (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) - {-# INLINE readBytes #-} - - writeBytes mba off (DoubleX2# a1 a2) s - | i <- BOFF_TO_PRIMOFF(off) - = writeDoubleArray# mba (i +# 1#) a2 - ( writeDoubleArray# mba i a1 s ) - {-# INLINE writeBytes #-} - - readAddr addr s0 - = case readDoubleOffAddr# addr 0# s0 of - (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of - (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) - {-# INLINE readAddr #-} - - writeAddr (DoubleX2# a1 a2) addr s - = writeDoubleOffAddr# addr 1# a2 - ( writeDoubleOffAddr# addr 0# a1 s ) - {-# INLINE writeAddr #-} - - byteSize _ = byteSize @Double undefined *# ELEM_N# - {-# INLINE byteSize #-} - - byteAlign _ = byteAlign @Double undefined - {-# INLINE byteAlign #-} - - byteOffset _ = 0# - {-# INLINE byteOffset #-} - - indexArray ba off - | i <- off *# ELEM_N# - = DoubleX2# - (indexDoubleArray# ba i) - (indexDoubleArray# ba (i +# 1#)) - {-# INLINE indexArray #-} - - readArray mba off s0 - | i <- off *# ELEM_N# - = case readDoubleArray# mba i s0 of - (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> (# s2, DoubleX2# a1 a2 #) - {-# INLINE readArray #-} - - writeArray mba off (DoubleX2# a1 a2) s - | i <- off *# ELEM_N# - = writeDoubleArray# mba (i +# 1#) a2 - ( writeDoubleArray# mba i a1 s ) - {-# INLINE writeArray #-} - - -instance PrimArray Double DoubleX2 where - - broadcast (D# x) = DoubleX2# x x - {-# INLINE broadcast #-} - - ix# 0# (DoubleX2# a1 _) = D# a1 - ix# 1# (DoubleX2# _ a2) = D# a2 - ix# _ _ = undefined - {-# INLINE ix# #-} - - gen# _ f s0 = case f s0 of - (# s1, D# a1 #) -> case f s1 of - (# s2, D# a2 #) -> (# s2, DoubleX2# a1 a2 #) - - - upd# _ 0# (D# q) (DoubleX2# _ y) = DoubleX2# q y - upd# _ 1# (D# q) (DoubleX2# x _) = DoubleX2# x q - upd# _ _ _ x = x - {-# INLINE upd# #-} - - elemOffset _ = 0# - {-# INLINE elemOffset #-} - - elemSize0 _ = ELEM_N# - {-# INLINE elemSize0 #-} - - fromElems off _ ba = DoubleX2# - (indexDoubleArray# ba off) - (indexDoubleArray# ba (off +# 1#)) - {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX3.hs b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX3.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX3.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -module Numeric.DataFrame.Internal.Array.Family.DoubleX3 (DoubleX3 (..)) where - - -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.PrimBytes - - -data DoubleX3 = DoubleX3# Double# Double# Double# - - -instance Bounded DoubleX3 where - maxBound = case inftyD of D# x -> DoubleX3# x x x - minBound = case negate inftyD of D# x -> DoubleX3# x x x - - -instance Show DoubleX3 where - show (DoubleX3# a1 a2 a3) - = "{ " ++ show (D# a1) - ++ ", " ++ show (D# a2) - ++ ", " ++ show (D# a3) - ++ " }" - - - -instance Eq DoubleX3 where - - DoubleX3# a1 a2 a3 == DoubleX3# b1 b2 b3 = - isTrue# - ( (a1 ==## b1) - `andI#` (a2 ==## b2) - `andI#` (a3 ==## b3) - ) - {-# INLINE (==) #-} - - DoubleX3# a1 a2 a3 /= DoubleX3# b1 b2 b3 = - isTrue# - ( (a1 /=## b1) - `orI#` (a2 /=## b2) - `orI#` (a3 /=## b3) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord DoubleX3 where - DoubleX3# a1 a2 a3 > DoubleX3# b1 b2 b3 = - isTrue# - ( (a1 >## b1) - `andI#` (a2 >## b2) - `andI#` (a3 >## b3) - ) - {-# INLINE (>) #-} - - DoubleX3# a1 a2 a3 < DoubleX3# b1 b2 b3 = - isTrue# - ( (a1 <## b1) - `andI#` (a2 <## b2) - `andI#` (a3 <## b3) - ) - {-# INLINE (<) #-} - - DoubleX3# a1 a2 a3 >= DoubleX3# b1 b2 b3 = - isTrue# - ( (a1 >=## b1) - `andI#` (a2 >=## b2) - `andI#` (a3 >=## b3) - ) - {-# INLINE (>=) #-} - - DoubleX3# a1 a2 a3 <= DoubleX3# b1 b2 b3 = - isTrue# - ( (a1 <=## b1) - `andI#` (a2 <=## b2) - `andI#` (a3 <=## b3) - ) - {-# INLINE (<=) #-} - - -- | Compare lexicographically - compare (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) - | isTrue# (a1 >## b1) = GT - | isTrue# (a1 <## b1) = LT - | isTrue# (a2 >## b2) = GT - | isTrue# (a2 <## b2) = LT - | isTrue# (a3 >## b3) = GT - | isTrue# (a3 <## b3) = LT - | otherwise = EQ - {-# INLINE compare #-} - - -- | Element-wise minimum - min (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) = DoubleX3# - (if isTrue# (a1 >## b1) then b1 else a1) - (if isTrue# (a2 >## b2) then b2 else a2) - (if isTrue# (a3 >## b3) then b3 else a3) - {-# INLINE min #-} - - -- | Element-wise maximum - max (DoubleX3# a1 a2 a3) (DoubleX3# b1 b2 b3) = DoubleX3# - (if isTrue# (a1 >## b1) then a1 else b1) - (if isTrue# (a2 >## b2) then a2 else b2) - (if isTrue# (a3 >## b3) then a3 else b3) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num DoubleX3 where - - DoubleX3# a1 a2 a3 + DoubleX3# b1 b2 b3 - = DoubleX3# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) - {-# INLINE (+) #-} - - DoubleX3# a1 a2 a3 - DoubleX3# b1 b2 b3 - = DoubleX3# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) - {-# INLINE (-) #-} - - DoubleX3# a1 a2 a3 * DoubleX3# b1 b2 b3 - = DoubleX3# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) - {-# INLINE (*) #-} - - negate (DoubleX3# a1 a2 a3) = DoubleX3# - (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) - {-# INLINE negate #-} - - abs (DoubleX3# a1 a2 a3) - = DoubleX3# - (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) - (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) - (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) - {-# INLINE abs #-} - - signum (DoubleX3# a1 a2 a3) - = DoubleX3# (if isTrue# (a1 >## 0.0##) - then 1.0## - else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a2 >## 0.0##) - then 1.0## - else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a3 >## 0.0##) - then 1.0## - else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) - {-# INLINE signum #-} - - fromInteger n = case fromInteger n of D# x -> DoubleX3# x x x - {-# INLINE fromInteger #-} - - - -instance Fractional DoubleX3 where - - DoubleX3# a1 a2 a3 / DoubleX3# b1 b2 b3 = DoubleX3# - ((/##) a1 b1) ((/##) a2 b2) ((/##) a3 b3) - {-# INLINE (/) #-} - - recip (DoubleX3# a1 a2 a3) = DoubleX3# - ((/##) 1.0## a1) ((/##) 1.0## a2) ((/##) 1.0## a3) - {-# INLINE recip #-} - - fromRational r = case fromRational r of D# x -> DoubleX3# x x x - {-# INLINE fromRational #-} - - - -instance Floating DoubleX3 where - - pi = DoubleX3# - 3.141592653589793238## - 3.141592653589793238## - 3.141592653589793238## - {-# INLINE pi #-} - - exp (DoubleX3# a1 a2 a3) = DoubleX3# - (expDouble# a1) (expDouble# a2) (expDouble# a3) - {-# INLINE exp #-} - - log (DoubleX3# a1 a2 a3) = DoubleX3# - (logDouble# a1) (logDouble# a2) (logDouble# a3) - {-# INLINE log #-} - - sqrt (DoubleX3# a1 a2 a3) = DoubleX3# - (sqrtDouble# a1) (sqrtDouble# a2) (sqrtDouble# a3) - {-# INLINE sqrt #-} - - sin (DoubleX3# a1 a2 a3) = DoubleX3# - (sinDouble# a1) (sinDouble# a2) (sinDouble# a3) - {-# INLINE sin #-} - - cos (DoubleX3# a1 a2 a3) = DoubleX3# - (cosDouble# a1) (cosDouble# a2) (cosDouble# a3) - {-# INLINE cos #-} - - tan (DoubleX3# a1 a2 a3) = DoubleX3# - (tanDouble# a1) (tanDouble# a2) (tanDouble# a3) - {-# INLINE tan #-} - - asin (DoubleX3# a1 a2 a3) = DoubleX3# - (asinDouble# a1) (asinDouble# a2) (asinDouble# a3) - {-# INLINE asin #-} - - acos (DoubleX3# a1 a2 a3) = DoubleX3# - (acosDouble# a1) (acosDouble# a2) (acosDouble# a3) - {-# INLINE acos #-} - - atan (DoubleX3# a1 a2 a3) = DoubleX3# - (atanDouble# a1) (atanDouble# a2) (atanDouble# a3) - {-# INLINE atan #-} - - sinh (DoubleX3# a1 a2 a3) = DoubleX3# - (sinhDouble# a1) (sinhDouble# a2) (sinhDouble# a3) - {-# INLINE sinh #-} - - cosh (DoubleX3# a1 a2 a3) = DoubleX3# - (coshDouble# a1) (coshDouble# a2) (coshDouble# a3) - {-# INLINE cosh #-} - - tanh (DoubleX3# a1 a2 a3) = DoubleX3# - (tanhDouble# a1) (tanhDouble# a2) (tanhDouble# a3) - {-# INLINE tanh #-} - - DoubleX3# a1 a2 a3 ** DoubleX3# b1 b2 b3 = DoubleX3# - ((**##) a1 b1) ((**##) a2 b2) ((**##) a3 b3) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - --- offset in bytes is S times bigger than offset in prim elements, --- when S is power of two, this is equal to shift -#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# -#define ELEM_N 3 - -instance PrimBytes DoubleX3 where - - getBytes (DoubleX3# a1 a2 a3) = case runRW# - ( \s0 -> case newByteArray# (byteSize @DoubleX3 undefined) s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of - s2 -> case writeDoubleArray# marr 1# a2 s2 of - s3 -> case writeDoubleArray# marr 2# a3 s3 of - s4 -> unsafeFreezeByteArray# marr s4 - ) of (# _, a #) -> a - {-# INLINE getBytes #-} - - fromBytes off arr - | i <- BOFF_TO_PRIMOFF(off) - = DoubleX3# - (indexDoubleArray# arr i) - (indexDoubleArray# arr (i +# 1#)) - (indexDoubleArray# arr (i +# 2#)) - {-# INLINE fromBytes #-} - - readBytes mba off s0 - | i <- BOFF_TO_PRIMOFF(off) - = case readDoubleArray# mba i s0 of - (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) - {-# INLINE readBytes #-} - - writeBytes mba off (DoubleX3# a1 a2 a3) s - | i <- BOFF_TO_PRIMOFF(off) - = writeDoubleArray# mba (i +# 2#) a3 - ( writeDoubleArray# mba (i +# 1#) a2 - ( writeDoubleArray# mba i a1 s )) - {-# INLINE writeBytes #-} - - readAddr addr s0 - = case readDoubleOffAddr# addr 0# s0 of - (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of - (# s2, a2 #) -> case readDoubleOffAddr# addr 2# s2 of - (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) - {-# INLINE readAddr #-} - - writeAddr (DoubleX3# a1 a2 a3) addr s - = writeDoubleOffAddr# addr 2# a3 - ( writeDoubleOffAddr# addr 1# a2 - ( writeDoubleOffAddr# addr 0# a1 s )) - {-# INLINE writeAddr #-} - - byteSize _ = byteSize @Double undefined *# ELEM_N# - {-# INLINE byteSize #-} - - byteAlign _ = byteAlign @Double undefined - {-# INLINE byteAlign #-} - - byteOffset _ = 0# - {-# INLINE byteOffset #-} - - indexArray ba off - | i <- off *# ELEM_N# - = DoubleX3# - (indexDoubleArray# ba i) - (indexDoubleArray# ba (i +# 1#)) - (indexDoubleArray# ba (i +# 2#)) - {-# INLINE indexArray #-} - - readArray mba off s0 - | i <- off *# ELEM_N# - = case readDoubleArray# mba i s0 of - (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) - {-# INLINE readArray #-} - - writeArray mba off (DoubleX3# a1 a2 a3) s - | i <- off *# ELEM_N# - = writeDoubleArray# mba (i +# 2#) a3 - ( writeDoubleArray# mba (i +# 1#) a2 - ( writeDoubleArray# mba i a1 s )) - {-# INLINE writeArray #-} - - -instance PrimArray Double DoubleX3 where - - broadcast (D# x) = DoubleX3# x x x - {-# INLINE broadcast #-} - - ix# 0# (DoubleX3# a1 _ _) = D# a1 - ix# 1# (DoubleX3# _ a2 _) = D# a2 - ix# 2# (DoubleX3# _ _ a3) = D# a3 - ix# _ _ = undefined - {-# INLINE ix# #-} - - gen# _ f s0 = case f s0 of - (# s1, D# a1 #) -> case f s1 of - (# s2, D# a2 #) -> case f s2 of - (# s3, D# a3 #) -> (# s3, DoubleX3# a1 a2 a3 #) - - - upd# _ 0# (D# q) (DoubleX3# _ y z) = DoubleX3# q y z - upd# _ 1# (D# q) (DoubleX3# x _ z) = DoubleX3# x q z - upd# _ 2# (D# q) (DoubleX3# x y _) = DoubleX3# x y q - upd# _ _ _ x = x - {-# INLINE upd# #-} - - elemOffset _ = 0# - {-# INLINE elemOffset #-} - - elemSize0 _ = ELEM_N# - {-# INLINE elemSize0 #-} - - fromElems off _ ba = DoubleX3# - (indexDoubleArray# ba off) - (indexDoubleArray# ba (off +# 1#)) - (indexDoubleArray# ba (off +# 2#)) - {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX4.hs b/src/Numeric/DataFrame/Internal/Array/Family/DoubleX4.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/DoubleX4.hs +++ /dev/null @@ -1,391 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -module Numeric.DataFrame.Internal.Array.Family.DoubleX4 (DoubleX4 (..)) where - - -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.PrimBytes - - -data DoubleX4 = DoubleX4# Double# Double# Double# Double# - - -instance Bounded DoubleX4 where - maxBound = case inftyD of D# x -> DoubleX4# x x x x - minBound = case negate inftyD of D# x -> DoubleX4# x x x x - - -instance Show DoubleX4 where - show (DoubleX4# a1 a2 a3 a4) - = "{ " ++ show (D# a1) - ++ ", " ++ show (D# a2) - ++ ", " ++ show (D# a3) - ++ ", " ++ show (D# a4) - ++ " }" - - - -instance Eq DoubleX4 where - - DoubleX4# a1 a2 a3 a4 == DoubleX4# b1 b2 b3 b4 = - isTrue# - ( (a1 ==## b1) - `andI#` (a2 ==## b2) - `andI#` (a3 ==## b3) - `andI#` (a4 ==## b4) - ) - {-# INLINE (==) #-} - - DoubleX4# a1 a2 a3 a4 /= DoubleX4# b1 b2 b3 b4 = - isTrue# - ( (a1 /=## b1) - `orI#` (a2 /=## b2) - `orI#` (a3 /=## b3) - `orI#` (a4 /=## b4) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord DoubleX4 where - DoubleX4# a1 a2 a3 a4 > DoubleX4# b1 b2 b3 b4 = - isTrue# - ( (a1 >## b1) - `andI#` (a2 >## b2) - `andI#` (a3 >## b3) - `andI#` (a4 >## b4) - ) - {-# INLINE (>) #-} - - DoubleX4# a1 a2 a3 a4 < DoubleX4# b1 b2 b3 b4 = - isTrue# - ( (a1 <## b1) - `andI#` (a2 <## b2) - `andI#` (a3 <## b3) - `andI#` (a4 <## b4) - ) - {-# INLINE (<) #-} - - DoubleX4# a1 a2 a3 a4 >= DoubleX4# b1 b2 b3 b4 = - isTrue# - ( (a1 >=## b1) - `andI#` (a2 >=## b2) - `andI#` (a3 >=## b3) - `andI#` (a4 >=## b4) - ) - {-# INLINE (>=) #-} - - DoubleX4# a1 a2 a3 a4 <= DoubleX4# b1 b2 b3 b4 = - isTrue# - ( (a1 <=## b1) - `andI#` (a2 <=## b2) - `andI#` (a3 <=## b3) - `andI#` (a4 <=## b4) - ) - {-# INLINE (<=) #-} - - -- | Compare lexicographically - compare (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) - | isTrue# (a1 >## b1) = GT - | isTrue# (a1 <## b1) = LT - | isTrue# (a2 >## b2) = GT - | isTrue# (a2 <## b2) = LT - | isTrue# (a3 >## b3) = GT - | isTrue# (a3 <## b3) = LT - | isTrue# (a4 >## b4) = GT - | isTrue# (a4 <## b4) = LT - | otherwise = EQ - {-# INLINE compare #-} - - -- | Element-wise minimum - min (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) = DoubleX4# - (if isTrue# (a1 >## b1) then b1 else a1) - (if isTrue# (a2 >## b2) then b2 else a2) - (if isTrue# (a3 >## b3) then b3 else a3) - (if isTrue# (a4 >## b4) then b4 else a4) - {-# INLINE min #-} - - -- | Element-wise maximum - max (DoubleX4# a1 a2 a3 a4) (DoubleX4# b1 b2 b3 b4) = DoubleX4# - (if isTrue# (a1 >## b1) then a1 else b1) - (if isTrue# (a2 >## b2) then a2 else b2) - (if isTrue# (a3 >## b3) then a3 else b3) - (if isTrue# (a4 >## b4) then a4 else b4) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num DoubleX4 where - - DoubleX4# a1 a2 a3 a4 + DoubleX4# b1 b2 b3 b4 - = DoubleX4# ((+##) a1 b1) ((+##) a2 b2) ((+##) a3 b3) ((+##) a4 b4) - {-# INLINE (+) #-} - - DoubleX4# a1 a2 a3 a4 - DoubleX4# b1 b2 b3 b4 - = DoubleX4# ((-##) a1 b1) ((-##) a2 b2) ((-##) a3 b3) ((-##) a4 b4) - {-# INLINE (-) #-} - - DoubleX4# a1 a2 a3 a4 * DoubleX4# b1 b2 b3 b4 - = DoubleX4# ((*##) a1 b1) ((*##) a2 b2) ((*##) a3 b3) ((*##) a4 b4) - {-# INLINE (*) #-} - - negate (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (negateDouble# a1) (negateDouble# a2) (negateDouble# a3) (negateDouble# a4) - {-# INLINE negate #-} - - abs (DoubleX4# a1 a2 a3 a4) - = DoubleX4# - (if isTrue# (a1 >=## 0.0##) then a1 else negateDouble# a1) - (if isTrue# (a2 >=## 0.0##) then a2 else negateDouble# a2) - (if isTrue# (a3 >=## 0.0##) then a3 else negateDouble# a3) - (if isTrue# (a4 >=## 0.0##) then a4 else negateDouble# a4) - {-# INLINE abs #-} - - signum (DoubleX4# a1 a2 a3 a4) - = DoubleX4# (if isTrue# (a1 >## 0.0##) - then 1.0## - else if isTrue# (a1 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a2 >## 0.0##) - then 1.0## - else if isTrue# (a2 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a3 >## 0.0##) - then 1.0## - else if isTrue# (a3 <## 0.0##) then -1.0## else 0.0## ) - (if isTrue# (a4 >## 0.0##) - then 1.0## - else if isTrue# (a4 <## 0.0##) then -1.0## else 0.0## ) - {-# INLINE signum #-} - - fromInteger n = case fromInteger n of D# x -> DoubleX4# x x x x - {-# INLINE fromInteger #-} - - - -instance Fractional DoubleX4 where - - DoubleX4# a1 a2 a3 a4 / DoubleX4# b1 b2 b3 b4 = DoubleX4# - ((/##) a1 b1) ((/##) a2 b2) ((/##) a3 b3) ((/##) a4 b4) - {-# INLINE (/) #-} - - recip (DoubleX4# a1 a2 a3 a4) = DoubleX4# - ((/##) 1.0## a1) ((/##) 1.0## a2) ((/##) 1.0## a3) ((/##) 1.0## a4) - {-# INLINE recip #-} - - fromRational r = case fromRational r of D# x -> DoubleX4# x x x x - {-# INLINE fromRational #-} - - - -instance Floating DoubleX4 where - - pi = DoubleX4# - 3.141592653589793238## - 3.141592653589793238## - 3.141592653589793238## - 3.141592653589793238## - {-# INLINE pi #-} - - exp (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (expDouble# a1) (expDouble# a2) (expDouble# a3) (expDouble# a4) - {-# INLINE exp #-} - - log (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (logDouble# a1) (logDouble# a2) (logDouble# a3) (logDouble# a4) - {-# INLINE log #-} - - sqrt (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (sqrtDouble# a1) (sqrtDouble# a2) (sqrtDouble# a3) (sqrtDouble# a4) - {-# INLINE sqrt #-} - - sin (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (sinDouble# a1) (sinDouble# a2) (sinDouble# a3) (sinDouble# a4) - {-# INLINE sin #-} - - cos (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (cosDouble# a1) (cosDouble# a2) (cosDouble# a3) (cosDouble# a4) - {-# INLINE cos #-} - - tan (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (tanDouble# a1) (tanDouble# a2) (tanDouble# a3) (tanDouble# a4) - {-# INLINE tan #-} - - asin (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (asinDouble# a1) (asinDouble# a2) (asinDouble# a3) (asinDouble# a4) - {-# INLINE asin #-} - - acos (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (acosDouble# a1) (acosDouble# a2) (acosDouble# a3) (acosDouble# a4) - {-# INLINE acos #-} - - atan (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (atanDouble# a1) (atanDouble# a2) (atanDouble# a3) (atanDouble# a4) - {-# INLINE atan #-} - - sinh (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (sinhDouble# a1) (sinhDouble# a2) (sinhDouble# a3) (sinhDouble# a4) - {-# INLINE sinh #-} - - cosh (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (coshDouble# a1) (coshDouble# a2) (coshDouble# a3) (coshDouble# a4) - {-# INLINE cosh #-} - - tanh (DoubleX4# a1 a2 a3 a4) = DoubleX4# - (tanhDouble# a1) (tanhDouble# a2) (tanhDouble# a3) (tanhDouble# a4) - {-# INLINE tanh #-} - - DoubleX4# a1 a2 a3 a4 ** DoubleX4# b1 b2 b3 b4 = DoubleX4# - ((**##) a1 b1) ((**##) a2 b2) ((**##) a3 b3) ((**##) a4 b4) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - --- offset in bytes is S times bigger than offset in prim elements, --- when S is power of two, this is equal to shift -#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 3# -#define ELEM_N 4 - -instance PrimBytes DoubleX4 where - - getBytes (DoubleX4# a1 a2 a3 a4) = case runRW# - ( \s0 -> case newByteArray# (byteSize @DoubleX4 undefined) s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# a1 s1 of - s2 -> case writeDoubleArray# marr 1# a2 s2 of - s3 -> case writeDoubleArray# marr 2# a3 s3 of - s4 -> case writeDoubleArray# marr 3# a4 s4 of - s5 -> unsafeFreezeByteArray# marr s5 - ) of (# _, a #) -> a - {-# INLINE getBytes #-} - - fromBytes off arr - | i <- BOFF_TO_PRIMOFF(off) - = DoubleX4# - (indexDoubleArray# arr i) - (indexDoubleArray# arr (i +# 1#)) - (indexDoubleArray# arr (i +# 2#)) - (indexDoubleArray# arr (i +# 3#)) - {-# INLINE fromBytes #-} - - readBytes mba off s0 - | i <- BOFF_TO_PRIMOFF(off) - = case readDoubleArray# mba i s0 of - (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> case readDoubleArray# mba (i +# 3#) s3 of - (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) - {-# INLINE readBytes #-} - - writeBytes mba off (DoubleX4# a1 a2 a3 a4) s - | i <- BOFF_TO_PRIMOFF(off) - = writeDoubleArray# mba (i +# 3#) a4 - ( writeDoubleArray# mba (i +# 2#) a3 - ( writeDoubleArray# mba (i +# 1#) a2 - ( writeDoubleArray# mba i a1 s ))) - {-# INLINE writeBytes #-} - - readAddr addr s0 - = case readDoubleOffAddr# addr 0# s0 of - (# s1, a1 #) -> case readDoubleOffAddr# addr 1# s1 of - (# s2, a2 #) -> case readDoubleOffAddr# addr 2# s2 of - (# s3, a3 #) -> case readDoubleOffAddr# addr 3# s3 of - (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) - {-# INLINE readAddr #-} - - writeAddr (DoubleX4# a1 a2 a3 a4) addr s - = writeDoubleOffAddr# addr 3# a4 - ( writeDoubleOffAddr# addr 2# a3 - ( writeDoubleOffAddr# addr 1# a2 - ( writeDoubleOffAddr# addr 0# a1 s ))) - {-# INLINE writeAddr #-} - - byteSize _ = byteSize @Double undefined *# ELEM_N# - {-# INLINE byteSize #-} - - byteAlign _ = byteAlign @Double undefined - {-# INLINE byteAlign #-} - - byteOffset _ = 0# - {-# INLINE byteOffset #-} - - indexArray ba off - | i <- off *# ELEM_N# - = DoubleX4# - (indexDoubleArray# ba i) - (indexDoubleArray# ba (i +# 1#)) - (indexDoubleArray# ba (i +# 2#)) - (indexDoubleArray# ba (i +# 3#)) - {-# INLINE indexArray #-} - - readArray mba off s0 - | i <- off *# ELEM_N# - = case readDoubleArray# mba i s0 of - (# s1, a1 #) -> case readDoubleArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readDoubleArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> case readDoubleArray# mba (i +# 3#) s3 of - (# s4, a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) - {-# INLINE readArray #-} - - writeArray mba off (DoubleX4# a1 a2 a3 a4) s - | i <- off *# ELEM_N# - = writeDoubleArray# mba (i +# 3#) a4 - ( writeDoubleArray# mba (i +# 2#) a3 - ( writeDoubleArray# mba (i +# 1#) a2 - ( writeDoubleArray# mba i a1 s ))) - {-# INLINE writeArray #-} - - -instance PrimArray Double DoubleX4 where - - broadcast (D# x) = DoubleX4# x x x x - {-# INLINE broadcast #-} - - ix# 0# (DoubleX4# a1 _ _ _) = D# a1 - ix# 1# (DoubleX4# _ a2 _ _) = D# a2 - ix# 2# (DoubleX4# _ _ a3 _) = D# a3 - ix# 3# (DoubleX4# _ _ _ a4) = D# a4 - ix# _ _ = undefined - {-# INLINE ix# #-} - - gen# _ f s0 = case f s0 of - (# s1, D# a1 #) -> case f s1 of - (# s2, D# a2 #) -> case f s2 of - (# s3, D# a3 #) -> case f s3 of - (# s4, D# a4 #) -> (# s4, DoubleX4# a1 a2 a3 a4 #) - - - upd# _ 0# (D# q) (DoubleX4# _ y z w) = DoubleX4# q y z w - upd# _ 1# (D# q) (DoubleX4# x _ z w) = DoubleX4# x q z w - upd# _ 2# (D# q) (DoubleX4# x y _ w) = DoubleX4# x y q w - upd# _ 3# (D# q) (DoubleX4# x y z _) = DoubleX4# x y z q - upd# _ _ _ x = x - {-# INLINE upd# #-} - - elemOffset _ = 0# - {-# INLINE elemOffset #-} - - elemSize0 _ = ELEM_N# - {-# INLINE elemSize0 #-} - - fromElems off _ ba = DoubleX4# - (indexDoubleArray# ba off) - (indexDoubleArray# ba (off +# 1#)) - (indexDoubleArray# ba (off +# 2#)) - (indexDoubleArray# ba (off +# 3#)) - {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/FloatX2.hs b/src/Numeric/DataFrame/Internal/Array/Family/FloatX2.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/FloatX2.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -module Numeric.DataFrame.Internal.Array.Family.FloatX2 (FloatX2 (..)) where - - -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.PrimBytes - - -data FloatX2 = FloatX2# Float# Float# - - -instance Bounded FloatX2 where - maxBound = case inftyF of F# x -> FloatX2# x x - minBound = case negate inftyF of F# x -> FloatX2# x x - - -instance Show FloatX2 where - show (FloatX2# a1 a2) - = "{ " ++ show (F# a1) - ++ ", " ++ show (F# a2) - ++ " }" - - - -instance Eq FloatX2 where - - FloatX2# a1 a2 == FloatX2# b1 b2 = - isTrue# - ( (a1 `eqFloat#` b1) - `andI#` (a2 `eqFloat#` b2) - ) - {-# INLINE (==) #-} - - FloatX2# a1 a2 /= FloatX2# b1 b2 = - isTrue# - ( (a1 `neFloat#` b1) - `orI#` (a2 `neFloat#` b2) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord FloatX2 where - FloatX2# a1 a2 > FloatX2# b1 b2 = - isTrue# - ( (a1 `gtFloat#` b1) - `andI#` (a2 `gtFloat#` b2) - ) - {-# INLINE (>) #-} - - FloatX2# a1 a2 < FloatX2# b1 b2 = - isTrue# - ( (a1 `ltFloat#` b1) - `andI#` (a2 `ltFloat#` b2) - ) - {-# INLINE (<) #-} - - FloatX2# a1 a2 >= FloatX2# b1 b2 = - isTrue# - ( (a1 `geFloat#` b1) - `andI#` (a2 `geFloat#` b2) - ) - {-# INLINE (>=) #-} - - FloatX2# a1 a2 <= FloatX2# b1 b2 = - isTrue# - ( (a1 `leFloat#` b1) - `andI#` (a2 `leFloat#` b2) - ) - {-# INLINE (<=) #-} - - -- | Compare lexicographically - compare (FloatX2# a1 a2) (FloatX2# b1 b2) - | isTrue# (a1 `gtFloat#` b1) = GT - | isTrue# (a1 `ltFloat#` b1) = LT - | isTrue# (a2 `gtFloat#` b2) = GT - | isTrue# (a2 `ltFloat#` b2) = LT - | otherwise = EQ - {-# INLINE compare #-} - - -- | Element-wise minimum - min (FloatX2# a1 a2) (FloatX2# b1 b2) = FloatX2# - (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) - (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) - {-# INLINE min #-} - - -- | Element-wise maximum - max (FloatX2# a1 a2) (FloatX2# b1 b2) = FloatX2# - (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) - (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num FloatX2 where - - FloatX2# a1 a2 + FloatX2# b1 b2 - = FloatX2# (plusFloat# a1 b1) (plusFloat# a2 b2) - {-# INLINE (+) #-} - - FloatX2# a1 a2 - FloatX2# b1 b2 - = FloatX2# (minusFloat# a1 b1) (minusFloat# a2 b2) - {-# INLINE (-) #-} - - FloatX2# a1 a2 * FloatX2# b1 b2 - = FloatX2# (timesFloat# a1 b1) (timesFloat# a2 b2) - {-# INLINE (*) #-} - - negate (FloatX2# a1 a2) = FloatX2# - (negateFloat# a1) (negateFloat# a2) - {-# INLINE negate #-} - - abs (FloatX2# a1 a2) - = FloatX2# - (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) - (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) - {-# INLINE abs #-} - - signum (FloatX2# a1 a2) - = FloatX2# (if isTrue# (a1 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a2 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - {-# INLINE signum #-} - - fromInteger n = case fromInteger n of F# x -> FloatX2# x x - {-# INLINE fromInteger #-} - - - -instance Fractional FloatX2 where - - FloatX2# a1 a2 / FloatX2# b1 b2 = FloatX2# - (divideFloat# a1 b1) (divideFloat# a2 b2) - {-# INLINE (/) #-} - - recip (FloatX2# a1 a2) = FloatX2# - (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) - {-# INLINE recip #-} - - fromRational r = case fromRational r of F# x -> FloatX2# x x - {-# INLINE fromRational #-} - - - -instance Floating FloatX2 where - - pi = FloatX2# - 3.141592653589793238# - 3.141592653589793238# - {-# INLINE pi #-} - - exp (FloatX2# a1 a2) = FloatX2# - (expFloat# a1) (expFloat# a2) - {-# INLINE exp #-} - - log (FloatX2# a1 a2) = FloatX2# - (logFloat# a1) (logFloat# a2) - {-# INLINE log #-} - - sqrt (FloatX2# a1 a2) = FloatX2# - (sqrtFloat# a1) (sqrtFloat# a2) - {-# INLINE sqrt #-} - - sin (FloatX2# a1 a2) = FloatX2# - (sinFloat# a1) (sinFloat# a2) - {-# INLINE sin #-} - - cos (FloatX2# a1 a2) = FloatX2# - (cosFloat# a1) (cosFloat# a2) - {-# INLINE cos #-} - - tan (FloatX2# a1 a2) = FloatX2# - (tanFloat# a1) (tanFloat# a2) - {-# INLINE tan #-} - - asin (FloatX2# a1 a2) = FloatX2# - (asinFloat# a1) (asinFloat# a2) - {-# INLINE asin #-} - - acos (FloatX2# a1 a2) = FloatX2# - (acosFloat# a1) (acosFloat# a2) - {-# INLINE acos #-} - - atan (FloatX2# a1 a2) = FloatX2# - (atanFloat# a1) (atanFloat# a2) - {-# INLINE atan #-} - - sinh (FloatX2# a1 a2) = FloatX2# - (sinhFloat# a1) (sinhFloat# a2) - {-# INLINE sinh #-} - - cosh (FloatX2# a1 a2) = FloatX2# - (coshFloat# a1) (coshFloat# a2) - {-# INLINE cosh #-} - - tanh (FloatX2# a1 a2) = FloatX2# - (tanhFloat# a1) (tanhFloat# a2) - {-# INLINE tanh #-} - - FloatX2# a1 a2 ** FloatX2# b1 b2 = FloatX2# - (powerFloat# a1 b1) (powerFloat# a2 b2) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - --- offset in bytes is S times bigger than offset in prim elements, --- when S is power of two, this is equal to shift -#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# -#define ELEM_N 2 - -instance PrimBytes FloatX2 where - - getBytes (FloatX2# a1 a2) = case runRW# - ( \s0 -> case newByteArray# (byteSize @FloatX2 undefined) s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of - s2 -> case writeFloatArray# marr 1# a2 s2 of - s3 -> unsafeFreezeByteArray# marr s3 - ) of (# _, a #) -> a - {-# INLINE getBytes #-} - - fromBytes off arr - | i <- BOFF_TO_PRIMOFF(off) - = FloatX2# - (indexFloatArray# arr i) - (indexFloatArray# arr (i +# 1#)) - {-# INLINE fromBytes #-} - - readBytes mba off s0 - | i <- BOFF_TO_PRIMOFF(off) - = case readFloatArray# mba i s0 of - (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) - {-# INLINE readBytes #-} - - writeBytes mba off (FloatX2# a1 a2) s - | i <- BOFF_TO_PRIMOFF(off) - = writeFloatArray# mba (i +# 1#) a2 - ( writeFloatArray# mba i a1 s ) - {-# INLINE writeBytes #-} - - readAddr addr s0 - = case readFloatOffAddr# addr 0# s0 of - (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of - (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) - {-# INLINE readAddr #-} - - writeAddr (FloatX2# a1 a2) addr s - = writeFloatOffAddr# addr 1# a2 - ( writeFloatOffAddr# addr 0# a1 s ) - {-# INLINE writeAddr #-} - - byteSize _ = byteSize @Float undefined *# ELEM_N# - {-# INLINE byteSize #-} - - byteAlign _ = byteAlign @Float undefined - {-# INLINE byteAlign #-} - - byteOffset _ = 0# - {-# INLINE byteOffset #-} - - indexArray ba off - | i <- off *# ELEM_N# - = FloatX2# - (indexFloatArray# ba i) - (indexFloatArray# ba (i +# 1#)) - {-# INLINE indexArray #-} - - readArray mba off s0 - | i <- off *# ELEM_N# - = case readFloatArray# mba i s0 of - (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> (# s2, FloatX2# a1 a2 #) - {-# INLINE readArray #-} - - writeArray mba off (FloatX2# a1 a2) s - | i <- off *# ELEM_N# - = writeFloatArray# mba (i +# 1#) a2 - ( writeFloatArray# mba i a1 s ) - {-# INLINE writeArray #-} - - -instance PrimArray Float FloatX2 where - - broadcast (F# x) = FloatX2# x x - {-# INLINE broadcast #-} - - ix# 0# (FloatX2# a1 _) = F# a1 - ix# 1# (FloatX2# _ a2) = F# a2 - ix# _ _ = undefined - {-# INLINE ix# #-} - - gen# _ f s0 = case f s0 of - (# s1, F# a1 #) -> case f s1 of - (# s2, F# a2 #) -> (# s2, FloatX2# a1 a2 #) - - - upd# _ 0# (F# q) (FloatX2# _ y) = FloatX2# q y - upd# _ 1# (F# q) (FloatX2# x _) = FloatX2# x q - upd# _ _ _ x = x - {-# INLINE upd# #-} - - elemOffset _ = 0# - {-# INLINE elemOffset #-} - - elemSize0 _ = ELEM_N# - {-# INLINE elemSize0 #-} - - fromElems off _ ba = FloatX2# - (indexFloatArray# ba off) - (indexFloatArray# ba (off +# 1#)) - {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/FloatX3.hs b/src/Numeric/DataFrame/Internal/Array/Family/FloatX3.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/FloatX3.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -module Numeric.DataFrame.Internal.Array.Family.FloatX3 (FloatX3 (..)) where - - -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.PrimBytes - - -data FloatX3 = FloatX3# Float# Float# Float# - - -instance Bounded FloatX3 where - maxBound = case inftyF of F# x -> FloatX3# x x x - minBound = case negate inftyF of F# x -> FloatX3# x x x - - -instance Show FloatX3 where - show (FloatX3# a1 a2 a3) - = "{ " ++ show (F# a1) - ++ ", " ++ show (F# a2) - ++ ", " ++ show (F# a3) - ++ " }" - - - -instance Eq FloatX3 where - - FloatX3# a1 a2 a3 == FloatX3# b1 b2 b3 = - isTrue# - ( (a1 `eqFloat#` b1) - `andI#` (a2 `eqFloat#` b2) - `andI#` (a3 `eqFloat#` b3) - ) - {-# INLINE (==) #-} - - FloatX3# a1 a2 a3 /= FloatX3# b1 b2 b3 = - isTrue# - ( (a1 `neFloat#` b1) - `orI#` (a2 `neFloat#` b2) - `orI#` (a3 `neFloat#` b3) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord FloatX3 where - FloatX3# a1 a2 a3 > FloatX3# b1 b2 b3 = - isTrue# - ( (a1 `gtFloat#` b1) - `andI#` (a2 `gtFloat#` b2) - `andI#` (a3 `gtFloat#` b3) - ) - {-# INLINE (>) #-} - - FloatX3# a1 a2 a3 < FloatX3# b1 b2 b3 = - isTrue# - ( (a1 `ltFloat#` b1) - `andI#` (a2 `ltFloat#` b2) - `andI#` (a3 `ltFloat#` b3) - ) - {-# INLINE (<) #-} - - FloatX3# a1 a2 a3 >= FloatX3# b1 b2 b3 = - isTrue# - ( (a1 `geFloat#` b1) - `andI#` (a2 `geFloat#` b2) - `andI#` (a3 `geFloat#` b3) - ) - {-# INLINE (>=) #-} - - FloatX3# a1 a2 a3 <= FloatX3# b1 b2 b3 = - isTrue# - ( (a1 `leFloat#` b1) - `andI#` (a2 `leFloat#` b2) - `andI#` (a3 `leFloat#` b3) - ) - {-# INLINE (<=) #-} - - -- | Compare lexicographically - compare (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) - | isTrue# (a1 `gtFloat#` b1) = GT - | isTrue# (a1 `ltFloat#` b1) = LT - | isTrue# (a2 `gtFloat#` b2) = GT - | isTrue# (a2 `ltFloat#` b2) = LT - | isTrue# (a3 `gtFloat#` b3) = GT - | isTrue# (a3 `ltFloat#` b3) = LT - | otherwise = EQ - {-# INLINE compare #-} - - -- | Element-wise minimum - min (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) = FloatX3# - (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) - (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) - (if isTrue# (a3 `gtFloat#` b3) then b3 else a3) - {-# INLINE min #-} - - -- | Element-wise maximum - max (FloatX3# a1 a2 a3) (FloatX3# b1 b2 b3) = FloatX3# - (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) - (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) - (if isTrue# (a3 `gtFloat#` b3) then a3 else b3) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num FloatX3 where - - FloatX3# a1 a2 a3 + FloatX3# b1 b2 b3 - = FloatX3# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) - {-# INLINE (+) #-} - - FloatX3# a1 a2 a3 - FloatX3# b1 b2 b3 - = FloatX3# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) - {-# INLINE (-) #-} - - FloatX3# a1 a2 a3 * FloatX3# b1 b2 b3 - = FloatX3# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) - {-# INLINE (*) #-} - - negate (FloatX3# a1 a2 a3) = FloatX3# - (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) - {-# INLINE negate #-} - - abs (FloatX3# a1 a2 a3) - = FloatX3# - (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) - (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) - (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) - {-# INLINE abs #-} - - signum (FloatX3# a1 a2 a3) - = FloatX3# (if isTrue# (a1 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a2 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a3 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - {-# INLINE signum #-} - - fromInteger n = case fromInteger n of F# x -> FloatX3# x x x - {-# INLINE fromInteger #-} - - - -instance Fractional FloatX3 where - - FloatX3# a1 a2 a3 / FloatX3# b1 b2 b3 = FloatX3# - (divideFloat# a1 b1) (divideFloat# a2 b2) (divideFloat# a3 b3) - {-# INLINE (/) #-} - - recip (FloatX3# a1 a2 a3) = FloatX3# - (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) (divideFloat# 1.0# a3) - {-# INLINE recip #-} - - fromRational r = case fromRational r of F# x -> FloatX3# x x x - {-# INLINE fromRational #-} - - - -instance Floating FloatX3 where - - pi = FloatX3# - 3.141592653589793238# - 3.141592653589793238# - 3.141592653589793238# - {-# INLINE pi #-} - - exp (FloatX3# a1 a2 a3) = FloatX3# - (expFloat# a1) (expFloat# a2) (expFloat# a3) - {-# INLINE exp #-} - - log (FloatX3# a1 a2 a3) = FloatX3# - (logFloat# a1) (logFloat# a2) (logFloat# a3) - {-# INLINE log #-} - - sqrt (FloatX3# a1 a2 a3) = FloatX3# - (sqrtFloat# a1) (sqrtFloat# a2) (sqrtFloat# a3) - {-# INLINE sqrt #-} - - sin (FloatX3# a1 a2 a3) = FloatX3# - (sinFloat# a1) (sinFloat# a2) (sinFloat# a3) - {-# INLINE sin #-} - - cos (FloatX3# a1 a2 a3) = FloatX3# - (cosFloat# a1) (cosFloat# a2) (cosFloat# a3) - {-# INLINE cos #-} - - tan (FloatX3# a1 a2 a3) = FloatX3# - (tanFloat# a1) (tanFloat# a2) (tanFloat# a3) - {-# INLINE tan #-} - - asin (FloatX3# a1 a2 a3) = FloatX3# - (asinFloat# a1) (asinFloat# a2) (asinFloat# a3) - {-# INLINE asin #-} - - acos (FloatX3# a1 a2 a3) = FloatX3# - (acosFloat# a1) (acosFloat# a2) (acosFloat# a3) - {-# INLINE acos #-} - - atan (FloatX3# a1 a2 a3) = FloatX3# - (atanFloat# a1) (atanFloat# a2) (atanFloat# a3) - {-# INLINE atan #-} - - sinh (FloatX3# a1 a2 a3) = FloatX3# - (sinhFloat# a1) (sinhFloat# a2) (sinhFloat# a3) - {-# INLINE sinh #-} - - cosh (FloatX3# a1 a2 a3) = FloatX3# - (coshFloat# a1) (coshFloat# a2) (coshFloat# a3) - {-# INLINE cosh #-} - - tanh (FloatX3# a1 a2 a3) = FloatX3# - (tanhFloat# a1) (tanhFloat# a2) (tanhFloat# a3) - {-# INLINE tanh #-} - - FloatX3# a1 a2 a3 ** FloatX3# b1 b2 b3 = FloatX3# - (powerFloat# a1 b1) (powerFloat# a2 b2) (powerFloat# a3 b3) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - --- offset in bytes is S times bigger than offset in prim elements, --- when S is power of two, this is equal to shift -#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# -#define ELEM_N 3 - -instance PrimBytes FloatX3 where - - getBytes (FloatX3# a1 a2 a3) = case runRW# - ( \s0 -> case newByteArray# (byteSize @FloatX3 undefined) s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of - s2 -> case writeFloatArray# marr 1# a2 s2 of - s3 -> case writeFloatArray# marr 2# a3 s3 of - s4 -> unsafeFreezeByteArray# marr s4 - ) of (# _, a #) -> a - {-# INLINE getBytes #-} - - fromBytes off arr - | i <- BOFF_TO_PRIMOFF(off) - = FloatX3# - (indexFloatArray# arr i) - (indexFloatArray# arr (i +# 1#)) - (indexFloatArray# arr (i +# 2#)) - {-# INLINE fromBytes #-} - - readBytes mba off s0 - | i <- BOFF_TO_PRIMOFF(off) - = case readFloatArray# mba i s0 of - (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) - {-# INLINE readBytes #-} - - writeBytes mba off (FloatX3# a1 a2 a3) s - | i <- BOFF_TO_PRIMOFF(off) - = writeFloatArray# mba (i +# 2#) a3 - ( writeFloatArray# mba (i +# 1#) a2 - ( writeFloatArray# mba i a1 s )) - {-# INLINE writeBytes #-} - - readAddr addr s0 - = case readFloatOffAddr# addr 0# s0 of - (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of - (# s2, a2 #) -> case readFloatOffAddr# addr 2# s2 of - (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) - {-# INLINE readAddr #-} - - writeAddr (FloatX3# a1 a2 a3) addr s - = writeFloatOffAddr# addr 2# a3 - ( writeFloatOffAddr# addr 1# a2 - ( writeFloatOffAddr# addr 0# a1 s )) - {-# INLINE writeAddr #-} - - byteSize _ = byteSize @Float undefined *# ELEM_N# - {-# INLINE byteSize #-} - - byteAlign _ = byteAlign @Float undefined - {-# INLINE byteAlign #-} - - byteOffset _ = 0# - {-# INLINE byteOffset #-} - - indexArray ba off - | i <- off *# ELEM_N# - = FloatX3# - (indexFloatArray# ba i) - (indexFloatArray# ba (i +# 1#)) - (indexFloatArray# ba (i +# 2#)) - {-# INLINE indexArray #-} - - readArray mba off s0 - | i <- off *# ELEM_N# - = case readFloatArray# mba i s0 of - (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> (# s3, FloatX3# a1 a2 a3 #) - {-# INLINE readArray #-} - - writeArray mba off (FloatX3# a1 a2 a3) s - | i <- off *# ELEM_N# - = writeFloatArray# mba (i +# 2#) a3 - ( writeFloatArray# mba (i +# 1#) a2 - ( writeFloatArray# mba i a1 s )) - {-# INLINE writeArray #-} - - -instance PrimArray Float FloatX3 where - - broadcast (F# x) = FloatX3# x x x - {-# INLINE broadcast #-} - - ix# 0# (FloatX3# a1 _ _) = F# a1 - ix# 1# (FloatX3# _ a2 _) = F# a2 - ix# 2# (FloatX3# _ _ a3) = F# a3 - ix# _ _ = undefined - {-# INLINE ix# #-} - - gen# _ f s0 = case f s0 of - (# s1, F# a1 #) -> case f s1 of - (# s2, F# a2 #) -> case f s2 of - (# s3, F# a3 #) -> (# s3, FloatX3# a1 a2 a3 #) - - - upd# _ 0# (F# q) (FloatX3# _ y z) = FloatX3# q y z - upd# _ 1# (F# q) (FloatX3# x _ z) = FloatX3# x q z - upd# _ 2# (F# q) (FloatX3# x y _) = FloatX3# x y q - upd# _ _ _ x = x - {-# INLINE upd# #-} - - elemOffset _ = 0# - {-# INLINE elemOffset #-} - - elemSize0 _ = ELEM_N# - {-# INLINE elemSize0 #-} - - fromElems off _ ba = FloatX3# - (indexFloatArray# ba off) - (indexFloatArray# ba (off +# 1#)) - (indexFloatArray# ba (off +# 2#)) - {-# INLINE fromElems #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/FloatX4.hs b/src/Numeric/DataFrame/Internal/Array/Family/FloatX4.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/FloatX4.hs +++ /dev/null @@ -1,420 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.DataFrame.Internal.Array.Family.FloatX4 (FloatX4 (..)) where - - -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.DataFrame.SubSpace -import Numeric.Dimensions -import Numeric.PrimBytes - - -data FloatX4 = FloatX4# Float# Float# Float# Float# - - -instance Bounded FloatX4 where - maxBound = case inftyF of F# x -> FloatX4# x x x x - minBound = case negate inftyF of F# x -> FloatX4# x x x x - - -instance Show FloatX4 where - show (FloatX4# a1 a2 a3 a4) - = "{ " ++ show (F# a1) - ++ ", " ++ show (F# a2) - ++ ", " ++ show (F# a3) - ++ ", " ++ show (F# a4) - ++ " }" - - - -instance Eq FloatX4 where - - FloatX4# a1 a2 a3 a4 == FloatX4# b1 b2 b3 b4 = - isTrue# - ( (a1 `eqFloat#` b1) - `andI#` (a2 `eqFloat#` b2) - `andI#` (a3 `eqFloat#` b3) - `andI#` (a4 `eqFloat#` b4) - ) - {-# INLINE (==) #-} - - FloatX4# a1 a2 a3 a4 /= FloatX4# b1 b2 b3 b4 = - isTrue# - ( (a1 `neFloat#` b1) - `orI#` (a2 `neFloat#` b2) - `orI#` (a3 `neFloat#` b3) - `orI#` (a4 `neFloat#` b4) - ) - {-# INLINE (/=) #-} - - - --- | Implement partial ordering for `>`, `<`, `>=`, `<=` --- and lexicographical ordering for `compare` -instance Ord FloatX4 where - FloatX4# a1 a2 a3 a4 > FloatX4# b1 b2 b3 b4 = - isTrue# - ( (a1 `gtFloat#` b1) - `andI#` (a2 `gtFloat#` b2) - `andI#` (a3 `gtFloat#` b3) - `andI#` (a4 `gtFloat#` b4) - ) - {-# INLINE (>) #-} - - FloatX4# a1 a2 a3 a4 < FloatX4# b1 b2 b3 b4 = - isTrue# - ( (a1 `ltFloat#` b1) - `andI#` (a2 `ltFloat#` b2) - `andI#` (a3 `ltFloat#` b3) - `andI#` (a4 `ltFloat#` b4) - ) - {-# INLINE (<) #-} - - FloatX4# a1 a2 a3 a4 >= FloatX4# b1 b2 b3 b4 = - isTrue# - ( (a1 `geFloat#` b1) - `andI#` (a2 `geFloat#` b2) - `andI#` (a3 `geFloat#` b3) - `andI#` (a4 `geFloat#` b4) - ) - {-# INLINE (>=) #-} - - FloatX4# a1 a2 a3 a4 <= FloatX4# b1 b2 b3 b4 = - isTrue# - ( (a1 `leFloat#` b1) - `andI#` (a2 `leFloat#` b2) - `andI#` (a3 `leFloat#` b3) - `andI#` (a4 `leFloat#` b4) - ) - {-# INLINE (<=) #-} - - -- | Compare lexicographically - compare (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) - | isTrue# (a1 `gtFloat#` b1) = GT - | isTrue# (a1 `ltFloat#` b1) = LT - | isTrue# (a2 `gtFloat#` b2) = GT - | isTrue# (a2 `ltFloat#` b2) = LT - | isTrue# (a3 `gtFloat#` b3) = GT - | isTrue# (a3 `ltFloat#` b3) = LT - | isTrue# (a4 `gtFloat#` b4) = GT - | isTrue# (a4 `ltFloat#` b4) = LT - | otherwise = EQ - {-# INLINE compare #-} - - -- | Element-wise minimum - min (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) = FloatX4# - (if isTrue# (a1 `gtFloat#` b1) then b1 else a1) - (if isTrue# (a2 `gtFloat#` b2) then b2 else a2) - (if isTrue# (a3 `gtFloat#` b3) then b3 else a3) - (if isTrue# (a4 `gtFloat#` b4) then b4 else a4) - {-# INLINE min #-} - - -- | Element-wise maximum - max (FloatX4# a1 a2 a3 a4) (FloatX4# b1 b2 b3 b4) = FloatX4# - (if isTrue# (a1 `gtFloat#` b1) then a1 else b1) - (if isTrue# (a2 `gtFloat#` b2) then a2 else b2) - (if isTrue# (a3 `gtFloat#` b3) then a3 else b3) - (if isTrue# (a4 `gtFloat#` b4) then a4 else b4) - {-# INLINE max #-} - - - --- | element-wise operations for vectors -instance Num FloatX4 where - - FloatX4# a1 a2 a3 a4 + FloatX4# b1 b2 b3 b4 - = FloatX4# (plusFloat# a1 b1) (plusFloat# a2 b2) (plusFloat# a3 b3) (plusFloat# a4 b4) - {-# INLINE (+) #-} - - FloatX4# a1 a2 a3 a4 - FloatX4# b1 b2 b3 b4 - = FloatX4# (minusFloat# a1 b1) (minusFloat# a2 b2) (minusFloat# a3 b3) (minusFloat# a4 b4) - {-# INLINE (-) #-} - - FloatX4# a1 a2 a3 a4 * FloatX4# b1 b2 b3 b4 - = FloatX4# (timesFloat# a1 b1) (timesFloat# a2 b2) (timesFloat# a3 b3) (timesFloat# a4 b4) - {-# INLINE (*) #-} - - negate (FloatX4# a1 a2 a3 a4) = FloatX4# - (negateFloat# a1) (negateFloat# a2) (negateFloat# a3) (negateFloat# a4) - {-# INLINE negate #-} - - abs (FloatX4# a1 a2 a3 a4) - = FloatX4# - (if isTrue# (a1 `geFloat#` 0.0#) then a1 else negateFloat# a1) - (if isTrue# (a2 `geFloat#` 0.0#) then a2 else negateFloat# a2) - (if isTrue# (a3 `geFloat#` 0.0#) then a3 else negateFloat# a3) - (if isTrue# (a4 `geFloat#` 0.0#) then a4 else negateFloat# a4) - {-# INLINE abs #-} - - signum (FloatX4# a1 a2 a3 a4) - = FloatX4# (if isTrue# (a1 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a1 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a2 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a2 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a3 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a3 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - (if isTrue# (a4 `gtFloat#` 0.0#) - then 1.0# - else if isTrue# (a4 `ltFloat#` 0.0#) then -1.0# else 0.0# ) - {-# INLINE signum #-} - - fromInteger n = case fromInteger n of F# x -> FloatX4# x x x x - {-# INLINE fromInteger #-} - - - -instance Fractional FloatX4 where - - FloatX4# a1 a2 a3 a4 / FloatX4# b1 b2 b3 b4 = FloatX4# - (divideFloat# a1 b1) (divideFloat# a2 b2) (divideFloat# a3 b3) (divideFloat# a4 b4) - {-# INLINE (/) #-} - - recip (FloatX4# a1 a2 a3 a4) = FloatX4# - (divideFloat# 1.0# a1) (divideFloat# 1.0# a2) (divideFloat# 1.0# a3) (divideFloat# 1.0# a4) - {-# INLINE recip #-} - - fromRational r = case fromRational r of F# x -> FloatX4# x x x x - {-# INLINE fromRational #-} - - - -instance Floating FloatX4 where - - pi = FloatX4# - 3.141592653589793238# - 3.141592653589793238# - 3.141592653589793238# - 3.141592653589793238# - {-# INLINE pi #-} - - exp (FloatX4# a1 a2 a3 a4) = FloatX4# - (expFloat# a1) (expFloat# a2) (expFloat# a3) (expFloat# a4) - {-# INLINE exp #-} - - log (FloatX4# a1 a2 a3 a4) = FloatX4# - (logFloat# a1) (logFloat# a2) (logFloat# a3) (logFloat# a4) - {-# INLINE log #-} - - sqrt (FloatX4# a1 a2 a3 a4) = FloatX4# - (sqrtFloat# a1) (sqrtFloat# a2) (sqrtFloat# a3) (sqrtFloat# a4) - {-# INLINE sqrt #-} - - sin (FloatX4# a1 a2 a3 a4) = FloatX4# - (sinFloat# a1) (sinFloat# a2) (sinFloat# a3) (sinFloat# a4) - {-# INLINE sin #-} - - cos (FloatX4# a1 a2 a3 a4) = FloatX4# - (cosFloat# a1) (cosFloat# a2) (cosFloat# a3) (cosFloat# a4) - {-# INLINE cos #-} - - tan (FloatX4# a1 a2 a3 a4) = FloatX4# - (tanFloat# a1) (tanFloat# a2) (tanFloat# a3) (tanFloat# a4) - {-# INLINE tan #-} - - asin (FloatX4# a1 a2 a3 a4) = FloatX4# - (asinFloat# a1) (asinFloat# a2) (asinFloat# a3) (asinFloat# a4) - {-# INLINE asin #-} - - acos (FloatX4# a1 a2 a3 a4) = FloatX4# - (acosFloat# a1) (acosFloat# a2) (acosFloat# a3) (acosFloat# a4) - {-# INLINE acos #-} - - atan (FloatX4# a1 a2 a3 a4) = FloatX4# - (atanFloat# a1) (atanFloat# a2) (atanFloat# a3) (atanFloat# a4) - {-# INLINE atan #-} - - sinh (FloatX4# a1 a2 a3 a4) = FloatX4# - (sinhFloat# a1) (sinhFloat# a2) (sinhFloat# a3) (sinhFloat# a4) - {-# INLINE sinh #-} - - cosh (FloatX4# a1 a2 a3 a4) = FloatX4# - (coshFloat# a1) (coshFloat# a2) (coshFloat# a3) (coshFloat# a4) - {-# INLINE cosh #-} - - tanh (FloatX4# a1 a2 a3 a4) = FloatX4# - (tanhFloat# a1) (tanhFloat# a2) (tanhFloat# a3) (tanhFloat# a4) - {-# INLINE tanh #-} - - FloatX4# a1 a2 a3 a4 ** FloatX4# b1 b2 b3 b4 = FloatX4# - (powerFloat# a1 b1) (powerFloat# a2 b2) (powerFloat# a3 b3) (powerFloat# a4 b4) - {-# INLINE (**) #-} - - logBase x y = log y / log x - {-# INLINE logBase #-} - - asinh x = log (x + sqrt (1.0+x*x)) - {-# INLINE asinh #-} - - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - {-# INLINE acosh #-} - - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) - {-# INLINE atanh #-} - --- offset in bytes is S times bigger than offset in prim elements, --- when S is power of two, this is equal to shift -#define BOFF_TO_PRIMOFF(off) uncheckedIShiftRL# off 2# -#define ELEM_N 4 - -instance PrimBytes FloatX4 where - - getBytes (FloatX4# a1 a2 a3 a4) = case runRW# - ( \s0 -> case newByteArray# (byteSize @FloatX4 undefined) s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# a1 s1 of - s2 -> case writeFloatArray# marr 1# a2 s2 of - s3 -> case writeFloatArray# marr 2# a3 s3 of - s4 -> case writeFloatArray# marr 3# a4 s4 of - s5 -> unsafeFreezeByteArray# marr s5 - ) of (# _, a #) -> a - {-# INLINE getBytes #-} - - fromBytes off arr - | i <- BOFF_TO_PRIMOFF(off) - = FloatX4# - (indexFloatArray# arr i) - (indexFloatArray# arr (i +# 1#)) - (indexFloatArray# arr (i +# 2#)) - (indexFloatArray# arr (i +# 3#)) - {-# INLINE fromBytes #-} - - readBytes mba off s0 - | i <- BOFF_TO_PRIMOFF(off) - = case readFloatArray# mba i s0 of - (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> case readFloatArray# mba (i +# 3#) s3 of - (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) - {-# INLINE readBytes #-} - - writeBytes mba off (FloatX4# a1 a2 a3 a4) s - | i <- BOFF_TO_PRIMOFF(off) - = writeFloatArray# mba (i +# 3#) a4 - ( writeFloatArray# mba (i +# 2#) a3 - ( writeFloatArray# mba (i +# 1#) a2 - ( writeFloatArray# mba i a1 s ))) - {-# INLINE writeBytes #-} - - readAddr addr s0 - = case readFloatOffAddr# addr 0# s0 of - (# s1, a1 #) -> case readFloatOffAddr# addr 1# s1 of - (# s2, a2 #) -> case readFloatOffAddr# addr 2# s2 of - (# s3, a3 #) -> case readFloatOffAddr# addr 3# s3 of - (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) - {-# INLINE readAddr #-} - - writeAddr (FloatX4# a1 a2 a3 a4) addr s - = writeFloatOffAddr# addr 3# a4 - ( writeFloatOffAddr# addr 2# a3 - ( writeFloatOffAddr# addr 1# a2 - ( writeFloatOffAddr# addr 0# a1 s ))) - {-# INLINE writeAddr #-} - - byteSize _ = byteSize @Float undefined *# ELEM_N# - {-# INLINE byteSize #-} - - byteAlign _ = byteAlign @Float undefined - {-# INLINE byteAlign #-} - - byteOffset _ = 0# - {-# INLINE byteOffset #-} - - indexArray ba off - | i <- off *# ELEM_N# - = FloatX4# - (indexFloatArray# ba i) - (indexFloatArray# ba (i +# 1#)) - (indexFloatArray# ba (i +# 2#)) - (indexFloatArray# ba (i +# 3#)) - {-# INLINE indexArray #-} - - readArray mba off s0 - | i <- off *# ELEM_N# - = case readFloatArray# mba i s0 of - (# s1, a1 #) -> case readFloatArray# mba (i +# 1#) s1 of - (# s2, a2 #) -> case readFloatArray# mba (i +# 2#) s2 of - (# s3, a3 #) -> case readFloatArray# mba (i +# 3#) s3 of - (# s4, a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) - {-# INLINE readArray #-} - - writeArray mba off (FloatX4# a1 a2 a3 a4) s - | i <- off *# ELEM_N# - = writeFloatArray# mba (i +# 3#) a4 - ( writeFloatArray# mba (i +# 2#) a3 - ( writeFloatArray# mba (i +# 1#) a2 - ( writeFloatArray# mba i a1 s ))) - {-# INLINE writeArray #-} - - -instance PrimArray Float FloatX4 where - - broadcast (F# x) = FloatX4# x x x x - {-# INLINE broadcast #-} - - ix# 0# (FloatX4# a1 _ _ _) = F# a1 - ix# 1# (FloatX4# _ a2 _ _) = F# a2 - ix# 2# (FloatX4# _ _ a3 _) = F# a3 - ix# 3# (FloatX4# _ _ _ a4) = F# a4 - ix# _ _ = undefined - {-# INLINE ix# #-} - - gen# _ f s0 = case f s0 of - (# s1, F# a1 #) -> case f s1 of - (# s2, F# a2 #) -> case f s2 of - (# s3, F# a3 #) -> case f s3 of - (# s4, F# a4 #) -> (# s4, FloatX4# a1 a2 a3 a4 #) - - - upd# _ 0# (F# q) (FloatX4# _ y z w) = FloatX4# q y z w - upd# _ 1# (F# q) (FloatX4# x _ z w) = FloatX4# x q z w - upd# _ 2# (F# q) (FloatX4# x y _ w) = FloatX4# x y q w - upd# _ 3# (F# q) (FloatX4# x y z _) = FloatX4# x y z q - upd# _ _ _ x = x - {-# INLINE upd# #-} - - elemOffset _ = 0# - {-# INLINE elemOffset #-} - - elemSize0 _ = ELEM_N# - {-# INLINE elemSize0 #-} - - fromElems off _ ba = FloatX4# - (indexFloatArray# ba off) - (indexFloatArray# ba (off +# 1#)) - (indexFloatArray# ba (off +# 2#)) - (indexFloatArray# ba (off +# 3#)) - {-# INLINE fromElems #-} - - --------------------------------------------------------------------------------- --- Rewrite rules to improve efficiency of algorithms --- --- Here we don't have access to DataFrame constructors, because we cannot import --- Numeric.DataFrame.Type module. --- However, we know that all DataFrame instances are just newtype wrappers --- (as well as Scalar). Thus, we can use unsafeCoerce# to get access to Arrays --- inside DataFrames. --- --------------------------------------------------------------------------------- - -getIdxOffset :: Idxs '[4] -> Int# -getIdxOffset is = case unsafeCoerce# is of - [W# i] -> word2Int# i -# 1# - _ -> 0# -{-# INLINE getIdxOffset #-} - - -{-# RULES -"index/FloatX4" forall i . (!.) @Float @'[] i - = unsafeCoerce# (ix# @Float @FloatX4 (getIdxOffset i)) - - #-} diff --git a/src/Numeric/DataFrame/Internal/Array/Family/ScalarBase.hs b/src/Numeric/DataFrame/Internal/Array/Family/ScalarBase.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/Family/ScalarBase.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedTuples #-} -module Numeric.DataFrame.Internal.Array.Family.ScalarBase (ScalarBase (..)) where - - -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.PrimBytes - --- | Specialize ScalarBase type without any arrays -newtype ScalarBase t = ScalarBase { _unScalarBase :: t } - deriving ( Enum, Eq, Integral - , Num, Fractional, Floating, Ord, Read, Real, RealFrac, RealFloat - , PrimBytes) - -instance Show t => Show (ScalarBase t) where - show (ScalarBase t) = "{ " ++ show t ++ " }" - -deriving instance {-# OVERLAPPABLE #-} Bounded t => Bounded (ScalarBase t) -instance {-# OVERLAPPING #-} Bounded (ScalarBase Double) where - maxBound = ScalarBase inftyD - minBound = ScalarBase $ negate inftyD -instance {-# OVERLAPPING #-} Bounded (ScalarBase Float) where - maxBound = ScalarBase inftyF - minBound = ScalarBase $ negate inftyF - -instance PrimBytes t => PrimArray t (ScalarBase t) where - broadcast = unsafeCoerce# - {-# INLINE broadcast #-} - ix# _ = unsafeCoerce# - {-# INLINE ix# #-} - gen# _ = unsafeCoerce# - {-# INLINE gen# #-} - upd# _ 0# = const . ScalarBase - upd# _ _ = const id - {-# INLINE upd# #-} - elemOffset _ = 0# - {-# INLINE elemOffset #-} - elemSize0 _ = 1# - {-# INLINE elemSize0 #-} - fromElems off _ ba = indexArray ba off - {-# INLINE fromElems #-} - -_suppressHlintUnboxedTuplesWarning :: () -> (# (), () #) -_suppressHlintUnboxedTuplesWarning = undefined diff --git a/src/Numeric/DataFrame/Internal/Array/PrimOps.hs b/src/Numeric/DataFrame/Internal/Array/PrimOps.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Internal/Array/PrimOps.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE UnboxedTuples #-} --- | Internal primitive functions shared across modules -module Numeric.DataFrame.Internal.Array.PrimOps where - -import GHC.Base -import Numeric.Dimensions - -inftyD :: Double -inftyD = read "Infinity" -{-# INLINE inftyD #-} - -inftyF :: Float -inftyF = read "Infinity" -{-# INLINE inftyF #-} - - - -minInt# :: Int# -> Int# -> Int# -minInt# a b | isTrue# (a ># b) = b - | otherwise = a -{-# INLINE minInt# #-} - - -loop# :: Int# -- ^ initial value - -> Int# -- ^ step - -> Int# -- ^ final value (LESS THAN condition) - -> (Int# -> State# s -> State# s) -> State# s -> State# s -loop# n0 di n1 f = loop0 n0 - where - loop0 i s | isTrue# (i >=# n1) = s - | otherwise = loop0 (i +# di) (f i s) -{-# INLINE loop# #-} - - --- | Loop with given increment, plus keep the step number --- in the first argument of the iterated function -loopWithI# :: Int# -- ^ initial value - -> Int# -- ^ step - -> Int# -- ^ final value (LESS THAN condition) - -> (Int# -> Int# -> State# s -> State# s) -> State# s -> State# s -loopWithI# n0 di n1 f = loop0 0# n0 - where - loop0 j i s | isTrue# (i >=# n1) = s - | otherwise = loop0 (j +# 1#) (i +# di) (f j i s) -{-# INLINE loopWithI# #-} - - --- | Do something in a loop for int i from 0 to (n-1) -loop1# :: Int# -> (Int# -> State# s -> State# s) -> State# s -> State# s -loop1# n f = loop0 0# - where - loop0 i s | isTrue# (i ==# n) = s - | otherwise = loop0 (i +# 1#) (f i s) -{-# INLINE loop1# #-} - --- | Do something in a loop for int i from 0 to (n-1) -loop1a# :: Int# -> (Int# -> a -> a) -> a -> a -loop1a# n f = loop0 0# - where - loop0 i s | isTrue# (i ==# n) = s - | otherwise = s `seq` case f i s of s1 -> s1 `seq` loop0 (i +# 1#) s1 -{-# INLINE loop1a# #-} - - --- | Same as overDim#, but with no return value -overDim_# :: Dims (ds :: [k]) - -> (Idxs ds -> Int# -> State# s -> State# s) -- ^ function to map over each dimension - -> Int# -- ^ Initial offset - -> Int# -- ^ offset step - -> State# s - -> State# s -overDim_# ds f off0# step# s0 = case overDim_'# ds g off0# s0 of - (# s1, _ #) -> s1 - where - g i off# s = (# f i off# s, off# +# step# #) -{-# INLINE overDim_# #-} - - -overDim_'# :: Dims (ds :: [k]) - -> (Idxs ds -> Int# -> State# s -> (# State# s, Int# #)) -- ^ function to map over each dimension - -> Int# -- ^ Initial offset - -> State# s - -> (# State# s, Int# #) -overDim_'# U f = f U -overDim_'# (d :* ds) f = overDim_'# ds (loop 1) - where - n = dimVal d - loop i js off# s | i > n = (# s , off# #) - | otherwise = case f (Idx i :* js) off# s of - (# s', off1# #) -> loop (i+1) js off1# s' diff --git a/src/Numeric/DataFrame/Internal/Backend.hs b/src/Numeric/DataFrame/Internal/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Backend.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#if defined(__HADDOCK__) || defined(__HADDOCK_VERSION__) +{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-} +#else +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +#endif + +module Numeric.DataFrame.Internal.Backend + ( DFBackend, Backend (..), BackendFamily, KnownBackend () + , inferKnownBackend, inferPrimElem + -- * Auto-deriving instances + , inferEq, inferOrd + , inferProductOrder, inferPONonTransitive, inferPOPartial + , inferBounded, inferNum + , inferFractional, inferFloating + , inferPrimBytes, inferPrimArray + ) where + + +import Data.Constraint +import Data.Constraint.Deriving +import Data.Constraint.Unsafe +import Data.Kind (Type) +import Unsafe.Coerce (unsafeCoerce) + +import Numeric.DataFrame.Internal.PrimArray +import Numeric.Dimensions +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + +import Numeric.DataFrame.Internal.Backend.Family (BackendFamily) +import qualified Numeric.DataFrame.Internal.Backend.Family as Impl (KnownBackend, + inferBackendInstance, + inferKnownBackend, + inferPrimArray, + inferPrimElem) +import Numeric.DataFrame.Internal.BackendI (I) + +-- | Implementation behind the DataFrame +type DFBackend (t :: Type) (ds :: [Nat]) = Backend I t ds (BackendFamily t ds) + +-- | Backend resolver: +-- Use this constraint to find any class instances defined for all DataFrame implementations, +-- e.g. @Num@, @PrimBytes@, etc. +type KnownBackend (t :: Type) (ds :: [Nat]) = Impl.KnownBackend t ds (BackendFamily t ds) + +-- | A newtype wrapper for all DataFrame implementations. +-- I need two layers of wrappers to provide default overlappable instances to +-- all type classes using KnownBackend mechanics. +-- Type arguments are redundant here; +-- nevertheless, they improve readability of error messages. +newtype Backend (i :: Type) (t :: Type) (ds :: [Nat]) (backend :: Type) + = Backend { _getBackend :: backend } +type role Backend phantom phantom phantom representational +type instance DeriveContext (Backend I t ds b) = b ~ BackendFamily t ds +-- When typechecker knows what the third parameter @b@ is, no instances overlap, +-- because @b@ is always always a concrete type. +-- The "dynamic instances" derived via ToInstance have to be incoherent, +-- because @BackendFamily t ds@ as a type family (before resolving it) +-- is no more conrete than just @b@. +{-# ANN type Backend (DeriveAll' NoOverlap ["KnownBackend"]) #-} + + + +inferKnownBackend + :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions ds) + => Dict (KnownBackend t ds) +inferKnownBackend + = Impl.inferKnownBackend @t @ds @(BackendFamily t ds) + +inferPrimElem + :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) + . KnownBackend t (d ': ds) + => DFBackend t (d ': ds) -> Dict (PrimBytes t) +inferPrimElem = Impl.inferPrimElem @t @d @ds . _getBackend + + + +inferEq + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Eq t, Impl.KnownBackend t ds b) + => Dict (Eq (Backend I t ds b)) +inferEq + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferOrd + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (Backend I t ds b)) +inferOrd + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferProductOrder + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (ProductOrder (Backend I t ds b)) +inferProductOrder + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferPONonTransitive + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (NonTransitive.ProductOrd (Backend I t ds b))) +inferPONonTransitive + = mapDict (unsafeDerive NonTransitive.ProductOrd) + . mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferPOPartial + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (Partial.ProductOrd (Backend I t ds b))) +inferPOPartial + = mapDict (unsafeDerive Partial.ProductOrd) + . mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferBounded + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Bounded t, Impl.KnownBackend t ds b) + => Dict (Bounded (Backend I t ds b)) +inferBounded + -- Here is an ugly trick: + -- We don't have instance of @Bounded Float@ and @Bounded Double@. + -- However, we want to have an instance @Bounded t => Bounded (Backend t ds b)@. + -- Some specialized implementations (e.g. FloatX4) require explicit + -- constraints @Bounded Float@ or @Bounded Double@. + -- To satisfy these, I pull @Bounded t@ convincing the compiler that @t ~ Float@. + -- This should work fine even if a user implements instances of Bounded for + -- the floating types, because we know that @t ~ Float@ or @t ~ Double@ + -- automatically whenever this instance is called for these types. + | Dict <- (case (unsafeCoerce (Dict @(t ~ t)) :: Dict (t ~ Float)) of + Dict -> Dict) :: Dict (Bounded Float) + , Dict <- (case (unsafeCoerce (Dict @(t ~ t)) :: Dict (t ~ Double)) of + Dict -> Dict) :: Dict (Bounded Double) + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferNum + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Num t, Impl.KnownBackend t ds b) + => Dict (Num (Backend I t ds b)) +inferNum + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferFractional + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Fractional t, Impl.KnownBackend t ds b) + => Dict (Fractional (Backend I t ds b)) +inferFractional + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferFloating + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Floating t, Impl.KnownBackend t ds b) + => Dict (Floating (Backend I t ds b)) +inferFloating + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + + +inferPrimBytes + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (PrimBytes t, Dimensions ds, Impl.KnownBackend t ds b) + => Dict (PrimBytes (Backend I t ds b)) +inferPrimBytes + = mapDict toBackend + . mapDict (Sub (Impl.inferBackendInstance @t @ds)) + $ inferDeriveContext @t @ds @b undefined + +inferPrimArray + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (PrimBytes t, Impl.KnownBackend t ds b) + => Dict (PrimArray t (Backend I t ds b)) +inferPrimArray + = mapDict toBackend + . mapDict (Sub (Impl.inferPrimArray @t @ds)) + $ inferDeriveContext @t @ds @b undefined + + +-- This is the rule that cannot be encoded in the type system, but enforced +-- as an invariant: Backend t ds b implies DeriveContext t ds b +inferDeriveContext :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . Backend I t ds b + -> Dict (DeriveContext (Backend I t ds b)) +inferDeriveContext _ = unsafeCoerce (Dict :: Dict (b ~ b)) +{-# INLINE inferDeriveContext #-} + +-- Backend is the newtype wrapper over b. +-- It has the same represenation and I expect it to have the same instance behavior. +toBackend :: forall c t ds b . c b :- c (Backend I t ds b) +toBackend = unsafeDerive Backend +{-# INLINE toBackend #-} diff --git a/src/Numeric/DataFrame/Internal/Backend.hs-boot b/src/Numeric/DataFrame/Internal/Backend.hs-boot new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/Backend.hs-boot @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeOperators #-} +#if defined(__HADDOCK__) || defined(__HADDOCK_VERSION__) +{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-} +#endif + +module Numeric.DataFrame.Internal.Backend + ( DFBackend, Backend (..), BackendFamily, KnownBackend () + , inferKnownBackend, inferPrimElem + -- * Auto-deriving instances + , inferEq, inferOrd + , inferProductOrder, inferPONonTransitive, inferPOPartial + , inferBounded, inferNum + , inferFractional, inferFloating + , inferPrimBytes, inferPrimArray + ) where + +import Data.Kind (Type) +import Numeric.DataFrame.Internal.PrimArray (PrimArray) +import Numeric.Dimensions (Dict, Dimensions, Nat) +import Numeric.PrimBytes (PrimBytes) +import Numeric.ProductOrd (ProductOrder) +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + +import {-# SOURCE #-} Numeric.DataFrame.Internal.Backend.Family (BackendFamily) +import {-# SOURCE #-} qualified Numeric.DataFrame.Internal.Backend.Family as Impl + (KnownBackend) +import {-# SOURCE #-} Numeric.DataFrame.Internal.BackendI (I) + +-- | Implementation behind the DataFrame +type DFBackend (t :: Type) (ds :: [Nat]) = Backend I t ds (BackendFamily t ds) + +-- | Backend resolver: +-- Use this constraint to find any class instances defined for all DataFrame implementations, +-- e.g. @Num@, @PrimBytes@, etc. +type KnownBackend (t :: Type) (ds :: [Nat]) = Impl.KnownBackend t ds (BackendFamily t ds) + +-- | A newtype wrapper for all DataFrame implementations. +-- I need two layers of wrappers to provide default overlappable instances to +-- all type classes using KnownBackend mechanics. +-- Type arguments are redundant here; +-- nevertheless, they improve readability of error messages. +newtype Backend (i :: Type) (t :: Type) (ds :: [Nat]) (backend :: Type) + = Backend { _getBackend :: backend } +type role Backend phantom phantom phantom representational + +inferKnownBackend + :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions ds) + => Dict (KnownBackend t ds) + +inferPrimElem + :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) + . KnownBackend t (d ': ds) + => DFBackend t (d ': ds) -> Dict (PrimBytes t) + +inferEq + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Eq t, Impl.KnownBackend t ds b) + => Dict (Eq (Backend I t ds b)) + +inferOrd + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (Backend I t ds b)) + +inferProductOrder + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (ProductOrder (Backend I t ds b)) + +inferPONonTransitive + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (NonTransitive.ProductOrd (Backend I t ds b))) + +inferPOPartial + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (Partial.ProductOrd (Backend I t ds b))) + +inferBounded + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Bounded t, Impl.KnownBackend t ds b) + => Dict (Bounded (Backend I t ds b)) + +inferNum + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Num t, Impl.KnownBackend t ds b) + => Dict (Num (Backend I t ds b)) + +inferFractional + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Fractional t, Impl.KnownBackend t ds b) + => Dict (Fractional (Backend I t ds b)) + +inferFloating + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Floating t, Impl.KnownBackend t ds b) + => Dict (Floating (Backend I t ds b)) + +inferPrimBytes + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (PrimBytes t, Dimensions ds, Impl.KnownBackend t ds b) + => Dict (PrimBytes (Backend I t ds b)) + +inferPrimArray + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (PrimBytes t, Impl.KnownBackend t ds b) + => Dict (PrimArray t (Backend I t ds b)) diff --git a/src/Numeric/DataFrame/Internal/BackendI.hs b/src/Numeric/DataFrame/Internal/BackendI.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/BackendI.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +#if defined(__HADDOCK__) || defined(__HADDOCK_VERSION__) +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} +{-# OPTIONS_GHC -fno-warn-deferred-type-errors #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-} +#else +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +#endif + +module Numeric.DataFrame.Internal.BackendI + ( I + , inferEq, inferOrd + , inferProductOrder, inferPONonTransitive, inferPOPartial + , inferBounded, inferNum + , inferFractional, inferFloating + , inferPrimBytes, inferPrimArray + ) where + + + +import Data.Constraint.Deriving (OverlapMode (..), + ToInstance (..)) +import Data.Kind (Type) +import Numeric.DataFrame.Internal.PrimArray (PrimArray) +import Numeric.Dimensions (Dict, Dimensions, Nat) +import Numeric.PrimBytes (PrimBytes) +import Numeric.ProductOrd (ProductOrder) +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial + +import {-# SOURCE #-} Numeric.DataFrame.Internal.Backend (Backend) +import {-# SOURCE #-} qualified Numeric.DataFrame.Internal.Backend as Backend +import {-# SOURCE #-} qualified Numeric.DataFrame.Internal.Backend.Family as Impl + + + +{- | The instance keeper for the `Backend` type. + + Using this data as a tag to the `Backend` type allows to define `Backend` instances + in two different modules without any orphans. + + -} +data I + + +{-# ANN inferEq (ToInstance Incoherent) #-} +inferEq + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Eq t, Impl.KnownBackend t ds b) + => Dict (Eq (Backend I t ds b)) +inferEq = Backend.inferEq @t @ds @b + +{-# ANN inferOrd (ToInstance Incoherent) #-} +inferOrd + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (Backend I t ds b)) +inferOrd = Backend.inferOrd @t @ds @b + +{-# ANN inferProductOrder (ToInstance Incoherent) #-} +inferProductOrder + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (ProductOrder (Backend I t ds b)) +inferProductOrder = Backend.inferProductOrder @t @ds @b + +{-# ANN inferPONonTransitive (ToInstance Incoherent) #-} +inferPONonTransitive + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (NonTransitive.ProductOrd (Backend I t ds b))) +inferPONonTransitive = Backend.inferPONonTransitive @t @ds @b + +{-# ANN inferPOPartial (ToInstance Incoherent) #-} +inferPOPartial + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Dict (Ord (Partial.ProductOrd (Backend I t ds b))) +inferPOPartial = Backend.inferPOPartial @t @ds @b + +{-# ANN inferBounded (ToInstance Incoherent) #-} +inferBounded + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Bounded t, Impl.KnownBackend t ds b) + => Dict (Bounded (Backend I t ds b)) +inferBounded = Backend.inferBounded @t @ds @b + +{-# ANN inferNum (ToInstance Incoherent) #-} +inferNum + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Num t, Impl.KnownBackend t ds b) + => Dict (Num (Backend I t ds b)) +inferNum = Backend.inferNum @t @ds @b + +{-# ANN inferFractional (ToInstance Incoherent) #-} +inferFractional + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Fractional t, Impl.KnownBackend t ds b) + => Dict (Fractional (Backend I t ds b)) +inferFractional = Backend.inferFractional @t @ds @b + +{-# ANN inferFloating (ToInstance Incoherent) #-} +inferFloating + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Floating t, Impl.KnownBackend t ds b) + => Dict (Floating (Backend I t ds b)) +inferFloating = Backend.inferFloating @t @ds @b + +{-# ANN inferPrimBytes (ToInstance Incoherent) #-} +inferPrimBytes + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (PrimBytes t, Dimensions ds, Impl.KnownBackend t ds b) + => Dict (PrimBytes (Backend I t ds b)) +inferPrimBytes = Backend.inferPrimBytes @t @ds @b + +{-# ANN inferPrimArray (ToInstance Incoherent) #-} +inferPrimArray + :: forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (PrimBytes t, Impl.KnownBackend t ds b) + => Dict (PrimArray t (Backend I t ds b)) +inferPrimArray = Backend.inferPrimArray @t @ds @b + + + +-- The instances below are bumb stubs needed only to compile haddock +#if defined(__HADDOCK__) || defined(__HADDOCK_VERSION__) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Eq t, Impl.KnownBackend t ds b) + => Eq (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Ord (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => ProductOrder (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Ord (NonTransitive.ProductOrd (Backend I t ds b)) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Ord t, Impl.KnownBackend t ds b) + => Ord (Partial.ProductOrd (Backend I t ds b)) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Bounded t, Impl.KnownBackend t ds b) + => Bounded (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Num t, Impl.KnownBackend t ds b) + => Num (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Fractional t, Impl.KnownBackend t ds b) + => Fractional (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . (Floating t, Impl.KnownBackend t ds b) + => Floating (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . ( PrimBytes t + , Dimensions ds + , Impl.KnownBackend t ds b + ) + => PrimBytes (Backend I t ds b) + +instance + forall (t :: Type) (ds :: [Nat]) (b :: Type) + . ( PrimBytes t + , Impl.KnownBackend t ds b + ) + => PrimArray t (Backend I t ds b) + +#endif diff --git a/src/Numeric/DataFrame/Internal/BackendI.hs-boot b/src/Numeric/DataFrame/Internal/BackendI.hs-boot new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/BackendI.hs-boot @@ -0,0 +1,9 @@ +module Numeric.DataFrame.Internal.BackendI (I) where + +{- | The instance keeper for the `Backend` type. + + Using this data as a tag to the `Backend` type allows to define `Backend` instances + in two different modules without any orphans. + + -} +data I diff --git a/src/Numeric/DataFrame/Internal/Mutable.hs b/src/Numeric/DataFrame/Internal/Mutable.hs --- a/src/Numeric/DataFrame/Internal/Mutable.hs +++ b/src/Numeric/DataFrame/Internal/Mutable.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} @@ -11,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.DataFrame.Internal.Mutable @@ -27,6 +27,7 @@ ( MDataFrame () , newDataFrame#, newPinnedDataFrame# , copyDataFrame#, copyMDataFrame# + , copyDataFrame'#, copyMDataFrame'# , freezeDataFrame#, unsafeFreezeDataFrame# , thawDataFrame#, thawPinDataFrame#, unsafeThawDataFrame# , writeDataFrame#, writeDataFrameOff# @@ -35,17 +36,17 @@ ) where -import GHC.Base -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Type -import Numeric.Dimensions -import Numeric.PrimBytes +import GHC.Base +import Numeric.DataFrame.Internal.PrimArray +import Numeric.DataFrame.Type +import Numeric.Dimensions +import Numeric.PrimBytes -- | Mutable DataFrame type. -- Keeps element offset, number of elements, and a mutable byte storage data MDataFrame s t (ns :: [Nat]) - = MDataFrame# Int# Int# (MutableByteArray# s) + = MDataFrame# Int# CumulDims (MutableByteArray# s) -- | Create a new mutable DataFrame. @@ -53,10 +54,10 @@ . ( PrimBytes t, Dimensions ns) => State# s -> (# State# s, MDataFrame s t ns #) newDataFrame# s0 - | W# nw <- totalDim' @ns - , n <- word2Int# nw + | steps <- cumulDims $ dims @ns + , n <- cdTotalDim# steps , (# s1, mba #) <- newByteArray# (n *# byteSize @t undefined) s0 - = (# s1, MDataFrame# 0# n mba #) + = (# s1, MDataFrame# 0# steps mba #) {-# INLINE newDataFrame# #-} -- | Create a new mutable DataFrame. @@ -64,109 +65,163 @@ . ( PrimBytes t, Dimensions ns) => State# s -> (# State# s, MDataFrame s t ns #) newPinnedDataFrame# s0 - | W# nw <- totalDim' @ns - , n <- word2Int# nw + | steps <- cumulDims $ dims @ns + , n <- cdTotalDim# steps , (# s1, mba #) <- newAlignedPinnedByteArray# (n *# byteSize @t undefined) (byteAlign @t undefined) s0 - = (# s1, MDataFrame# 0# n mba #) + = (# s1, MDataFrame# 0# steps mba #) {-# INLINE newPinnedDataFrame# #-} -- | Copy one DataFrame into another mutable DataFrame at specified position. -copyDataFrame# :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) - (bs :: [Nat]) (asbs :: [Nat]) s - . ( PrimBytes t - , PrimBytes (DataFrame t (as +: b')) +-- +-- In contrast to @copyDataFrame'@, this function allows to copy over a range of contiguous +-- indices over a single dimension. +-- For example, you can write a 3x4 matrix into a 7x4 matrix, starting at indices 0..3. +copyDataFrame# :: forall (t :: Type) + (b :: Nat) (bi :: Nat) (bd :: Nat) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( b ~ (bi + bd - 1) + , PrimBytes t + , PrimBytes (DataFrame t (bd :+ bs)) , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) ) - => DataFrame t (as +: b') -> Idxs (b :+ bs) -> MDataFrame s t asbs + => Idxs (as +: bi) -> DataFrame t (bd :+ bs) -> MDataFrame s t asbs -> State# s -> (# State# s, () #) -copyDataFrame# df ei (MDataFrame# off _ mba) s - | I# i <- fromEnum ei +copyDataFrame# ei df (MDataFrame# off steps mba) s + | I# i <- cdIx steps ei = (# writeBytes mba ((off +# i) *# byteSize @t undefined) df s, () #) {-# INLINE copyDataFrame# #-} + +{-# ANN copyMDataFrame# "HLint: ignore Use camelCase" #-} -- | Copy one mutable DataFrame into another mutable DataFrame at specified position. -copyMDataFrame# :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) - (bs :: [Nat]) (asbs :: [Nat]) s - . ( PrimBytes t +-- +-- In contrast to @copyMDataFrame'@, this function allows to copy over a range of contiguous +-- indices over a single dimension. +-- For example, you can write a 3x4 matrix into a 7x4 matrix, starting at indices 0..3. +copyMDataFrame# :: forall (t :: Type) + (b :: Nat) (bi :: Nat) (bd :: Nat) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( b ~ (bi + bd - 1) + , PrimBytes t , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) ) - => MDataFrame s t (as +: b') -> Idxs (b :+ bs) -> MDataFrame s t asbs + => Idxs (as +: bi) -> MDataFrame s t (bd :+ bs) -> MDataFrame s t asbs -> State# s -> (# State# s, () #) -copyMDataFrame# (MDataFrame# offA lenA arrA) ei (MDataFrame# offM _ arrM) s + -- all information for copying in this case is taken from the inside + -- of the data types at the term level; + -- steps zips with indices just fine independently of their types + -- and length. + -- Thus, it's fine here to just unsafeCoerce# an index. +copyMDataFrame# ei df = + copyMDataFrame'# + (unsafeCoerce# ei :: Idxs as) + (unsafeCoerce# df :: MDataFrame s t (b :+ bs)) +{-# INLINE copyMDataFrame# #-} + +{-# ANN copyDataFrame'# "HLint: ignore Use camelCase" #-} +-- | Copy one DataFrame into another mutable DataFrame at specified position. +-- +-- This is a simpler version of @copyDataFrame@ that allows to copy over one index at a time. +copyDataFrame'# :: forall (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t + , PrimBytes (DataFrame t bs) + , ConcatList as bs asbs + ) + => Idxs as -> DataFrame t bs -> MDataFrame s t asbs + -> State# s -> (# State# s, () #) +copyDataFrame'# ei df (MDataFrame# off steps mba) s + | I# i <- cdIx steps ei + = (# writeBytes mba ((off +# i) *# byteSize @t undefined) df s, () #) +{-# INLINE copyDataFrame'# #-} + +{-# ANN copyMDataFrame'# "HLint: ignore Use camelCase" #-} +-- | Copy one mutable DataFrame into another mutable DataFrame at specified position. +-- +-- This is a simpler version of @copyMDataFrame@ that allows to copy over one index at a time. +copyMDataFrame'# :: forall (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t + , ConcatList as bs asbs + ) + => Idxs as -> MDataFrame s t bs -> MDataFrame s t asbs + -> State# s -> (# State# s, () #) +copyMDataFrame'# ei (MDataFrame# offA stepsA arrA) (MDataFrame# offM stepsM arrM) s | elS <- byteSize @t undefined - , I# i <- fromEnum ei + , lenA <- cdTotalDim# stepsA + , I# i <- cdIx stepsM ei = (# copyMutableByteArray# arrA (offA *# elS) arrM ((offM +# i) *# elS) (lenA *# elS) s , () #) -{-# INLINE copyMDataFrame# #-} +{-# INLINE copyMDataFrame'# #-} -- | Make a mutable DataFrame immutable, without copying. unsafeFreezeDataFrame# :: forall (t :: Type) (ns :: [Nat]) s . PrimArray t (DataFrame t ns) => MDataFrame s t ns -> State# s -> (# State# s, DataFrame t ns #) -unsafeFreezeDataFrame# (MDataFrame# offM lenM arrM) s1 +unsafeFreezeDataFrame# (MDataFrame# offM steps arrM) s1 | (# s2, arrA #) <- unsafeFreezeByteArray# arrM s1 - = (# s2, fromElems offM lenM arrA #) + = (# s2, fromElems steps offM arrA #) {-# INLINE unsafeFreezeDataFrame# #-} -- | Copy content of a mutable DataFrame into a new immutable DataFrame. freezeDataFrame# :: forall (t :: Type) (ns :: [Nat]) s . PrimArray t (DataFrame t ns) => MDataFrame s t ns -> State# s -> (# State# s, DataFrame t ns #) -freezeDataFrame# (MDataFrame# offM n arrM) s0 +freezeDataFrame# (MDataFrame# offM steps arrM) s0 | elS <- byteSize @t undefined + , n <- cdTotalDim# steps , (# s1, mba #) <- newByteArray# (n *# elS) s0 , s2 <- copyMutableByteArray# arrM (offM *# elS) mba 0# (n *# elS) s1 , (# s3, arrA #) <- unsafeFreezeByteArray# mba s2 - = (# s3, fromElems 0# n arrA #) + = (# s3, fromElems steps 0# arrA #) {-# INLINE freezeDataFrame# #-} -- | Create a new mutable DataFrame and copy content of immutable one in there. thawDataFrame# :: forall (t :: Type) (ns :: [Nat]) s - . (PrimBytes (DataFrame t ns), PrimBytes t) + . ( Dimensions ns + , PrimBytes (DataFrame t ns)) => DataFrame t ns -> State# s -> (# State# s, MDataFrame s t ns #) thawDataFrame# df s0 - | elS <- byteSize @t undefined - , arrA <- getBytes df - , boff <- byteOffset df + | arrA <- getBytes df + , boff <- byteOffset df , bsize <- byteSize df + , steps <- cumulDims $ dims @ns , (# s1, arrM #) <- newByteArray# bsize s0 , s2 <- copyByteArray# arrA boff arrM 0# bsize s1 - = (# s2, MDataFrame# 0# (quotInt# bsize elS) arrM #) + = (# s2, MDataFrame# 0# steps arrM #) {-# INLINE thawDataFrame# #-} -- | Create a new mutable DataFrame and copy content of immutable one in there. -- The result array is pinned and aligned. thawPinDataFrame# :: forall (t :: Type) (ns :: [Nat]) s - . (PrimBytes (DataFrame t ns), PrimBytes t) + . ( Dimensions ns + , PrimBytes (DataFrame t ns)) => DataFrame t ns -> State# s -> (# State# s, MDataFrame s t ns #) thawPinDataFrame# df s0 - | elS <- byteSize @t undefined - , arrA <- getBytes df - , boff <- byteOffset df + | arrA <- getBytes df + , boff <- byteOffset df , bsize <- byteSize df + , steps <- cumulDims $ dims @ns , (# s1, arrM #) <- newAlignedPinnedByteArray# bsize (byteAlign df) s0 , s2 <- copyByteArray# arrA boff arrM 0# bsize s1 - = (# s2, MDataFrame# 0# (quotInt# bsize elS) arrM #) + = (# s2, MDataFrame# 0# steps arrM #) {-# INLINE thawPinDataFrame# #-} -- | UnsafeCoerces an underlying byte array. unsafeThawDataFrame# :: forall (t :: Type) (ns :: [Nat]) s - . (PrimBytes (DataFrame t ns), PrimBytes t) + . ( Dimensions ns + , PrimBytes (DataFrame t ns), PrimBytes t) => DataFrame t ns -> State# s -> (# State# s, MDataFrame s t ns #) unsafeThawDataFrame# df s0 | elS <- byteSize @t undefined - , arrA <- getBytes df + , arrA <- getBytes df , boff <- byteOffset df - , bsize <- byteSize df + , steps <- cumulDims $ dims @ns = (# s0 - , MDataFrame# (quotInt# boff elS) (quotInt# bsize elS) (unsafeCoerce# arrA) + , MDataFrame# (quotInt# boff elS) steps (unsafeCoerce# arrA) #) {-# INLINE unsafeThawDataFrame# #-} @@ -181,9 +236,10 @@ -- | Write a single element at the specified index writeDataFrame# :: forall (t :: Type) (ns :: [Nat]) s - . ( PrimBytes t, Dimensions ns ) + . PrimBytes t => MDataFrame s t ns -> Idxs ns -> t -> State# s -> (# State# s, () #) -writeDataFrame# mdf ei | I# i <- fromEnum ei = writeDataFrameOff# mdf i +writeDataFrame# mdf@(MDataFrame# _ st _) ei + | I# i <- cdIx st ei = writeDataFrameOff# mdf i {-# INLINE writeDataFrame# #-} -- | Read a single element at the specified element offset @@ -195,9 +251,10 @@ -- | Read a single element at the specified index readDataFrame# :: forall (t :: Type) (ns :: [Nat]) s - . ( PrimBytes t, Dimensions ns ) + . PrimBytes t => MDataFrame s t ns -> Idxs ns -> State# s -> (# State# s, t #) -readDataFrame# mdf ei | I# i <- fromEnum ei = readDataFrameOff# mdf i +readDataFrame# mdf@(MDataFrame# _ st _) ei + | I# i <- cdIx st ei = readDataFrameOff# mdf i {-# INLINE readDataFrame# #-} -- | Allow arbitrary operations on a pointer to the beginning of the data. diff --git a/src/Numeric/DataFrame/Internal/PrimArray.hs b/src/Numeric/DataFrame/Internal/PrimArray.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/DataFrame/Internal/PrimArray.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.DataFrame.Internal.PrimArray + ( PrimArray (..), CumulDims (..) + , cumulDims, cdTotalDim, cdTotalDim#, cdIx + , ixOff, unsafeFromFlatList, getSteps, fromSteps + ) where + +import Data.Monoid as Mon (Monoid (..)) +import Data.Semigroup as Sem (Semigroup (..)) +import GHC.Base (ByteArray#, Int (..), Int#, Word (..), word2Int#) +import Numeric.Dimensions +import Numeric.PrimBytes + +-- | Given @Dims ns@, @CumulativeDims@ is a list of length @Length ns + 1@; +-- which cumulative @totalDim@ accumulated on the right. +-- In particular, its first element is @totalDim ds@, +-- its last element is always is always @1@. +newtype CumulDims = CumulDims { unCumulDims :: [Word] } + +instance Sem.Semigroup CumulDims where + CumulDims as <> CumulDims bs = CumulDims $ map (head bs *) (init as) ++ bs + +instance Mon.Monoid CumulDims where + mempty = CumulDims [1] +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + + +-- | Calculate cumulative dims +cumulDims :: Dims (ns :: [k]) -> CumulDims +cumulDims = CumulDims . uncurry (:) + . foldr (\d (c, cs) -> (c*d,c:cs)) (1, []) . listDims + +-- | Get the total number of elements +cdTotalDim :: CumulDims -> Word +cdTotalDim ~(CumulDims ~(n:_)) = n + +cdTotalDim# :: CumulDims -> Int# +cdTotalDim# ~(CumulDims ~(n:_)) = case n of W# w -> word2Int# w + +-- | Calculate offset of an Idxs +-- +-- Note, you can take offset of subspace with CumulDims of larger space +-- - very convenient! +cdIx :: CumulDims -> Idxs ns -> Int +cdIx ~(CumulDims ~(_:steps)) + = fromIntegral . sum . zipWith (*) steps . listIdxs + +-- | Try to get @CumulDims@ from an array, +-- and create it using @Dims@ if failed. +getSteps :: PrimArray t a => Dims (ns :: [k]) -> a -> CumulDims +getSteps dds df = case uniqueOrCumulDims df of + Left _ -> cumulDims dds + Right ds -> ds +{-# INLINE getSteps #-} + +-- | Get @Dims@ by "de-accumulating" @CumulDims@. +fromSteps :: CumulDims -> SomeDims +fromSteps = someDimsVal . f . unCumulDims + where + -- ignore last value, which is always 1 + f :: [Word] -> [Word] + f [] = [] + f [_] = [] + f [n,_] = [n] + f (a:b:cs) = a `quot` b : f (b:cs) +{-# INLINE fromSteps #-} + +class PrimBytes t => PrimArray t a | a -> t where + -- | Broadcast element into array + broadcast :: t -> a + -- | Index an array given an offset + ix# :: Int# -> a -> t + -- | Generate an array using an accumulator funtion + gen# :: CumulDims + -- ^ Dimensionality of the result array; + -- Be careful! @ns@ depends on @a@, but this is not reflected in + -- types and is not checked at runtime. + -> (s -> (# s, t #)) + -> s -> (# s, a #) + -- | update a single element in an array given an offset + upd# :: CumulDims + -- ^ Dimensionality of the result array; + -- Be careful! @ns@ depends on @a@, but this is not reflected in + -- types and is not checked at runtime. + -> Int# -> t -> a -> a + + -- | If the array represented as a single broadcasted value, + -- return this value. + -- Otherwise, return full array content: + -- @CumulDims@, array offset (elements), byte array with the content. + arrayContent# :: a -> (# t | (# CumulDims, Int#, ByteArray# #) #) + + -- | Offset of an array as a number of elements + offsetElems :: a -> Int# + offsetElems a = case arrayContent# a of + (# _ | #) -> 0# + (# | (# _, o, _ #) #) -> o + {-# INLINE offsetElems #-} + + -- | Normally, this returns a cumulative @totalDim@s. + -- However, if a particular implementation does not have the dimensionality + -- information, it cannot return @CumulDims@; + -- In this case, it is a sign that all elements of an array are same. + -- Thus, it is possible to return the single element value instead. + -- + -- Note, this function returns the only unique element only if it is + -- a such by construction (there is no equality checks involved). + uniqueOrCumulDims :: a -> Either t CumulDims + uniqueOrCumulDims a = case arrayContent# a of + (# x | #) -> Left x + (# | (# cd, _, _ #) #) -> Right cd + {-# INLINE uniqueOrCumulDims #-} + + -- | Get array by its offset and cumulative dims in a ByteArray. + -- Both offset and dims are given in element number (not in bytes). + -- + -- It is better to use this function instead of @fromBytes@ to avoid + -- recalculating @CumulDims@ for implementations that require it. + fromElems :: CumulDims -> Int# -> ByteArray# -> a + +-- | Index array by an integer offset (starting from 0). +ixOff :: PrimArray t a => Int -> a -> t +ixOff (I# i) = ix# i + +-- | Construct an array from a flat list and @Dims@; +-- Be careful! @ns@ depends on @a@, but this is not reflected in +-- types and is not checked at runtime. +unsafeFromFlatList :: PrimArray t a => Dims ns -> t -> [t] -> a +unsafeFromFlatList ds x0 vs = case gen# (cumulDims ds) f vs of (# _, r #) -> r + where + f [] = (# [], x0 #) + f (x:xs) = (# xs, x #) diff --git a/src/Numeric/DataFrame/ST.hs b/src/Numeric/DataFrame/ST.hs --- a/src/Numeric/DataFrame/ST.hs +++ b/src/Numeric/DataFrame/ST.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} @@ -17,8 +16,6 @@ -- Copyright : (c) Artem Chirkin -- License : BSD3 -- --- Maintainer : chirkin@arch.ethz.ch --- -- Mutable DataFrames living in ST. -- ----------------------------------------------------------------------------- @@ -27,6 +24,7 @@ ( STDataFrame (XSTFrame), SomeSTDataFrame (..) , newDataFrame, newPinnedDataFrame , copyDataFrame, copyMutableDataFrame + , copyDataFrame', copyMutableDataFrame' , freezeDataFrame, unsafeFreezeDataFrame , thawDataFrame, thawPinDataFrame, unsafeThawDataFrame , writeDataFrame, writeDataFrameOff @@ -35,14 +33,13 @@ ) where -import GHC.Base -import GHC.ST (ST (..)) +import GHC.Base +import GHC.ST (ST (..)) -import Numeric.DataFrame.Family -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Mutable -import Numeric.Dimensions -import Numeric.PrimBytes +import Numeric.DataFrame.Internal.Mutable +import Numeric.DataFrame.Internal.PrimArray +import Numeric.DataFrame.Type +import Numeric.Dimensions -- | Mutable DataFrame that lives in ST. @@ -79,31 +76,69 @@ -- | Copy one DataFrame into another mutable DataFrame at specified position. -copyDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) - (bs :: [Nat]) (asbs :: [Nat]) s - . ( PrimBytes t - , PrimBytes (DataFrame t (as +: b')) +-- +-- In contrast to @copyMDataFrame'@, this function allows to copy over a range of contiguous +-- indices over a single dimension. +-- For example, you can write a 3x4 matrix into a 7x4 matrix, starting at indices 0..3. +copyDataFrame :: forall (t :: Type) + (b :: Nat) (bi :: Nat) (bd :: Nat) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( b ~ (bi + bd - 1) + , PrimBytes t + , PrimBytes (DataFrame t (bd :+ bs)) , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) ) - => DataFrame t (as +: b') -> Idxs (b :+ bs) -> STDataFrame s t asbs -> ST s () -copyDataFrame df ei (STDataFrame mdf) = ST (copyDataFrame# df ei mdf) + => Idxs (as +: bi) -> DataFrame t (bd :+ bs) + -> STDataFrame s t asbs -> ST s () +copyDataFrame ei df (STDataFrame mdf) = ST (copyDataFrame# ei df mdf) {-# INLINE copyDataFrame #-} -- | Copy one mutable DataFrame into another mutable DataFrame at specified position. -copyMutableDataFrame :: forall (t :: Type) (as :: [Nat]) (b' :: Nat) (b :: Nat) - (bs :: [Nat]) (asbs :: [Nat]) s - . ( PrimBytes t +-- +-- In contrast to @copyMDataFrame'@, this function allows to copy over a range of contiguous +-- indices over a single dimension. +-- For example, you can write a 3x4 matrix into a 7x4 matrix, starting at indices 0..3. +copyMutableDataFrame :: forall (t :: Type) + (b :: Nat) (bi :: Nat) (bd :: Nat) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( b ~ (bi + bd - 1) + , PrimBytes t , ConcatList as (b :+ bs) asbs - , Dimensions (b :+ bs) ) - => STDataFrame s t (as +: b') -> Idxs (b :+ bs) + => Idxs (as +: bi) -> STDataFrame s t (bd :+ bs) -> STDataFrame s t asbs -> ST s () -copyMutableDataFrame (STDataFrame mdfA) ei (STDataFrame mdfB) - = ST (copyMDataFrame# mdfA ei mdfB) +copyMutableDataFrame ei (STDataFrame mdfA) (STDataFrame mdfB) + = ST (copyMDataFrame# ei mdfA mdfB) {-# INLINE copyMutableDataFrame #-} +-- | Copy one DataFrame into another mutable DataFrame at specified position. +-- +-- This is a simpler version of @copyDataFrame@ that allows to copy over one index at a time. +copyDataFrame' :: forall (t :: Type) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t + , PrimBytes (DataFrame t bs) + , ConcatList as bs asbs + ) + => Idxs as -> DataFrame t bs + -> STDataFrame s t asbs -> ST s () +copyDataFrame' ei df (STDataFrame mdf) = ST (copyDataFrame'# ei df mdf) +{-# INLINE copyDataFrame' #-} +-- | Copy one mutable DataFrame into another mutable DataFrame at specified position. +-- +-- This is a simpler version of @copyDataFrame@ that allows to copy over one index at a time. +copyMutableDataFrame' :: forall (t :: Type) + (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) s + . ( PrimBytes t + , ConcatList as bs asbs + ) + => Idxs as -> STDataFrame s t bs + -> STDataFrame s t asbs -> ST s () +copyMutableDataFrame' ei (STDataFrame mdfA) (STDataFrame mdfB) + = ST (copyMDataFrame'# ei mdfA mdfB) +{-# INLINE copyMutableDataFrame' #-} + -- | Make a mutable DataFrame immutable, without copying. unsafeFreezeDataFrame :: forall (t :: Type) (ns :: [Nat]) s . PrimArray t (DataFrame t ns) @@ -121,7 +156,7 @@ -- | Create a new mutable DataFrame and copy content of immutable one in there. thawDataFrame :: forall (t :: Type) (ns :: [Nat]) s - . (PrimBytes (DataFrame t ns), PrimBytes t) + . (Dimensions ns, PrimBytes (DataFrame t ns)) => DataFrame t ns -> ST s (STDataFrame s t ns) thawDataFrame df = STDataFrame <$> ST (thawDataFrame# df) {-# INLINE thawDataFrame #-} @@ -129,14 +164,15 @@ -- | Create a new mutable DataFrame and copy content of immutable one in there. -- The result array is pinned and aligned. thawPinDataFrame :: forall (t :: Type) (ns :: [Nat]) s - . (PrimBytes (DataFrame t ns), PrimBytes t) + . (Dimensions ns, PrimBytes (DataFrame t ns)) => DataFrame t ns -> ST s (STDataFrame s t ns) thawPinDataFrame df = STDataFrame <$> ST (thawPinDataFrame# df) {-# INLINE thawPinDataFrame #-} -- | UnsafeCoerces an underlying byte array. unsafeThawDataFrame :: forall (t :: Type) (ns :: [Nat]) s - . (PrimBytes (DataFrame t ns), PrimBytes t) + . ( Dimensions ns + , PrimBytes (DataFrame t ns), PrimBytes t) => DataFrame t ns -> ST s (STDataFrame s t ns) unsafeThawDataFrame df = STDataFrame <$> ST (unsafeThawDataFrame# df) {-# INLINE unsafeThawDataFrame #-} @@ -144,7 +180,7 @@ -- | Write a single element at the specified index writeDataFrame :: forall t (ns :: [Nat]) s - . ( PrimBytes t, Dimensions ns ) + . PrimBytes t => STDataFrame s t ns -> Idxs ns -> DataFrame t ('[] :: [Nat]) -> ST s () writeDataFrame (STDataFrame mdf) ei = ST . writeDataFrame# mdf ei . unsafeCoerce# {-# INLINE writeDataFrame #-} @@ -152,7 +188,7 @@ -- | Read a single element at the specified index readDataFrame :: forall (t :: Type) (ns :: [Nat]) s - . ( PrimBytes t, Dimensions ns ) + . PrimBytes t => STDataFrame s t ns -> Idxs ns -> ST s (DataFrame t ('[] :: [Nat])) readDataFrame (STDataFrame mdf) = unsafeCoerce# . ST . readDataFrame# mdf {-# INLINE readDataFrame #-} @@ -178,7 +214,7 @@ -- | Check if the byte array wrapped by this DataFrame is pinned, -- which means cannot be relocated by GC. -isDataFramePinned :: forall (t :: Type) (ns :: [k]) s +isDataFramePinned :: forall (k :: Type) (t :: Type) (ns :: [k]) s . KnownDimKind k => STDataFrame s t ns -> Bool isDataFramePinned df = case dimKind @k of diff --git a/src/Numeric/DataFrame/Shape.hs b/src/Numeric/DataFrame/Shape.hs deleted file mode 100644 --- a/src/Numeric/DataFrame/Shape.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.DataFrame.Shape --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- Construct new DataFrames from pieces. --- ------------------------------------------------------------------------------ - -module Numeric.DataFrame.Shape - ( (<:>), (<::>), (<+:>) - , fromScalar - , DataFrameToList (..) - , fromListN, fromList - ) where - -import GHC.Base - -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.Family (inferASing, inferPrim, - inferPrimElem) -import Numeric.DataFrame.SubSpace -import Numeric.DataFrame.Type (DataFrame (..)) -import Numeric.Dimensions -import Numeric.PrimBytes -import Numeric.Scalar as Scalar -import Numeric.TypedList (TypedList (..)) -import qualified Numeric.TypedList as Dims -import Numeric.Vector - - --- | Append one DataFrame to another, sum up last dimension -(<:>) :: forall (n :: Nat) (m :: Nat) (npm :: Nat) (ds :: [Nat]) - (t :: Type) - . ( PrimBytes (DataFrame t (ds +: n)) - , PrimBytes (DataFrame t (ds +: m)) - , PrimBytes (DataFrame t (ds +: npm)) - , npm ~ (n + m) - , n ~ (npm - m) - , m ~ (npm - n) - ) - => DataFrame t (ds +: n) - -> DataFrame t (ds +: m) - -> DataFrame t (ds +: npm) -(<:>) = appendDF -infixl 5 <:> -{-# INLINE [1] (<:>) #-} - --- | Append one DataFrame to another, --- add another @Dim = 2@ to their dimension list. -(<::>) :: forall (ds :: [Nat]) (t :: Type) - . ( PrimBytes (DataFrame t ds) - , PrimBytes (DataFrame t ds) - , PrimBytes (DataFrame t (ds +: 2 :: [Nat])) - ) - => DataFrame t ds - -> DataFrame t ds - -> DataFrame t (ds +: 2 :: [Nat]) -(<::>) = appendDF -infixl 5 <::> -{-# INLINE [1] (<::>) #-} - - -vec2t :: forall t . SubSpace t '[] '[2] '[2] => Scalar t -> Scalar t -> Vector t 2 -vec2t = unsafeCoerce# (vec2 @t) -{-# INLINE vec2t #-} - -{-# RULES -"<::>/vec2-Float" (<::>) = vec2t @Float -"<::>/vec2-Double" (<::>) = vec2t @Double -"<::>/vec2-Int" (<::>) = vec2t @Int -"<::>/vec2-Word" (<::>) = vec2t @Word - #-} - --- | Grow the first DataFrame by adding the second one to it --- incrementing the last Dim in the list. -(<+:>) :: forall (ds :: [Nat]) (n :: Nat) (m :: Nat) (t :: Type) - . ( PrimBytes (DataFrame t (ds +: n)) - , PrimBytes (DataFrame t ds) - , PrimBytes (DataFrame t (ds +: m)) - , m ~ (n + 1) - ) - => DataFrame t (ds +: n) - -> DataFrame t ds - -> DataFrame t (ds +: m) -(<+:>) = appendDF -infixl 5 <+:> -{-# INLINE [1] (<+:>) #-} - - --- | Concatenate a list of @DataFrame@s. --- Returns @Nothing@ if the list does not have enough elements. --- --- Input must be parametrized by @[Nat]@ to make sure every element --- in the input list has the same dimensionality. --- Output is in @[XNat]@, because the last dimension is unknown at compile time. -fromList :: forall m ns t - . ( Dimensions ns - , PrimBytes t - ) - => Dim m - -- ^ Minimum number of elements in a list - -> [DataFrame t ns] - -- ^ List of frames to concatenate - -> Maybe (DataFrame t (AsXDims ns +: XN m)) -fromList d xs = fromListN d (length xs) xs - - - --- | Implement function `toList`. --- We need to create a dedicated type class for this --- to make it polymorphic over kind k (Nat <-> XNat). -class DataFrameToList (t :: Type) (ds :: [k]) (z :: k) where - -- | Unwrap the last dimension of a DataFrame into a list of smaller frames - toList :: DataFrame t (ds +: z) -> [DataFrame t ds] - - - -instance ( Dimensions (ns +: z) - , PrimBytes t - ) - => DataFrameToList t (ns :: [Nat]) (z :: Nat) where - toList df - | Dims.Snoc (Dims :: Dims ns') dn <- dims @Nat @(ns +: z) - -- TODO: line below is a workaround and should be avoided. - , E <- unsafeCoerce# (E @(ns ~ ns)) :: Evidence (ns ~ ns') - , E <- inferASing @t @ns - , E <- inferASing @t @(ns +: z) - , E <- inferPrim @t @(ns +: z) - , E <- inferPrim @t @ns - , n <- dimVal dn - , I# step <- fromIntegral $ totalDim' @ns - , off0 <- elemOffset df - , ba <- getBytes df - = let go 0 _ = [] - go k off = fromElems off step ba : go (k-1) (off +# step) - in go n off0 - | otherwise = [] - -instance DataFrameToList t (xns :: [XNat]) (xz :: XNat) where - toList (XFrame (df :: DataFrame t nsz)) - | nsz <- dims @Nat @nsz - , xnsz <- xDims @(xns +: xz) nsz - -- TODO: line below is a workaround and should be avoided. - , E <- unsafeCoerce# (E @(xns ~ xns)) :: Evidence (xns ~ Init (xns +: xz)) - , xns <- Dims.init xnsz - , TypeList <- types xnsz - , EvList <- Dims.init (EvList @_ @KnownXNatType @(xns +: xz)) - , Dims.Snoc (ns@Dims :: Dims ns) _ <- nsz - , Dims.Cons (_ :: Dim k) (_ :: Dims ks) <- nsz - , E <- inferPrimElem @t @k @ks - , XDims ns' <- xns - , Just E <- sameDims ns ns' - , E <- inferASing @t @ns - = map XFrame (toList df) - toList _ = [] - --- | Concatenate a list of @DataFrame@s. --- Returns @Nothing@ if the list does not have enough elements --- or if provided length is invalid. -fromListN :: forall (m :: Nat) (ns :: [Nat]) (t :: Type) - . ( Dimensions ns - , PrimBytes t - ) - => Dim m - -- ^ Minimum number of elements in a list - -> Int - -- ^ How many elements of a list to take. - -- Must be not smaller than @m@ and not greater than @length ns@. - -> [DataFrame t ns] - -- ^ List of frames to concatenate - -> Maybe (DataFrame t (AsXDims ns +: XN m)) -fromListN Dim n@(I# n#) xs' - | n < 0 = Nothing - | Just dxn@(Dx dn@(D :: Dim n)) <- constrain @m (someDimVal (fromIntegral n)) - , Just xs <- takeMaybe n xs' - , ns@(AsXDims xns) <- dims @Nat @ns - , nsn@Dims <- Dims.snoc ns dn - , xnsn <- Dims.snoc xns dxn - , EvList <- Dims.snoc (EvList @XNat @KnownXNatType @(AsXDims ns)) - (toEvidence' (E @(KnownXNatType (XN m)))) - , XDims nsn' <- xnsn - , Just E <- sameDims nsn nsn' - , E <- inferASing @t @ns - , E <- inferASing @t @(ns +: n) - , E <- inferPrim @t @ns - , E <- inferPrim @t @(ns +: n) - , I# partElN <- fromIntegral $ totalDim' @ns - , totalElN <- partElN *# n# - , elS <- byteSize @t undefined - , partBS <- partElN *# elS - = case runRW# - ( \s0 -> case newByteArray# (totalElN *# elS) s0 of - (# s1, mba #) -> - let go _ [] s = s - go off (p : ps) s = go (off +# partBS) ps (writeBytes mba off p s) - in unsafeFreezeByteArray# mba (go 0# xs s1) - ) of (# _, r #) - -> Just (XFrame (fromElems 0# totalElN r :: DataFrame t (ns +: n))) -fromListN _ _ _ = Nothing - -takeMaybe :: Int -> [a] -> Maybe [a] -takeMaybe 0 _ = Just [] -takeMaybe _ [] = Nothing -takeMaybe n (x : xs) = (x:) <$> takeMaybe (n-1) xs - - - -appendDF :: (PrimBytes x, PrimBytes y, PrimBytes z) - => x -> y -> z -appendDF x y - | sx <- byteSize x - = case runRW# - ( \s0 -> case newByteArray# (sx +# byteSize y) s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( writeBytes mba sx y - ( writeBytes mba 0# x s1)) - ) of (# _, r #) -> fromBytes 0# r -{-# INLINE appendDF #-} diff --git a/src/Numeric/DataFrame/SubSpace.hs b/src/Numeric/DataFrame/SubSpace.hs --- a/src/Numeric/DataFrame/SubSpace.hs +++ b/src/Numeric/DataFrame/SubSpace.hs @@ -3,8 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -20,31 +18,30 @@ -- Copyright : (c) Artem Chirkin -- License : BSD3 -- --- Maintainer : chirkin@arch.ethz.ch -- --- ----------------------------------------------------------------------------- module Numeric.DataFrame.SubSpace - ( SubSpace (..), (!), (!.), element + ( SubSpace (..), (!), element , ewfoldMap, iwfoldMap , ewzip, iwzip , indexWise_, elementWise_ ) where -import GHC.Base +import Data.Kind +import GHC.Exts -import Numeric.DataFrame.Family -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.PrimOps -import Numeric.Dimensions -import Numeric.PrimBytes +import Numeric.DataFrame.Internal.PrimArray +import Numeric.DataFrame.Type +import Numeric.Dimensions +import Numeric.PrimBytes + -- | Operations on DataFrames -- --- @as@ is an element dimensionality +-- @as@ is an indexing dimensionality -- --- @bs@ is an indexing dimensionality +-- @bs@ is an element dimensionality -- -- @t@ is an underlying data type (i.e. Float, Int, Double) -- @@ -52,92 +49,366 @@ , Dimensions as , Dimensions bs , Dimensions asbs + , PrimArray t (DataFrame t bs) , PrimArray t (DataFrame t asbs) + , PrimBytes (DataFrame t bs) + , PrimBytes (DataFrame t asbs) ) => SubSpace (t :: Type) (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) | asbs as -> bs, asbs bs -> as, as bs -> asbs where + -- | Unsafely get a sub-dataframe by its primitive element offset. -- The offset is not checked to be aligned to the space structure or for bounds. - -- Arguments are zero-based primitive element offset and subset ("as" element) size (aka `totalDim` of sub dataframe) + -- Arguments are zero-based primitive element offset and subset ("bs" 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 + -- > index i = case (# dimVal (dim @bs), fromEnum i #) of (# I# n, I# j #) -> indexOffset# (n *# j) indexOffset# :: Int# -- ^ Prim element offset - -> Int# -- ^ Number of prim elements in the prefix subspace - -> DataFrame t asbs -> DataFrame t as + -> DataFrame t asbs -> DataFrame t bs + indexOffset# off df = case uniqueOrCumulDims df of + Left a -> broadcast a + Right steps -> fromElems (dropPref (dims @as) steps) (offsetElems df +# off) (getBytes df) + {-# INLINE [1] indexOffset# #-} + + -- | Unsafely update a sub-dataframe by its primitive element offset. + -- The offset is not checked to be aligned to the space structure or for bounds. + -- Arguments are zero-based primitive element offset and subset ("bs" element) + -- size (aka `totalDim` of sub dataframe) + -- + -- Normal updating can be expressed in terms of `indexOffset#`: + -- + -- > update i = case (# dimVal (dim @bs), fromEnum i #) of (# I# n, I# j #) -> updateOffset# (n *# j) + updateOffset# :: Int# -- ^ Prim element offset + -> DataFrame t bs -> DataFrame t asbs -> DataFrame t asbs + updateOffset# off x df + | steps <- getSteps (dims @asbs) df + , elemBS <- byteSize @t undefined = case runRW# + ( \s0 -> case newByteArray# (cdTotalDim# steps *# elemBS) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( writeBytes mba (off *# elemBS) x + ( writeBytes mba 0# df s1 ) + ) + ) of (# _, r #) -> fromElems steps 0# r + {-# INLINE [1] updateOffset# #-} + + -- | Get an element by its index in the dataframe + index :: Idxs as -> DataFrame t asbs -> DataFrame t bs + index i df = case uniqueOrCumulDims df of + Left a -> broadcast a + Right steps -> case cdIx steps i of + I# off -> fromElems (dropPref (dims @as) steps) (offsetElems df +# off) (getBytes df) + {-# INLINE [1] index #-} + + -- | Get a few contiguous elements. + -- + -- In a sense, this is just a more complicated version of `index`. + slice :: forall (bi :: Nat) (bd :: Nat) (b' :: Nat) (bs' :: [Nat]) + . ( b' ~ (bi + bd - 1), bs ~ (b' :+ bs'), KnownDim bd) + => Idxs (as +: bi) -> DataFrame t asbs -> DataFrame t (bd :+ bs') + slice i df + | _ :* Dims <- dims @bs + , Dict <- inferKnownBackend @t @(bd ': bs') + = case uniqueOrCumulDims df of + Left a -> broadcast a + Right steps -> case cdIx steps i of + I# off + | bsteps <- repHead (dimVal' @bd) (dropPref (dims @as) steps) + -> fromElems bsteps (offsetElems df +# off) (getBytes df) + | otherwise = error "SubSpace/slice: impossible arguments" + where + repHead y (CumulDims (_:x:xs)) = CumulDims (y*x:x:xs) + repHead _ steps = steps + -- | Set a new value to an element - update :: Idxs bs -> DataFrame t as -> DataFrame t asbs -> DataFrame t asbs + update :: Idxs as -> DataFrame t bs -> DataFrame t asbs -> DataFrame t asbs + update i x df + | steps <- getSteps (dims @asbs) df + , I# off <- cdIx steps i + , elemBS <- byteSize @t undefined = case runRW# + ( \s0 -> case newByteArray# (cdTotalDim# steps *# elemBS) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( writeBytes mba (off *# elemBS) x + ( writeBytes mba 0# df s1 ) + ) + ) of (# _, r #) -> fromElems steps 0# r + {-# INLINE [1] update #-} + + -- | Update a few contiguous elements + -- + -- In a sense, this is just a more complicated version of `update`. + updateSlice :: forall (bi :: Nat) (bd :: Nat) (b' :: Nat) (bs' :: [Nat]) + . ( b' ~ (bi + bd - 1), bs ~ (b' :+ bs'), KnownDim bd) + => Idxs (as +: bi) -> DataFrame t (bd :+ bs') -> DataFrame t asbs -> DataFrame t asbs + updateSlice i x df + | _ :* Dims <- dims @bs + , Dict <- inferKnownBackend @t @(bd ': bs') + , steps <- getSteps (dims @asbs) df + , I# off <- cdIx steps i + , elemBS <- byteSize @t undefined = case runRW# + ( \s0 -> case newByteArray# (cdTotalDim# steps *# elemBS) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( writeBytes mba (off *# elemBS) x + ( writeBytes mba 0# df s1 ) + ) + ) of (# _, r #) -> fromElems steps 0# r + | otherwise = error "SubSpace/updateSlice: impossible arguments" + {-# INLINE [1] updateSlice #-} + -- | Map a function over each element of DataFrame - ewmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) - . SubSpace s as' bs asbs' - => (DataFrame s as' -> DataFrame t as) + ewmap :: forall s (bs' :: [Nat]) (asbs' :: [Nat]) + . SubSpace s as bs' asbs' + => (DataFrame s bs' -> DataFrame t bs) -> DataFrame s asbs' -> DataFrame t asbs + ewmap f df + | bsizeT <- byteSize @t undefined + , stepsAS <- cumulDims $ dims @as + , stepsBS <- cumulDims $ dims @bs + , stepsBS' <- cumulDims $ dims @bs' + , stepsASBS <- stepsAS <> stepsBS + , lenAS <- cdTotalDim# stepsAS + , lenBS <- cdTotalDim# stepsBS + , lenBS' <- cdTotalDim# stepsBS' + , lenBSB <- lenBS *# bsizeT + , lenASBSB <- lenAS *# lenBSB + = let go mba sourceOffE destOffB s + | isTrue# (destOffB >=# lenASBSB) + = s + | otherwise + = go mba (sourceOffE +# lenBS') (destOffB +# lenBSB) + (writeBytes mba destOffB (f (indexOffset# sourceOffE df)) s) + in case runRW# + ( \s0 -> case newByteArray# lenASBSB s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba ( go mba 0# 0# s1 ) + ) of (# _, r #) -> fromElems stepsASBS 0# r + {-# INLINE [1] ewmap #-} + -- | Map a function over each element with its index of DataFrame - iwmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) - . SubSpace s as' bs asbs' - => (Idxs bs -> DataFrame s as' -> DataFrame t as) + iwmap :: forall s (bs' :: [Nat]) (asbs' :: [Nat]) + . SubSpace s as bs' asbs' + => (Idxs as -> DataFrame s bs' -> DataFrame t bs) -> DataFrame s asbs' -> DataFrame t asbs + iwmap f df + | bsizeT <- byteSize @t undefined + , stepsAS <- cumulDims $ dims @as + , stepsBS <- cumulDims $ dims @bs + , stepsBS' <- cumulDims $ dims @bs' + , stepsASBS <- stepsAS <> stepsBS + , lenAS <- cdTotalDim# stepsAS + , lenBS <- cdTotalDim# stepsBS + , lenBS' <- cdTotalDim# stepsBS' + , lenBSB <- lenBS *# bsizeT + , lenASBSB <- lenAS *# lenBSB + = let go _ [] _ _ s = s + go mba (i:is) sourceOffE destOffB s + = go mba is (sourceOffE +# lenBS') (destOffB +# lenBSB) + (writeBytes mba destOffB (f i (indexOffset# sourceOffE df)) s) + in case runRW# + ( \s0 -> case newByteArray# lenASBSB s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba ( go mba [minBound..maxBound] 0# 0# s1 ) + ) of (# _, r #) -> fromElems stepsASBS 0# r + {-# INLINE [1] iwmap #-} + -- | Generate a DataFrame by repeating an element - ewgen :: DataFrame t as -> DataFrame t asbs + ewgen :: DataFrame t bs -> DataFrame t asbs + ewgen df = case uniqueOrCumulDims df of + Left a -> broadcast a + Right stepsBS + | stepsAS <- cumulDims $ dims @as + , stepsASBS <- stepsAS <> stepsBS + , elS <- byteSize @t undefined + , lenBSB <- cdTotalDim# stepsBS *# elS + , lenASBSB <- cdTotalDim# stepsASBS *# elS + -> let go mba destOffB s + | isTrue# (destOffB >=# lenASBSB) + = s + | otherwise + = go mba (destOffB +# lenBSB) + (writeBytes mba destOffB df s) + in case runRW# + ( \s0 -> case newByteArray# lenASBSB s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba ( go mba 0# s1 ) + ) of (# _, r #) -> fromElems stepsASBS 0# r + {-# INLINE [1] ewgen #-} + -- | Generate a DataFrame by iterating a function (index -> element) - iwgen :: (Idxs bs -> DataFrame t as) -> DataFrame t asbs + iwgen :: (Idxs as -> DataFrame t bs) -> DataFrame t asbs + iwgen f + | stepsAS <- cumulDims $ dims @as + , stepsBS <- cumulDims $ dims @bs + , stepsASBS <- stepsAS <> stepsBS + , elS <- byteSize @t undefined + , lenBSB <- cdTotalDim# stepsBS *# elS + , lenASBSB <- cdTotalDim# stepsASBS *# elS + = let go _ [] _ s = s + go mba (i:is) destOffB s + = go mba is (destOffB +# lenBSB) (writeBytes mba destOffB (f i) s) + in case runRW# + ( \s0 -> case newByteArray# lenASBSB s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba ( go mba [minBound..maxBound] 0# s1 ) + ) of (# _, r #) -> fromElems stepsASBS 0# r + {-# INLINE [1] iwgen #-} + -- | Left-associative fold of a DataFrame. -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not -- produce memory leaks deeply inside the result data type. - ewfoldl :: (b -> DataFrame t as -> b) -> b -> DataFrame t asbs -> b + ewfoldl :: (b -> DataFrame t bs -> b) -> b -> DataFrame t asbs -> b + ewfoldl f x0 df = case uniqueOrCumulDims df of + Left a -> + let b = broadcast a + go 0 x = x + go n x = go (n-1) $! f x b + in go (totalDim' @as) x0 + Right stepsASBS + | stepsBS <- dropPref (dims @as) stepsASBS + , lenBS <- cdTotalDim# stepsBS + , lenASBS <- cdTotalDim# stepsASBS + -> let go sourceOffE x + | isTrue# (sourceOffE >=# lenASBS) + = x + | otherwise + = go (sourceOffE +# lenBS) $! f x (indexOffset# sourceOffE df) + in go 0# x0 + -- | Left-associative fold of a DataFrame with an index -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not -- produce memory leaks deeply inside the result data type. - iwfoldl :: (Idxs bs -> b -> DataFrame t as -> b) -> b -> DataFrame t asbs -> b + iwfoldl :: (Idxs as -> b -> DataFrame t bs -> b) -> b -> DataFrame t asbs -> b + iwfoldl f x0 df = case uniqueOrCumulDims df of + Left a -> + let b = broadcast a + go [] x = x + go (i:is) x = go is $! f i x b + in go [minBound..maxBound] x0 + Right stepsASBS + | stepsBS <- dropPref (dims @as) stepsASBS + , lenBS <- cdTotalDim# stepsBS + -> let go [] _ x = x + go (i:is) sourceOffE x + = go is (sourceOffE +# lenBS) $! f i x (indexOffset# sourceOffE df) + in go [minBound..maxBound] 0# x0 + -- | Right-associative fold of a DataFrame -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not -- produce memory leaks deeply inside the result data type. - ewfoldr :: (DataFrame t as -> b -> b) -> b -> DataFrame t asbs -> b + ewfoldr :: (DataFrame t bs -> b -> b) -> b -> DataFrame t asbs -> b + ewfoldr f x0 df = case uniqueOrCumulDims df of + Left a -> + let b = broadcast a + go 0 x = x + go n x = go (n-1) $! f b x + in go (totalDim' @as) x0 + Right stepsASBS + | stepsBS <- dropPref (dims @as) stepsASBS + , lenBS <- cdTotalDim# stepsBS + , lenASBS <- cdTotalDim# stepsASBS + -> let go sourceOffE x + | isTrue# (sourceOffE <# 0#) + = x + | otherwise + = go (sourceOffE -# lenBS) $! f (indexOffset# sourceOffE df) x + in go (lenASBS -# lenBS) x0 + -- | Right-associative fold of a DataFrame with an index -- The fold is strict, so accumulater is evaluated to WHNF; -- but you'd better make sure that the function is strict enough to not -- produce memory leaks deeply inside the result data type. - iwfoldr :: (Idxs bs -> DataFrame t as -> b -> b) -> b -> DataFrame t asbs -> b + iwfoldr :: (Idxs as -> DataFrame t bs -> b -> b) -> b -> DataFrame t asbs -> b + iwfoldr f x0 df = case uniqueOrCumulDims df of + Left a -> + let b = broadcast a + go [] x = x + go (i:is) x = go is $! f i b x + in go [maxBound, pred maxBound .. minBound] x0 + Right stepsASBS + | stepsBS <- dropPref (dims @as) stepsASBS + , lenBS <- cdTotalDim# stepsBS + , lenASBS <- cdTotalDim# stepsASBS + -> let go [] _ x = x + go (i:is) sourceOffE x + = go is (sourceOffE -# lenBS) $! f i (indexOffset# sourceOffE df) x + in go [maxBound, pred maxBound .. minBound] (lenASBS -# lenBS) x0 + -- | Apply an applicative functor on each element (Lens-like traversal) - elementWise :: forall s (as' :: [Nat]) (asbs' :: [Nat]) f + elementWise :: forall (s :: Type) (bs' :: [Nat]) (asbs' :: [Nat]) (f :: Type -> Type) . ( Applicative f - , SubSpace s as' bs asbs' + , SubSpace s as bs' asbs' ) - => (DataFrame s as' -> f (DataFrame t as)) + => (DataFrame s bs' -> f (DataFrame t bs)) -> DataFrame s asbs' -> f (DataFrame t asbs) + elementWise = indexWise . const + {-# INLINE [1] elementWise #-} + -- | Apply an applicative functor on each element with its index -- (Lens-like indexed traversal) - indexWise :: forall s (as' :: [Nat]) (asbs' :: [Nat]) f + indexWise :: forall (s :: Type) (bs' :: [Nat]) (asbs' :: [Nat]) (f :: Type -> Type) . ( Applicative f - , SubSpace s as' bs asbs' + , SubSpace s as bs' asbs' ) - => (Idxs bs -> DataFrame s as' -> f (DataFrame t as)) + => (Idxs as -> DataFrame s bs' -> f (DataFrame t bs)) -> DataFrame s asbs' -> f (DataFrame t asbs) + indexWise f df = runWithState <$> iwfoldl applyF (pure initialState) df + where + steps = cumulDims $ dims @asbs + -- run a state-based continuation within RW + runWithState :: ( State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) + -> DataFrame t asbs + runWithState g = case runRW# + ( \s0 -> case g s0 of + (# s1, (# marr, _ #) #) -> unsafeFreezeByteArray# marr s1 + ) of (# _, arr #) -> fromElems steps 0# arr --- | Get an element by its index in the dataframe -(!.) :: forall t as bs asbs - . SubSpace t as bs asbs - => Idxs bs -> DataFrame t asbs -> DataFrame t as -(!.) i = case (# totalDim (dims @_ @as), fromEnum i #) of - (# W# n, I# j #) -> indexOffset# (word2Int# n *# j) (word2Int# n) -{-# INLINE [1] (!.) #-} -infixr 4 !. + -- Prepare empty byte array for the result DataFrame and keep a current position counter + -- Input: state + -- Output: state + + -- ( current mutable byte array + current write position ) + initialState :: State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #) + initialState s0 = case newByteArray# (rezLength# *# rezElBSize#) s0 of + (# s1, marr #) -> (# s1, (# marr, 0# #) #) + -- Given the result chunk, write it into a mutable array + updateChunk :: (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) + -> DataFrame t bs + -> (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) + updateChunk g dfChunk = case (# byteOffset dfChunk, getBytes dfChunk #) of + (# off#, arr# #) -> \s -> case g s of + (# s1, (# marr#, pos# #) #) -> case + copyByteArray# arr# (off# *# rezElBSize#) + marr# (pos# *# rezElBSize#) + (rezStepN# *# rezElBSize#) s1 of + s2 -> (# s2, (# marr#, pos# +# rezStepN# #) #) + + -- Apply applicative functor on each chunk and update a state. + applyF :: Idxs as + -> f (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) + -> DataFrame s bs' + -> f (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) + applyF idx s dfChunk = idx `seq` dfChunk `seq` updateChunk <$> s <*> f idx dfChunk + + -- Element byte size of the result DataFrame (byte size of s) + rezElBSize# = byteSize @t undefined + -- Number of primitive elements in the result DataFrame chunk + !(I# rezStepN#) = fromIntegral $ totalDim' @bs + -- Number of primitive elements in the result DataFrame + rezLength# = cdTotalDim# steps + + + -- | Apply an applicative functor on each element with its index -- (Lens-like indexed traversal) indexWise_ :: forall t as bs asbs f b . (SubSpace t as bs asbs, Applicative f) - => (Idxs bs -> DataFrame t as -> f b) + => (Idxs as -> DataFrame t bs -> f b) -> DataFrame t asbs -> f () indexWise_ f = iwfoldr (\i -> (*>) . f i) (pure ()) -- | Apply an applicative functor on each element (Lens-like traversal) elementWise_ :: forall t as bs asbs f b . (SubSpace t as bs asbs, Applicative f) - => (DataFrame t as -> f b) + => (DataFrame t bs -> f b) -> DataFrame t asbs -> f () elementWise_ f = ewfoldr ((*>) . f) (pure ()) @@ -145,29 +416,30 @@ -- | Apply a functor over a single element (simple lens) element :: forall t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) f . (SubSpace t as bs asbs, Applicative f) - => Idxs bs - -> (DataFrame t as -> f (DataFrame t as)) + => Idxs as + -> (DataFrame t bs -> f (DataFrame t bs)) -> DataFrame t asbs -> f (DataFrame t asbs) -element i f df = flip (update i) df <$> f (i !. df) +element i f df = flip (update i) df <$> f (index i df) {-# INLINE element #-} --- | Index an element (reverse of !.) +-- | Index an element (reverse arguments of `index`) (!) :: SubSpace t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) - => DataFrame t asbs -> Idxs bs -> DataFrame t as -(!) = flip (!.) -infixl 4 ! + => DataFrame t asbs -> Idxs as -> DataFrame t bs +(!) = flip index {-# INLINE (!) #-} +infixl 4 ! + ewfoldMap :: forall t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) m . (Monoid m, SubSpace t as bs asbs) - => (DataFrame t as -> m) -> DataFrame t asbs -> m + => (DataFrame t bs -> m) -> DataFrame t asbs -> m ewfoldMap f = ewfoldl (\m b -> m `seq` (mappend m $! f b)) mempty {-# INLINE ewfoldMap #-} iwfoldMap :: forall t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) m . ( Monoid m, SubSpace t as bs asbs) - => (Idxs bs -> DataFrame t as -> m) -> DataFrame t asbs -> m + => (Idxs as -> DataFrame t bs -> m) -> DataFrame t asbs -> m iwfoldMap f = iwfoldl (\i m b -> m `seq` (mappend m $! f i b)) mempty {-# INLINE iwfoldMap #-} @@ -175,30 +447,30 @@ -- | Zip two spaces on a specified subspace index-wise (with index) iwzip :: forall t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) - s (as' :: [Nat]) (asbs' :: [Nat]) - r (as'' :: [Nat]) (asbs'' :: [Nat]) + s (bs' :: [Nat]) (asbs' :: [Nat]) + r (bs'' :: [Nat]) (asbs'' :: [Nat]) . ( SubSpace t as bs asbs - , SubSpace s as' bs asbs' - , SubSpace r as'' bs asbs'' + , SubSpace s as bs' asbs' + , SubSpace r as bs'' asbs'' ) - => (Idxs bs -> DataFrame t as -> DataFrame s as' -> DataFrame r as'') + => (Idxs as -> DataFrame t bs -> DataFrame s bs' -> DataFrame r bs'') -> DataFrame t asbs -> DataFrame s asbs' -> DataFrame r asbs'' iwzip f dft dfs = iwmap g dft where - g i dft' = f i dft' (i !. dfs) + g i dft' = f i dft' (index i dfs) {-# INLINE iwzip #-} -- | Zip two spaces on a specified subspace element-wise (without index) ewzip :: forall t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) - s (as' :: [Nat]) (asbs' :: [Nat]) - r (as'' :: [Nat]) (asbs'' :: [Nat]) + s (bs' :: [Nat]) (asbs' :: [Nat]) + r (bs'' :: [Nat]) (asbs'' :: [Nat]) . ( SubSpace t as bs asbs - , SubSpace s as' bs asbs' - , SubSpace r as'' bs asbs'' + , SubSpace s as bs' asbs' + , SubSpace r as bs'' asbs'' ) - => (DataFrame t as -> DataFrame s as' -> DataFrame r as'') + => (DataFrame t bs -> DataFrame s bs' -> DataFrame r bs'') -> DataFrame t asbs -> DataFrame s asbs' -> DataFrame r asbs'' @@ -210,194 +482,16 @@ , Dimensions as , Dimensions bs , Dimensions asbs - , PrimArray t (DataFrame t as) + , PrimArray t (DataFrame t bs) , PrimArray t (DataFrame t asbs) - , PrimBytes (DataFrame t as) + , PrimBytes (DataFrame t bs) , PrimBytes (DataFrame t asbs) ) => SubSpace t (as :: [Nat]) (bs :: [Nat]) (asbs :: [Nat]) where - indexOffset# i l d = case elemSize0 d of - -- if elemSize0 returns 0, then this is a fromScalar-like constructor - 0# -> broadcast (ix# 0# d) - _ -> fromElems (elemOffset d +# i) l (getBytes d) - update ei x df - | I# i <- fromEnum ei - , I# len <- fromIntegral $ totalDim' @asbs - = case runRW# - ( \s0 -> case newByteArray# (len *# byteSize @t undefined) s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( writeArray mba i x - ( writeBytes mba 0# df s1 ) - ) - ) of (# _, r #) -> fromElems 0# len r - - ewmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) - . SubSpace s as' bs asbs' - => (DataFrame s as' -> DataFrame t as) - -> DataFrame s asbs' -> DataFrame t asbs - ewmap f df - | elS <- byteSize @t undefined - , W# lenBSW <- totalDim' @bs - , W# lenASW <- totalDim' @as - , W# lenAS'W <- totalDim' @as' - , lenBS <- word2Int# lenBSW - , lenAS <- word2Int# lenASW - , lenAS' <- word2Int# lenAS'W - , lenASBS <- lenAS *# lenBS - , lenAS'BS <- lenAS' *# lenBS - = case runRW# - ( \s0 -> case newByteArray# (lenASBS *# elS) s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( loopWithI# 0# lenAS' lenAS'BS - (\i off -> writeArray mba i (f (indexOffset# off lenAS' df))) - s1 - ) - ) of (# _, r #) -> fromElems 0# lenASBS r - {-# INLINE ewmap #-} - - - iwmap :: forall s (as' :: [Nat]) (asbs' :: [Nat]) - . SubSpace s as' bs asbs' - => (Idxs bs -> DataFrame s as' -> DataFrame t as) - -> DataFrame s asbs' -> DataFrame t asbs - iwmap f df - | elS <- byteSize @t undefined - , dbs <- dims @_ @bs - , W# lenBSW <- totalDim dbs - , W# lenASW <- totalDim' @as - , W# lenAS'W <- totalDim' @as' - , lenBS <- word2Int# lenBSW - , lenAS <- word2Int# lenASW - , lenAS' <- word2Int# lenAS'W - , lenASBS <- lenAS *# lenBS - = case runRW# - ( \s0 -> case newByteArray# (lenASBS *# elS) s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( overDim_# dbs - ( \i pos -> - writeArray mba pos (f i (indexOffset# (pos *# lenAS') lenAS' df)) - ) 0# 1# s1 - ) - ) of (# _, r #) -> fromElems 0# lenASBS r - - ewgen x = case elemSize0 x of - 0# -> broadcast (ix# 0# x) - 1# -> broadcast (ix# 0# x) - lenAS - | elS <- byteSize @t undefined - , W# lenBSW <- totalDim' @bs - , lenBS <- word2Int# lenBSW - , lenASBS <- lenAS *# lenBS - , bsize <- lenASBS *# elS - -> case runRW# - ( \s0 -> case newByteArray# bsize s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( loop# 0# (lenAS *# elS) bsize - (\off -> writeBytes mba off x) - s1 - ) - ) of (# _, r #) -> fromElems 0# lenASBS r - {-# INLINE [1] ewgen #-} - - iwgen f - | elS <- byteSize @t undefined - , dbs <- dims @_ @bs - , W# lenBSW <- totalDim dbs - , W# lenASW <- totalDim' @as - , lenBS <- word2Int# lenBSW - , lenAS <- word2Int# lenASW - , lenASBS <- lenAS *# lenBS - = case runRW# - ( \s0 -> case newByteArray# (lenASBS *# elS) s0 of - (# s1, mba #) -> unsafeFreezeByteArray# mba - ( overDim_# dbs - ( \i pos -> writeArray mba pos (f i) - ) 0# 1# s1 - ) - ) of (# _, r #) -> fromElems 0# lenASBS r - - ewfoldl f x0 df - | ba <- getBytes df - = foldDimOff (dims @_ @bs) (\(I# o) acc -> f acc (fromBytes o ba)) - (I# (byteOffset df)) - (I# (byteSize @t undefined) * fromIntegral (totalDim' @as)) x0 - - iwfoldl f x0 df - | ba <- getBytes df - = foldDim (dims @_ @bs) (\i (I# o) acc -> f i acc (fromBytes o ba)) - (I# (byteOffset df)) - (I# (byteSize @t undefined) * fromIntegral (totalDim' @as)) x0 - - ewfoldr f x0 df - | step <- I# (byteSize @t undefined) * fromIntegral (totalDim' @as) - , ba <- getBytes df - = foldDimOff (dims @_ @bs) (\(I# o) -> f (fromBytes o ba)) - (I# (byteOffset df +# byteSize df) - step) - (negate step) x0 - - iwfoldr f x0 df - | step <- I# (byteSize @t undefined) * fromIntegral (totalDim' @as) - , ba <- getBytes df - = foldDimReverse (dims @_ @bs) (\i (I# o) -> f i (fromBytes o ba)) - (I# (byteOffset df +# byteSize df) - step) - step x0 - - - -- implement elementWise in terms of indexWise - elementWise = indexWise . const - {-# INLINE elementWise #-} - - indexWise :: forall (s :: Type) (f :: Type -> Type) (as' :: [Nat]) (asbs' :: [Nat]) - . ( Applicative f - , SubSpace s as' bs asbs' - ) - => (Idxs bs -> DataFrame s as' -> f (DataFrame t as)) - -> DataFrame s asbs' -> f (DataFrame t asbs) - indexWise f df = runWithState <$> iwfoldl applyF (pure initialState) df - where - -- run a state-based continuation within RW - runWithState :: ( State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) - -> DataFrame t asbs - runWithState g = case runRW# - ( \s0 -> case g s0 of - (# s1, (# marr, _ #) #) -> unsafeFreezeByteArray# marr s1 - ) of (# _, arr #) -> fromElems 0# rezLength# arr - - -- Prepare empty byte array for the result DataFrame and keep a current position counter - -- Input: state - -- Output: state + - -- ( current mutable byte array + current write position ) - initialState :: State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #) - initialState s0 = case newByteArray# (rezLength# *# rezElBSize#) s0 of - (# s1, marr #) -> (# s1, (# marr, 0# #) #) - - -- Given the result chunk, write it into a mutable array - updateChunk :: (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) - -> DataFrame t as - -> (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) - updateChunk g dfChunk = case (# byteOffset dfChunk, getBytes dfChunk #) of - (# off#, arr# #) -> \s -> case g s of - (# s1, (# marr#, pos# #) #) -> case - copyByteArray# arr# (off# *# rezElBSize#) - marr# (pos# *# rezElBSize#) - (rezStepN# *# rezElBSize#) s1 of - s2 -> (# s2, (# marr#, pos# +# rezStepN# #) #) - - -- Apply applicative functor on each chunk and update a state. - applyF :: Idxs bs - -> f (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) - -> DataFrame s as' - -> f (State# RealWorld -> (# State# RealWorld, (# MutableByteArray# RealWorld, Int# #) #)) - applyF idx s dfChunk = idx `seq` dfChunk `seq` updateChunk <$> s <*> f idx dfChunk - - -- Element byte size of the result DataFrame (byte size of s) - rezElBSize# = byteSize @t undefined - -- Number of primitive elements in the result DataFrame chunk - !(I# rezStepN#) = fromIntegral $ totalDim' @as - -- Number of primitive elements in the result DataFrame - !(I# rezLength#) = fromIntegral $ totalDim' @asbs +dropPref :: Dims (ns :: [Nat]) -> CumulDims -> CumulDims +dropPref ds = CumulDims . drop (length $ listDims ds) . unCumulDims unSc :: DataFrame (t :: Type) ('[] :: [Nat]) -> t 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,464 +1,1140 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Numeric.DataFrame.Type - ( -- * Data types - DataFrame (..) - , SomeDataFrame (..), DataFrame' - , pattern (:*:), pattern Z - -- * Infer type class instances - , AllTypes, ImplAllows, ArraySingletons, PrimFrames - , DataFrameInference (..) - , inferOrd, inferNum, inferFractional, inferFloating - , inferOrd', inferNum', inferFractional', inferFloating' - , inferASing', inferEq', inferShow', inferPrim', inferPrimElem' - -- * Misc - , ixOff, unsafeFromFlatList - , Dim1 (..), Dim2 (..), Dim3 (..) - , dimSize1, dimSize2, dimSize3 - , bSizeOf, bAlignOf - -- * Re-exports from dimensions - , Dim (..), Idx (..), XNat (..), Dims, Idxs, TypedList (..) - ) where - - -import Data.Proxy (Proxy) -import Foreign.Storable (Storable (..)) -import GHC.Base -import GHC.Ptr (Ptr (..)) - -import Numeric.DataFrame.Family -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.Family (Array, ArraySingleton (..)) -import qualified Numeric.DataFrame.Internal.Array.Family as AFam -import Numeric.Dimensions -import Numeric.PrimBytes - --- | Single frame -newtype instance DataFrame (t :: Type) (ns :: [Nat]) - = SingleFrame { _getDF :: Array t ns } - --- | Multiple "columns" of data frames of the same shape -newtype instance DataFrame (ts :: [Type]) (ns :: [Nat]) - = MultiFrame { _getDFS :: TypedList (DataFrame' ns) ts } - --- | Data frame with some dimensions missing at compile time. --- Pattern-match against its constructor to get a Nat-indexed data frame. -data instance DataFrame (ts :: l) (xns :: [XNat]) - = forall (ns :: [Nat]) - . (KnownXNatTypes xns, FixedDims xns ns, Dimensions ns, ArraySingletons ts ns) - => XFrame (DataFrame ts ns) - --- | Data frame that has an unknown dimensionality at compile time. --- Pattern-match against its constructor to get a Nat-indexed data frame -data SomeDataFrame (t :: l) - = forall (ns :: [Nat]) . (Dimensions ns, ArraySingletons t ns) - => SomeDataFrame (DataFrame t ns) - --- | DataFrame with its type arguments swapped. -newtype DataFrame' (xs :: [k]) (t :: l) = DataFrame' (DataFrame t xs) - -{-# COMPLETE Z, (:*:) #-} - - --- | Constructing a @MultiFrame@ using DataFrame columns -pattern (:*:) :: forall (xs :: [Type]) (ns :: [Nat]) - . () - => forall (y :: Type) (ys :: [Type]) - . (xs ~ (y ': ys)) - => DataFrame y ns - -> DataFrame ys ns -> DataFrame xs ns -pattern (:*:) x xs <- (MultiFrame (DataFrame' x :* (MultiFrame -> xs))) - where - (:*:) x (MultiFrame xs) = MultiFrame (DataFrame' x :* xs) -infixr 6 :*: - --- | Empty MultiFrame -pattern Z :: forall (xs :: [Type]) (ns :: [Nat]) - . () => (xs ~ '[]) => DataFrame xs ns -pattern Z = MultiFrame U - - --------------------------------------------------------------------------------- --- All Eq instances --------------------------------------------------------------------------------- - -deriving instance Eq (Array t ds) => Eq (DataFrame (t :: Type) (ds :: [Nat])) - -instance ImplAllows Eq ts ds => Eq (DataFrame (ts :: [Type]) ds) where - Z == Z = True - (a :*: as) == (b :*: bs) = a == b && as == bs - -instance (AllTypes Eq t, DataFrameInference t) - => Eq (DataFrame (t :: l) (ds :: [XNat])) where - (XFrame dfa) == (XFrame dfb) - | Just E <- sameDims' dfa dfb - , E <- inferEq dfa = dfa == dfb - _ == _ = False - -instance (AllTypes Eq t, DataFrameInference t) - => Eq (SomeDataFrame (t :: l)) where - (SomeDataFrame dfa) == (SomeDataFrame dfb) - | Just E <- sameDims' dfa dfb - , E <- inferEq dfa = dfa == dfb - _ == _ = False - - --------------------------------------------------------------------------------- --- All Show instances --------------------------------------------------------------------------------- - -instance ( Show (Array t ds) - , Dimensions ds - ) => Show (DataFrame (t :: Type) (ds :: [Nat])) where - show (SingleFrame arr) = unlines - [ "DF " ++ drop 5 (show $ dims @_ @ds) ++ ":" - , show arr - ] - -instance ( Dimensions ds - , ImplAllows Show ts ds - ) => Show (DataFrame (ts :: [Type]) (ds :: [Nat])) where - show dfs = unlines $ - ("DF " ++ show (order dds) ++ " x " ++ drop 5 (show dds) ++ ":") - : showAll 1 dfs - where - dds = dims @_ @ds - showAll :: ImplAllows Show xs ds - => Word -> DataFrame (xs :: [Type]) ds -> [String] - showAll _ Z = [] - showAll n (SingleFrame arr :*: fs) - = ("Var " ++ show n) : show arr : showAll (n+1) fs - - -instance (AllTypes Show t, DataFrameInference t) - => Show (DataFrame (t :: l) (xns :: [XNat])) where - show (XFrame df) - | E <- inferShow df = 'X': show df - -instance (AllTypes Show t, DataFrameInference t) - => Show (SomeDataFrame (t :: l)) where - show (SomeDataFrame df) - | E <- inferShow df = "Some" ++ show df - --------------------------------------------------------------------------------- - - - -type family AllTypes (f :: Type -> Constraint) (ts :: l) :: Constraint where - AllTypes f (t :: Type) = f t - AllTypes f (ts :: [Type]) = All f ts - -type family ImplAllows (f :: Type -> Constraint) (ts :: l) (ds :: [Nat]) - :: Constraint where - ImplAllows f (t :: Type) ds = f (Array t ds) - ImplAllows _ ('[] :: [Type]) _ = () - ImplAllows f (t ': ts :: [Type]) ds = (f (Array t ds), ImplAllows f ts ds) - -type family ArraySingletons (ts :: l) (ns :: [Nat]) :: Constraint where - ArraySingletons (t :: Type) ns = ArraySingleton t ns - ArraySingletons ('[] :: [Type]) _ = () - ArraySingletons (t ': ts :: [Type]) ns - = (ArraySingleton t ns, ArraySingletons ts ns) - -type family PrimFrames (ts :: l) (ns :: [Nat]) :: Constraint where - PrimFrames (t :: Type) ns - = (PrimBytes (DataFrame t ns), PrimArray t (DataFrame t ns)) - PrimFrames ('[] :: [Type]) _ = () - PrimFrames (t ': ts :: [Type]) ns - = ( PrimBytes (DataFrame t ns), PrimArray t (DataFrame t ns) - , PrimFrames ts ns) - - -deriving instance Bounded (Array t ds) => Bounded (DataFrame t ds) -deriving instance Enum (Array t ds) => Enum (DataFrame t ds) -deriving instance Integral (Array t ds) - => Integral (DataFrame t ds) -deriving instance Num (Array t ds) - => Num (DataFrame t ds) -deriving instance Fractional (Array t ds) - => Fractional (DataFrame t ds) -deriving instance Floating (Array t ds) - => Floating (DataFrame t ds) -deriving instance Ord (Array t ds) - => Ord (DataFrame t ds) -deriving instance ( Read (Array t ds), Dimensions ds ) - => Read (DataFrame t ds) -deriving instance Real (Array t ds) - => Real (DataFrame t ds) -deriving instance RealFrac (Array t ds) - => RealFrac (DataFrame t ds) -deriving instance RealFloat (Array t ds) - => RealFloat (DataFrame t ds) -deriving instance (PrimArray t (Array t ds), PrimBytes t) - => PrimArray t (DataFrame t ds) -deriving instance PrimBytes (Array t ds) - => PrimBytes (DataFrame t ds) - - - -instance PrimBytes (DataFrame t ds) => Storable (DataFrame t ds) where - sizeOf x = I# (byteSize x) - alignment x = I# (byteAlign x) - peek (Ptr addr) = IO (readAddr addr) - poke (Ptr addr) a = IO (\s -> (# writeAddr a addr s, () #)) - - - -class DataFrameInference (t :: l) where - -- | Bring an evidence of `ArraySingleton` instance into - -- a scope at runtime. - -- This is often used to let GHC infer other complex type class instances, - -- such as `SubSpace`. - inferASing - :: (AllTypes PrimBytes t, Dimensions ds) - => DataFrame t ds -> Evidence (ArraySingletons t ds) - inferEq - :: (AllTypes Eq t, ArraySingletons t ds) - => DataFrame t ds -> Evidence (Eq (DataFrame t ds)) - inferShow - :: (AllTypes Show t, ArraySingletons t ds, Dimensions ds) - => DataFrame t ds -> Evidence (Show (DataFrame t ds)) - inferPrim - :: (AllTypes PrimBytes t, ArraySingletons t ds, Dimensions ds) - => DataFrame t ds -> Evidence (PrimFrames t ds) - -- | This is a special function, because Scalar does not require PrimBytes. - -- That is why the dimension list in the argument nust not be empty. - inferPrimElem - :: (ArraySingletons t ds, ds ~ (Head ds ': Tail ds)) - => DataFrame t ds -> Evidence (AllTypes PrimBytes t) - - - -instance DataFrameInference (t :: Type) where - inferASing (_ :: DataFrame t ds) - = AFam.inferASing @t @ds - inferEq (_ :: DataFrame t ds) - = case AFam.inferEq @t @ds of E -> E - inferShow (_ :: DataFrame t ds) - = case AFam.inferShow @t @ds of E -> E - inferPrim (_ :: DataFrame t ds) - = case AFam.inferPrim @t @ds of E -> E - inferPrimElem (_ :: DataFrame t ds) - = case AFam.inferPrimElem @t @(Head ds) @(Tail ds) of E -> E - -inferOrd' :: forall t ds - . (Ord t, ArraySingleton t ds) - => Evidence (Ord (DataFrame t ds)) -inferOrd' = case AFam.inferOrd @t @ds of E -> E - -inferNum' :: forall t ds - . (Num t, ArraySingletons t ds) - => Evidence (Num (DataFrame t ds)) -inferNum' = case AFam.inferNum @t @ds of E -> E - -inferFractional' :: forall t ds - . (Fractional t, ArraySingleton t ds) - => Evidence (Fractional (DataFrame t ds)) -inferFractional' = case AFam.inferFractional @t @ds of E -> E - -inferFloating' :: forall t ds - . (Floating t, ArraySingleton t ds) - => Evidence (Floating (DataFrame t ds)) -inferFloating' = case AFam.inferFloating @t @ds of E -> E - - -instance RepresentableList ts => DataFrameInference (ts :: [Type]) where - inferASing (_ :: DataFrame t ds) - = inferASings @ts @ds (tList @_ @ts) - inferEq (_ :: DataFrame t ds) - = case inferEqs @ts @ds (tList @_ @ts) of E -> E - inferShow (_ :: DataFrame t ds) - = case inferShows @ts @ds (tList @_ @ts) of E -> E - inferPrim (_ :: DataFrame t ds) - = case inferPrims @ts @ds (tList @_ @ts) of E -> E - inferPrimElem (_ :: DataFrame t ds) - = case inferPrimElems @ts @(Head ds) @(Tail ds) (tList @_ @ts) of E -> E - - - -inferASings :: forall ts ds - . (All PrimBytes ts, Dimensions ds) - => TypeList ts -> Evidence (ArraySingletons ts ds) -inferASings U = E -inferASings ((_ :: Proxy t) :* ts) - = case (inferASing' @t @ds, inferASings @_ @ds ts) of (E, E) -> E - - - -inferEqs :: forall ts ds - . (All Eq ts, ArraySingletons ts ds) - => TypeList ts -> Evidence (ImplAllows Eq ts ds) -inferEqs U = E -inferEqs ((_ :: Proxy t) :* ts) - = case (AFam.inferEq @t @ds, inferEqs @_ @ds ts) of (E, E) -> E - -inferShows :: forall ts ds - . (All Show ts, ArraySingletons ts ds, Dimensions ds) - => TypeList ts -> Evidence (ImplAllows Show ts ds) -inferShows U = E -inferShows ((_ :: Proxy t) :* ts) - = case (AFam.inferShow @t @ds, inferShows @_ @ds ts) of (E, E) -> E - -inferPrims :: forall ts ds - . (All PrimBytes ts, ArraySingletons ts ds, Dimensions ds) - => TypeList ts -> Evidence (PrimFrames ts ds) -inferPrims U = E -inferPrims ((_ :: Proxy t) :* ts) - = case (AFam.inferPrim @t @ds, inferPrims @_ @ds ts) of (E, E) -> E - -inferPrimElems :: forall ts d ds - . (ArraySingletons ts (d ': ds)) - => TypeList ts -> Evidence (All PrimBytes ts) -inferPrimElems U = E -inferPrimElems ((_ :: Proxy t) :* ts) - = case (AFam.inferPrimElem @t @d @ds, inferPrimElems @_ @d @ds ts) of (E, E) -> E - - -inferASing' :: forall t ds - . (DataFrameInference t, AllTypes PrimBytes t, Dimensions ds) - => Evidence (ArraySingletons t ds) -inferASing' = inferASing (undefined :: DataFrame t ds) - -inferEq' :: forall t ds - . (DataFrameInference t, AllTypes Eq t, ArraySingletons t ds) - => Evidence (Eq (DataFrame t ds)) -inferEq' = inferEq (undefined :: DataFrame t ds) - -inferShow' :: forall t ds - . ( DataFrameInference t, AllTypes Show t - , ArraySingletons t ds, Dimensions ds) - => Evidence (Show (DataFrame t ds)) -inferShow' = inferShow (undefined :: DataFrame t ds) - - -inferPrim' :: forall t ds - . ( DataFrameInference t, AllTypes PrimBytes t - , ArraySingletons t ds, Dimensions ds) - => Evidence (PrimFrames t ds) -inferPrim' = inferPrim (undefined :: DataFrame t ds) - - -inferPrimElem' :: forall t ds - . ( DataFrameInference t, ArraySingletons t ds - , ds ~ (Head ds ': Tail ds)) - => Evidence (AllTypes PrimBytes t) -inferPrimElem' = inferPrimElem (undefined :: DataFrame t ds) - -inferOrd :: forall t ds - . (Ord t, ArraySingleton t ds) - => DataFrame t ds -> Evidence (Ord (DataFrame t ds)) -inferOrd = const (inferOrd' @t @ds) - -inferNum :: forall t ds - . (Num t, ArraySingletons t ds) - => DataFrame t ds -> Evidence (Num (DataFrame t ds)) -inferNum = const (inferNum' @t @ds) - -inferFractional :: forall t ds - . (Fractional t, ArraySingleton t ds) - => DataFrame t ds -> Evidence (Fractional (DataFrame t ds)) -inferFractional = const (inferFractional' @t @ds) - -inferFloating :: forall t ds - . (Floating t, ArraySingleton t ds) - => DataFrame t ds -> Evidence (Floating (DataFrame t ds)) -inferFloating = const (inferFloating' @t @ds) - - --------------------------------------------------------------------------------- --- * Misc --------------------------------------------------------------------------------- - --- | A wrapper on `byteSize` -bSizeOf :: PrimBytes a => a -> Int -bSizeOf a = I# (byteSize a) - --- | A wrapper on `byteAlign` -bAlignOf :: PrimBytes a => a -> Int -bAlignOf a = I# (byteAlign a) - --- | Number of elements along the 1st dimension. -dimSize1 :: Dim1 t ds => t ds -> Word -dimSize1 = dimVal . dim1 - --- | Number of elements along the 2nd dimension. -dimSize2 :: Dim2 t ds => t ds -> Word -dimSize2 = dimVal . dim2 - --- | Number of elements along the 3rd dimension. -dimSize3 :: Dim3 t ds => t ds -> Word -dimSize3 = dimVal . dim3 - -class Dim1 (t :: [k] -> Type) (ds :: [k]) where - dim1 :: t ds -> Dim (Head ds) - -class Dim2 (t :: [k] -> Type) (ds :: [k]) where - dim2 :: t ds -> Dim (Head (Tail ds)) - -class Dim3 (t :: [k] -> Type) (ds :: [k]) where - dim3 :: t ds -> Dim (Head (Tail (Tail ds))) - - -instance {-# OVERLAPPABLE #-} - Dimensions (d ': ds) - => Dim1 t (d ': ds :: [k]) where - dim1 _ = case dims @k @(d ': ds) of d :* _ -> d - -instance {-# OVERLAPPING #-} - Dim1 (TypedList Dim) (d ': ds) where - dim1 (d :* _) = d - -instance {-# OVERLAPPING #-} - Dim1 (DataFrame l) (d ': ds :: [XNat]) where - dim1 (XFrame (_ :: DataFrame l ns)) - = case xDims' @(d ': ds) @ns of d :* _ -> d - -instance {-# OVERLAPPABLE #-} - Dimensions (d1 ': d2 ': ds) - => Dim2 t (d1 ': d2 ': ds :: [k]) where - dim2 _ = case dims @k @(d1 ': d2 ': ds) of _ :* d :* _ -> d - -instance {-# OVERLAPPING #-} - Dim2 (TypedList Dim) (d1 ': d2 ': ds) where - dim2 (_ :* d :* _) = d - -instance {-# OVERLAPPING #-} - Dim2 (DataFrame l) (d1 ': d2 ': ds :: [XNat]) where - dim2 (XFrame (_ :: DataFrame l ns)) - = case xDims' @(d1 ': d2 ': ds) @ns of _ :* d :* _ -> d - -instance {-# OVERLAPPABLE #-} - Dimensions (d1 ': d2 ': d3 ': ds) - => Dim3 t (d1 ': d2 ': d3 ': ds :: [k]) where - dim3 _ = case dims @k @(d1 ': d2 ': d3 ': ds) of _ :* _ :* d :* _ -> d - -instance {-# OVERLAPPING #-} - Dim3 (TypedList Dim) (d1 ': d2 ': d3 ': ds) where - dim3 (_ :* _ :* d :* _) = d - -instance {-# OVERLAPPING #-} - Dim3 (DataFrame l) (d1 ': d2 ': d3 ': ds :: [XNat]) where - dim3 (XFrame (_ :: DataFrame l ns)) - = case xDims' @(d1 ': d2 ': d3 ': ds) @ns of _ :* _ :* d :* _ -> d +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{- | + The core @easytensor@ types. + -} +module Numeric.DataFrame.Type + ( -- * Data types + SomeDataFrame (..), DataFrame' +#if defined(__HADDOCK__) || defined(__HADDOCK_VERSION__) + , DataFrame (SingleFrame, MultiFrame, XFrame) + , pattern Z, pattern (:*:) + , pattern S, pattern DF2, pattern DF3, pattern DF4, pattern DF5 + , pattern DF6, pattern DF7, pattern DF8, pattern DF9 +#else + , DataFrame ( SingleFrame, MultiFrame, XFrame, (:*:), Z + , S, DF2, DF3, DF4, DF5, DF6, DF7, DF8, DF9) +#endif + -- * Flexible assembling and disassembling + , PackDF, packDF, unpackDF + , appendDF, consDF, snocDF + , fromFlatList, fromListWithDefault, fromList + , constrainDF + -- * Infer type class instances + , KnownBackend (), DFBackend, KnownBackends + , InferKnownBackend (..), inferPrimElem + -- * Re-exports + , Dim (..), Idx (), XNat (..), N, XN, Dims, Idxs, TypedList (..) + , PrimBytes (), bSizeOf, bAlignOf, bFieldOffsetOf + , PrimArray (), ixOff + ) where + + +import Data.Data +import Data.Proxy (Proxy) +import Data.Semigroup hiding (All) +import Data.Type.Lits +import Data.Void +import Foreign.Storable (Storable (..)) +import GHC.Base +import GHC.Exts (TYPE) +import qualified GHC.Generics as G +import GHC.Ptr (Ptr (..)) +import qualified Text.ParserCombinators.ReadPrec as Read +import qualified Text.Read as Read +import qualified Text.Read.Lex as Read + +import Numeric.DataFrame.Internal.PrimArray +import Numeric.Dimensions +import Numeric.PrimBytes +import Numeric.ProductOrd +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial +import Numeric.TypedList (typeables) + +import {-# SOURCE #-} Numeric.DataFrame.Internal.Backend (DFBackend, + KnownBackend) +import {-# SOURCE #-} qualified Numeric.DataFrame.Internal.Backend as Backend +import Numeric.DataFrame.Internal.BackendI () + + +-- | Keep data in a primitive data frame +-- and maintain information about Dimensions in the type system +data family DataFrame (t :: l) (xs :: [k]) + +-- | Single frame +newtype instance DataFrame (t :: Type) (ns :: [Nat]) + = SingleFrame { getSingleFrame :: DFBackend t ns } + +-- | Multiple "columns" of data frames of the same shape +newtype instance DataFrame (ts :: [Type]) (ns :: [Nat]) + = MultiFrame ( TypedList (DataFrame' ns) ts ) + +-- | Data frame with some dimensions missing at compile time. +-- Pattern-match against its constructor to get a Nat-indexed data frame. +data instance DataFrame (ts :: l) (xns :: [XNat]) + = forall (ns :: [Nat]) + . (KnownXNatTypes xns, FixedDims xns ns, Dimensions ns, KnownBackends ts ns) + => XFrame (DataFrame ts ns) + +-- | Data frame that has an unknown dimensionality at compile time. +-- Pattern-match against its constructor to get a Nat-indexed data frame +data SomeDataFrame (t :: l) + = forall (ns :: [Nat]) . (Dimensions ns, KnownBackends t ns) + => SomeDataFrame (DataFrame t ns) + deriving Typeable + +-- | DataFrame with its type arguments swapped. +newtype DataFrame' (xs :: [k]) (t :: l) = DataFrame' (DataFrame t xs) + deriving Typeable + +{-# COMPLETE Z, (:*:) #-} + + +-- | Constructing a @MultiFrame@ using DataFrame columns +pattern (:*:) :: forall (xs :: [Type]) (ns :: [Nat]) . () + => forall (y :: Type) (ys :: [Type]) . (xs ~ (y ': ys)) + => DataFrame y ns -> DataFrame ys ns -> DataFrame xs ns +pattern (:*:) x xs <- (MultiFrame (DataFrame' x :* (MultiFrame -> xs))) + where + (:*:) x (MultiFrame xs) = MultiFrame (DataFrame' x :* xs) +infixr 6 :*: + +-- | Empty MultiFrame +pattern Z :: forall (xs :: [Type]) (ns :: [Nat]) + . () => (xs ~ '[]) => DataFrame xs ns +pattern Z = MultiFrame U + +-- | I use this kind-polymorphic constraint to generalize @XFrame@ and @SomeDataFrame@ +-- over @SingleFrame@ and @MultiFrame@. +type family KnownBackends (ts :: l) (ns :: [Nat]) :: Constraint where + KnownBackends ( t :: Type ) ns = KnownBackend t ns + KnownBackends ('[] :: [Type]) _ = () + KnownBackends (t ': ts :: [Type]) ns = + (KnownBackend t ns, KnownBackends ts ns) + +-- | Allow inferring @KnownBackends@ if you know the dimensions and the element types. +class InferKnownBackend (t :: k) ds where + -- Infer @KnownBackends@ if you know the dimensions and the element types. + inferKnownBackend :: Dict (KnownBackends t ds) + +instance (PrimBytes t, Dimensions ds) => InferKnownBackend (t :: Type) ds where + inferKnownBackend = Backend.inferKnownBackend @t @ds + +instance (RepresentableList ts, All PrimBytes ts, Dimensions ds) + => InferKnownBackend (ts :: [Type]) ds where + inferKnownBackend = go (tList @_ @ts) + where + go :: forall ss . All PrimBytes ss => TypeList ss -> Dict (KnownBackends ss ds) + go U = Dict + go ((_ :: Proxy t) :* ts) + = case Backend.inferKnownBackend @t @ds of + Dict -> case go ts of + Dict -> Dict + +-- | All component data frames must satisfy a given constraint. +type family AllFrames (f :: Type -> Constraint) (ts :: [Type]) (ds :: [Nat]) + :: Constraint where + AllFrames _ '[] _ = () + AllFrames f (t ': ts) ds = (f (DataFrame t ds), AllFrames f ts ds) + + +deriving instance Typeable (DataFrame (t :: l) (xs :: [k])) +deriving instance ( Data (DataFrame t xs) + , Typeable t, Typeable xs, Typeable k, Typeable l) + => Data (DataFrame' (xs :: [k]) (t :: l)) +deriving instance Eq (DFBackend t ds) + => Eq (DataFrame t ds) +deriving instance Ord (DFBackend t ds) + => Ord (DataFrame t ds) +deriving instance ProductOrder (DFBackend t ds) + => ProductOrder (DataFrame t ds) +deriving instance Bounded (DFBackend t ds) + => Bounded (DataFrame t ds) +deriving instance Enum (DFBackend t ds) + => Enum (DataFrame t ds) +deriving instance Integral (DFBackend t ds) + => Integral (DataFrame t ds) +deriving instance Num (DFBackend t ds) + => Num (DataFrame t ds) +deriving instance Fractional (DFBackend t ds) + => Fractional (DataFrame t ds) +deriving instance Floating (DFBackend t ds) + => Floating (DataFrame t ds) +deriving instance Real (DFBackend t ds) + => Real (DataFrame t ds) +deriving instance RealFrac (DFBackend t ds) + => RealFrac (DataFrame t ds) +deriving instance RealFloat (DFBackend t ds) + => RealFloat (DataFrame t ds) +deriving instance PrimBytes (DFBackend t ds) + => PrimBytes (DataFrame t ds) +deriving instance (PrimArray t (DFBackend t ds), PrimBytes t) + => PrimArray t (DataFrame t ds) + +instance Ord (NonTransitive.ProductOrd (DFBackend t ds)) + => Ord (NonTransitive.ProductOrd (DataFrame t ds)) where + (>) = coerce ((>) @(NonTransitive.ProductOrd (DFBackend t ds))) + (<) = coerce ((<) @(NonTransitive.ProductOrd (DFBackend t ds))) + (>=) = coerce ((>=) @(NonTransitive.ProductOrd (DFBackend t ds))) + (<=) = coerce ((<=) @(NonTransitive.ProductOrd (DFBackend t ds))) + compare = coerce (compare @(NonTransitive.ProductOrd (DFBackend t ds))) + min = coerce (min @(NonTransitive.ProductOrd (DFBackend t ds))) + max = coerce (max @(NonTransitive.ProductOrd (DFBackend t ds))) + +instance (Ord (Partial.ProductOrd (DFBackend t ds)), Eq (DFBackend t ds)) + => Ord (Partial.ProductOrd (DataFrame t ds)) where + (>) = coerce ((>) @(Partial.ProductOrd (DFBackend t ds))) + (<) = coerce ((<) @(Partial.ProductOrd (DFBackend t ds))) + (>=) = coerce ((>=) @(Partial.ProductOrd (DFBackend t ds))) + (<=) = coerce ((<=) @(Partial.ProductOrd (DFBackend t ds))) + compare = coerce (compare @(Partial.ProductOrd (DFBackend t ds))) + min = coerce (min @(Partial.ProductOrd (DFBackend t ds))) + max = coerce (max @(Partial.ProductOrd (DFBackend t ds))) + + + +instance PrimBytes (DataFrame t ds) => Storable (DataFrame t ds) where + sizeOf x = I# (byteSize x) + alignment x = I# (byteAlign x) + peek (Ptr addr) = IO (readAddr addr) + poke (Ptr addr) a = IO (\s -> (# writeAddr a addr s, () #)) + + +instance AllFrames Eq ts ds => Eq (DataFrame (ts :: [Type]) ds) where + Z == Z = True + (a :*: as) == (b :*: bs) = a == b && as == bs + +instance Eq t => Eq (DataFrame (t :: Type) (ds :: [XNat])) where + XFrame dfa == XFrame dfb + | Just Dict <- sameDims' dfa dfb = dfa == dfb + | otherwise = False + +instance All Eq ts => Eq (DataFrame (ts :: [Type]) (ds :: [XNat])) where + XFrame dfa == XFrame dfb + | Just Dict <- sameDims' dfa dfb = eqFrames dfa dfb + | otherwise = False + +instance Eq t => Eq (SomeDataFrame (t :: Type)) where + SomeDataFrame dfa == SomeDataFrame dfb + | Just Dict <- sameDims' dfa dfb = dfa == dfb + | otherwise = False + +instance All Eq ts => Eq (SomeDataFrame (ts :: [Type])) where + SomeDataFrame dfa == SomeDataFrame dfb + | Just Dict <- sameDims' dfa dfb = eqFrames dfa dfb + | otherwise = False + + +eqFrames :: forall (xs :: [Type]) (ns :: [Nat]) + . (KnownBackends xs ns, All Eq xs) + => DataFrame xs ns -> DataFrame xs ns -> Bool +eqFrames Z Z = True +eqFrames (a :*: as) (b :*: bs) = a == b && eqFrames as bs + + + +instance ( Show t + , PrimBytes t + , Dimensions ds + ) => Show (DataFrame (t :: Type) (ds :: [Nat])) where + showsPrec p x = case dims @ds of + U -> showParen (p >= 10) + $ showString "S " . showsPrec 10 (unsafeCoerce# x :: t) + D0 :* _ -> showString "DF0" + d :* _ -> showParen (p >= 10) + $ unpackDF' ( \Dict f -> + let g :: Endo (Int -> ShowS) + g = Endo $ \k -> f (\o e -> k o . showChar ' ' . showsPrec 11 e) + n = dimVal d + in appEndo (stimes n g) (const $ showString "DF" . shows n) + ) x + +instance ( All Show ts + , All PrimBytes ts + , Dimensions ds + ) => Show (DataFrame (ts :: [Type]) (ds :: [Nat])) where + showsPrec _ Z = showChar 'Z' + showsPrec p (x :*: xs) = showParen (p >= 7) $ + showsPrec 7 x . showString " :*: " . showsPrec 6 xs + +instance (Show t, PrimBytes t) + => Show (DataFrame (t :: Type) (xns :: [XNat])) where + showsPrec p (XFrame x) + = showParen (p >= 10) $ showString "XFrame " . showsPrec 11 x + +instance (All Show ts, All PrimBytes ts) + => Show (DataFrame (ts :: [Type]) (xns :: [XNat])) where + showsPrec p (XFrame x) + = showParen (p >= 10) $ showString "XFrame " . showsPrec 11 x + +instance (Show t, PrimBytes t) + => Show (SomeDataFrame (t :: Type)) where + showsPrec p (SomeDataFrame x) + = showParen (p >= 10) $ showString "SomeDataFrame " . showsPrec 11 x + +instance (All Show ts, All PrimBytes ts) + => Show (SomeDataFrame (ts :: [Type])) where + showsPrec p (SomeDataFrame x) + = showParen (p >= 10) $ showString "SomeDataFrame " . showsPrec 11 x + + +instance (Read t, PrimBytes t, Dimensions ds) + => Read (DataFrame (t :: Type) (ds :: [Nat])) where + readPrec = readPrecFixedDF (dims @ds) + readList = Read.readListDefault + readListPrec = Read.readListPrecDefault + +instance (All Read ts, All PrimBytes ts, RepresentableList ts, Dimensions ds) + => Read (DataFrame (ts :: [Type]) (ds :: [Nat])) where + readPrec = readFixedMultiDF (tList @Type @ts) (dims @ds) + readList = Read.readListDefault + readListPrec = Read.readListPrecDefault + +instance (Read t, PrimBytes t, BoundedDims ds, All KnownXNatType ds) + => Read (DataFrame (t :: Type) (ds :: [XNat])) where + readPrec = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect $ Read.Ident "XFrame" + Read.step $ readPrecBoundedDF (minDims @XNat @ds) + readList = Read.readListDefault + readListPrec = Read.readListPrecDefault + +instance ( All Read ts, All PrimBytes ts, RepresentableList ts + , BoundedDims ds, All KnownXNatType ds) + => Read (DataFrame (ts :: [Type]) (ds :: [XNat])) where + readPrec = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect $ Read.Ident "XFrame" + Read.step $ readBoundedMultiDF (tList @Type @ts) (minDims @XNat @ds) + readList = Read.readListDefault + readListPrec = Read.readListPrecDefault + +instance (Read t, PrimBytes t) + => Read (SomeDataFrame (t :: Type)) where + readPrec = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect $ Read.Ident "SomeDataFrame" + Read.step readPrecSomeDF + readList = Read.readListDefault + readListPrec = Read.readListPrecDefault + +instance ( All Read ts, All PrimBytes ts, RepresentableList ts ) + => Read (SomeDataFrame (ts :: [Type])) where + readPrec = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect $ Read.Ident "SomeDataFrame" + Read.step $ readSomeMultiDF (tList @Type @ts) + readList = Read.readListDefault + readListPrec = Read.readListPrecDefault + +readPrecFixedDF :: forall (t :: Type) (ds :: [Nat]) + . (Read t, PrimBytes t) + => Dims ds -> Read.ReadPrec (DataFrame t ds) +readPrecFixedDF U + = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect $ Read.Ident "S" + S <$> Read.step Read.readPrec +readPrecFixedDF (D0 :* Dims) + = Read.parens $ do + Read.lift . Read.expect . Read.Ident $ "DF0" + return (packDF @t @0) +readPrecFixedDF (d@D :* ds@Dims) + = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect . Read.Ident $ "DF" ++ show (dimVal d) + packDF' (<*> Read.step (readPrecFixedDF ds)) pure + +{- +The first argument is, in fact, a @dimsBound@, but covered in the same @[XNat]@ + form. That is, XN values are lower bounds rather than actual runtime dimensions. + +The interesting bit about this function is that it is very particular in specifying +what is enforced and what is unknown. +At the very least, the call site must know the order of the Dims (unless DF0 is present) + -- and specify all dims as @XN 0@. +It allows a fine-grained control over the shape of a DataFrame. + +For example, + +>>> readPrecBoundedDF (Dx @5 DF5 :* Dn DF4 :* Dn DF4 :* U) + + reads an array of 4x4 matrices of length at least 5. + + -} +readPrecBoundedDF :: forall (t :: Type) (ds :: [XNat]) + . (Read t, PrimBytes t, KnownXNatTypes ds) + => Dims ds -> Read.ReadPrec (DataFrame t ds) +-- reading scalar +readPrecBoundedDF U + = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect $ Read.Ident "S" + case inferKnownBackend @t @'[] of + Dict -> XFrame . S <$> Read.step Read.readPrec +-- DF0 is funny because it will succesfully parse any dimension to the right of it. +readPrecBoundedDF (Dn D0 :* XDims (Dims :: Dims ns)) + = Read.parens $ do + Read.lift . Read.expect . Read.Ident $ "DF0" + return $ case inferKnownBackend @t @(0 ': ns) of + Dict -> XFrame @Type @t @ds @(0 ': ns) (packDF @t @0 @ns) +-- Fixed dimension: +-- The number of component frames is exactly n +-- the first component frame fixes the shape of the rest n-1 +readPrecBoundedDF (Dn d@(D :: Dim n) :* xns) + = Read.parens . Read.prec 10 $ do + Read.lift . Read.expect . Read.Ident $ "DF" ++ show (dimVal d) + XFrame (x :: DataFrame t ns) <- Read.step $ readPrecBoundedDF @t xns + case inferKnownBackend @t @(n ': ns) of + Dict -> fmap XFrame . snd . runDelay $ packDF' @t @n @ns + (readDelayed $ Read.prec 10 (readPrecFixedDF @t @ns dims)) + (followedBy x) +-- Bounded dimension: +-- The number of component frames is at least m +-- the first component frame fixes the shape of the rest n-1 +readPrecBoundedDF ((Dx (m :: Dim m) :: Dim xm) :* xns) + | Dict <- unsafeEqTypes @XNat @('XN m) @xm -- by user contract the argument is dimBound + = Read.parens $ lookLex >>= \case + Read.Ident ('D':'F':s) + | Just (Dx (n :: Dim n)) <- (Read.readMaybe ('D':s) :: Maybe SomeDim) + , Just Dict <- indeedLE m n -- check if the DF dim is not less than m + -> case n of + D0 -> do -- need to repack it under different constraint dims + XFrame x <- readPrecBoundedDF @t (Dn D0 :* xns) + return (XFrame x) + D -> do + Read.lift . Read.expect . Read.Ident $ "DF" ++ show (dimVal n) + XFrame (x :: DataFrame t ns) <- Read.prec 10 $ readPrecBoundedDF @t xns + case inferKnownBackend @t @(n ': ns) of + Dict -> fmap XFrame . snd . runDelay $ packDF' @t @n @ns + (readDelayed $ Read.prec 10 (readPrecFixedDF @t @ns dims)) + (followedBy x) + + _ -> Read.pfail + where + indeedLE :: forall (a ::Nat) (b :: Nat) . Dim a -> Dim b -> Maybe (Dict (a <= b)) + indeedLE a b = case compareDim a b of + SLT -> Just Dict + SEQ -> Just Dict + SGT -> Nothing + +{- +In this case we know Nothing about the dimensionality of a DataFrame. +The logic is similar to readPrecBoundedDF, but a bit simpler: +the first dimension is flexible, but fixes the rest dimensions. + -} +readPrecSomeDF :: forall (t :: Type) . (Read t, PrimBytes t) + => Read.ReadPrec (SomeDataFrame t) +readPrecSomeDF = Read.parens $ + Read.prec 10 (do + Read.lift . Read.expect $ Read.Ident "S" + case inferKnownBackend @t @'[] of + Dict -> SomeDataFrame . S <$> Read.readPrec + ) + Read.+++ + (lookLex >>= \case + Read.Ident ('D':'F':s) + | Just (Dx (d :: Dim d)) <- (Read.readMaybe ('D':s) :: Maybe SomeDim) + -> case d of + D0 | Dict <- inferKnownBackend @t @'[0] + -> SomeDataFrame <$> readPrecFixedDF @t (D0 :* U) + _ -> do + Read.lift . Read.expect . Read.Ident $ "DF" ++ show (dimVal d) + SomeDataFrame (x :: DataFrame t ds) <- Read.prec 10 $ readPrecSomeDF @t + case inferKnownBackend @t @(d ': ds) of + Dict -> fmap SomeDataFrame . snd . runDelay $ packDF' @t @d @ds + (readDelayed $ Read.prec 10 (readPrecFixedDF @t @ds dims)) + (followedBy x) + _ -> Read.pfail + ) + +readFixedMultiDF :: forall (ts :: [Type]) (ds :: [Nat]) + . (All Read ts, All PrimBytes ts) + => TypeList ts + -> Dims ds + -> Read.ReadPrec (DataFrame ts ds) +readFixedMultiDF U _ = Read.parens $ + Z <$ Read.lift (Read.expect $ Read.Ident "Z") +readFixedMultiDF (_ :* ts) ds = Read.parens . Read.prec 6 $ do + x <- Read.step $ readPrecFixedDF ds + Read.lift . Read.expect $ Read.Symbol ":*:" + xs <- readFixedMultiDF ts ds + return (x :*: xs) + +readBoundedMultiDF :: forall (ts :: [Type]) (ds :: [XNat]) + . (All Read ts, All PrimBytes ts, KnownXNatTypes ds) + => TypeList ts + -> Dims ds + -> Read.ReadPrec (DataFrame ts ds) +readBoundedMultiDF U (XDims (Dims :: Dims ns)) + = Read.parens $ + XFrame @[Type] @'[] @ds @ns Z <$ Read.lift (Read.expect $ Read.Ident "Z") +readBoundedMultiDF ((_ :: Proxy t) :* ts@TypeList) ds + = Read.parens . Read.prec 6 $ do + XFrame (x :: DataFrame t ns) <- Read.step $ readPrecBoundedDF @t ds + Read.lift . Read.expect $ Read.Symbol ":*:" + xs <- readFixedMultiDF ts (dims @ns) + case inferKnownBackend @ts @ns of + Dict -> return $ XFrame (x :*: xs) + +readSomeMultiDF :: forall (ts :: [Type]) + . (All Read ts, All PrimBytes ts) + => TypeList ts + -> Read.ReadPrec (SomeDataFrame ts) +readSomeMultiDF U + = Read.parens $ + SomeDataFrame @[Type] @ts @'[] Z <$ Read.lift (Read.expect $ Read.Ident "Z") +readSomeMultiDF ((_ :: Proxy t) :* ts@TypeList) + = Read.parens . Read.prec 6 $ do + SomeDataFrame (x :: DataFrame t ns) <- Read.step $ readPrecSomeDF @t + Read.lift . Read.expect $ Read.Symbol ":*:" + xs <- readFixedMultiDF ts (dims @ns) + case inferKnownBackend @ts @ns of + Dict -> return $ SomeDataFrame (x :*: xs) + +-- First element is read separately, enforcing the structure of the rest. +newtype Delayed t ds c a = Delayed { runDelay :: (c (DataFrame t ds), c a) } + +followedBy :: Applicative c => DataFrame t ds -> a -> Delayed t ds c a +followedBy x = Delayed . (,) (pure x) . pure + +readDelayed :: forall (t :: Type) (ds :: [Nat]) (c :: Type -> Type) (r :: Type) + . Applicative c + => c (DataFrame t ds) + -> Delayed t ds c (DataFrame t ds -> r) -> Delayed t ds c r +readDelayed readF (Delayed (cprev, cf)) = Delayed (readF, cf <*> cprev) + + +-- | Check the next lexeme without consuming it +lookLex :: Read.ReadPrec Read.Lexeme +lookLex = Read.look >>= + Read.choice . map (pure . fst) . Read.readPrec_to_S Read.lexP 10 + + + + +-- | Evidence that the elements of the DataFrame are PrimBytes. +inferPrimElem + :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) + . KnownBackend t (d ': ds) + => DataFrame t (d ': ds) -> Dict (PrimBytes t) +inferPrimElem = Backend.inferPrimElem . getSingleFrame + +-- | Construct a DataFrame from a flat list. +-- +-- The values are filled according to the DataFrame layout: row-by-row and +-- further from the last dimension (least significant) to the first dimension +-- (most significant). +-- +-- If the argument list is shorter than @totalDim@, then the rest of the frame +-- is padded with a default value (second argument). +-- +-- If the argument list is longer than @totalDim@, then unused values are dropped. +-- If you want, you can pass an infinite list as an argument, i.e. the following +-- is a valid use: +-- +-- >>> fromFlatList (dims :: Dims '[2,5]) 0 [6,8..] +-- +fromFlatList :: forall (t :: Type) (ds :: [Nat]) + . PrimArray t (DataFrame t ds) + => Dims ds -> t -> [t] -> DataFrame t ds +fromFlatList = unsafeFromFlatList + + + +-- | A scalar DataFrame is just a newtype wrapper on a value. +pattern S :: forall (t :: Type) . t -> DataFrame t ('[] :: [Nat]) +-- rely on that Scalar is just two times newtype alias to t +pattern S x <- (unsafeCoerce# -> x) + where + S = unsafeCoerce# +{-# COMPLETE S #-} + + +pattern DF2 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (2 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t (2 ': ds) +pattern DF2 a1 a2 + <- (unpackDF @t @2 @ds (#,,#) -> (# a1,a2,Dict #)) + where DF2 = packDF @t @2 @ds +{-# COMPLETE DF2 #-} + +pattern DF3 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (3 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t (3 ': ds) +pattern DF3 a1 a2 a3 + <- (unpackDF @t @3 @ds (#,,,#) -> (# a1,a2,a3,Dict #)) + where DF3 = packDF @t @3 @ds +{-# COMPLETE DF3 #-} + +pattern DF4 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (4 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t (4 ': ds) +pattern DF4 a1 a2 a3 a4 + <- (unpackDF @t @4 @ds (#,,,,#) -> (# a1,a2,a3,a4,Dict #)) + where DF4 = packDF @t @4 @ds +{-# COMPLETE DF4 #-} + +pattern DF5 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (5 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t ds + -> DataFrame t (5 ': ds) +pattern DF5 a1 a2 a3 a4 a5 + <- (unpackDF @t @5 @ds (#,,,,,#) -> (# a1,a2,a3,a4,a5,Dict #)) + where DF5 = packDF @t @5 @ds +{-# COMPLETE DF5 #-} + +pattern DF6 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (6 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t ds -> DataFrame t ds + -> DataFrame t (6 ': ds) +pattern DF6 a1 a2 a3 a4 a5 a6 + <- (unpackDF @t @6 @ds (#,,,,,,#) -> (# a1,a2,a3,a4,a5,a6,Dict #)) + where DF6 = packDF @t @6 @ds +{-# COMPLETE DF6 #-} + +pattern DF7 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (7 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t (7 ': ds) +pattern DF7 a1 a2 a3 a4 a5 a6 a7 + <- (unpackDF @t @7 @ds (#,,,,,,,#) -> (# a1,a2,a3,a4,a5,a6,a7,Dict #)) + where DF7 = packDF @t @7 @ds +{-# COMPLETE DF7 #-} + +pattern DF8 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (8 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t (8 ': ds) +pattern DF8 a1 a2 a3 a4 a5 a6 a7 a8 + <- (unpackDF @t @8 @ds (#,,,,,,,,#) -> (# a1,a2,a3,a4,a5,a6,a7,a8,Dict #)) + where DF8 = packDF @t @8 @ds +{-# COMPLETE DF8 #-} + +pattern DF9 :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions (9 ': ds)) + => (Dimensions ds, KnownBackend t ds) + => DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds -> DataFrame t ds + -> DataFrame t ds + -> DataFrame t (9 ': ds) +pattern DF9 a1 a2 a3 a4 a5 a6 a7 a8 a9 + <- (unpackDF @t @9 @ds (#,,,,,,,,,#) -> (# a1,a2,a3,a4,a5,a6,a7,a8,a9,Dict #)) + where DF9 = packDF @t @9 @ds +{-# COMPLETE DF9 #-} + + +-- | Represent smart constructor functions `packDF` and `unpackDF`. +type family PackDF (t :: Type) (ds :: [Nat]) (d :: Nat) (r :: Type) :: Type where + PackDF _ _ 0 r = r + PackDF t ds d r = DataFrame t ds -> PackDF t ds (d - 1) r + +{- | + Takes @d@ arguments of type @DataFrame t ds@ and produce a @DataFrame t (d ': ds)@. + + NB: always use @TypeApplications@ extension with this function to apply all + type arguments! + Otherwise, a very dumb type family @PackDF@ will not infer the types for you. + + The following example creates a @Matrix Double 12 3@ filled with twelve + 3D vectors (using @fromInteger@ of @Vector Double 3@): + + >>> packDF @Double @12 @'[3] 1 2 3 4 5 6 7 8 9 10 11 12 + + `packDF` and `unpackDF` together serve as a generic constructor for a DataFrame + of an arbitrary (statically known) size. + + -} +packDF :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) + . (PrimBytes t, Dimensions (d ': ds)) + => PackDF t ds d (DataFrame t (d ': ds)) +packDF + | d :* Dims <- dims @(d ': ds) + , Dict <- inferKnownBackend @t @(d ': ds) + , Dict <- inferKnownBackend @t @ds + = go d + | otherwise = error "Numeric.DataFrame.Type.packDF: impossible args" + where + go :: (Dimensions ds, KnownBackend t ds, KnownBackend t (d ': ds)) + => Dim d + -> PackDF t ds d (DataFrame t (d ': ds)) + go d = recur d getResult + where + -- number of elements in the frame as Int# + els = case dimVal d of W# w -> word2Int# w + -- size of a single element in bytes + asize = byteSize @(DataFrame t ds) undefined + + getResult :: forall rRep (r :: TYPE rRep) + . (forall s. Int# -> MutableByteArray# s -> State# s -> r) + -> r + getResult f = runRW# + ( \s0 -> case newByteArray# (asize *# els) s0 of + (# s1, mba #) -> f 0# mba s1 + ) + + recur :: forall n . Dim n + -> (forall rRep (r :: TYPE rRep) + . (forall s. Int# -> MutableByteArray# s -> State# s -> r ) -> r) + -> PackDF t ds n (DataFrame t (d ': ds)) + recur n f = case minusDimM n (D :: Dim 1) of + Nothing -> case unsafeEqTypes @Nat @n @0 of + Dict -> f (\_ mba s -> case unsafeFreezeByteArray# mba s of + (# _, ba #) -> fromBytes 0# ba ) + Just n' -> case unsafeEqTypes @_ + @(PackDF t ds n (DataFrame t (d ': ds))) + @(DataFrame t ds -> PackDF t ds (n - 1) (DataFrame t (d ': ds))) of + Dict -> \x -> recur n' + ( \c -> f (\off mba s -> c (off +# asize) mba (writeBytes mba off x s)) ) + + + +{- | + Takes a function (e.g. a constructor) with @d+1@ argument (df1, df2, .. dfd, Dict) + and a @DataFrame t (d ': ds)@. + Feeds the dataframe elements into that function. + For example, you can pass a tuple to this function, and get all dataframe elements + (and some dictionaries -- useful evidence to work with element frames) + + NB: always use @TypeApplications@ extension with this function to apply all + type arguments! + Otherwise, a very dumb type family @PackDF@ will not infer the types for you. + + The following example unpacks a 3D vector + (created using @fromInteger@ of @Vector Double 3@) + into a 4-tuple with three scalars and one Dict: + + >>> unpackDF @Double @3 @'[] (,,,) 2 + + `packDF` and `unpackDF` together serve as a generic constructor for a DataFrame + of an arbitrary (statically known) size. + + -} +unpackDF :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) + (rep :: RuntimeRep) (r :: TYPE rep) + . (PrimBytes t, Dimensions (d ': ds)) + => PackDF t ds d (Dict (Dimensions ds, KnownBackend t ds) -> r) + -> DataFrame t (d ': ds) -> r +unpackDF c + | d :* Dims <- dims @(d ': ds) + = unpackDF' (go d) + | otherwise = error "Numeric.DataFrame.Type.unpackDF: impossible args" + where + go :: forall a . (a ~ Dict (Dimensions ds, KnownBackend t ds)) + => Dim d -> a + -> (forall (zRep :: RuntimeRep) (z :: TYPE zRep) + . (Int -> DataFrame t ds -> z) -> Int -> z) + -> Int -> r + go d a k = recur d (const c) + where + recur :: forall n + . Dim n + -> (Int -> PackDF t ds n (a -> r)) + -> Int -> r + recur n f = case minusDimM n (D :: Dim 1) of + Nothing -> case unsafeEqTypes @Nat @n @0 of + Dict -> (`f` a) + Just n' -> case unsafeEqTypes @_ + @(PackDF t ds n (a -> r)) + @(DataFrame t ds -> PackDF t ds (n - 1) (a -> r)) of + Dict -> recur n' (k f) + + +packDF' :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) c + . (PrimBytes t, Dimensions (d ': ds)) + => (forall r. c (DataFrame t ds -> r) -> c r) + -> (forall r. r -> c r) + -> c (DataFrame t (d ': ds)) +packDF' k z + | d :* _ <- dims @(d ': ds) + = go d (z (packDF @t @d @ds)) + | otherwise = error "Numeric.DataFrame.Type.packDF': impossible args" + where + go :: forall n . Dim n + -> c (PackDF t ds n (DataFrame t (d ': ds))) -> c (DataFrame t (d ': ds)) + go n = case minusDimM n (D :: Dim 1) of + Nothing -> case unsafeEqTypes @Nat @n @0 of Dict -> id + Just n' -> case unsafeEqTypes @_ + @(PackDF t ds n (DataFrame t (d ': ds))) + @(DataFrame t ds -> PackDF t ds (n - 1) (DataFrame t (d ': ds))) of + Dict -> go n' . k + + +-- Parameter Int# here is an element offset, it should not be used at the call site. +unpackDF' :: forall (rep :: RuntimeRep) + (t :: Type) (d :: Nat) (ds :: [Nat]) (r :: TYPE rep) + . (PrimBytes t, Dimensions (d ': ds)) + => ( Dict (Dimensions ds, KnownBackend t ds) + -> (forall (zRep :: RuntimeRep) (z :: TYPE zRep) + . (Int -> DataFrame t ds -> z) -> Int -> z) + -> Int -> r) + -> DataFrame t (d ': ds) + -> r +unpackDF' k df + | d :* Dims <- dims @(d ': ds) + , Dict <- inferKnownBackend @t @(d ': ds) + , Dict <- inferKnownBackend @t @ds + = case arrayContent# df of + (# x | #) + | e <- broadcast x + -> let f :: forall (zr :: RuntimeRep) (z :: TYPE zr) + . (Int -> DataFrame t ds -> z) -> Int -> z + f consume = (`consume` e) + in k Dict f 0 + (# | (# cdims, off, arr #) #) + | cd <- CumulDims . tail $ unCumulDims cdims + , td <- cdTotalDim# cd + , n <- case dimVal d of W# w -> word2Int# w + -> let f :: forall (zr :: RuntimeRep) (z :: TYPE zr) + . (Int -> DataFrame t ds -> z) -> Int -> z + f consume (I# o) = consume (I# (o -# td)) (fromElems cd o arr) + in k Dict f (I# (off +# td *# (n -# 1#))) + | otherwise = error "Numeric.DataFrame.Type.unpackDF: impossible args" + + +-- | Append one DataFrame to another, sum up the first dimension. +-- +-- If you want to deconstruct a DataFrame, use +-- `Numeric.DataFrame.SubSpace.index` +-- or `Numeric.DataFrame.SubSpace.slice` instead. +appendDF :: forall (n :: Nat) (m :: Nat) (ds :: [Nat]) (t :: Type) + . ( PrimBytes t, Dimensions ds, KnownDim n, KnownDim m ) + => DataFrame t (n :+ ds) + -> DataFrame t (m :+ ds) + -> DataFrame t ((n + m) :+ ds) +appendDF + | D <- D @n `plusDim` D @m + , Dict <- inferKnownBackend @t @(n :+ ds) + , Dict <- inferKnownBackend @t @(m :+ ds) + , Dict <- inferKnownBackend @t @((n + m) :+ ds) + = unsafeAppendPB + | otherwise = error "Numeri.DataFrame.Type/appendDF: impossible arguments" + +-- | Append a small DataFrame to a big DataFrame on the left. +-- +-- If you want to deconstruct a DataFrame, use +-- `Numeric.DataFrame.SubSpace.index` +-- or `Numeric.DataFrame.SubSpace.slice` instead. +consDF :: forall (n :: Nat) (ds :: [Nat]) (t :: Type) + . ( PrimBytes t, Dimensions ds, KnownDim n ) + => DataFrame t ds + -> DataFrame t (n :+ ds) + -> DataFrame t ((n + 1) :+ ds) +consDF + | D <- D @n `plusDim` D1 + , Dict <- inferKnownBackend @t @(n :+ ds) + , Dict <- inferKnownBackend @t @ds + , Dict <- inferKnownBackend @t @((n + 1) :+ ds) + = unsafeAppendPB + | otherwise = error "Numeri.DataFrame.Type/consDF: impossible arguments" + +-- | Append a small DataFrame to a big DataFrame on the right. +-- +-- If you want to deconstruct a DataFrame, use +-- `Numeric.DataFrame.SubSpace.index` +-- or `Numeric.DataFrame.SubSpace.slice` instead. +snocDF :: forall (n :: Nat) (ds :: [Nat]) (t :: Type) + . ( PrimBytes t, Dimensions ds, KnownDim n ) + => DataFrame t (n :+ ds) + -> DataFrame t ds + -> DataFrame t ((n + 1) :+ ds) +snocDF + | D <- D @n `plusDim` D1 + , Dict <- inferKnownBackend @t @(n :+ ds) + , Dict <- inferKnownBackend @t @ds + , Dict <- inferKnownBackend @t @((n + 1) :+ ds) + = unsafeAppendPB + | otherwise = error "Numeri.DataFrame.Type/snocDF: impossible arguments" + + +-- | Unsafely copy two PrimBytes values into a third one. +unsafeAppendPB :: (PrimBytes x, PrimBytes y, PrimBytes z) + => x -> y -> z +unsafeAppendPB x y + | sx <- byteSize x + = case runRW# + ( \s0 -> case newByteArray# (sx +# byteSize y) s0 of + (# s1, mba #) -> unsafeFreezeByteArray# mba + ( writeBytes mba sx y + ( writeBytes mba 0# x s1)) + ) of (# _, r #) -> fromBytes 0# r + + +-- | Construct a DataFrame from a list of smaller DataFrames. +-- +-- +-- If the argument list is shorter than @d@, then the rest of the frame +-- is padded with a default value (first argument). +-- +-- If the argument list is longer than @d@, then unused values are dropped. +-- If you want, you can pass an infinite list as an argument. +fromListWithDefault :: forall (t :: Type) (d :: Nat) (ds :: [Nat]) + . (PrimBytes t, Dimensions (d ': ds)) + => DataFrame t ds -> [DataFrame t ds] -> DataFrame t (d ': ds) +fromListWithDefault d ds = snd $ packDF' f ((,) ds) + where + f :: forall r . ([DataFrame t ds], DataFrame t ds -> r) -> ([DataFrame t ds], r) + f ([] , k) = ([], k d) + f (x:xs, k) = (xs, k x) + +-- | Construct a dynamic DataFrame from a list of smaller DataFrames. +-- Pattern-match against the resulting @XFrame@ to find out its dimensionality. +-- +-- You must not provide an infinite list as an argument. +fromList :: forall (t :: Type) (ds :: [Nat]) + . (PrimBytes t, Dimensions ds) + => [DataFrame t ds] -> DataFrame t (XN 0 ': AsXDims ds) +fromList xs + | Dx (D :: Dim n) <- someDimVal . fromIntegral $ length xs + , Dict <- inferKnownBackend @t @(n ': ds) + , ds@(AsXDims (XDims ds')) <- dims @ds + , Just Dict <- sameDims ds ds' + = XFrame (fromListWithDefault @t @n @ds undefined xs) + | otherwise + = error "Numeri.DataFrame.Type/fromList: impossible arguments" + + +-- | Try to convert between @XNat@-indexed DataFrames. +-- +-- This is useful for imposing restrictions on unknown DataFrames, +-- e.g. increasing the minimum number of elements. +constrainDF :: forall (ds :: [XNat]) (ys :: [XNat]) (l :: Type) (ts :: l) + . (BoundedDims ds, All KnownXNatType ds) + => DataFrame ts ys -> Maybe (DataFrame ts ds) +constrainDF (XFrame (df :: DataFrame ts ns)) + | ns <- dims @ns + = case constrainDims @XNat @ds ns of + Just (XDims (Dims :: Dims ms)) + | Dict <- unsafeEqTypes @[Nat] @ns @ms + -> Just $ XFrame df + _ -> Nothing + + + +-- Need this for @packDF'@ to make @Int -> c z@ a proper second-order type +-- parameterized by the result type. +newtype Off c z = Off { runOff :: Int -> c z } + +-- | Term-level structure of a @SingleFrame t ds@ is fully determined by its +-- type dimensionality @Typeable ds@. +-- Thus, @gunfold@ does not use its last argument (@Constr@) at all, +-- relying on the structure of the type parameter. +instance (Data t, PrimBytes t, Typeable ds) + => Data (DataFrame (t :: Type) (ds :: [Nat])) where + gfoldl k z v = case typeableDims @ds of + U | S x <- v + -> z S `k` x + D :* (Dims :: Dims ns) + -> case inferTypeableCons @_ @ds of + Dict -> + -- PLZ don't ask me how does this work + unpackDF' (\_ f -> runOff $ packDF' + (\g -> Off . f $ k . runOff g) + (Off . const . z) + ) v + gunfold k z _ = case typeableDims @ds of + U -> k (z S) + D :* (Dims :: Dims ns) + -> case inferTypeableCons @_ @ds of Dict -> packDF' k z + toConstr _ = case typeableDims @ds of + U -> scalarFrameConstr + d :* _ -> singleFrameConstr $ dimVal d + dataTypeOf _ = case typeableDims @ds of + U -> dataFrameDataType [scalarFrameConstr] + d :* _ -> dataFrameDataType . (:[]). singleFrameConstr $ dimVal d + +-- | Term-level structure of a @MultiFrame ts@ is fully determined by its +-- type @Typeable ts@. +-- Thus, @gunfold@ does not use its last argument (@Constr@) at all, +-- relying on the structure of the type parameter. +instance (AllFrames Data ts ds, Typeable ts, Typeable ds) + => Data (DataFrame (ts :: [Type]) (ds :: [Nat])) where + gfoldl _ z Z = z Z + gfoldl k z (x :*: xs) = case inferTypeableCons @Type @ts of + Dict -> z (:*:) `k` x `k` xs + gunfold k z _ = case typeables @Type @ts of + U -> z Z + _ :* _ -> case inferTypeableCons @_ @ts of Dict -> k (k (z (:*:))) + toConstr Z = multiFrameZConstr + toConstr (_ :*: _) = multiFrameConsConstr + dataTypeOf _ = dataFrameDataType [multiFrameZConstr, multiFrameConsConstr] + + +dataFrameDataType :: [Constr] -> DataType +dataFrameDataType = mkDataType "Numeric.DataFrame.Type.DataFrame" + +scalarFrameConstr :: Constr +scalarFrameConstr + = mkConstr (dataFrameDataType [scalarFrameConstr]) "S" [] Prefix + +singleFrameConstr :: Word -> Constr +singleFrameConstr d + = mkConstr (dataFrameDataType [singleFrameConstr d]) ("DF" ++ show d) [] Prefix + +multiFrameZConstr :: Constr +multiFrameZConstr = mkConstr + (dataFrameDataType [multiFrameZConstr, multiFrameConsConstr]) + "Z" [] Prefix + +multiFrameConsConstr :: Constr +multiFrameConsConstr = mkConstr + (dataFrameDataType [multiFrameZConstr, multiFrameConsConstr]) + ":*:" [] Infix + + +type DFMetaSel = 'G.MetaSel + 'Nothing 'G.NoSourceUnpackedness 'G.NoSourceStrictness 'G.DecidedLazy + +type family DFTree (t :: Type) (ds :: [Nat]) (d :: Nat) where + DFTree t ds 0 = G.U1 + DFTree t ds 1 = G.S1 DFMetaSel (G.Rec0 (DataFrame t ds)) + DFTree t ds n = DFTree t ds (Div n 2) G.:*: DFTree t ds (Div n 2 + Mod n 2) + +type family SingleFrameRep (t :: Type) (ds :: [Nat]) :: (Type -> Type) where + SingleFrameRep t '[] + = G.C1 ('G.MetaCons "S" 'G.PrefixI 'False) (G.S1 DFMetaSel (G.Rec0 t)) + SingleFrameRep t (d ': ds) + = G.C1 ('G.MetaCons (AppendSymbol "DF" (ShowNat d)) 'G.PrefixI 'False) (DFTree t ds d) + +instance (PrimBytes t, Dimensions ds) + => G.Generic (DataFrame (t :: Type) (ds :: [Nat])) where + type Rep (DataFrame t ds) = G.D1 + ('G.MetaData "DataFrame" "Numeric.DataFrame.Type" "easytensor" 'False) + ( SingleFrameRep t ds ) + from = G.M1 . fromSingleFrame (dims @ds) + to (G.M1 rep) = toSingleFrame (dims @ds) rep + +fromSingleFrame :: forall (t :: Type) (ds :: [Nat]) (x :: Type) + . PrimBytes t + => Dims ds + -> DataFrame t ds + -> SingleFrameRep t ds x +fromSingleFrame U (S x) = G.M1 . G.M1 $ G.K1 x +fromSingleFrame (dd@D :* (Dims :: Dims ds')) x + | Dict <- inferKnownBackend @t @ds + , Dict <- inferKnownBackend @t @ds' + = G.M1 $ case arrayContent# x of + (# e | #) -> fillRep @_ @ds' (const $ broadcast e) 0 dd + (# | (# cdims, off, arr #) #) + | cd <- CumulDims . tail $ unCumulDims cdims + , td <- cdTotalDim# cd + -> fillRep @_ @ds' + (\(W# i) -> fromElems cd (off +# td *# word2Int# i) arr) 0 dd + where + fillRep :: forall (n :: Nat) (ns :: [Nat]) + . (Word -> DataFrame t ns) + -> Word + -> Dim n + -> DFTree t ns n x + fillRep _ _ D0 = G.U1 + fillRep f i D1 = G.M1 . G.K1 $ f i + fillRep f i d + | Dict <- unsafeEqTypes @(Type -> Type) + @(DFTree t ns n) + @(DFTree t ns (Div n 2) G.:*: DFTree t ns (Div n 2 + Mod n 2)) + = fillRep f i d2 G.:*: fillRep f (i + dimVal d2) d2' + where + d2 = divDim d D2 + d2' = d2 `plusDim` modDim d D2 + +toSingleFrame :: forall (t :: Type) (ds :: [Nat]) (x :: Type) + . PrimBytes t + => Dims ds + -> SingleFrameRep t ds x + -> DataFrame t ds +toSingleFrame U (G.M1 (G.M1 (G.K1 x))) = S x +toSingleFrame (dd@D :* (Dims :: Dims ds')) (G.M1 rep) + | Dict <- inferKnownBackend @t @ds + , Dict <- inferKnownBackend @t @ds' + , els <- case dimVal dd of W# w -> word2Int# w + , asize <- byteSize @(DataFrame t ds') undefined + = runRW# + ( \s0 -> case newByteArray# (asize *# els) s0 of + (# s1, mba #) + | s2 <- fillDF @_ @ds' + (\(W# i) df -> writeBytes mba (asize *# word2Int# i) df) + 0 dd rep s1 + , (# _, ba #) <- unsafeFreezeByteArray# mba s2 + -> fromBytes 0# ba + ) + where + fillDF :: forall (n :: Nat) (ns :: [Nat]) s + . (Word -> DataFrame t ns -> State# s -> State# s) + -> Word + -> Dim n + -> DFTree t ns n x + -> State# s -> State# s + fillDF _ _ D0 _ s = s + fillDF f i D1 (G.M1 (G.K1 e)) s = f i e s + fillDF f i d xy s + | Dict <- unsafeEqTypes @(Type -> Type) + @(DFTree t ns n) + @(DFTree t ns (Div n 2) G.:*: DFTree t ns (Div n 2 + Mod n 2)) + , x G.:*: y <- xy + = fillDF f (i + dimVal d2) d2' y (fillDF f i d2 x s) + where + d2 = divDim d D2 + d2' = d2 `plusDim` modDim d D2 + + +type family MultiFrameRepNil (ts :: [Type]) :: (Type -> Type) where + MultiFrameRepNil '[] = G.C1 ('G.MetaCons "Z" 'G.PrefixI 'False) G.U1 + MultiFrameRepNil (_ ': _) = G.Rec0 Void + +type family MultiFrameRepCons (ts :: [Type]) (ds :: [Nat]) :: (Type -> Type) where + MultiFrameRepCons '[] _ = G.Rec0 Void + MultiFrameRepCons (t ': ts) ds = G.C1 + ('G.MetaCons ":*:" ('G.InfixI 'G.RightAssociative 6) 'False) + ( G.S1 DFMetaSel + (G.Rec0 (DataFrame t ds)) + G.:*: + G.S1 DFMetaSel + (G.Rec0 (DataFrame ts ds)) + ) + +instance G.Generic (DataFrame (ts :: [Type]) (ds :: [Nat])) where + type Rep (DataFrame ts ds) = G.D1 + ('G.MetaData "DataFrame" "Numeric.DataFrame.Type" "easytensor" 'False) + ( MultiFrameRepNil ts G.:+: MultiFrameRepCons ts ds ) + from Z = G.M1 (G.L1 (G.M1 G.U1)) + from (x :*: xs) = G.M1 (G.R1 (G.M1 (G.M1 (G.K1 x) G.:*: G.M1 (G.K1 xs)))) + to (G.M1 (G.L1 _)) + | Dict <- unsafeEqTypes @[Type] @ts @'[] = Z + to (G.M1 (G.R1 xxs)) + | Dict <- unsafeEqTypes @[Type] @ts @(Head ts ': Tail ts) + , G.M1 (G.M1 (G.K1 x) G.:*: G.M1 (G.K1 xs)) <- xxs = x :*: xs + + + +unsafeEqTypes :: forall k (a :: k) (b :: k) . Dict (a ~ b) +unsafeEqTypes = unsafeCoerce# (Dict :: Dict (a ~ a)) diff --git a/src/Numeric/Matrix.hs b/src/Numeric/Matrix.hs --- a/src/Numeric/Matrix.hs +++ b/src/Numeric/Matrix.hs @@ -1,32 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedSums #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Matrix --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- ------------------------------------------------------------------------------ - module Numeric.Matrix ( MatrixTranspose (..) , SquareMatrix (..) @@ -46,300 +17,7 @@ , pivotMat, luSolve ) where - -import Control.Monad (foldM) -import Data.Foldable (forM_, foldl') -import Data.List (delete) -import GHC.Base -import Numeric.DataFrame.Contraction ((%*)) -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.Family as AFam -import Numeric.DataFrame.Shape -import Numeric.DataFrame.SubSpace -import Numeric.DataFrame.Type -import Numeric.Dimensions -import Numeric.Matrix.Class -import Numeric.Matrix.Mat44d () -import Numeric.Matrix.Mat44f () -import Numeric.PrimBytes -import Numeric.Scalar -import Numeric.Vector - -import Control.Monad.ST -import Numeric.DataFrame.ST - - - --- | Compose a 2x2D matrix -mat22 :: ( PrimBytes (Vector (t :: Type) 2) - , PrimBytes (Matrix t 2 2) - ) - => Vector t 2 -> Vector t 2 -> Matrix t 2 2 -mat22 = (<::>) - --- | Compose a 3x3D matrix -mat33 :: ( PrimBytes (t :: Type) - , PrimBytes (Vector t 3) - , PrimBytes (Matrix t 3 3) - ) - => Vector t 3 -> Vector t 3 -> Vector t 3 -> Matrix t 3 3 -mat33 a b c = runST $ do - mmat <- newDataFrame - copyDataFrame a (1:*1:*U) mmat - copyDataFrame b (1:*2:*U) mmat - copyDataFrame c (1:*3:*U) mmat - unsafeFreezeDataFrame mmat - --- | Compose a 4x4D matrix -mat44 :: forall (t :: Type) - . ( PrimBytes t - , PrimBytes (Vector t (4 :: Nat)) - , PrimBytes (Matrix t (4 :: Nat) (4 :: Nat)) - ) - => Vector t (4 :: Nat) - -> Vector t (4 :: Nat) - -> Vector t (4 :: Nat) - -> Vector t (4 :: Nat) - -> Matrix t (4 :: Nat) (4 :: Nat) -mat44 a b c d = runST $ do - mmat <- newDataFrame - copyDataFrame a (1:*1:*U) mmat - copyDataFrame b (1:*2:*U) mmat - copyDataFrame c (1:*3:*U) mmat - copyDataFrame d (1:*4:*U) mmat - unsafeFreezeDataFrame mmat - - - -instance ( KnownDim n, KnownDim m - , PrimArray t (Matrix t n m) - , PrimArray t (Matrix t m n) - ) => MatrixTranspose t (n :: Nat) (m :: Nat) where - transpose df = case elemSize0 df of - 0# -> broadcast (ix# 0# df) - nm | I# m <- fromIntegral $ dimVal' @m - , I# n <- fromIntegral $ dimVal' @n - -> let f ( I# j, I# i ) - | isTrue# (j ==# m) = f ( 0 , I# (i +# 1#) ) - | otherwise = (# ( I# (j +# 1#), I# i ) - , ix# (j *# n +# i) df - #) - in case gen# nm f (0,0) of - (# _, r #) -> r - -instance MatrixTranspose (t :: Type) (xn :: XNat) (xm :: XNat) where - transpose (XFrame (df :: DataFrame t ns)) - | ((D :: Dim n) :* (D :: Dim m) :* U) <- dims @Nat @ns - , E <- AFam.inferPrimElem @t @n @'[m] - = XFrame (transpose df :: Matrix t m n) - transpose _ = error "MatrixTranspose/transpose: impossible argument" - -instance (KnownDim n, PrimArray t (Matrix t n n), Num t) - => SquareMatrix t n where - eye - | n@(I# n#) <- fromIntegral $ dimVal' @n - = let f 0 = (# n, 1 #) - f k = (# k - 1, 0 #) - in case gen# (n# *# n#) f 0 of - (# _, r #) -> r - diag se - | n@(I# n#) <- fromIntegral $ dimVal' @n - , e <- unScalar se - = let f 0 = (# n, e #) - f k = (# k - 1, 0 #) - in case gen# (n# *# n#) f 0 of - (# _, r #) -> r - trace df - | I# n <- fromIntegral $ dimVal' @n - , n1 <- n +# 1# - = let f 0# = ix# 0# df - f k = ix# k df + f (k -# n1) - in scalar $ f (n *# n -# 1#) - - -instance ( KnownDim n, Ord t, Fractional t - , PrimBytes t - , PrimArray t (Matrix t n n) - , PrimArray t (Vector t n) - , PrimBytes (Vector t n) - , PrimBytes (Matrix t n n) - ) - => MatrixInverse t n where - inverse m = ewmap (luSolve (lu m)) eye - - -instance ( KnownDim n, Ord t, Fractional t - , PrimBytes t, PrimArray t (Matrix t n n)) - => MatrixDeterminant t n where - det m = prodF (luUpper f) * prodF (luLower f) * luPermSign f - where - f = lu m - !(I# n) = fromIntegral $ dimVal' @n - n1 = n +# 1# - nn1 = n *# n -# 1# - prodF a = scalar $ prodF' nn1 a - prodF' 0# a = ix# 0# a - prodF' k a = ix# k a * prodF' (k -# n1) a - - -instance ( KnownDim n, Ord t, Fractional t - , PrimBytes t, PrimArray t (Matrix t n n)) - => MatrixLU t n where - lu m' = case runRW# go of - (# _, (# bu, bl #) #) -> LUFact - { luLower = fromElems 0# nn bl - , luUpper = fromElems 0# nn bu - , luPerm = p - , luPermSign = si - } - where - (m, p, si) = pivotMat m' - !(I# n) = fromIntegral $ dimVal' @n - nn = n *# n - tbs = byteSize @t undefined - bsize = nn *# tbs - ixm i j = ix# (i +# n *# j) m - loop :: (Int# -> a -> State# s -> (# State# s, a #)) - -> Int# -> Int# -> a -> State# s -> (# State# s, a #) - loop f i k x s - | isTrue# (i ==# k) = (# s, x #) - | otherwise = case f i x s of - (# s', y #) -> loop f ( i +# 1# ) k y s' - go s0 - | (# s1, mbl #) <- newByteArray# bsize s0 - , (# s2, mbu #) <- newByteArray# bsize s1 - , s3 <- setByteArray# mbl 0# bsize 0# s2 - , s4 <- setByteArray# mbu 0# bsize 0# s3 - , readL <- \i j -> readArray @t mbl (i +# n *# j) - , readU <- \i j -> readArray @t mbu (i +# n *# j) - , writeL <- \i j -> writeArray @t mbl (i +# n *# j) - , writeU <- \i j -> writeArray @t mbu (i +# n *# j) - , computeU <- \i j -> - let f k x s - | (# s' , ukj #) <- readU k j s - , (# s'', lik #) <- readL i k s' - = (# s'', x - ukj * lik #) - in loop f 0# i (ixm i j) - , computeL' <- \i j -> - let f k x s - | (# s' , ukj #) <- readU k j s - , (# s'', lik #) <- readL i k s' - = (# s'', x - ukj * lik #) - in loop f 0# j (ixm i j) - , (# sr, () #) <- - loop - ( \j _ sj -> case sj of - sj0 - | sj1 <- writeL j j 1 sj0 - , (# sj2, () #) <- loop - ( \i _ sij0 -> case computeU i j sij0 of - (# sij1, uij #) -> (# writeU i j uij sij1, () #) - ) 0# j () sj1 - , (# sj3, ujj #) <- computeU j j sj2 - , sj4 <- writeU j j ujj sj3 - -> case ujj of - 0 -> loop - ( \i _ sij -> (# writeL i j 0 sij, () #) - ) (j +# 1#) n () sj4 - x -> loop - ( \i _ sij0 -> case computeL' i j sij0 of - (# sij1, lij #) -> (# writeL i j (lij / x) sij1, () #) - ) (j +# 1#) n () sj4 - ) 0# n () s4 - , (# sf0, bl #) <- unsafeFreezeByteArray# mbl sr - , (# sf1, bu #) <- unsafeFreezeByteArray# mbu sf0 - = (# sf1, (# bu, bl #) #) - - --- | Solve @Ax = b@ problem given LU decomposition of A. -luSolve :: forall (t :: Type) (n :: Nat) - . ( KnownDim n, Ord t, Fractional t - , PrimBytes t, PrimArray t (Matrix t n n), PrimArray t (Vector t n)) - => LUFact t n -> Vector t n -> Vector t n -luSolve LUFact {..} b = x - where - -- Pb = LUx - pb = luPerm %* b - !n@(I# n#) = fromIntegral $ dimVal' @n - -- Ly = Pb - y :: Vector t n - y = runST $ do - my <- newDataFrame - let ixA (I# i) (I# j) = scalar $ ix# (i +# n# *# j) luLower - ixB (I# i) = scalar $ ix# i pb - forM_ [0..n-1] $ \i -> do - v <- foldM ( \v j -> do - dj <- readDataFrameOff my j - return $ v - dj * ixA i j - ) (ixB i) [0..i-1] - writeDataFrameOff my i v - unsafeFreezeDataFrame my - -- Ux = y - x = runST $ do - mx <- newDataFrame - let ixA (I# i) (I# j) = scalar $ ix# (i +# n# *# j) luUpper - ixB (I# i) = scalar $ ix# i y - forM_ [n-1, n-2 .. 0] $ \i -> do - v <- foldM ( \v j -> do - dj <- readDataFrameOff mx j - return $ v - dj * ixA i j - ) (ixB i) [i+1..n-1] - writeDataFrameOff mx i (v / ixA i i) - unsafeFreezeDataFrame mx - - --- | Permute rows that the largest magnitude elements in columns are on diagonals. --- --- Invariants of result matrix: --- * forall j >= i: |M[i,i]| >= M[j,i] --- * if M[i,i] == 0 then forall j >= i: |M[i+1,i+1]| >= M[j,i+1] -pivotMat :: forall (t :: Type) (n :: k) - . (KnownDim n, PrimArray t (Matrix t n n), Ord t, Num t) - => Matrix t n n -> ( Matrix t n n -- permutated matrix - , Matrix t n n -- permutation matrix - , Scalar t -- sign of permutation matrix - ) -pivotMat m - = ( let f ( j, [] ) = f (j+1, rowOrder) - f ( j, i:is ) = (# (j, is), ix i j #) - in case gen# nn f (0,rowOrder) of - (# _, r #) -> r - , let f ( j, [] ) = f (j+1, rowOrder) - f ( j, x:xs ) - | j == x = (# ( j, xs), 1 #) - | otherwise = (# ( j, xs), 0 #) - in case gen# nn f (0,rowOrder) of - (# _, r #) -> r - , if countMisordered rowOrder `rem` 2 == 1 - then -1 else 1 - ) - where - -- permuted row ordering - rowOrder = uncurry fillPass $ searchPass 0 [0..n-1] - -- matrix size - !n@(I# n#) = fromIntegral $ dimVal' @n - -- sign of permutations - countMisordered :: [Int] -> Int - countMisordered [] = 0 - countMisordered (i:is) = foldl' (\c j -> if i > j then succ c else c) 0 is - + countMisordered is - nn = n# *# n# - ix (I# i) (I# j) = ix# (i +# j *# n#) m - findMax :: Int -> [Int] -> (t, Int) - findMax j = foldl' (\(ox, oi) i -> let x = abs (ix i j) - in if x > ox then (x, i) - else (ox, oi) - ) (0, 0) - -- search maximums, leaving Nothing where all rows are 0 - searchPass :: Int -> [Int] -> ([Int], [Maybe Int]) - searchPass j is - | j == n = (is, []) - | otherwise = case findMax j is of - (0, _) -> (Nothing:) <$> searchPass (j+1) is - (_, i) -> (Just i:) <$> searchPass (j+1) (delete i is) - -- replace Nothings with remaining row numbers - fillPass :: [Int] -> [Maybe Int] -> [Int] - fillPass _ [] = [] - fillPass js (Just i : is) = i : fillPass js is - fillPass (j:js) (Nothing : is) = j : fillPass js is - fillPass [] (Nothing : is) = 0 : fillPass [] is +import Numeric.DataFrame.Internal.Backend () +import Numeric.Matrix.Internal +import Numeric.Matrix.Internal.Mat44d () +import Numeric.Matrix.Internal.Mat44f () diff --git a/src/Numeric/Matrix/Class.hs b/src/Numeric/Matrix/Class.hs deleted file mode 100644 --- a/src/Numeric/Matrix/Class.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Numeric.Matrix.Class - ( MatrixTranspose (..) - , SquareMatrix (..) - , MatrixDeterminant (..) - , MatrixInverse (..) - , MatrixLU (..), LUFact (..) - , Matrix - , HomTransform4 (..) - , Mat22f, Mat23f, Mat24f - , Mat32f, Mat33f, Mat34f - , Mat42f, Mat43f, Mat44f - , Mat22d, Mat23d, Mat24d - , Mat32d, Mat33d, Mat34d - , Mat42d, Mat43d, Mat44d - ) where - -import Numeric.DataFrame.Family -import Numeric.Dimensions (Nat) -import Numeric.Scalar -import Numeric.Vector - --- | Alias for DataFrames of rank 2 -type Matrix (t :: l) (n :: k) (m :: k) = DataFrame t '[n,m] - -class MatrixTranspose t (n :: k) (m :: k) where - -- | Transpose Mat - transpose :: Matrix t n m -> Matrix t m n - -- (MatrixTranspose t m n, PrimBytes (Matrix t m n)) => - -class SquareMatrix t (n :: Nat) where - -- | Mat with 1 on diagonal and 0 elsewhere - eye :: Matrix t n n - -- | Put the same value on the Mat diagonal, 0 otherwise - diag :: Scalar t -> Matrix t n n - -- | Sum of diagonal elements - trace :: Matrix t n n -> Scalar t - -class MatrixDeterminant t (n :: Nat) where - -- | Determinant of Mat - det :: Matrix t n n -> Scalar t - -class MatrixInverse t (n :: Nat) where - -- | Matrix inverse - inverse :: Matrix t n n -> Matrix t n n - - --- | Result of LU factorization with Partial Pivoting --- @ PA = LU @. -data LUFact t n - = LUFact - { luLower :: Matrix t n n - -- ^ Lower triangular matrix @L@. - -- All elements on the diagonal of @L@ equal @1@. - , luUpper :: Matrix t n n - -- ^ Upper triangular matrix @U@ - , luPerm :: Matrix t n n - -- ^ Row permutation matrix @P@ - , luPermSign :: Scalar t - -- ^ Sign of permutation @luPermSign == det . luPerm@ - } - -deriving instance (Show (Matrix t n n), Show t) => Show (LUFact t n) -deriving instance (Eq (Matrix t n n), Eq t) => Eq (LUFact t n) - -class MatrixLU t (n :: Nat) where - -- | Compute LU factorization with Partial Pivoting - lu :: Matrix t n n -> LUFact t n - - --- | Operations on 4x4 transformation matrices and vectors in homogeneous coordinates. --- All angles are specified in radians. -class HomTransform4 t where - -- | Create a translation matrix from a vector. The 4th coordinate is ignored. - translate4 :: Vector t 4 -> Matrix t 4 4 - -- | Create a translation matrix from a vector. - translate3 :: Vector t 3 -> Matrix t 4 4 - -- | Rotation matrix for a rotation around the X axis, angle is given in radians. - rotateX :: t -> Matrix t 4 4 - -- | Rotation matrix for a rotation around the Y axis, angle is given in radians. - rotateY :: t -> Matrix t 4 4 - -- | Rotation matrix for a rotation around the Z axis, angle is given in radians. - rotateZ :: t -> Matrix t 4 4 - -- | Rotation matrix for a rotation around an arbitrary normalized vector - rotate :: Vector t 3 -> t -> Matrix t 4 4 - -- | Rotation matrix from the Euler angles roll (axis @Z@), yaw (axis @Y'@), and pitch (axis @X''@). - -- This order is known as Tait-Bryan angles (@Z-Y'-X''@ intrinsic rotations), or nautical angles, or Cardan angles. - -- - -- > rotateEuler pitch yaw roll == rotateX pitch %* rotateY yaw %* rotateZ roll - -- - -- https://en.wikipedia.org/wiki/Euler_angles#Conventions_2 - rotateEuler :: t -- ^ pitch (axis @X''@) - -> t -- ^ yaw (axis @Y'@) - -> t -- ^ roll (axis @Z@) - -> Matrix t 4 4 - -- | Create a transform matrix using up direction, camera position and a point to look at. - -- Just the same as GluLookAt. - lookAt :: Vector t 3 -- ^ The up direction, not necessary unit length or perpendicular to the view vector - -> Vector t 3 -- ^ The viewers position - -> Vector t 3 -- ^ The point to look at - -> Matrix t 4 4 - -- | A perspective symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) - -- http://en.wikibooks.org/wiki/GLSL_Programming/Vertex_Transformations - perspective :: t -- ^ Near plane clipping distance (always positive) - -> t -- ^ Far plane clipping distance (always positive) - -> t -- ^ Field of view of the y axis, in radians - -> t -- ^ Aspect ratio, i.e. screen's width\/height - -> Matrix t 4 4 - -- | An orthogonal symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) - -- http://en.wikibooks.org/wiki/GLSL_Programming/Vertex_Transformations - orthogonal :: t -- ^ Near plane clipping distance - -> t -- ^ Far plane clipping distance - -> t -- ^ width - -> t -- ^ height - -> Matrix t 4 4 - -- | Add one more dimension and set it to 1. - toHomPoint :: Vector t 3 -> Vector t 4 - -- | Add one more dimension and set it to 0. - toHomVector :: Vector t 3 -> Vector t 4 - -- | Transform a homogenous vector or point into a normal 3D vector. - -- If the last coordinate is not zero, divide the rest by it. - fromHom :: Vector t 4 -> Vector t 3 - --- Type abbreviations - -type Mat22f = Matrix Float 2 2 -type Mat32f = Matrix Float 3 2 -type Mat42f = Matrix Float 4 2 -type Mat23f = Matrix Float 2 3 -type Mat33f = Matrix Float 3 3 -type Mat43f = Matrix Float 4 3 -type Mat24f = Matrix Float 2 4 -type Mat34f = Matrix Float 3 4 -type Mat44f = Matrix Float 4 4 - -type Mat22d = Matrix Double 2 2 -type Mat32d = Matrix Double 3 2 -type Mat42d = Matrix Double 4 2 -type Mat23d = Matrix Double 2 3 -type Mat33d = Matrix Double 3 3 -type Mat43d = Matrix Double 4 3 -type Mat24d = Matrix Double 2 4 -type Mat34d = Matrix Double 3 4 -type Mat44d = Matrix Double 4 4 diff --git a/src/Numeric/Matrix/Internal.hs b/src/Numeric/Matrix/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Matrix/Internal.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.Matrix.Internal + ( MatrixTranspose (..) + , SquareMatrix (..) + , MatrixDeterminant (..) + , MatrixInverse (..) + , MatrixLU (..), LUFact (..) + , Matrix + , HomTransform4 (..) + , Mat22f, Mat23f, Mat24f + , Mat32f, Mat33f, Mat34f + , Mat42f, Mat43f, Mat44f + , Mat22d, Mat23d, Mat24d + , Mat32d, Mat33d, Mat34d + , Mat42d, Mat43d, Mat44d + , mat22, mat33, mat44 + , (%*) + , pivotMat, luSolve + ) where + +import Control.Monad (foldM) +import Control.Monad.ST +import Data.Foldable (foldl', forM_) +import Data.List (delete) +import GHC.Base +import Numeric.DataFrame.Contraction ((%*)) +import Numeric.DataFrame.Internal.PrimArray +import Numeric.DataFrame.ST +import Numeric.DataFrame.SubSpace +import Numeric.DataFrame.Type +import Numeric.Dimensions +import Numeric.PrimBytes +import Numeric.Scalar.Internal +import Numeric.Vector.Internal + +-- | Alias for DataFrames of rank 2 +type Matrix (t :: l) (n :: k) (m :: k) = DataFrame t '[n,m] + +class MatrixTranspose t (n :: k) (m :: k) where + -- | Transpose Mat + transpose :: Matrix t n m -> Matrix t m n + +class SquareMatrix t (n :: Nat) where + -- | Mat with 1 on diagonal and 0 elsewhere + eye :: Matrix t n n + -- | Put the same value on the Mat diagonal, 0 otherwise + diag :: Scalar t -> Matrix t n n + -- | Sum of diagonal elements + trace :: Matrix t n n -> Scalar t + +class MatrixDeterminant t (n :: Nat) where + -- | Determinant of Mat + det :: Matrix t n n -> Scalar t + +class MatrixInverse t (n :: Nat) where + -- | Matrix inverse + inverse :: Matrix t n n -> Matrix t n n + + +-- | Result of LU factorization with Partial Pivoting +-- @ PA = LU @. +data LUFact t n + = LUFact + { luLower :: Matrix t n n + -- ^ Lower triangular matrix @L@. + -- All elements on the diagonal of @L@ equal @1@. + , luUpper :: Matrix t n n + -- ^ Upper triangular matrix @U@ + , luPerm :: Matrix t n n + -- ^ Row permutation matrix @P@ + , luPermSign :: Scalar t + -- ^ Sign of permutation @luPermSign == det . luPerm@ + } + +deriving instance (Show t, PrimBytes t, KnownDim n) => Show (LUFact t n) +deriving instance (Eq (Matrix t n n), Eq t) => Eq (LUFact t n) + +class MatrixLU t (n :: Nat) where + -- | Compute LU factorization with Partial Pivoting + lu :: Matrix t n n -> LUFact t n + + +-- | Operations on 4x4 transformation matrices and vectors in homogeneous coordinates. +-- All angles are specified in radians. +-- +-- Note: since version 2 of @easytensor@, DataFrames and matrices are row-major. +-- A good SIMD implementation may drastically improve performance +-- of 4D vector-matrix products of the form @v %* m@, but not so much +-- for products of the form @m %* v@ (due to memory layout). +-- Thus, all operations here assume the former form to benefit more from +-- SIMD in future. +class HomTransform4 t where + -- | Create a translation matrix from a vector. The 4th coordinate is ignored. + -- + -- If @p ! 3 == 1@ and @v ! 3 == 0@, then + -- + -- > p %* translate4 v == p + v + -- + translate4 :: Vector t 4 -> Matrix t 4 4 + -- | Create a translation matrix from a vector. + -- + -- If @p ! 3 == 1@, then + -- + -- > p %* translate3 v == p + toHomVector v + -- + translate3 :: Vector t 3 -> Matrix t 4 4 + -- | Rotation matrix for a rotation around the X axis, angle is given in radians. + -- e.g. @p %* rotateX (pi/2)@ rotates point @p@ around @Ox@ by 90 degrees. + rotateX :: t -> Matrix t 4 4 + -- | Rotation matrix for a rotation around the Y axis, angle is given in radians. + -- e.g. @p %* rotateY (pi/2)@ rotates point @p@ around @Oy@ by 90 degrees. + rotateY :: t -> Matrix t 4 4 + -- | Rotation matrix for a rotation around the Z axis, angle is given in radians. + -- e.g. @p %* rotateZ (pi/2)@ rotates point @p@ around @Oz@ by 90 degrees. + rotateZ :: t -> Matrix t 4 4 + -- | Rotation matrix for a rotation around an arbitrary normalized vector + -- e.g. @p %* rotate (pi/2) v@ rotates point @p@ around @v@ by 90 degrees. + rotate :: Vector t 3 -> t -> Matrix t 4 4 + -- | Rotation matrix from the Euler angles roll (axis @Z@), yaw (axis @Y'@), and pitch (axis @X''@). + -- This order is known as Tait-Bryan angles (@Z-Y'-X''@ intrinsic rotations), or nautical angles, or Cardan angles. + -- + -- > rotateEuler pitch yaw roll == rotateZ roll %* rotateY yaw %* rotateX pitch + -- + -- https://en.wikipedia.org/wiki/Euler_angles#Conventions_2 + rotateEuler :: t -- ^ pitch (axis @X''@) + -> t -- ^ yaw (axis @Y'@) + -> t -- ^ roll (axis @Z@) + -> Matrix t 4 4 + -- | Create a transform matrix using up direction, camera position and a point to look at. + -- Just the same as GluLookAt. + lookAt :: Vector t 3 -- ^ The up direction, not necessary unit length or perpendicular to the view vector + -> Vector t 3 -- ^ The viewers position + -> Vector t 3 -- ^ The point to look at + -> Matrix t 4 4 + -- | A perspective symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) + -- http://en.wikibooks.org/wiki/GLSL_Programming/Vertex_Transformations + perspective :: t -- ^ Near plane clipping distance (always positive) + -> t -- ^ Far plane clipping distance (always positive) + -> t -- ^ Field of view of the y axis, in radians + -> t -- ^ Aspect ratio, i.e. screen's width\/height + -> Matrix t 4 4 + -- | An orthogonal symmetric projection matrix. Right-handed coordinate system. (@x@ - right, @y@ - top) + -- http://en.wikibooks.org/wiki/GLSL_Programming/Vertex_Transformations + orthogonal :: t -- ^ Near plane clipping distance + -> t -- ^ Far plane clipping distance + -> t -- ^ width + -> t -- ^ height + -> Matrix t 4 4 + -- | Add one more dimension and set it to 1. + toHomPoint :: Vector t 3 -> Vector t 4 + -- | Add one more dimension and set it to 0. + toHomVector :: Vector t 3 -> Vector t 4 + -- | Transform a homogenous vector or point into a normal 3D vector. + -- If the last coordinate is not zero, divide the rest by it. + fromHom :: Vector t 4 -> Vector t 3 + +-- Type abbreviations + +type Mat22f = Matrix Float 2 2 +type Mat32f = Matrix Float 3 2 +type Mat42f = Matrix Float 4 2 +type Mat23f = Matrix Float 2 3 +type Mat33f = Matrix Float 3 3 +type Mat43f = Matrix Float 4 3 +type Mat24f = Matrix Float 2 4 +type Mat34f = Matrix Float 3 4 +type Mat44f = Matrix Float 4 4 + +type Mat22d = Matrix Double 2 2 +type Mat32d = Matrix Double 3 2 +type Mat42d = Matrix Double 4 2 +type Mat23d = Matrix Double 2 3 +type Mat33d = Matrix Double 3 3 +type Mat43d = Matrix Double 4 3 +type Mat24d = Matrix Double 2 4 +type Mat34d = Matrix Double 3 4 +type Mat44d = Matrix Double 4 4 + + +-- | Compose a 2x2D matrix +mat22 :: PrimBytes (t :: Type) + => Vector t 2 -> Vector t 2 -> Matrix t 2 2 +mat22 = packDF @_ @2 @'[2] +{-# INLINE mat22 #-} + +-- | Compose a 3x3D matrix +mat33 :: PrimBytes (t :: Type) + => Vector t 3 -> Vector t 3 -> Vector t 3 -> Matrix t 3 3 +mat33 = packDF @_ @3 @'[3] +{-# INLINE mat33 #-} + +-- | Compose a 4x4D matrix +mat44 :: PrimBytes (t :: Type) + => Vector t 4 + -> Vector t 4 + -> Vector t 4 + -> Vector t 4 + -> Matrix t 4 4 +mat44 = packDF @_ @4 @'[4] +{-# INLINE mat44 #-} + + + +instance ( KnownDim n, KnownDim m + , PrimArray t (Matrix t n m) + , PrimArray t (Matrix t m n) + ) => MatrixTranspose t (n :: Nat) (m :: Nat) where + transpose df = case uniqueOrCumulDims df of + Left a -> broadcast a + Right _ + | wm <- dimVal' @m + , wn <- dimVal' @n + , m <- case wm of W# w -> word2Int# w + , n <- case wn of W# w -> word2Int# w + -> let f ( I# i, I# j ) + | isTrue# (i ==# n) = f ( 0, I# (j +# 1#) ) + | otherwise = (# ( I# (i +# 1#), I# j ) + , ix# (i *# m +# j) df + #) + in case gen# (CumulDims [wm*wn, wn, 1]) f (0,0) of (# _, r #) -> r + +instance MatrixTranspose (t :: Type) (xn :: XNat) (xm :: XNat) where + transpose (XFrame (df :: DataFrame t ns)) + | ((D :: Dim n) :* (D :: Dim m) :* U) <- dims @ns + , Dict <- inferPrimElem df + = XFrame (transpose df :: Matrix t m n) + transpose _ = error "MatrixTranspose/transpose: impossible argument" + +instance (KnownDim n, PrimArray t (Matrix t n n), Num t) + => SquareMatrix t n where + eye + | n <- dimVal' @n + = let f 0 = (# n , 1 #) + f k = (# k - 1, 0 #) + in case gen# (CumulDims [n*n, n, 1]) f 0 of + (# _, r #) -> r + diag se + | n <- dimVal' @n + , e <- unScalar se + = let f 0 = (# n , e #) + f k = (# k - 1, 0 #) + in case gen# (CumulDims [n*n, n, 1]) f 0 of + (# _, r #) -> r + trace df + | I# n <- fromIntegral $ dimVal' @n + , n1 <- n +# 1# + = let f 0# = ix# 0# df + f k = ix# k df + f (k -# n1) + in scalar $ f (n *# n -# 1#) + + +instance ( KnownDim n, Ord t, Fractional t + , PrimBytes t + , PrimArray t (Matrix t n n) + , PrimArray t (Vector t n) + , PrimBytes (Vector t n) + , PrimBytes (Matrix t n n) + ) + => MatrixInverse t n where + inverse m = runST $ do + m' <- newDataFrame + indexWise_ @t @'[n] @'[n] @'[n, n] @_ @() + (\is -> + indexWise_ @t @'[n] @'[] @'[n] @_ @() + (\(j:*U) -> writeDataFrame m' (j:*is)) . luSolve luM + ) eye + unsafeFreezeDataFrame m' + where + luM = lu m + + -- much nicer, but probably slower version: + -- (it is not particularly fast to do an extra transpose + -- before calculating the inverse) + -- ewmap (luSolve . lu $ transpose m) eye + + + +instance ( KnownDim n, Ord t, Fractional t + , PrimBytes t, PrimArray t (Matrix t n n)) + => MatrixDeterminant t n where + det m = prodF (luUpper f) * prodF (luLower f) * luPermSign f + where + f = lu m + n = case dimVal' @n of W# w -> word2Int# w + n1 = n +# 1# + nn1 = n *# n -# 1# + prodF a = scalar $ prodF' nn1 a + prodF' 0# a = ix# 0# a + prodF' k a = ix# k a * prodF' (k -# n1) a + + +instance ( KnownDim n, Ord t, Fractional t + , PrimBytes t, PrimArray t (Matrix t n n)) + => MatrixLU t n where + lu m' = case runRW# go of + (# _, (# bu, bl #) #) -> LUFact + { luLower = fromElems steps 0# bl + , luUpper = fromElems steps 0# bu + , luPerm = p + , luPermSign = si + } + where + dn = dimVal' @n + dnn = dn * dn + steps = CumulDims [dnn, dn, 1] + (m, p, si) = pivotMat m' + n = case dn of W# w -> word2Int# w + nn = case dnn of W# w -> word2Int# w + tbs = byteSize @t undefined + bsize = nn *# tbs + ixm i j = ix# (i *# n +# j) m + loop :: (Int# -> a -> State# s -> (# State# s, a #)) + -> Int# -> Int# -> a -> State# s -> (# State# s, a #) + loop f i k x s + | isTrue# (i ==# k) = (# s, x #) + | otherwise = case f i x s of + (# s', y #) -> loop f ( i +# 1# ) k y s' + go s0 + | (# s1, mbl #) <- newByteArray# bsize s0 + , (# s2, mbu #) <- newByteArray# bsize s1 + , s3 <- setByteArray# mbl 0# bsize 0# s2 + , s4 <- setByteArray# mbu 0# bsize 0# s3 + , readL <- \i j -> readArray @t mbl (i *# n +# j) + , readU <- \i j -> readArray @t mbu (i *# n +# j) + , writeL <- \i j -> writeArray @t mbl (i *# n +# j) + , writeU <- \i j -> writeArray @t mbu (i *# n +# j) + , computeU <- \i j -> + let f k x s + | (# s' , ukj #) <- readU k j s + , (# s'', lik #) <- readL i k s' + = (# s'', x - ukj * lik #) + in loop f 0# i (ixm i j) + , computeL' <- \i j -> + let f k x s + | (# s' , ukj #) <- readU k j s + , (# s'', lik #) <- readL i k s' + = (# s'', x - ukj * lik #) + in loop f 0# j (ixm i j) + , (# sr, () #) <- + loop + ( \j _ sj -> case sj of + sj0 + | sj1 <- writeL j j 1 sj0 + , (# sj2, () #) <- loop + ( \i _ sij0 -> case computeU i j sij0 of + (# sij1, uij #) -> (# writeU i j uij sij1, () #) + ) 0# j () sj1 + , (# sj3, ujj #) <- computeU j j sj2 + , sj4 <- writeU j j ujj sj3 + -> case ujj of + 0 -> loop + ( \i _ sij -> (# writeL i j 0 sij, () #) + ) (j +# 1#) n () sj4 + x -> loop + ( \i _ sij0 -> case computeL' i j sij0 of + (# sij1, lij #) -> (# writeL i j (lij / x) sij1, () #) + ) (j +# 1#) n () sj4 + ) 0# n () s4 + , (# sf0, bl #) <- unsafeFreezeByteArray# mbl sr + , (# sf1, bu #) <- unsafeFreezeByteArray# mbu sf0 + = (# sf1, (# bu, bl #) #) + + +-- | Solve @Ax = b@ problem given LU decomposition of A. +luSolve :: forall (t :: Type) (n :: Nat) + . ( KnownDim n, Fractional t + , PrimArray t (Matrix t n n), PrimArray t (Vector t n)) + => LUFact t n -> Vector t n -> Vector t n +luSolve LUFact {..} b = x + where + -- Pb = LUx + pb = luPerm %* b + n# = case dimVal' @n of W# w -> word2Int# w + n = I# n# + -- Ly = Pb + y :: Vector t n + y = runST $ do + my <- newDataFrame + let ixA (I# i) (I# j) = scalar $ ix# (i *# n# +# j) luLower + ixB (I# i) = scalar $ ix# i pb + forM_ [0..n-1] $ \i -> do + v <- foldM ( \v j -> do + dj <- readDataFrameOff my j + return $ v - dj * ixA i j + ) (ixB i) [0..i-1] + writeDataFrameOff my i v + unsafeFreezeDataFrame my + -- Ux = y + x = runST $ do + mx <- newDataFrame + let ixA (I# i) (I# j) = scalar $ ix# (i *# n# +# j) luUpper + ixB (I# i) = scalar $ ix# i y + forM_ [n-1, n-2 .. 0] $ \i -> do + v <- foldM ( \v j -> do + dj <- readDataFrameOff mx j + return $ v - dj * ixA i j + ) (ixB i) [i+1..n-1] + writeDataFrameOff mx i (v / ixA i i) + unsafeFreezeDataFrame mx + + +-- | Permute rows that the largest magnitude elements in columns are on diagonals. +-- +-- Invariants of result matrix: +-- * forall j >= i: |M[i,i]| >= M[j,i] +-- * if M[i,i] == 0 then forall j >= i: |M[i+1,i+1]| >= M[j,i+1] +pivotMat :: forall (t :: Type) (n :: Nat) + . (KnownDim n, PrimArray t (Matrix t n n), Ord t, Num t) + => Matrix t n n -> ( Matrix t n n -- permutated matrix + , Matrix t n n -- permutation matrix + , Scalar t -- sign of permutation matrix + ) +pivotMat mat + = ( let f ( _, [] ) = undefined + f ( j, i:is ) + | j == n = f (0, is) + | otherwise = (# (j+1, i:is), ix i j #) + in case gen# steps f (0,rowOrder) of + (# _, r #) -> r + , let f ( _, [] ) = undefined + f ( j, x:xs ) + | j == n = f (0, xs) + | otherwise = (# ( j + 1, x:xs), if j == x then 1 else 0 #) + in case gen# steps f (0,rowOrder) of + (# _, r #) -> r + , if countMisordered rowOrder `rem` 2 == 1 + then -1 else 1 + ) + where + dn = dimVal' @n + steps = CumulDims [dn * dn, dn, 1] + -- permuted row ordering + rowOrder = uncurry fillPass $ searchPass 0 [0..n-1] + -- matrix size + n = fromIntegral dn + n# = case n of I# x -> x + -- sign of permutations + countMisordered :: [Int] -> Int + countMisordered [] = 0 + countMisordered (i:is) = foldl' (\c j -> if i > j then succ c else c) 0 is + + countMisordered is + ix (I# i) (I# j) = ix# (i *# n# +# j) mat + findMax :: Int -> [Int] -> (t, Int) + findMax j = foldl' (\(ox, oi) i -> let x = abs (ix i j) + in if x > ox then (x, i) + else (ox, oi) + ) (0, 0) + -- search maximums, leaving Nothing where all rows are 0 + searchPass :: Int -> [Int] -> ([Int], [Maybe Int]) + searchPass j is + | j == n = (is, []) + | otherwise = case findMax j is of + (0, _) -> (Nothing:) <$> searchPass (j+1) is + (_, i) -> (Just i:) <$> searchPass (j+1) (delete i is) + -- replace Nothings with remaining row numbers + fillPass :: [Int] -> [Maybe Int] -> [Int] + fillPass _ [] = [] + fillPass js (Just i : is) = i : fillPass js is + fillPass (j:js) (Nothing : is) = j : fillPass js is + fillPass [] (Nothing : is) = 0 : fillPass [] is diff --git a/src/Numeric/Matrix/Internal/Mat44d.hs b/src/Numeric/Matrix/Internal/Mat44d.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Matrix/Internal/Mat44d.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Numeric.Matrix.Internal.Mat44d () where + +import qualified Control.Monad.ST as ST +import qualified Numeric.DataFrame.ST as ST +import Numeric.Matrix.Internal +import Numeric.Scalar.Internal +import Numeric.Vector.Internal + +{-# INLINE mkMat #-} +mkMat :: + Double -> Double -> Double -> Double -> + Double -> Double -> Double -> Double -> + Double -> Double -> Double -> Double -> + Double -> Double -> Double -> Double -> + Mat44d +mkMat + _11 _12 _13 _14 + _21 _22 _23 _24 + _31 _32 _33 _34 + _41 _42 _43 _44 + = ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ scalar _11 + ST.writeDataFrameOff df 1 $ scalar _12 + ST.writeDataFrameOff df 2 $ scalar _13 + ST.writeDataFrameOff df 3 $ scalar _14 + ST.writeDataFrameOff df 4 $ scalar _21 + ST.writeDataFrameOff df 5 $ scalar _22 + ST.writeDataFrameOff df 6 $ scalar _23 + ST.writeDataFrameOff df 7 $ scalar _24 + ST.writeDataFrameOff df 8 $ scalar _31 + ST.writeDataFrameOff df 9 $ scalar _32 + ST.writeDataFrameOff df 10 $ scalar _33 + ST.writeDataFrameOff df 11 $ scalar _34 + ST.writeDataFrameOff df 12 $ scalar _41 + ST.writeDataFrameOff df 13 $ scalar _42 + ST.writeDataFrameOff df 14 $ scalar _43 + ST.writeDataFrameOff df 15 $ scalar _44 + ST.unsafeFreezeDataFrame df + +instance HomTransform4 Double where + {-# INLINE translate4 #-} + translate4 (unpackV4# -> (# x, y, z, _ #)) = mkMat + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y z 1 + + {-# INLINE translate3 #-} + translate3 (unpackV3# -> (# x, y, z #)) = mkMat + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y z 1 + + {-# INLINE rotateX #-} + rotateX a = mkMat + 1 0 0 0 + 0 c s 0 + 0 n c 0 + 0 0 0 1 + where + c = cos a + s = sin a + n = -s + + {-# INLINE rotateY #-} + rotateY a = mkMat + c 0 n 0 + 0 1 0 0 + s 0 c 0 + 0 0 0 1 + where + c = cos a + s = sin a + n = -s + + {-# INLINE rotateZ #-} + rotateZ a = mkMat + c s 0 0 + n c 0 0 + 0 0 1 0 + 0 0 0 1 + where + c = cos a + s = sin a + n = -s + + {-# INLINE rotate #-} + rotate (unpackV3# -> (# x, y, z #)) a = mkMat + (c+xxv) (yxv+zs) (zxv-ys) 0 + (xyv-zs) (c+yyv) (zyv+xs) 0 + (xzv+ys) (yzv-xs) (c+zzv) 0 + 0 0 0 1 + where + c = cos a + v = 1 - c -- v for versine + s = sin a + xxv = x * x * v + xyv = x * y * v + xzv = x * z * v + yxv = xyv + yyv = y * y * v + yzv = y * z * v + zxv = xzv + zyv = yzv + zzv = z * z * v + xs = x * s + ys = y * s + zs = z * s + + {-# INLINE rotateEuler #-} + rotateEuler x y z = mkMat + (cy*cz) (cx*sz+sx*sy*cz) (sx*sz-cx*sy*cz) 0 + (-cy*sz) (cx*cz-sx*sy*sz) (sx*cz+cx*sy*sz) 0 + sy (-sx*cy) (cx*cy) 0 + 0 0 0 1 + where + cx = cos x + sx = sin x + cy = cos y + sy = sin y + cz = cos z + sz = sin z + + {-# INLINE lookAt #-} + lookAt up cam foc = mkMat + xb1 yb1 zb1 0 + xb2 yb2 zb2 0 + xb3 yb3 zb3 0 + tx ty tz 1 + where + (# xb1, xb2, xb3 #) = unpackV3# xb + (# yb1, yb2, yb3 #) = unpackV3# yb + (# zb1, zb2, zb3 #) = unpackV3# zb + zb = normalized $ cam - foc -- Basis vector for "backward", since +Z is behind the camera + xb = normalized $ up `cross` zb -- Basis vector for "right" + yb = zb `cross` xb -- Basis vector for "up" + ncam = -cam + tx = unScalar $ xb `dot` ncam + ty = unScalar $ yb `dot` ncam + tz = unScalar $ zb `dot` ncam + + {-# INLINE perspective #-} + perspective n f fovy aspect = mkMat + dpw 0 0 0 + 0 dph 0 0 + 0 0 a (-1) + 0 0 b 0 + where + hpd = tan (fovy * 0.5) -- height/distance + wpd = aspect * hpd; -- width/distance + dph = recip hpd -- distance/height + dpw = recip wpd -- distance/width + nmf = n - f + a = (n + f) / nmf + b = 2 * n * f / nmf + + {-# INLINE orthogonal #-} + orthogonal n f w h = mkMat + iw 0 0 0 + 0 ih 0 0 + 0 0 a 0 + 0 0 b 1 + where + ih = 2 / h + iw = 2 / w + nmf = n - f + a = 2 / nmf + b = (n + f) / nmf + + {-# INLINE toHomPoint #-} + toHomPoint (unpackV3# -> (# x, y, z #)) = vec4 x y z 1 + + {-# INLINE toHomVector #-} + toHomVector (unpackV3# -> (# x, y, z #)) = vec4 x y z 0 + + {-# INLINE fromHom #-} + fromHom (unpackV4# -> (# x, y, z, w #)) + | w == 0 = vec3 x y z + | otherwise = vec3 (x/w) (y/w) (z/w) diff --git a/src/Numeric/Matrix/Internal/Mat44f.hs b/src/Numeric/Matrix/Internal/Mat44f.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Matrix/Internal/Mat44f.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Numeric.Matrix.Internal.Mat44f () where + +import qualified Control.Monad.ST as ST +import qualified Numeric.DataFrame.ST as ST +import Numeric.Matrix.Internal +import Numeric.Scalar.Internal +import Numeric.Vector.Internal + +{-# INLINE mkMat #-} +mkMat :: + Float -> Float -> Float -> Float -> + Float -> Float -> Float -> Float -> + Float -> Float -> Float -> Float -> + Float -> Float -> Float -> Float -> + Mat44f +mkMat + _11 _12 _13 _14 + _21 _22 _23 _24 + _31 _32 _33 _34 + _41 _42 _43 _44 + = ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ scalar _11 + ST.writeDataFrameOff df 1 $ scalar _12 + ST.writeDataFrameOff df 2 $ scalar _13 + ST.writeDataFrameOff df 3 $ scalar _14 + ST.writeDataFrameOff df 4 $ scalar _21 + ST.writeDataFrameOff df 5 $ scalar _22 + ST.writeDataFrameOff df 6 $ scalar _23 + ST.writeDataFrameOff df 7 $ scalar _24 + ST.writeDataFrameOff df 8 $ scalar _31 + ST.writeDataFrameOff df 9 $ scalar _32 + ST.writeDataFrameOff df 10 $ scalar _33 + ST.writeDataFrameOff df 11 $ scalar _34 + ST.writeDataFrameOff df 12 $ scalar _41 + ST.writeDataFrameOff df 13 $ scalar _42 + ST.writeDataFrameOff df 14 $ scalar _43 + ST.writeDataFrameOff df 15 $ scalar _44 + ST.unsafeFreezeDataFrame df + +instance HomTransform4 Float where + {-# INLINE translate4 #-} + translate4 (unpackV4# -> (# x, y, z, _ #)) = mkMat + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y z 1 + + {-# INLINE translate3 #-} + translate3 (unpackV3# -> (# x, y, z #)) = mkMat + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + x y z 1 + + {-# INLINE rotateX #-} + rotateX a = mkMat + 1 0 0 0 + 0 c s 0 + 0 n c 0 + 0 0 0 1 + where + c = cos a + s = sin a + n = -s + + {-# INLINE rotateY #-} + rotateY a = mkMat + c 0 n 0 + 0 1 0 0 + s 0 c 0 + 0 0 0 1 + where + c = cos a + s = sin a + n = -s + + {-# INLINE rotateZ #-} + rotateZ a = mkMat + c s 0 0 + n c 0 0 + 0 0 1 0 + 0 0 0 1 + where + c = cos a + s = sin a + n = -s + + {-# INLINE rotate #-} + rotate (unpackV3# -> (# x, y, z #)) a = mkMat + (c+xxv) (yxv+zs) (zxv-ys) 0 + (xyv-zs) (c+yyv) (zyv+xs) 0 + (xzv+ys) (yzv-xs) (c+zzv) 0 + 0 0 0 1 + where + c = cos a + v = 1 - c -- v for versine + s = sin a + xxv = x * x * v + xyv = x * y * v + xzv = x * z * v + yxv = xyv + yyv = y * y * v + yzv = y * z * v + zxv = xzv + zyv = yzv + zzv = z * z * v + xs = x * s + ys = y * s + zs = z * s + + {-# INLINE rotateEuler #-} + rotateEuler x y z = mkMat + (cy*cz) (cx*sz+sx*sy*cz) (sx*sz-cx*sy*cz) 0 + (-cy*sz) (cx*cz-sx*sy*sz) (sx*cz+cx*sy*sz) 0 + sy (-sx*cy) (cx*cy) 0 + 0 0 0 1 + where + cx = cos x + sx = sin x + cy = cos y + sy = sin y + cz = cos z + sz = sin z + + {-# INLINE lookAt #-} + lookAt up cam foc = mkMat + xb1 yb1 zb1 0 + xb2 yb2 zb2 0 + xb3 yb3 zb3 0 + tx ty tz 1 + where + (# xb1, xb2, xb3 #) = unpackV3# xb + (# yb1, yb2, yb3 #) = unpackV3# yb + (# zb1, zb2, zb3 #) = unpackV3# zb + zb = normalized $ cam - foc -- Basis vector for "backward", since +Z is behind the camera + xb = normalized $ up `cross` zb -- Basis vector for "right" + yb = zb `cross` xb -- Basis vector for "up" + ncam = -cam + tx = unScalar $ xb `dot` ncam + ty = unScalar $ yb `dot` ncam + tz = unScalar $ zb `dot` ncam + + {-# INLINE perspective #-} + perspective n f fovy aspect = mkMat + dpw 0 0 0 + 0 dph 0 0 + 0 0 a (-1) + 0 0 b 0 + where + hpd = tan (fovy * 0.5) -- height/distance + wpd = aspect * hpd; -- width/distance + dph = recip hpd -- distance/height + dpw = recip wpd -- distance/width + nmf = n - f + a = (n + f) / nmf + b = 2 * n * f / nmf + + {-# INLINE orthogonal #-} + orthogonal n f w h = mkMat + iw 0 0 0 + 0 ih 0 0 + 0 0 a 0 + 0 0 b 1 + where + ih = 2 / h + iw = 2 / w + nmf = n - f + a = 2 / nmf + b = (n + f) / nmf + + {-# INLINE toHomPoint #-} + toHomPoint (unpackV3# -> (# x, y, z #)) = vec4 x y z 1 + + {-# INLINE toHomVector #-} + toHomVector (unpackV3# -> (# x, y, z #)) = vec4 x y z 0 + + {-# INLINE fromHom #-} + fromHom (unpackV4# -> (# x, y, z, w #)) + | w == 0 = vec3 x y z + | otherwise = vec3 (x/w) (y/w) (z/w) diff --git a/src/Numeric/Matrix/Mat44d.hs b/src/Numeric/Matrix/Mat44d.hs deleted file mode 100644 --- a/src/Numeric/Matrix/Mat44d.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Numeric.Matrix.Mat44d () where - -import qualified Control.Monad.ST as ST -import GHC.Exts -import Numeric.DataFrame.Internal.Array.Family.DoubleX3 -import Numeric.DataFrame.Internal.Array.Family.DoubleX4 -import qualified Numeric.DataFrame.ST as ST -import Numeric.DataFrame.SubSpace -import Numeric.DataFrame.Type -import Numeric.Matrix.Class -import Numeric.Scalar -import Numeric.Vector - -{-# INLINE mat44d #-} -mat44d :: - Scd -> Scd -> Scd -> Scd -> - Scd -> Scd -> Scd -> Scd -> - Scd -> Scd -> Scd -> Scd -> - Scd -> Scd -> Scd -> Scd -> - Mat44d -mat44d - _11 _12 _13 _14 - _21 _22 _23 _24 - _31 _32 _33 _34 - _41 _42 _43 _44 - = ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 _11 - ST.writeDataFrameOff df 1 _21 - ST.writeDataFrameOff df 2 _31 - ST.writeDataFrameOff df 3 _41 - ST.writeDataFrameOff df 4 _12 - ST.writeDataFrameOff df 5 _22 - ST.writeDataFrameOff df 6 _32 - ST.writeDataFrameOff df 7 _42 - ST.writeDataFrameOff df 8 _13 - ST.writeDataFrameOff df 9 _23 - ST.writeDataFrameOff df 10 _33 - ST.writeDataFrameOff df 11 _43 - ST.writeDataFrameOff df 12 _14 - ST.writeDataFrameOff df 13 _24 - ST.writeDataFrameOff df 14 _34 - ST.writeDataFrameOff df 15 _44 - ST.unsafeFreezeDataFrame df - -instance HomTransform4 Double where - {-# INLINE translate4 #-} - translate4 (SingleFrame (DoubleX4# x# y# z# _)) = mat44d - 1 0 0 x - 0 1 0 y - 0 0 1 z - 0 0 0 1 - where - x = scalar $ D# x# - y = scalar $ D# y# - z = scalar $ D# z# - - {-# INLINE translate3 #-} - translate3 (SingleFrame (DoubleX3# x# y# z#)) = mat44d - 1 0 0 x - 0 1 0 y - 0 0 1 z - 0 0 0 1 - where - x = scalar $ D# x# - y = scalar $ D# y# - z = scalar $ D# z# - - {-# INLINE rotateX #-} - rotateX a = mat44d - 1 0 0 0 - 0 c n 0 - 0 s c 0 - 0 0 0 1 - where - c = scalar $ cos a - s = scalar $ sin a - n = -s - - {-# INLINE rotateY #-} - rotateY a = mat44d - c 0 s 0 - 0 1 0 0 - n 0 c 0 - 0 0 0 1 - where - c = scalar $ cos a - s = scalar $ sin a - n = -s - - {-# INLINE rotateZ #-} - rotateZ a = mat44d - c n 0 0 - s c 0 0 - 0 0 1 0 - 0 0 0 1 - where - c = scalar $ cos a - s = scalar $ sin a - n = -s - - {-# INLINE rotate #-} - rotate (SingleFrame (DoubleX3# x# y# z#)) a = mat44d - (c+xxv) (xyv-zs) (xzv+ys) 0 - (yxv+zs) (c+yyv) (yzv-xs) 0 - (zxv-ys) (zyv+xs) (c+zzv) 0 - 0 0 0 1 - where - c = scalar $ cos a - v = 1 - c -- v for versine - s = scalar $ sin a - x = scalar $ D# x# - y = scalar $ D# y# - z = scalar $ D# z# - xxv = x * x * v - xyv = x * y * v - xzv = x * z * v - yxv = xyv - yyv = y * y * v - yzv = y * z * v - zxv = xzv - zyv = yzv - zzv = z * z * v - xs = x * s - ys = y * s - zs = z * s - - {-# INLINE rotateEuler #-} - rotateEuler x y z = mat44d - (cy*cz) (-cy*sz) sy 0 - (cx*sz+sx*sy*cz) (cx*cz-sx*sy*sz) (-sx*cy) 0 - (sx*sz-cx*sy*cz) (sx*cz+cx*sy*sz) (cx*cy) 0 - 0 0 0 1 - where - cx = scalar $ cos x - sx = scalar $ sin x - cy = scalar $ cos y - sy = scalar $ sin y - cz = scalar $ cos z - sz = scalar $ sin z - - {-# INLINE lookAt #-} - lookAt up cam foc = mat44d - (xb!1) (xb!2) (xb!3) tx - (yb!1) (yb!2) (yb!3) ty - (zb!1) (zb!2) (zb!3) tz - 0 0 0 1 - where - zb = normalized $ cam - foc -- Basis vector for "backward", since +Z is behind the camera - xb = normalized $ up `cross` zb -- Basis vector for "right" - yb = zb `cross` xb -- Basis vector for "up" - ncam = -cam - tx = xb `dot` ncam - ty = yb `dot` ncam - tz = zb `dot` ncam - - {-# INLINE perspective #-} - perspective n f fovy aspect = mat44d - dpw 0 0 0 - 0 dph 0 0 - 0 0 a b - 0 0 (-1) 0 - where - hpd = tan (fovy * 0.5) -- height/distance - wpd = aspect * hpd; -- width/distance - dph = scalar $ 1 / hpd -- distance/height - dpw = scalar $ 1 / wpd -- distance/width - nmf = n - f - a = scalar $ (n + f) / nmf - b = scalar $ 2 * n * f / nmf - - {-# INLINE orthogonal #-} - orthogonal n f w h = mat44d - iw 0 0 0 - 0 ih 0 0 - 0 0 a b - 0 0 0 1 - where - ih = scalar $ 2 / h - iw = scalar $ 2 / w - nmf = n - f - a = scalar $ 2 / nmf - b = scalar $ (n + f) / nmf - - {-# INLINE toHomPoint #-} - toHomPoint (SingleFrame (DoubleX3# x# y# z#)) = SingleFrame (DoubleX4# x# y# z# 1.0##) - - {-# INLINE toHomVector #-} - toHomVector (SingleFrame (DoubleX3# x# y# z#)) = SingleFrame (DoubleX4# x# y# z# 0.0##) - - {-# INLINE fromHom #-} - fromHom (SingleFrame (DoubleX4# x# y# z# 0.0##)) = SingleFrame (DoubleX3# x# y# z#) - fromHom (SingleFrame (DoubleX4# x# y# z# w#)) = SingleFrame (DoubleX3# (x# /## w#) (y# /## w#) (z# /## w#)) diff --git a/src/Numeric/Matrix/Mat44f.hs b/src/Numeric/Matrix/Mat44f.hs deleted file mode 100644 --- a/src/Numeric/Matrix/Mat44f.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Numeric.Matrix.Mat44f () where - -import qualified Control.Monad.ST as ST -import GHC.Exts -import Numeric.DataFrame.Internal.Array.Family.FloatX3 -import Numeric.DataFrame.Internal.Array.Family.FloatX4 -import qualified Numeric.DataFrame.ST as ST -import Numeric.DataFrame.SubSpace -import Numeric.DataFrame.Type -import Numeric.Matrix.Class -import Numeric.Scalar -import Numeric.Vector - -{-# INLINE mat44f #-} -mat44f :: - Scf -> Scf -> Scf -> Scf -> - Scf -> Scf -> Scf -> Scf -> - Scf -> Scf -> Scf -> Scf -> - Scf -> Scf -> Scf -> Scf -> - Mat44f -mat44f - _11 _12 _13 _14 - _21 _22 _23 _24 - _31 _32 _33 _34 - _41 _42 _43 _44 - = ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 _11 - ST.writeDataFrameOff df 1 _21 - ST.writeDataFrameOff df 2 _31 - ST.writeDataFrameOff df 3 _41 - ST.writeDataFrameOff df 4 _12 - ST.writeDataFrameOff df 5 _22 - ST.writeDataFrameOff df 6 _32 - ST.writeDataFrameOff df 7 _42 - ST.writeDataFrameOff df 8 _13 - ST.writeDataFrameOff df 9 _23 - ST.writeDataFrameOff df 10 _33 - ST.writeDataFrameOff df 11 _43 - ST.writeDataFrameOff df 12 _14 - ST.writeDataFrameOff df 13 _24 - ST.writeDataFrameOff df 14 _34 - ST.writeDataFrameOff df 15 _44 - ST.unsafeFreezeDataFrame df - -instance HomTransform4 Float where - {-# INLINE translate4 #-} - translate4 (SingleFrame (FloatX4# x# y# z# _)) = mat44f - 1 0 0 x - 0 1 0 y - 0 0 1 z - 0 0 0 1 - where - x = scalar $ F# x# - y = scalar $ F# y# - z = scalar $ F# z# - - {-# INLINE translate3 #-} - translate3 (SingleFrame (FloatX3# x# y# z#)) = mat44f - 1 0 0 x - 0 1 0 y - 0 0 1 z - 0 0 0 1 - where - x = scalar $ F# x# - y = scalar $ F# y# - z = scalar $ F# z# - - {-# INLINE rotateX #-} - rotateX a = mat44f - 1 0 0 0 - 0 c n 0 - 0 s c 0 - 0 0 0 1 - where - c = scalar $ cos a - s = scalar $ sin a - n = -s - - {-# INLINE rotateY #-} - rotateY a = mat44f - c 0 s 0 - 0 1 0 0 - n 0 c 0 - 0 0 0 1 - where - c = scalar $ cos a - s = scalar $ sin a - n = -s - - {-# INLINE rotateZ #-} - rotateZ a = mat44f - c n 0 0 - s c 0 0 - 0 0 1 0 - 0 0 0 1 - where - c = scalar $ cos a - s = scalar $ sin a - n = -s - - {-# INLINE rotate #-} - rotate (SingleFrame (FloatX3# x# y# z#)) a = mat44f - (c+xxv) (xyv-zs) (xzv+ys) 0 - (yxv+zs) (c+yyv) (yzv-xs) 0 - (zxv-ys) (zyv+xs) (c+zzv) 0 - 0 0 0 1 - where - c = scalar $ cos a - v = 1 - c -- v for versine - s = scalar $ sin a - x = scalar $ F# x# - y = scalar $ F# y# - z = scalar $ F# z# - xxv = x * x * v - xyv = x * y * v - xzv = x * z * v - yxv = xyv - yyv = y * y * v - yzv = y * z * v - zxv = xzv - zyv = yzv - zzv = z * z * v - xs = x * s - ys = y * s - zs = z * s - - {-# INLINE rotateEuler #-} - rotateEuler x y z = mat44f - (cy*cz) (-cy*sz) sy 0 - (cx*sz+sx*sy*cz) (cx*cz-sx*sy*sz) (-sx*cy) 0 - (sx*sz-cx*sy*cz) (sx*cz+cx*sy*sz) (cx*cy) 0 - 0 0 0 1 - where - cx = scalar $ cos x - sx = scalar $ sin x - cy = scalar $ cos y - sy = scalar $ sin y - cz = scalar $ cos z - sz = scalar $ sin z - - {-# INLINE lookAt #-} - lookAt up cam foc = mat44f - (xb!1) (xb!2) (xb!3) tx - (yb!1) (yb!2) (yb!3) ty - (zb!1) (zb!2) (zb!3) tz - 0 0 0 1 - where - zb = normalized $ cam - foc -- Basis vector for "backward", since +Z is behind the camera - xb = normalized $ up `cross` zb -- Basis vector for "right" - yb = zb `cross` xb -- Basis vector for "up" - ncam = -cam - tx = xb `dot` ncam - ty = yb `dot` ncam - tz = zb `dot` ncam - - {-# INLINE perspective #-} - perspective n f fovy aspect = mat44f - dpw 0 0 0 - 0 dph 0 0 - 0 0 a b - 0 0 (-1) 0 - where - hpd = tan (fovy * 0.5) -- height/distance - wpd = aspect * hpd; -- width/distance - dph = scalar $ 1 / hpd -- distance/height - dpw = scalar $ 1 / wpd -- distance/width - nmf = n - f - a = scalar $ (n + f) / nmf - b = scalar $ 2 * n * f / nmf - - {-# INLINE orthogonal #-} - orthogonal n f w h = mat44f - iw 0 0 0 - 0 ih 0 0 - 0 0 a b - 0 0 0 1 - where - ih = scalar $ 2 / h - iw = scalar $ 2 / w - nmf = n - f - a = scalar $ 2 / nmf - b = scalar $ (n + f) / nmf - - {-# INLINE toHomPoint #-} - toHomPoint (SingleFrame (FloatX3# x# y# z#)) = SingleFrame (FloatX4# x# y# z# 1.0#) - - {-# INLINE toHomVector #-} - toHomVector (SingleFrame (FloatX3# x# y# z#)) = SingleFrame (FloatX4# x# y# z# 0.0#) - - {-# INLINE fromHom #-} - fromHom (SingleFrame (FloatX4# x# y# z# 0.0#)) = SingleFrame (FloatX3# x# y# z#) - fromHom (SingleFrame (FloatX4# x# y# z# w#)) = SingleFrame (FloatX3# (x# `divideFloat#` w#) (y# `divideFloat#` w#) (z# `divideFloat#` w#)) diff --git a/src/Numeric/PrimBytes.hs b/src/Numeric/PrimBytes.hs --- a/src/Numeric/PrimBytes.hs +++ b/src/Numeric/PrimBytes.hs @@ -1,1428 +1,1792 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- {-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} - -module Numeric.PrimBytes - ( PrimBytes - ( getBytes, fromBytes, readBytes, writeBytes, byteSize, byteAlign, byteOffset - , indexArray, readArray, writeArray, readAddr, writeAddr) - , PrimTag (..), primTag - ) where - -#include "MachDeps.h" - -import Data.Proxy (Proxy (..)) -import GHC.Exts -import GHC.Generics -import GHC.Int -import GHC.Word -import Numeric.Dimensions.Idxs -import qualified Numeric.Tuple.Lazy as TL -import qualified Numeric.Tuple.Strict as TS -import qualified Numeric.Type.List as L - --- | Facilities to convert to and from raw byte array. -class PrimTagged a => PrimBytes a where - -- | Store content of a data type in a primitive byte array - -- Should be used together with @byteOffset@ function. - getBytes :: a -> ByteArray# - -- | Load content of a data type from a primitive byte array - fromBytes :: Int# -- ^ offset in bytes - -> ByteArray# - -> a - -- | Read data from a mutable byte array given an offset in bytes - readBytes :: MutableByteArray# s -- ^ source array - -> Int# -- ^ byte offset of the source array - -> State# s -> (# State# s, a #) - -- | Write data into a mutable byte array at a given position (offset in bytes) - writeBytes :: MutableByteArray# s -- ^ destination array - -> Int# -- ^ byte offset of the destination array - -> a -- ^ data to write into array - -> State# s -> State# s - -- | Read data from a specified address - readAddr :: Addr# -> State# s -> (# State# s, a #) - -- | Write data to a specified address - writeAddr :: a -> Addr# -> State# s -> State# s - -- | Size of a data type in bytes - byteSize :: a -> Int# - -- | Alignment of a data type in bytes. - -- @byteOffset@ should be multiple of this value. - byteAlign :: a -> Int# - -- | Offset of the data in a byte array used to store the data, - -- measured in bytes. - -- Should be used together with @getBytes@ function. - -- Unless in case of special data types represented by ByteArrays, - -- it is equal to zero. - byteOffset :: a -> Int# - - -- | Index array given an element offset. - -- - -- > indexArray arr i = fromBytes ( i *# byteSize t) arr - indexArray :: ByteArray# -> Int# -> a - indexArray ba i = fromBytes (i *# byteSize @a undefined) ba - {-# INLINE indexArray #-} - - -- | Read a mutable array given an element offset. - -- - -- > readArray arr i = readBytes arr ( i *# byteSize t) - readArray :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) - readArray ba i = readBytes ba (i *# byteSize @a undefined) - {-# INLINE readArray #-} - - -- | Write a mutable array given an element offset. - -- - -- > writeArray arr i = writeBytes arr ( i *# byteSize t) - writeArray :: MutableByteArray# s -> Int# -> a -> State# s -> State# s - writeArray ba i = writeBytes ba (i *# byteSize @a undefined) - {-# INLINE writeArray #-} - - - - default getBytes :: (Generic a, GPrimBytes (Rep a)) => a -> ByteArray# - getBytes a = ggetBytes (from a) - {-# INLINE getBytes #-} - - default fromBytes :: (Generic a, GPrimBytes (Rep a)) - => Int# -> ByteArray# -> a - fromBytes i arr = to (gfromBytes 0## i arr) - {-# INLINE fromBytes #-} - - default readBytes :: (Generic a, GPrimBytes (Rep a)) - => MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) - readBytes mba i s = case greadBytes 0## mba i s of - (# s', x #) -> (# s', to x #) - {-# INLINE readBytes #-} - - default writeBytes :: (Generic a, GPrimBytes (Rep a)) - => MutableByteArray# s -> Int# -> a -> State# s -> State# s - writeBytes mba i = gwriteBytes 0## mba i . from - {-# INLINE writeBytes #-} - - default readAddr :: (Generic a, GPrimBytes (Rep a)) - => Addr# -> State# s -> (# State# s, a #) - readAddr a s = case greadAddr 0## a s of - (# s', x #) -> (# s', to x #) - {-# INLINE readAddr #-} - - default writeAddr :: (Generic a, GPrimBytes (Rep a)) - => a -> Addr# -> State# s -> State# s - writeAddr = gwriteAddr 0## . from - {-# INLINE writeAddr #-} - - - default byteSize :: (Generic a, GPrimBytes (Rep a)) - => a -> Int# - byteSize a = gbyteSize (from a) - {-# INLINE byteSize #-} - - default byteAlign :: (Generic a, GPrimBytes (Rep a)) - => a -> Int# - byteAlign a = gbyteAlign (from a) - {-# INLINE byteAlign #-} - - default byteOffset :: (Generic a, GPrimBytes (Rep a)) - => a -> Int# - byteOffset a = gbyteOffset (from a) - {-# INLINE byteOffset #-} - - --- | Deriving `PrimBytes` using generics -class GPrimBytes f where - ggetBytes :: f p -> ByteArray# - gfromBytes :: Word# -- ^ Starting value of a constructor tag - -> Int# -> ByteArray# -> f p - greadBytes :: Word# -- ^ Starting value of a constructor tag - -> MutableByteArray# s -> Int# -> State# s -> (# State# s, f p #) - gwriteBytes :: Word# -- ^ Starting value of a constructor tag - -> MutableByteArray# s -> Int# -> f p -> State# s -> State# s - greadAddr :: Word# -- ^ Starting value of a constructor tag - -> Addr# -> State# s -> (# State# s, f p #) - gwriteAddr :: Word# -- ^ Starting value of a constructor tag - -> f p -> Addr# -> State# s -> State# s - gbyteSize :: f p -> Int# - gbyteAlign :: f p -> Int# - gbyteOffset :: f p -> Int# - -- | Number of constructors in the tree of a sum type. - -- This is equal to one for all other types. - gconTags :: f p -> Word# - - -instance GPrimBytes V1 where - -- Probably, this is illegal due to zero size of the array. - -- There is no bottom to put here, but one should not call this anyway. - ggetBytes _ = case runRW# - ( \s0 -> case newByteArray# 0# s0 of - (# s1, marr #) -> unsafeFreezeByteArray# marr s1 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ _ _ = undefined - {-# INLINE gfromBytes #-} - greadBytes _ _ _ s = (# s, undefined #) - {-# INLINE greadBytes #-} - gwriteBytes _ _ _ _ s = s - {-# INLINE gwriteBytes #-} - greadAddr _ _ s = (# s, undefined #) - {-# INLINE greadAddr #-} - gwriteAddr _ _ _ s = s - {-# INLINE gwriteAddr #-} - gbyteSize _ = 0# - {-# INLINE gbyteSize #-} - gbyteAlign _ = 1# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 1## - {-# INLINE gconTags #-} - -instance GPrimBytes U1 where - -- Probably, this is illegal due to zero size of the array. - -- There is no bottom to put here, but one should not call this anyway. - ggetBytes _ = case runRW# - ( \s0 -> case newByteArray# 0# s0 of - (# s1, marr #) -> unsafeFreezeByteArray# marr s1 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ _ _ = U1 - {-# INLINE gfromBytes #-} - greadBytes _ _ _ s = (# s, U1 #) - {-# INLINE greadBytes #-} - gwriteBytes _ _ _ _ s = s - {-# INLINE gwriteBytes #-} - greadAddr _ _ s = (# s, U1 #) - {-# INLINE greadAddr #-} - gwriteAddr _ _ _ s = s - {-# INLINE gwriteAddr #-} - gbyteSize _ = 0# - {-# INLINE gbyteSize #-} - gbyteAlign _ = 1# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 1## - {-# INLINE gconTags #-} - -instance PrimBytes a => GPrimBytes (K1 i a) where - ggetBytes ~(K1 a) = getBytes a - {-# NOINLINE ggetBytes #-} - gfromBytes _ i ba = K1 (fromBytes i ba) - {-# INLINE gfromBytes #-} - greadBytes _ = unsafeCoerce# (readBytes @a) - {-# INLINE greadBytes #-} - gwriteBytes _ mba i ~(K1 a) = writeBytes mba i a - {-# INLINE gwriteBytes #-} - greadAddr _ = unsafeCoerce# (readAddr @a) - {-# INLINE greadAddr #-} - gwriteAddr _ ~(K1 a) = writeAddr a - {-# INLINE gwriteAddr #-} - gbyteSize ~(K1 a) = byteSize a - {-# INLINE gbyteSize #-} - gbyteAlign ~(K1 a) = byteAlign a - {-# INLINE gbyteAlign #-} - gbyteOffset ~(K1 a) = byteOffset a - {-# INLINE gbyteOffset #-} - gconTags _ = 1## - {-# INLINE gconTags #-} - -instance GPrimBytes f => GPrimBytes (M1 i c f) where - ggetBytes ~(M1 a) = ggetBytes a - {-# NOINLINE ggetBytes #-} - gfromBytes t i ba = M1 (gfromBytes t i ba) - {-# INLINE gfromBytes #-} - greadBytes = unsafeCoerce# (greadBytes @f) - {-# INLINE greadBytes #-} - gwriteBytes t mba i ~(M1 a) = gwriteBytes t mba i a - {-# INLINE gwriteBytes #-} - greadAddr = unsafeCoerce# (greadAddr @f) - {-# INLINE greadAddr #-} - gwriteAddr t ~(M1 a) = gwriteAddr t a - {-# INLINE gwriteAddr #-} - gbyteSize ~(M1 a) = gbyteSize a - {-# INLINE gbyteSize #-} - gbyteAlign ~(M1 a) = gbyteAlign a - {-# INLINE gbyteAlign #-} - gbyteOffset ~(M1 a) = gbyteOffset a - {-# INLINE gbyteOffset #-} - gconTags ~(M1 a) = gconTags a - {-# INLINE gconTags #-} - - -instance (GPrimBytes f, GPrimBytes g) => GPrimBytes (f :*: g) where - -- | This function return not pinned byte array, which is aligned to - -- @SIZEOF_HSWORD@. - -- Thus, it ignores alignment of the underlying data type if it is larger. - -- However, alignment calculation still makes sense for data types - -- that are smaller than @SIZEOF_HSWORD@ bytes: they are packed more densely. - ggetBytes xy = case runRW# - ( \s0 -> case newByteArray# (gbyteSize xy) s0 of - (# s1, marr #) -> unsafeFreezeByteArray# marr - (gwriteBytes 0## marr 0# xy s1) - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ i ba = x :*: y - where - x = gfromBytes 0## i ba - y = gfromBytes 0## (i +# roundUpInt# (gbyteSize x) (gbyteAlign y)) ba - {-# INLINE gfromBytes #-} - greadBytes _ mba i s0 = case greadBytes 0## mba i s0 of - (# s1, x #) -> case greadBytes 0## mba - (i +# roundUpInt# (gbyteSize x) - (gbyteAlign @g undefined) - ) s1 of - (# s2, y #) -> (# s2, x :*: y #) - {-# INLINE greadBytes #-} - gwriteBytes _ mba off ~(x :*: y) s = - gwriteBytes 0## mba (off +# roundUpInt# (gbyteSize x) (gbyteAlign y)) y - (gwriteBytes 0## mba off x s) - {-# INLINE gwriteBytes #-} - greadAddr _ addr s0 = case greadAddr 0## addr s0 of - (# s1, x #) -> case greadAddr 0## - (plusAddr# addr - (roundUpInt# (gbyteSize x) - (gbyteAlign @g undefined)) - ) s1 of - (# s2, y #) -> (# s2, x :*: y #) - {-# INLINE greadAddr #-} - gwriteAddr _ ~(x :*: y) addr s = - gwriteAddr 0## y (plusAddr# addr (roundUpInt# (gbyteSize x) (gbyteAlign y))) - (gwriteAddr 0## x addr s) - {-# INLINE gwriteAddr #-} - gbyteSize ~(x :*: y) - = gbyteSize y +# roundUpInt# (gbyteSize x) (gbyteAlign y) - {-# INLINE gbyteSize #-} - gbyteAlign ~(x :*: y) = maxInt# (gbyteAlign x) (gbyteAlign y) - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 1## - {-# INLINE gconTags #-} - - --- | Reserve 4 bytes for tag and try to pack alternatives as good as possible. -instance (GPrimBytes f, GPrimBytes g) => GPrimBytes (f :+: g) where - ggetBytes xy = case runRW# - ( \s0 -> case newByteArray# (gbyteSize xy) s0 of - (# s1, marr #) -> unsafeFreezeByteArray# marr - (gwriteBytes 0## marr 0# xy s1) - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes toff off ba - = case (# gconTags (undefined :: f a) - , gconTags (undefined :: g a) - , indexWord32Array# ba (uncheckedIShiftRL# off 2#) - `minusWord#` toff - #) of - (# 1##, _ , 0## #) -> L1 (gfromBytes 0## (off +# 4#) ba) - (# cl , 1##, t #) - | isTrue# (eqWord# cl t) -> R1 (gfromBytes 0## (off +# 4#) ba) - (# cl , _ , t #) - | isTrue# (geWord# cl t) -> L1 (gfromBytes toff off ba) - | otherwise -> R1 (gfromBytes (plusWord# toff cl) off ba) - {-# INLINE gfromBytes #-} - greadBytes toff mba off s0 - = case readWord32Array# mba (uncheckedIShiftRL# off 2#) s0 of - (# s1, tval #) -> case (# gconTags (undefined :: f a) - , gconTags (undefined :: g a) - , tval `minusWord#` toff - #) of - (# 1##, _ , 0## #) -> case greadBytes 0## mba (off +# 4#) s1 of - (# s2, r #) -> (# s2, L1 r #) - (# cl , 1##, t #) - | isTrue# (eqWord# cl t) -> case greadBytes 0## mba (off +# 4#) s1 of - (# s2, r #) -> (# s2, R1 r #) - (# cl , _ , t #) - | isTrue# (geWord# cl t) -> case greadBytes toff mba off s1 of - (# s2, r #) -> (# s2, L1 r #) - | otherwise -> case greadBytes (plusWord# toff cl) mba off s1 of - (# s2, r #) -> (# s2, R1 r #) - {-# INLINE greadBytes #-} - gwriteBytes t mba off (L1 x) s - = case gconTags x of - 1## -> gwriteBytes 0## mba (off +# 4#) x - (writeWord32Array# mba (uncheckedIShiftRL# off 2#) t s) - _ -> gwriteBytes t mba off x s - gwriteBytes t mba off xy@(R1 y) s - = case (# gconTags y, plusWord# t (gconTags (undef1 @f xy)) #) of - (# 1## , t' #) -> gwriteBytes 0## mba (off +# 4#) y - (writeWord32Array# mba (uncheckedIShiftRL# off 2#) t' s) - (# _ , t' #) -> gwriteBytes t' mba off y s - {-# INLINE gwriteBytes #-} - greadAddr toff addr s0 - = case readWord32OffAddr# addr 0# s0 of - (# s1, tval #) -> case (# gconTags (undefined :: f a) - , gconTags (undefined :: g a) - , tval `minusWord#` toff - #) of - (# 1##, _ , 0## #) -> case greadAddr 0## (plusAddr# addr 4#) s1 of - (# s2, r #) -> (# s2, L1 r #) - (# cl , 1##, t #) - | isTrue# (eqWord# cl t) -> case greadAddr 0## (plusAddr# addr 4#) s1 of - (# s2, r #) -> (# s2, R1 r #) - (# cl , _ , t #) - | isTrue# (geWord# cl t) -> case greadAddr toff addr s1 of - (# s2, r #) -> (# s2, L1 r #) - | otherwise -> case greadAddr (plusWord# toff cl) addr s1 of - (# s2, r #) -> (# s2, R1 r #) - {-# INLINE greadAddr #-} - gwriteAddr t (L1 x) addr s - = case gconTags x of - 1## -> gwriteAddr 0## x (plusAddr# addr 4#) - (writeWord32OffAddr# addr 0# t s) - _ -> gwriteAddr t x addr s - gwriteAddr t xy@(R1 y) addr s - = case (# gconTags y, plusWord# t (gconTags (undef1 @f xy)) #) of - (# 1## , t' #) -> gwriteAddr 0## y (plusAddr# addr 4#) - (writeWord32OffAddr# addr 0# t' s) - (# _ , t' #) -> gwriteAddr t' y addr s - {-# INLINE gwriteAddr #-} - gbyteSize xy = maxInt# - (roundUpInt# 4# (gbyteAlign x) +# gbyteSize x) - (roundUpInt# 4# (gbyteAlign y) +# gbyteSize y) - where - x = undef1 @f xy - y = undef1 @g xy - {-# INLINE gbyteSize #-} - gbyteAlign xy = maxInt# 4# ( maxInt# (gbyteAlign (undef1 @f xy)) - (gbyteAlign (undef1 @g xy)) - ) - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags xy = gconTags (undef1 @f xy) `plusWord#` gconTags (undef1 @g xy) - {-# INLINE gconTags #-} - -maxInt# :: Int# -> Int# -> Int# -maxInt# a b | isTrue# (a ># b) = a - | otherwise = b - -roundUpInt# :: Int# -> Int# -> Int# -roundUpInt# a b = case remInt# a b of - 0# -> a - q -> a +# b -# q -{-# INLINE roundUpInt# #-} - -undef1 :: forall p q a . q a -> p a -undef1 = const undefined -{-# INLINE undef1 #-} - - - -#if SIZEOF_HSWORD == 4 -#define OFFSHIFT_W 2 -#else -#define OFFSHIFT_W 3 -#endif - -instance GPrimBytes (URec Word) where - ggetBytes x = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSWORD# s0 of - (# s1, marr #) -> case writeWordArray# marr 0# (uWord# x) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ off ba - = UWord (indexWordArray# ba (uncheckedIShiftRL# off OFFSHIFT_W#)) - {-# INLINE gfromBytes #-} - greadBytes _ mba off s - = case readWordArray# mba (uncheckedIShiftRL# off OFFSHIFT_W#) s of - (# s1, r #) -> (# s1, UWord r #) - {-# INLINE greadBytes #-} - gwriteBytes _ mba off x - = writeWordArray# mba (uncheckedIShiftRL# off OFFSHIFT_W#) (uWord# x) - {-# INLINE gwriteBytes #-} - greadAddr _ a s - = case readWordOffAddr# a 0# s of (# s', x #) -> (# s', UWord x #) - {-# INLINE greadAddr #-} - gwriteAddr _ x a - = writeWordOffAddr# a 0# (uWord# x) - {-# INLINE gwriteAddr #-} - gbyteSize _ = SIZEOF_HSWORD# - {-# INLINE gbyteSize #-} - gbyteAlign _ = ALIGNMENT_HSWORD# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 0## - {-# INLINE gconTags #-} - -#if SIZEOF_HSINT == 4 -#define OFFSHIFT_I 2 -#else -#define OFFSHIFT_I 3 -#endif - -instance GPrimBytes (URec Int) where - ggetBytes x = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSINT# s0 of - (# s1, marr #) -> case writeIntArray# marr 0# (uInt# x) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ off ba - = UInt (indexIntArray# ba (uncheckedIShiftRL# off OFFSHIFT_I#)) - {-# INLINE gfromBytes #-} - greadBytes _ mba off s - = case readIntArray# mba (uncheckedIShiftRL# off OFFSHIFT_I#) s of - (# s1, r #) -> (# s1, UInt r #) - {-# INLINE greadBytes #-} - gwriteBytes _ mba off x - = writeIntArray# mba (uncheckedIShiftRL# off OFFSHIFT_I#) (uInt# x) - {-# INLINE gwriteBytes #-} - greadAddr _ a s - = case readIntOffAddr# a 0# s of (# s', x #) -> (# s', UInt x #) - {-# INLINE greadAddr #-} - gwriteAddr _ x a - = writeIntOffAddr# a 0# (uInt# x) - {-# INLINE gwriteAddr #-} - gbyteSize _ = SIZEOF_HSINT# - {-# INLINE gbyteSize #-} - gbyteAlign _ = ALIGNMENT_HSINT# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 0## - {-# INLINE gconTags #-} - - -#if SIZEOF_HSFLOAT == 4 -#define OFFSHIFT_F 2 -#else -#define OFFSHIFT_F 3 -#endif - -instance GPrimBytes (URec Float) where - ggetBytes x = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSFLOAT# s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# (uFloat# x) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ off ba - = UFloat (indexFloatArray# ba (uncheckedIShiftRL# off OFFSHIFT_F#)) - {-# INLINE gfromBytes #-} - greadBytes _ mba off s - = case readFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) s of - (# s1, r #) -> (# s1, UFloat r #) - {-# INLINE greadBytes #-} - gwriteBytes _ mba off x - = writeFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) (uFloat# x) - {-# INLINE gwriteBytes #-} - greadAddr _ a s - = case readFloatOffAddr# a 0# s of (# s', x #) -> (# s', UFloat x #) - {-# INLINE greadAddr #-} - gwriteAddr _ x a - = writeFloatOffAddr# a 0# (uFloat# x) - {-# INLINE gwriteAddr #-} - gbyteSize _ = SIZEOF_HSFLOAT# - {-# INLINE gbyteSize #-} - gbyteAlign _ = ALIGNMENT_HSFLOAT# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 0## - {-# INLINE gconTags #-} - -#if SIZEOF_HSDOUBLE == 4 -#define OFFSHIFT_D 2 -#else -#define OFFSHIFT_D 3 -#endif - -instance GPrimBytes (URec Double) where - ggetBytes x = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSDOUBLE# s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# (uDouble# x) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ off ba - = UDouble (indexDoubleArray# ba (uncheckedIShiftRL# off OFFSHIFT_D#)) - {-# INLINE gfromBytes #-} - greadBytes _ mba off s - = case readDoubleArray# mba (uncheckedIShiftRL# off OFFSHIFT_D#) s of - (# s1, r #) -> (# s1, UDouble r #) - {-# INLINE greadBytes #-} - gwriteBytes _ mba off x - = writeDoubleArray# mba (uncheckedIShiftRL# off OFFSHIFT_D#) (uDouble# x) - {-# INLINE gwriteBytes #-} - greadAddr _ a s - = case readDoubleOffAddr# a 0# s of (# s', x #) -> (# s', UDouble x #) - {-# INLINE greadAddr #-} - gwriteAddr _ x a - = writeDoubleOffAddr# a 0# (uDouble# x) - {-# INLINE gwriteAddr #-} - gbyteSize _ = SIZEOF_HSDOUBLE# - {-# INLINE gbyteSize #-} - gbyteAlign _ = ALIGNMENT_HSDOUBLE# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 0## - {-# INLINE gconTags #-} - -#if SIZEOF_HSCHAR == 2 -#define OFFSHIFT_C 1 -#elif SIZEOF_HSCHAR == 4 -#define OFFSHIFT_C 2 -#else -#define OFFSHIFT_C 3 -#endif - -instance GPrimBytes (URec Char) where - ggetBytes x = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSCHAR# s0 of - (# s1, marr #) -> case writeCharArray# marr 0# (uChar# x) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ off ba - = UChar (indexCharArray# ba (uncheckedIShiftRL# off OFFSHIFT_C#)) - {-# INLINE gfromBytes #-} - greadBytes _ mba off s - = case readCharArray# mba (uncheckedIShiftRL# off OFFSHIFT_C#) s of - (# s1, r #) -> (# s1, UChar r #) - {-# INLINE greadBytes #-} - gwriteBytes _ mba off x - = writeCharArray# mba (uncheckedIShiftRL# off OFFSHIFT_C#) (uChar# x) - {-# INLINE gwriteBytes #-} - greadAddr _ a s - = case readCharOffAddr# a 0# s of (# s', x #) -> (# s', UChar x #) - {-# INLINE greadAddr #-} - gwriteAddr _ x a - = writeCharOffAddr# a 0# (uChar# x) - {-# INLINE gwriteAddr #-} - gbyteSize _ = SIZEOF_HSCHAR# - {-# INLINE gbyteSize #-} - gbyteAlign _ = ALIGNMENT_HSCHAR# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 0## - {-# INLINE gconTags #-} - -#if SIZEOF_HSPTR == 4 -#define OFFSHIFT_P 2 -#else -#define OFFSHIFT_P 3 -#endif - -instance GPrimBytes (URec (Ptr ())) where - ggetBytes x = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSPTR# s0 of - (# s1, marr #) -> case writeAddrArray# marr 0# (uAddr# x) s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE ggetBytes #-} - gfromBytes _ off ba - = UAddr (indexAddrArray# ba (uncheckedIShiftRL# off OFFSHIFT_P#)) - {-# INLINE gfromBytes #-} - greadBytes _ mba off s - = case readAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) s of - (# s1, r #) -> (# s1, UAddr r #) - {-# INLINE greadBytes #-} - gwriteBytes _ mba off x - = writeAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) (uAddr# x) - {-# INLINE gwriteBytes #-} - greadAddr _ a s - = case readAddrOffAddr# a 0# s of (# s', x #) -> (# s', UAddr x #) - {-# INLINE greadAddr #-} - gwriteAddr _ x a - = writeAddrOffAddr# a 0# (uAddr# x) - {-# INLINE gwriteAddr #-} - gbyteSize _ = SIZEOF_HSPTR# - {-# INLINE gbyteSize #-} - gbyteAlign _ = ALIGNMENT_HSPTR# - {-# INLINE gbyteAlign #-} - gbyteOffset _ = 0# - {-# INLINE gbyteOffset #-} - gconTags _ = 0## - {-# INLINE gconTags #-} - - - - --------------------------------------------------------------------------------- --- Basic instances --------------------------------------------------------------------------------- - - -instance PrimBytes Word where - getBytes (W# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSWORD# s0 of - (# s1, marr #) -> case writeWordArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = W# (indexWordArray# ba (uncheckedIShiftRL# off OFFSHIFT_W#)) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off OFFSHIFT_W#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_W#) - {-# INLINE writeBytes #-} - readAddr a s - = case readWordOffAddr# a 0# s of (# s', x #) -> (# s', W# x #) - {-# INLINE readAddr #-} - writeAddr (W# x) a - = writeWordOffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_HSWORD# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSWORD# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = W# (indexWordArray# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readWordArray# mba i s of (# s', x #) -> (# s', W# x #) - {-# INLINE readArray #-} - writeArray mba i (W# x) = writeWordArray# mba i x - {-# INLINE writeArray #-} - - -instance PrimBytes Int where - getBytes (I# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSINT# s0 of - (# s1, marr #) -> case writeIntArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = I# (indexIntArray# ba (uncheckedIShiftRL# off OFFSHIFT_I#)) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off OFFSHIFT_I#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_I#) - {-# INLINE writeBytes #-} - readAddr a s - = case readIntOffAddr# a 0# s of (# s', x #) -> (# s', I# x #) - {-# INLINE readAddr #-} - writeAddr (I# x) a - = writeIntOffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_HSINT# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSINT# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = I# (indexIntArray# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readIntArray# mba i s of (# s', x #) -> (# s', I# x #) - {-# INLINE readArray #-} - writeArray mba i (I# x) = writeIntArray# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Float where - getBytes (F# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSFLOAT# s0 of - (# s1, marr #) -> case writeFloatArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = F# (indexFloatArray# ba (uncheckedIShiftRL# off OFFSHIFT_F#)) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off OFFSHIFT_F#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_F#) - {-# INLINE writeBytes #-} - readAddr a s - = case readFloatOffAddr# a 0# s of (# s', x #) -> (# s', F# x #) - {-# INLINE readAddr #-} - writeAddr (F# x) a - = writeFloatOffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_HSFLOAT# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSFLOAT# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = F# (indexFloatArray# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readFloatArray# mba i s of (# s', x #) -> (# s', F# x #) - {-# INLINE readArray #-} - writeArray mba i (F# x) = writeFloatArray# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Double where - getBytes (D# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSDOUBLE# s0 of - (# s1, marr #) -> case writeDoubleArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = D# (indexDoubleArray# ba (uncheckedIShiftRL# off OFFSHIFT_D#)) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off OFFSHIFT_D#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_D#) - {-# INLINE writeBytes #-} - readAddr a s - = case readDoubleOffAddr# a 0# s of (# s', x #) -> (# s', D# x #) - {-# INLINE readAddr #-} - writeAddr (D# x) a - = writeDoubleOffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_HSDOUBLE# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSDOUBLE# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = D# (indexDoubleArray# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readDoubleArray# mba i s of (# s', x #) -> (# s', D# x #) - {-# INLINE readArray #-} - writeArray mba i (D# x) = writeDoubleArray# mba i x - {-# INLINE writeArray #-} - - -instance PrimBytes (Ptr a) where - getBytes (Ptr x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_HSPTR# s0 of - (# s1, marr #) -> case writeAddrArray# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = Ptr (indexAddrArray# ba (uncheckedIShiftRL# off OFFSHIFT_P#)) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off OFFSHIFT_P#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off OFFSHIFT_P#) - {-# INLINE writeBytes #-} - readAddr a s - = case readAddrOffAddr# a 0# s of (# s', x #) -> (# s', Ptr x #) - {-# INLINE readAddr #-} - writeAddr (Ptr x) a - = writeAddrOffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_HSPTR# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_HSPTR# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = Ptr (indexAddrArray# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readAddrArray# mba i s of (# s', x #) -> (# s', Ptr x #) - {-# INLINE readArray #-} - writeArray mba i (Ptr x) = writeAddrArray# mba i x - {-# INLINE writeArray #-} - - -instance PrimBytes Int8 where - getBytes (I8# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_INT8# s0 of - (# s1, marr #) -> case writeInt8Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba = indexArray ba off - {-# INLINE fromBytes #-} - readBytes = readArray - {-# INLINE readBytes #-} - writeBytes = writeArray - {-# INLINE writeBytes #-} - readAddr a s - = case readInt8OffAddr# a 0# s of (# s', x #) -> (# s', I8# x #) - {-# INLINE readAddr #-} - writeAddr (I8# x) a - = writeInt8OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_INT8# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT8# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = I8# (indexInt8Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readInt8Array# mba i s of (# s', x #) -> (# s', I8# x #) - {-# INLINE readArray #-} - writeArray mba i (I8# x) = writeInt8Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Int16 where - getBytes (I16# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_INT16# s0 of - (# s1, marr #) -> case writeInt16Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = indexArray ba (uncheckedIShiftRL# off 1#) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off 1#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off 1#) - {-# INLINE writeBytes #-} - readAddr a s - = case readInt16OffAddr# a 0# s of (# s', x #) -> (# s', I16# x #) - {-# INLINE readAddr #-} - writeAddr (I16# x) a - = writeInt16OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_INT16# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT16# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = I16# (indexInt16Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readInt16Array# mba i s of (# s', x #) -> (# s', I16# x #) - {-# INLINE readArray #-} - writeArray mba i (I16# x) = writeInt16Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Int32 where - getBytes (I32# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_INT32# s0 of - (# s1, marr #) -> case writeInt32Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = indexArray ba (uncheckedIShiftRL# off 2#) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off 2#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off 2#) - {-# INLINE writeBytes #-} - readAddr a s - = case readInt32OffAddr# a 0# s of (# s', x #) -> (# s', I32# x #) - {-# INLINE readAddr #-} - writeAddr (I32# x) a - = writeInt32OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_INT32# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT32# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = I32# (indexInt32Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readInt32Array# mba i s of (# s', x #) -> (# s', I32# x #) - {-# INLINE readArray #-} - writeArray mba i (I32# x) = writeInt32Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Int64 where - getBytes (I64# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_INT64# s0 of - (# s1, marr #) -> case writeInt64Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = indexArray ba (uncheckedIShiftRL# off 3#) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off 3#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off 3#) - {-# INLINE writeBytes #-} - readAddr a s - = case readInt64OffAddr# a 0# s of (# s', x #) -> (# s', I64# x #) - {-# INLINE readAddr #-} - writeAddr (I64# x) a - = writeInt64OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_INT64# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_INT64# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = I64# (indexInt64Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readInt64Array# mba i s of (# s', x #) -> (# s', I64# x #) - {-# INLINE readArray #-} - writeArray mba i (I64# x) = writeInt64Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Word8 where - getBytes (W8# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_WORD8# s0 of - (# s1, marr #) -> case writeWord8Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba = indexArray ba off - {-# INLINE fromBytes #-} - readBytes = readArray - {-# INLINE readBytes #-} - writeBytes = writeArray - {-# INLINE writeBytes #-} - readAddr a s - = case readWord8OffAddr# a 0# s of (# s', x #) -> (# s', W8# x #) - {-# INLINE readAddr #-} - writeAddr (W8# x) a - = writeWord8OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_WORD8# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD8# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = W8# (indexWord8Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readWord8Array# mba i s of (# s', x #) -> (# s', W8# x #) - {-# INLINE readArray #-} - writeArray mba i (W8# x) = writeWord8Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Word16 where - getBytes (W16# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_WORD16# s0 of - (# s1, marr #) -> case writeWord16Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = indexArray ba (uncheckedIShiftRL# off 1#) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off 1#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off 1#) - {-# INLINE writeBytes #-} - readAddr a s - = case readWord16OffAddr# a 0# s of (# s', x #) -> (# s', W16# x #) - {-# INLINE readAddr #-} - writeAddr (W16# x) a - = writeWord16OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_WORD16# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD16# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = W16# (indexWord16Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readWord16Array# mba i s of (# s', x #) -> (# s', W16# x #) - {-# INLINE readArray #-} - writeArray mba i (W16# x) = writeWord16Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Word32 where - getBytes (W32# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_WORD32# s0 of - (# s1, marr #) -> case writeWord32Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = indexArray ba (uncheckedIShiftRL# off 2#) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off 2#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off 2#) - {-# INLINE writeBytes #-} - readAddr a s - = case readWord32OffAddr# a 0# s of (# s', x #) -> (# s', W32# x #) - {-# INLINE readAddr #-} - writeAddr (W32# x) a - = writeWord32OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_WORD32# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD32# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = W32# (indexWord32Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readWord32Array# mba i s of (# s', x #) -> (# s', W32# x #) - {-# INLINE readArray #-} - writeArray mba i (W32# x) = writeWord32Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes Word64 where - getBytes (W64# x) = case runRW# - ( \s0 -> case newByteArray# SIZEOF_WORD64# s0 of - (# s1, marr #) -> case writeWord64Array# marr 0# x s1 of - s2 -> unsafeFreezeByteArray# marr s2 - ) of (# _, a #) -> a - {-# NOINLINE getBytes #-} - fromBytes off ba - = indexArray ba (uncheckedIShiftRL# off 3#) - {-# INLINE fromBytes #-} - readBytes mba off - = readArray mba (uncheckedIShiftRL# off 3#) - {-# INLINE readBytes #-} - writeBytes mba off - = writeArray mba (uncheckedIShiftRL# off 3#) - {-# INLINE writeBytes #-} - readAddr a s - = case readWord64OffAddr# a 0# s of (# s', x #) -> (# s', W64# x #) - {-# INLINE readAddr #-} - writeAddr (W64# x) a - = writeWord64OffAddr# a 0# x - {-# INLINE writeAddr #-} - byteSize _ = SIZEOF_WORD64# - {-# INLINE byteSize #-} - byteAlign _ = ALIGNMENT_WORD64# - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba i = W64# (indexWord64Array# ba i) - {-# INLINE indexArray #-} - readArray mba i s - = case readWord64Array# mba i s of (# s', x #) -> (# s', W64# x #) - {-# INLINE readArray #-} - writeArray mba i (W64# x) = writeWord64Array# mba i x - {-# INLINE writeArray #-} - -instance PrimBytes (Idx x) where - getBytes = unsafeCoerce# (getBytes @Word) - {-# INLINE getBytes #-} - fromBytes = unsafeCoerce# (fromBytes @Word) - {-# INLINE fromBytes #-} - readBytes = unsafeCoerce# (readBytes @Word) - {-# INLINE readBytes #-} - writeBytes = unsafeCoerce# (writeBytes @Word) - {-# INLINE writeBytes #-} - readAddr = unsafeCoerce# (readAddr @Word) - {-# INLINE readAddr #-} - writeAddr = unsafeCoerce# (readAddr @Word) - {-# INLINE writeAddr #-} - byteSize = unsafeCoerce# (byteSize @Word) - {-# INLINE byteSize #-} - byteAlign = unsafeCoerce# (byteAlign @Word) - {-# INLINE byteAlign #-} - byteOffset = unsafeCoerce# (byteOffset @Word) - {-# INLINE byteOffset #-} - indexArray = unsafeCoerce# (indexArray @Word) - {-# INLINE indexArray #-} - readArray = unsafeCoerce# (readArray @Word) - {-# INLINE readArray #-} - writeArray = unsafeCoerce# (writeArray @Word) - {-# INLINE writeArray #-} - -instance RepresentableList xs => PrimBytes (Idxs xs) where - getBytes is = case runRW# - ( \s0 -> case newByteArray# (byteSize is) s0 of - (# s1, marr #) -> unsafeFreezeByteArray# marr - (writeBytes marr 0# is s1) - ) of (# _, a #) -> a - {-# INLINE getBytes #-} - fromBytes off ba = unsafeCoerce# - (go (uncheckedIShiftRL# off OFFSHIFT_W#) (unsafeCoerce# (tList @_ @xs))) - where - go _ [] = [] - go i (Proxy : ls) = W# (indexWordArray# ba i) : go (i +# 1#) ls - {-# INLINE fromBytes #-} - readBytes mba off s = unsafeCoerce# - (go (uncheckedIShiftRL# off OFFSHIFT_W#) (unsafeCoerce# (tList @_ @xs)) s) - where - go _ [] s0 = (# s0, [] #) - go i (Proxy : ls) s0 = case readWordArray# mba off s0 of - (# s1, w #) -> case go (i +# 1#) ls s1 of - (# s2, xs #) -> (# s2, W# w : xs #) - {-# INLINE readBytes #-} - writeBytes mba off is - = go (uncheckedIShiftRL# off OFFSHIFT_W#) (listIdxs is) - where - go _ [] s = s - go i (W# x :xs) s = go (i +# 1#) xs (writeWordArray# mba i x s) - {-# INLINE writeBytes #-} - readAddr addr s = unsafeCoerce# - (go addr (unsafeCoerce# (tList @_ @xs)) s) - where - go _ [] s0 = (# s0, [] #) - go i (Proxy : ls) s0 = case readWordOffAddr# i 0# s0 of - (# s1, w #) -> case go (plusAddr# i SIZEOF_HSWORD#) ls s1 of - (# s2, xs #) -> (# s2, W# w : xs #) - {-# INLINE readAddr #-} - writeAddr is addr - = go addr (listIdxs is) - where - go _ [] s = s - go i (W# x :xs) s = go (plusAddr# i SIZEOF_HSWORD#) xs - (writeWordOffAddr# i 0# x s) - {-# INLINE writeAddr #-} - byteSize _ = case dimVal (order' @xs) of - W# n -> byteSize (undefined :: Idx x) *# word2Int# n - {-# INLINE byteSize #-} - byteAlign _ = byteAlign (undefined :: Idx x) - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - indexArray ba off - | n@(W# n#) <- dimVal (order' @xs) - = unsafeCoerce# (go (off *# word2Int# n#) n) - where - go _ 0 = [] - go i n = W# (indexWordArray# ba i) : go (i +# 1#) (n-1) - {-# INLINE indexArray #-} - readArray mba off s - | n@(W# n#) <- dimVal (order' @xs) - = unsafeCoerce# (go (off *# word2Int# n#) n s) - where - go _ 0 s0 = (# s0, [] #) - go i n s0 = case readWordArray# mba off s0 of - (# s1, w #) -> case go (i +# 1#) (n-1) s1 of - (# s2, xs #) -> (# s2, W# w : xs #) - {-# INLINE readArray #-} - writeArray mba off is - | W# n# <- dimVal (order' @xs) - = go (off *# word2Int# n#) (listIdxs is) - where - go _ [] s = s - go i (W# x :xs) s = go (i +# 1#) xs (writeWordArray# mba i x s) - {-# INLINE writeArray #-} - -instance ( RepresentableList xs - , L.All PrimBytes xs - ) => PrimBytes (TL.Tuple xs) where - getBytes = unsafeCoerce# (getBytes @(TS.Tuple xs)) - {-# INLINE getBytes #-} - fromBytes = unsafeCoerce# (fromBytes @(TS.Tuple xs)) - {-# INLINE fromBytes #-} - readBytes = unsafeCoerce# (readBytes @(TS.Tuple xs)) - {-# INLINE readBytes #-} - writeBytes = unsafeCoerce# (writeBytes @(TS.Tuple xs)) - {-# INLINE writeBytes #-} - readAddr = unsafeCoerce# (readAddr @(TS.Tuple xs)) - {-# INLINE readAddr #-} - writeAddr = unsafeCoerce# (writeAddr @(TS.Tuple xs)) - {-# INLINE writeAddr #-} - byteSize = unsafeCoerce# (byteSize @(TS.Tuple xs)) - {-# INLINE byteSize #-} - byteAlign = unsafeCoerce# (byteAlign @(TS.Tuple xs)) - {-# INLINE byteAlign #-} - byteOffset = unsafeCoerce# (byteOffset @(TS.Tuple xs)) - {-# INLINE byteOffset #-} - indexArray = unsafeCoerce# (indexArray @(TS.Tuple xs)) - {-# INLINE indexArray #-} - readArray = unsafeCoerce# (readArray @(TS.Tuple xs)) - {-# INLINE readArray #-} - writeArray = unsafeCoerce# (writeArray @(TS.Tuple xs)) - {-# INLINE writeArray #-} - -instance ( RepresentableList xs - , L.All PrimBytes xs - ) => PrimBytes (TS.Tuple xs) where - getBytes tup = case runRW# - ( \s0 -> case newByteArray# (byteSize tup) s0 of - (# s1, marr #) -> unsafeFreezeByteArray# marr - (go marr 0# tup (types tup) s1) - ) of (# _, a #) -> a - where - go :: L.All PrimBytes ds => MutableByteArray# s - -> Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s - go _ _ _ Empty s = s - go mb n (TS.Id x :* xs) (_ :* ts@TypeList) s - | n' <- roundUpInt# n (byteAlign x) - = go mb (n' +# byteSize x) xs ts (writeBytes mb n' x s) - {-# INLINE getBytes #-} - fromBytes off ba = go 0# (tList @_ @xs) - where - go :: L.All PrimBytes ds - => Int# -> TypeList ds -> TS.Tuple ds - go _ Empty = Empty - go n (t :* ts@TypeList) - | x <- undefP t - , n' <- roundUpInt# n (byteAlign x) - = TS.Id (fromBytes (off +# n') ba) :* go (n' +# byteSize x) ts - {-# INLINE fromBytes #-} - readBytes mb off = go mb 0# (tList @_ @xs) - where - go :: L.All PrimBytes ds - => MutableByteArray# s - -> Int# -> TypeList ds -> State# s -> (# State# s, TS.Tuple ds #) - go _ _ Empty s0 = (# s0, Empty #) - go mba n (t :* ts@TypeList) s0 - | x <- undefP t - , n' <- roundUpInt# n (byteAlign x) - = case readBytes mba (off +# n') s0 of - (# s1, r #) -> case go mba (n' +# byteSize x) ts s1 of - (# s2, rs #) -> (# s2, TS.Id r :* rs #) - {-# INLINE readBytes #-} - writeBytes mba off tup = go mba 0# tup (types tup) - where - go :: L.All PrimBytes ds => MutableByteArray# s - -> Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s - go _ _ _ Empty s = s - go mb n (TS.Id x :* xs) (_ :* ts@TypeList) s - | n' <- roundUpInt# n (byteAlign x) - = go mb (n' +# byteSize x) xs ts (writeBytes mb (off +# n') x s) - {-# INLINE writeBytes #-} - readAddr addr = go 0# (tList @_ @xs) - where - go :: L.All PrimBytes ds - => Int# -> TypeList ds -> State# s -> (# State# s, TS.Tuple ds #) - go _ Empty s0 = (# s0, Empty #) - go n (t :* ts@TypeList) s0 - | x <- undefP t - , n' <- roundUpInt# n (byteAlign x) - = case readAddr (plusAddr# addr n') s0 of - (# s1, r #) -> case go (n' +# byteSize x) ts s1 of - (# s2, rs #) -> (# s2, TS.Id r :* rs #) - {-# INLINE readAddr #-} - writeAddr tup addr = go 0# tup (types tup) - where - go :: L.All PrimBytes ds - => Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s - go _ _ Empty s = s - go n (TS.Id x :* xs) (_ :* ts@TypeList) s - | n' <- roundUpInt# n (byteAlign x) - = go (n' +# byteSize x) xs ts (writeAddr x (plusAddr# addr n') s) - {-# INLINE writeAddr #-} - byteSize _ = go 0# (tList @_ @xs) - where - go :: L.All PrimBytes ys => Int# -> TypeList ys -> Int# - go s Empty = s - go s (p :* ps) = let x = undefP p - in go (roundUpInt# s (byteAlign x) +# byteSize x) ps - {-# INLINE byteSize #-} - byteAlign _ = go (tList @_ @xs) - where - go :: L.All PrimBytes ys => TypeList ys -> Int# - go Empty = 0# - go (p :* ps) = maxInt# (byteAlign (undefP p)) (go ps) - {-# INLINE byteAlign #-} - byteOffset _ = 0# - {-# INLINE byteOffset #-} - - -undefP :: Proxy p -> p -undefP = const undefined -{-# INLINE undefP #-} - - -instance PrimBytes a => PrimBytes (Maybe a) -instance (PrimBytes a, PrimBytes b) => PrimBytes (Either a b) -instance PrimBytes a => PrimBytes [a] -- ??? likely to give inf byteSize - - -data PrimTag a where - PTagFloat :: PrimTag Float - PTagDouble :: PrimTag Double - PTagInt :: PrimTag Int - PTagInt8 :: PrimTag Int8 - PTagInt16 :: PrimTag Int16 - PTagInt32 :: PrimTag Int32 - PTagInt64 :: PrimTag Int64 - PTagWord :: PrimTag Word - PTagWord8 :: PrimTag Word8 - PTagWord16 :: PrimTag Word16 - PTagWord32 :: PrimTag Word32 - PTagWord64 :: PrimTag Word64 - PTagPtr :: PrimTag (Ptr a) - PTagOther :: PrimTag a - -class PrimTagged a where - primTag' :: a -> PrimTag a - --- | This function allows to find out a type by comparing its tag. --- This is needed for array overloading, to infer array instances. --- For non-basic types it defaults to `PTagOther` -primTag :: PrimBytes a => a -> PrimTag a -primTag = primTag' -{-# INLINE primTag #-} - -instance {-# OVERLAPPABLE #-} PrimTagged a where - primTag' = const PTagOther - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Float where - primTag' = const PTagFloat - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Double where - primTag' = const PTagDouble - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Int where - primTag' = const PTagInt - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Int8 where - primTag' = const PTagInt8 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Int16 where - primTag' = const PTagInt16 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Int32 where - primTag' = const PTagInt32 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Int64 where - primTag' = const PTagInt64 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Word where - primTag' = const PTagWord - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Word8 where - primTag' = const PTagWord8 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Word16 where - primTag' = const PTagWord16 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Word32 where - primTag' = const PTagWord32 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged Word64 where - primTag' = const PTagWord64 - {-# INLINE primTag' #-} - -instance {-# OVERLAPPING #-} PrimTagged (Ptr a) where - primTag' = const PTagPtr - {-# INLINE primTag' #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +Module : Numeric.PrimBytes +Copyright : (c) Artem Chirkin +License : BSD3 + +Facilities for converting Haskell data to and from raw bytes. + +The main purpose of this module is to support the implementation of the @DataFrame@ +`Numeric.DataFrame.Internal.Backend.Backend`. However, it also comes very useful for +writing FFI. To that end, the `PrimBytes` class is similar to +the `Foreign.Storable.Storable` class: it provides means to write +your data to and read from a raw memory area. Though, it is more flexible in that +it can work with both, foreign pointers and primitive byte arrays, +and it provides means to get data field offsets by their selector names. +On top of that, a `PrimBytes` instance can be derived via +the `GHC.Generics.Generic` machinery. + +A derived `PrimBytes` instance tries to pack the data as dense as possible, +while respecting the alignment requirements. In all cases known to me, +the resulting data layout coincides with a corresponding C struct, allowing +to marshal the data without any boilerplate. However, this is not guaranteed, +but you can write a `PrimBytes` instance manually if necessary +(and report an issue plz). + + +__Note about alignment, size, and padding of the data.__ +There are two basic sanity assumptions about these, which are not checked +in this module at all: + + * the alignment is always a power of 2; + * the size is always rounded up to a multiple of the alignment. + +Generated instances of `PrimBytes` meet these assumptions if all components of +a data meet these assumptions too. +You are strongly advised to provide all byte offset arguments to the `PrimBytes` +functions respecting the alignment of the data; +otherwise, the data may be written or read incorrectly. + -} +module Numeric.PrimBytes + ( -- * PrimBytes API + PrimBytes (..) + , bSizeOf, bAlignOf, bFieldOffsetOf + -- * Storable API + -- + -- | + -- `Foreign.Storable.Storable` can be defined in terms of `PrimBytes` + -- by doing something like the following for your data type: + -- + -- @ + -- instance PrimBytes a => Storable a where + -- sizeOf = bSizeOf + -- alignment = bAlignOf + -- peekElemOff = bPeekElemOff + -- pokeElemOff = bPokeElemOff + -- peekByteOff = bPeekByteOff + -- pokeByteOff = bPokeByteOff + -- peek = bPeek + -- poke = bPoke + -- @ + , bPeekElemOff, bPokeElemOff, bPeekByteOff, bPokeByteOff, bPeek, bPoke + -- * Specialization tools + , PrimTag (..), primTag + ) where + +#include "MachDeps.h" + +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Data.Type.Equality ((:~:) (..)) +import qualified Data.Type.List as L +import Data.Type.Lits +import GHC.Exts +import GHC.Generics +import GHC.Int +import GHC.IO (IO (..)) +import GHC.Ptr (Ptr (..)) +import GHC.Word +import Numeric.Dimensions +import qualified Numeric.Tuple.Lazy as TL +import qualified Numeric.Tuple.Strict as TS +import Text.Read (readMaybe) + +{- | + +Defines how to read and write your data to and from Haskell unboxed byte arrays +and plain pointers. + +Similarly to `Foreign.Storable.Storable`, this class provides functions to get +the size and alignment of a data via phantom arguments. +Thus, the size and alignment of the data must not depend on the data content +(they depend only on the type of the data). +In particular, this means that dynamically sized structures like Haskell lists +or maps are not allowed. + +This module provides default implementations for all methods of this class via +`GHC.Generics.Generic`. Hence, to make your data an instance of @PrimBytes@, +it is sufficient to write the instance head: + +@ +data MyData a b = ... + deriving Generic + +instance (PrimBytes a, PrimBytes b) => PrimBytes (MyData a b) +@ + +.. or use the @DeriveAnyClass@ extension to make it even shorter: + +@ +data MyData a b = ... + deriving (Generic, PrimBytes) +@ + +The derived instance tries to pack the data as dense as possible, but sometimes +it is better to write the instance by hand. +If a derived type has more than one constructor, the derived instance puts +a @Word32@ tag at the beginning of the byte representation. +All fields of a constructor are packed in a C-like fashion next to each other, +while respecting their alignments. + + -} +class PrimTagged a => PrimBytes a where + {- | List of field names. + + It is used to get field offsets using `byteFieldOffset` function. + + A Generic-derived instance has this list non-empty only if two + obvious conditions are met: + + 1. The data has only one constructor. + 2. The data uses record syntax to define its fields. + -} + type PrimFields a :: [Symbol] + type PrimFields a = GPrimFields (Rep a) + -- | Store content of a data type in a primitive byte array + -- (should be used together with @byteOffset@ function). + -- + -- Note, the default implementation of this function returns a not pinned + -- array, which is aligned to @SIZEOF_HSWORD@. + -- Thus, it ignores the alignment of the underlying data type if it is larger. + -- However, alignment calculation still makes sense for data types + -- that are smaller than @SIZEOF_HSWORD@ bytes: they are packed more densely. + getBytes :: a -> ByteArray# + getBytes a = case runRW# + ( \s0 -> case newByteArray# (byteSize a) s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr (writeBytes marr 0# a s1) + ) of (# _, r #) -> r + {-# NOINLINE getBytes #-} + -- | Store content of a data type in a primitive byte array + -- (should be used together with @byteOffset@ function). + -- + -- In contrast to `getBytes`, this function returns a pinned byte array, + -- aligned to the @byteAlign@ bytes of this data. + -- + -- Note, GC guarantees not to move the created array. + -- While this is very useful sometimes, it incurs a certain performance penalty. + getBytesPinned :: a -> ByteArray# + getBytesPinned a = case runRW# + ( \s0 -> case newAlignedPinnedByteArray# (byteSize a) (byteAlign a) s0 of + (# s1, marr #) -> unsafeFreezeByteArray# marr (writeBytes marr 0# a s1) + ) of (# _, r #) -> r + {-# NOINLINE getBytesPinned #-} + -- | Load content of a data type from a primitive byte array given an offset in bytes. + fromBytes :: Int# -- ^ Offset in bytes + -> ByteArray# -- ^ Source array + -> a + -- | Read data from a mutable byte array given an offset in bytes. + readBytes :: MutableByteArray# s -- ^ Source array + -> Int# -- ^ Byte offset in the source array + -> State# s -> (# State# s, a #) + -- | Write data into a mutable byte array at a given position (offset in bytes). + writeBytes :: MutableByteArray# s -- ^ Destination array + -> Int# -- ^ Byte offset in the destination array + -> a -- ^ Data to write into the array + -> State# s -> State# s + -- | Read data from a specified address. + readAddr :: Addr# -> State# s -> (# State# s, a #) + -- | Write data to a specified address. + writeAddr :: a -> Addr# -> State# s -> State# s + -- | Size of a data type in bytes. + -- It should be a multiple of @byteAlign@ for indexing functions to operate + -- correctly. + -- + -- Implementation of this function must not inspect the argument value; + -- a caller may provide @undefined@ in place of the argument. + byteSize :: a -> Int# + -- | Alignment of a data type in bytes. + -- @byteOffset@ should be multiple of this value. + -- + -- Implementation of this function must not inspect the argument value; + -- a caller may provide @undefined@ in place of the argument. + byteAlign :: a -> Int# + -- | Offset of the data in a byte array used to store the data, + -- measured in bytes. + -- Should be used together with @getBytes@ function. + -- Unless in case of special data types represented by ByteArrays, + -- it is equal to zero. + -- + -- Implementation of this function may inspect the argument value; + -- a caller must not provide @undefined@ in place of the argument. + byteOffset :: a -> Int# + byteOffset _ = 0# + {-# INLINE byteOffset #-} + + -- | Offset of a data record within the data type in bytes. + -- + -- Implementation of this function must not inspect the argument value; + -- a caller may provide @undefined@ in place of the argument. + -- + -- The default (generic) implementation of this fucntion looks for the + -- leftmost occurrence of a given field name (in case of multiple constructors). + -- If a field with the given name is not found, it returns @-1@, + -- but this is not possible thanks to @Elem name (PrimFields a)@ constraint. + byteFieldOffset :: (Elem name (PrimFields a), KnownSymbol name) + => Proxy# name -> a -> Int# + + -- | Index array given an element offset + -- (which is @byteSize a@ and should be a multiple of @byteAlign a@). + indexArray :: ByteArray# -> Int# -> a + indexArray ba i = fromBytes (i *# byteSize @a undefined) ba + {-# INLINE indexArray #-} + + -- | Read a mutable array given an element offset + -- (which is @byteSize a@ and should be a multiple of @byteAlign a@). + readArray :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) + readArray ba i = readBytes ba (i *# byteSize @a undefined) + {-# INLINE readArray #-} + + -- | Write a mutable array given an element offset + -- (which is @byteSize a@ and should be a multiple of @byteAlign a@). + writeArray :: MutableByteArray# s -> Int# -> a -> State# s -> State# s + writeArray ba i = writeBytes ba (i *# byteSize @a undefined) + {-# INLINE writeArray #-} + + + default fromBytes :: (Generic a, GPrimBytes (Rep a)) + => Int# -> ByteArray# -> a + fromBytes i arr = to (gfromBytes proxy# 0## 0# i arr) + {-# INLINE fromBytes #-} + + default readBytes :: (Generic a, GPrimBytes (Rep a)) + => MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) + readBytes mba i s = case greadBytes proxy# 0## 0# mba i s of + (# s', x #) -> (# s', to x #) + {-# INLINE readBytes #-} + + default writeBytes :: (Generic a, GPrimBytes (Rep a)) + => MutableByteArray# s -> Int# -> a -> State# s -> State# s + writeBytes mba i = gwriteBytes proxy# 0## 0# mba i . from + {-# INLINE writeBytes #-} + + default readAddr :: (Generic a, GPrimBytes (Rep a)) + => Addr# -> State# s -> (# State# s, a #) + readAddr a s = case greadAddr proxy# 0## 0# a s of + (# s', x #) -> (# s', to x #) + {-# INLINE readAddr #-} + + default writeAddr :: (Generic a, GPrimBytes (Rep a)) + => a -> Addr# -> State# s -> State# s + writeAddr = gwriteAddr proxy# 0## 0# . from + {-# INLINE writeAddr #-} + + default byteSize :: (Generic a, GPrimBytes (Rep a)) + => a -> Int# + byteSize a = gbyteSize proxy# 0## 0# (from a) `roundUpInt` byteAlign a + {-# INLINE byteSize #-} + + default byteAlign :: (Generic a, GPrimBytes (Rep a)) + => a -> Int# + byteAlign a = gbyteAlign proxy# (from a) + {-# INLINE byteAlign #-} + + default byteFieldOffset :: ( Generic a, GPrimBytes (Rep a) + , KnownSymbol name) + => Proxy# name -> a -> Int# + byteFieldOffset p a = gbyteFieldOffset proxy# 0## 0# p (from a) + {-# INLINE byteFieldOffset #-} + +-- | A wrapper on `byteSize` +bSizeOf :: (PrimBytes a, Num b) => a -> b +bSizeOf a = fromIntegral (I# (byteSize a)) + +-- | A wrapper on `byteAlign` +bAlignOf :: (PrimBytes a, Num b) => a -> b +bAlignOf a = fromIntegral (I# (byteAlign a)) + +-- | A wrapper on `byteFieldOffset`. +bFieldOffsetOf :: forall (name :: Symbol) (a :: Type) (b :: Type) + . ( PrimBytes a, Elem name (PrimFields a) + , KnownSymbol name, Num b) + => a -> b +bFieldOffsetOf a = fromIntegral (I# (byteFieldOffset (proxy# @Symbol @name) a)) + +-- | Same as `Foreign.Storable.peekElemOff`: peek an element @a@ by the offset +-- measured in @byteSize a@. +-- +-- Note: the size of the element must be a multiple of its alignment for +-- a correct operation of this function. +bPeekElemOff :: forall (a :: Type) . PrimBytes a => Ptr a -> Int -> IO a +bPeekElemOff (Ptr addr) (I# i) + = IO (readAddr (plusAddr# addr (i *# byteSize @a undefined))) + +-- | Same as `Foreign.Storable.pokeElemOff`: poke an element @a@ by the offset +-- measured in @byteSize a@. +-- +-- Note: the size of the element must be a multiple of its alignment for +-- a correct operation of this function. +bPokeElemOff :: forall (a :: Type) . PrimBytes a => Ptr a -> Int -> a -> IO () +bPokeElemOff (Ptr addr) (I# i) a + = IO (\s -> (# writeAddr a (plusAddr# addr (i *# byteSize a)) s, () #)) + +-- | Same as `Foreign.Storable.peekByteOff`: peek an element @a@ by the offset +-- measured in bytes. +-- +-- Note: you'd better be sure the address is a multiple of +-- the data alignment (`Foreign.Storable.peek`). +bPeekByteOff :: forall (a :: Type) (b :: Type) . PrimBytes a => Ptr b -> Int -> IO a +bPeekByteOff (Ptr addr) (I# i) + = IO (readAddr (plusAddr# addr i)) + +-- | Same as `Foreign.Storable.pokeByteOff`: poke an element @a@ by the offset +-- measured in bytes. +-- +-- Note: you'd better be sure the address is a multiple of +-- the data alignment (`Foreign.Storable.peek`). +bPokeByteOff :: forall (a :: Type) (b :: Type) . PrimBytes a => Ptr b -> Int -> a -> IO () +bPokeByteOff (Ptr addr) (I# i) a + = IO (\s -> (# writeAddr a (plusAddr# addr i) s, () #)) + +-- | Same as `Foreign.Storable.peek`: read a data from a pointer. +-- +-- Note: you'd better be sure the address is a multiple of +-- the data alignment (`Foreign.Storable.peek`). +bPeek :: forall (a :: Type) . PrimBytes a => Ptr a -> IO a +bPeek (Ptr addr) = IO (readAddr addr) + +-- | Same as `Foreign.Storable.poke`: write a data to a pointer. +-- +-- Note: you'd better be sure the address is a multiple of +-- the data alignment (`Foreign.Storable.peek`). +bPoke :: forall (a :: Type) . PrimBytes a => Ptr a -> a -> IO () +bPoke (Ptr addr) a = IO (\s -> (# writeAddr a addr s, () #)) + +-- | Derive a list of data selectors from the data representation @Rep a@. +type family GPrimFields (rep :: Type -> Type) :: [Symbol] where + GPrimFields (M1 D _ f) = GPrimFields f + GPrimFields (M1 C _ f) = GPrimFields f + GPrimFields (M1 S ('MetaSel ('Just n) _ _ _) _) = '[n] + GPrimFields (f :*: g) = Concat (GPrimFields f) (GPrimFields g) + GPrimFields _ = '[] + +{- | Deriving `PrimBytes` using generics + +This implementation relies on two assumptions, which are probably true +in the GHC implementation of derived generics and __is not checked here__: + +1. @Rep a@ is a sum-of-products. + This means the struct offset is always @4@ for the parts of the sum type, + and a constructor tag is always at position @0@ in the struct. + +2. The @Rep a@ tree is balanced. + Thus, I can implement a simple tag encoding: + each bit in a tag corresponds to a nesting level. + That is, maximum possible nesting level is 31 and minimum is 0. + +Therefore, the general logic for the sum type is summarized as follows: + reserve 4 bytes for the tag and try to pack alternatives as good as possible. + +If a data type has only one constructor (@Rep a@ contains no @:+:@), +then the tag is not added. + + +Every function in @GPrimBytes@ has the first Proxy# argument; +it is simply used to enforce type parameter and allows easy @coerce@ implementations +for @Meta@ wrapper types. + +All functions except @gbyteAlign@ have the second and third arguments: +tag mask (@Word#@) and current struct size (@Int#@); +both start with zero at the top of the @Rep a@ hierarchy. + + The tag mask is used by the sum constructors to find out where to write a bit value + to encode left or right branch. + + The current struct size is the size (in bytes) of all elements to the left of + the current one (before alignment). + + -} +class GPrimBytes f where + gfromBytes :: Proxy# p + -> Word# -- ^ Constructor tag position (mask) + -> Int# -- ^ Left neighbour cumulative size (current offset before alignment) + -> Int# -> ByteArray# -> f p + greadBytes :: Proxy# p + -> Word# -- ^ Constructor tag position (mask) + -> Int# -- ^ Left neighbour cumulative size (current offset before alignment) + -> MutableByteArray# s -> Int# -> State# s -> (# State# s, f p #) + gwriteBytes :: Proxy# p + -> Word# -- ^ Constructor tag position (mask) + -> Int# -- ^ Left neighbour cumulative size (current offset before alignment) + -> MutableByteArray# s -> Int# -> f p -> State# s -> State# s + greadAddr :: Proxy# p + -> Word# -- ^ Constructor tag position (mask) + -> Int# -- ^ Left neighbour cumulative size (current offset before alignment) + -> Addr# -> State# s -> (# State# s, f p #) + gwriteAddr :: Proxy# p + -> Word# -- ^ Constructor tag position (mask) + -> Int# -- ^ Left neighbour cumulative size (current offset before alignment) + -> f p -> Addr# -> State# s -> State# s + -- | Cumulative size of a Rep structure + gbyteSize :: Proxy# p + -> Word# -- ^ Constructor tag position (mask) + -> Int# -- ^ Left neighbour cumulative size (current offset before alignment) + -> f p -> Int# + gbyteAlign :: Proxy# p + -> f p -> Int# + -- | Gives an offset of the current piece of a Rep structure + gbyteFieldOffset :: KnownSymbol name + => Proxy# p + -> Word# -- ^ Constructor tag position (mask) + -> Int# -- ^ Left neighbour cumulative size (current offset before alignment) + -> Proxy# name -> f p -> Int# + gbyteFieldOffset _ _ _ _ _ = negateInt# 1# + {-# INLINE gbyteFieldOffset #-} + +instance GPrimBytes V1 where + gfromBytes _ _ _ _ _ = undefined + greadBytes _ _ _ _ _ s = (# s, undefined #) + gwriteBytes _ _ _ _ _ _ s = s + greadAddr _ _ _ _ s = (# s, undefined #) + gwriteAddr _ _ _ _ _ s = s + gbyteSize _ _ ps _ = ps + gbyteAlign _ _ = 1# + +instance GPrimBytes U1 where + gfromBytes _ _ _ _ _ = U1 + greadBytes _ _ _ _ _ s = (# s, U1 #) + gwriteBytes _ _ _ _ _ _ s = s + greadAddr _ _ _ _ s = (# s, U1 #) + gwriteAddr _ _ _ _ _ s = s + gbyteSize _ _ ps _ = ps + gbyteAlign _ _ = 1# + +getGOff :: forall a . PrimBytes a + => Int# -- parent cumulative size + -> Int# -- original offset + -> Int# -- new offset +getGOff ps i = i +# roundUpInt ps (byteAlign @a undefined) + +instance PrimBytes a => GPrimBytes (K1 i a) where + gfromBytes _ _ ps i ba = K1 (fromBytes (getGOff @a ps i) ba) + greadBytes _ _ ps mba i = coerce (readBytes @a mba (getGOff @a ps i)) + gwriteBytes _ _ ps mba i = coerce (writeBytes @a mba (getGOff @a ps i)) + greadAddr _ _ ps addr = coerce (readAddr @a (plusAddr# addr (getGOff @a ps 0#))) + gwriteAddr _ _ ps ka addr = writeAddr (unK1 ka) (plusAddr# addr (getGOff @a ps 0#)) + gbyteSize _ _ ps ~(K1 a) = roundUpInt ps (byteAlign a) +# byteSize a + gbyteAlign _ = coerce (byteAlign @a) + +instance {-# OVERLAPPING #-} + (GPrimBytes f, KnownSymbol sn) + => GPrimBytes (M1 S ('MetaSel ('Just sn) a b c) f) where + gfromBytes p = coerce (gfromBytes @f p) + greadBytes p = coerce (greadBytes @f p) + gwriteBytes p = coerce (gwriteBytes @f p) + greadAddr p = coerce (greadAddr @f p) + gwriteAddr p = coerce (gwriteAddr @f p) + gbyteSize p = coerce (gbyteSize @f p) + gbyteAlign p = coerce (gbyteAlign @f p) + gbyteFieldOffset p _ off (_ :: Proxy# n) ma + | Just Refl <- sameSymbol (undefined :: Proxy n) (undefined :: Proxy sn) + = off `roundUpInt` gbyteAlign p ma + | otherwise + = negateInt# 1# + +instance GPrimBytes f => GPrimBytes (M1 i c f) where + gfromBytes p = coerce (gfromBytes @f p) + greadBytes p = coerce (greadBytes @f p) + gwriteBytes p = coerce (gwriteBytes @f p) + greadAddr p = coerce (greadAddr @f p) + gwriteAddr p = coerce (gwriteAddr @f p) + gbyteSize p = coerce (gbyteSize @f p) + gbyteAlign p = coerce (gbyteAlign @f p) + gbyteFieldOffset p = coerce (gbyteFieldOffset @f p) + +instance (GPrimBytes f, GPrimBytes g) => GPrimBytes (f :*: g) where + gfromBytes p t ps i ba = x :*: y + where + x = gfromBytes p t ps i ba + y = gfromBytes p t (gbyteSize p t ps x) i ba + greadBytes p t ps mba i s0 + | (# s1, x #) <- greadBytes p t ps mba i s0 + , (# s2, y #) <- greadBytes p t (gbyteSize p t ps x) mba i s1 + = (# s2, x :*: y #) + gwriteBytes p t ps mba off (x :*: y) s0 + | s1 <- gwriteBytes p t ps mba off x s0 + , s2 <- gwriteBytes p t (gbyteSize p t ps x) mba off y s1 + = s2 + greadAddr p t ps addr s0 + | (# s1, x #) <- greadAddr p t ps addr s0 + , (# s2, y #) <- greadAddr p t (gbyteSize p t ps x) addr s1 + = (# s2, x :*: y #) + gwriteAddr p t ps (x :*: y) addr s0 + | s1 <- gwriteAddr p t ps x addr s0 + , s2 <- gwriteAddr p t (gbyteSize p t ps x) y addr s1 + = s2 + gbyteSize p t ps ~(x :*: y) = gbyteSize p t (gbyteSize p t ps x) y + gbyteAlign p ~(x :*: y) = gbyteAlign p x `maxInt` gbyteAlign p y + gbyteFieldOffset p t ps n ~(x :*: y) + | offX <- gbyteFieldOffset p t ps n x + , bsX <- gbyteSize p t ps x + , offY <- gbyteFieldOffset p t bsX n y + = if isTrue# (offX <# 0#) then offY else offX + +instance (GPrimBytes f, GPrimBytes g) => GPrimBytes (f :+: g) where + gfromBytes p t _ off ba + | c <- indexWord8ArrayAsWord32# ba off + = if isTrue# (eqWord# (and# c t1) 0##) + then L1 (gfromBytes p t1 4# off ba) + else R1 (gfromBytes p t1 4# off ba) + where + t1 = upTag t + greadBytes p t _ mba off s0 + | (# s1, c #) <- readWord8ArrayAsWord32# mba off s0 + = if isTrue# (eqWord# (and# c t1) 0##) + then case greadBytes p t1 4# mba off s1 of + (# s2, x #) -> (# s2, L1 x #) + else case greadBytes p t1 4# mba off s1 of + (# s2, y #) -> (# s2, R1 y #) + where + t1 = upTag t + -- if this is the uppermost sum, overwrite the tag. + gwriteBytes p 0## _ mba off (L1 x) s0 + | s1 <- writeWord8ArrayAsWord32# mba off 0## s0 + , s2 <- gwriteBytes p 1## 4# mba off x s1 = s2 + gwriteBytes p 0## _ mba off (R1 y) s0 + | s1 <- writeWord8ArrayAsWord32# mba off 1## s0 + , s2 <- gwriteBytes p 1## 4# mba off y s1 = s2 + -- here I know that I have written zero to the corresponding bit already + gwriteBytes p t _ mba off (L1 x) s0 + | s1 <- gwriteBytes p (upTag t) 4# mba off x s0 = s1 + -- otherwise, carefully write a single corresponding bit + gwriteBytes p t _ mba off (R1 y) s0 + | (# s1, c #) <- readWord8ArrayAsWord32# mba off s0 + , s2 <- writeWord8ArrayAsWord32# mba off (or# c t1) s1 + , s3 <- gwriteBytes p t1 4# mba off y s2 = s3 + where + t1 = upTag t + greadAddr p t _ addr s0 + | (# s1, c #) <- readWord32OffAddr# addr 0# s0 + = if isTrue# (eqWord# (and# c t1) 0##) + then case greadAddr p t1 4# addr s1 of + (# s2, x #) -> (# s2, L1 x #) + else case greadAddr p t1 4# addr s1 of + (# s2, y #) -> (# s2, R1 y #) + where + t1 = upTag t + -- if this is the uppermost sum, overwrite the tag. + gwriteAddr p 0## _ (L1 x) addr s0 + | s1 <- writeWord32OffAddr# addr 0# 0## s0 + , s2 <- gwriteAddr p 1## 4# x addr s1 = s2 + gwriteAddr p 0## _ (R1 y) addr s0 + | s1 <- writeWord32OffAddr# addr 0# 1## s0 + , s2 <- gwriteAddr p 1## 4# y addr s1 = s2 + -- here I know that I have written zero to the corresponding bit already + gwriteAddr p t _ (L1 x) addr s0 + | s1 <- gwriteAddr p (upTag t) 4# x addr s0 = s1 + -- otherwise, carefully write a single corresponding bit + gwriteAddr p t _ (R1 y) addr s0 + | (# s1, c #) <- readWord32OffAddr# addr 0# s0 + , s2 <- writeWord32OffAddr# addr 0# (or# c t1) s1 + , s3 <- gwriteAddr p t1 4# y addr s2 = s3 + where + t1 = upTag t + gbyteSize p 0## ps xy + = maxInt + (roundUpInt 4# (gbyteAlign p x) +# gbyteSize p 1## ps x) + (roundUpInt 4# (gbyteAlign p y) +# gbyteSize p 1## ps y) + where + x = undef1 @f xy + y = undef1 @g xy + gbyteSize p t ps xy + = maxInt + (gbyteSize p (upTag t) ps (undef1 @f xy)) + (gbyteSize p (upTag t) ps (undef1 @g xy)) + gbyteAlign p xy = 4# `maxInt` + maxInt (gbyteAlign p (undef1 @f xy)) + (gbyteAlign p (undef1 @g xy)) + -- check both branches if any of them contain the field. + -- If there are more than one branches containing the field, the left one + -- is preferred. + gbyteFieldOffset p t ps n xy + | offX <- gbyteFieldOffset p (upTag t) ps n (undef1 @f xy) + , offY <- gbyteFieldOffset p (upTag t) ps n (undef1 @g xy) + = if isTrue# (offX <# 0#) then offY else offX + +upTag :: Word# -> Word# +upTag 0## = 1## +upTag t = uncheckedShiftL# t 1# +{-# INLINE upTag #-} + + +maxInt :: Int# -> Int# -> Int# +maxInt a b = if isTrue# (a ># b) then a else b +{-# INLINE maxInt #-} + +-- | Round up the first numer to a multiple of the second. +-- +-- NB: this function is only used with alignment as the second number, +-- which is always a power of 2. +roundUpInt :: Int# -> Int# -> Int# +roundUpInt a b = (a +# b -# 1#) `andI#` negateInt# b +{-# INLINE roundUpInt #-} +-- It's pity that the assertion would not work due to kind of the result +-- not being Type. +-- assert (isTrue# (eqWord# (popCnt# (int2Word# b)) 1##)) +-- +-- The version above is optimized for second number being power of two (align) +-- The baseline implementation would be as follows: +-- roundUpInt a b = case remInt# a b of +-- 0# -> a + -- q -> a +# b -# q + +undef1 :: forall p q a . q a -> p a +undef1 = const undefined +{-# INLINE undef1 #-} + + + +#if SIZEOF_HSWORD == 4 +#define OFFSHIFT_W 2 +#else +#define OFFSHIFT_W 3 +#endif + +instance GPrimBytes (URec Word) where + gfromBytes _ _ ps off ba + = UWord (indexWord8ArrayAsWord# ba (off +# roundUpInt ps ALIGNMENT_HSWORD#)) + greadBytes _ _ ps mba off s + = case readWord8ArrayAsWord# mba (off +# roundUpInt ps ALIGNMENT_HSWORD#) s of + (# s1, r #) -> (# s1, UWord r #) + gwriteBytes _ _ ps mba off x + = writeWord8ArrayAsWord# mba (off +# roundUpInt ps ALIGNMENT_HSWORD#) (uWord# x) + greadAddr _ _ ps a s + = case readWordOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSWORD#)) 0# s of + (# s', x #) -> (# s', UWord x #) + gwriteAddr _ _ ps x a + = writeWordOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSWORD#)) 0# (uWord# x) + gbyteSize _ _ ps _ = roundUpInt ps ALIGNMENT_HSWORD# +# SIZEOF_HSWORD# + gbyteAlign _ _ = ALIGNMENT_HSWORD# + +#if SIZEOF_HSINT == 4 +#define OFFSHIFT_I 2 +#else +#define OFFSHIFT_I 3 +#endif + +instance GPrimBytes (URec Int) where + gfromBytes _ _ ps off ba + = UInt (indexWord8ArrayAsInt# ba (off +# roundUpInt ps ALIGNMENT_HSINT#)) + greadBytes _ _ ps mba off s + = case readWord8ArrayAsInt# mba (off +# roundUpInt ps ALIGNMENT_HSINT#) s of + (# s1, r #) -> (# s1, UInt r #) + gwriteBytes _ _ ps mba off x + = writeWord8ArrayAsInt# mba (off +# roundUpInt ps ALIGNMENT_HSINT#) (uInt# x) + greadAddr _ _ ps a s + = case readIntOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSINT#)) 0# s of + (# s', x #) -> (# s', UInt x #) + gwriteAddr _ _ ps x a + = writeIntOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSINT#)) 0# (uInt# x) + gbyteSize _ _ ps _ = roundUpInt ps ALIGNMENT_HSINT# +# SIZEOF_HSINT# + gbyteAlign _ _ = ALIGNMENT_HSINT# + +#if SIZEOF_HSFLOAT == 4 +#define OFFSHIFT_F 2 +#else +#define OFFSHIFT_F 3 +#endif + +instance GPrimBytes (URec Float) where + gfromBytes _ _ ps off ba + = UFloat (indexWord8ArrayAsFloat# ba (off +# roundUpInt ps ALIGNMENT_HSFLOAT#)) + greadBytes _ _ ps mba off s + = case readWord8ArrayAsFloat# mba (off +# roundUpInt ps ALIGNMENT_HSFLOAT#) s of + (# s1, r #) -> (# s1, UFloat r #) + gwriteBytes _ _ ps mba off x + = writeWord8ArrayAsFloat# mba (off +# roundUpInt ps ALIGNMENT_HSFLOAT#) (uFloat# x) + greadAddr _ _ ps a s + = case readFloatOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSFLOAT#)) 0# s of + (# s', x #) -> (# s', UFloat x #) + gwriteAddr _ _ ps x a + = writeFloatOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSFLOAT#)) 0# (uFloat# x) + gbyteSize _ _ ps _ = roundUpInt ps ALIGNMENT_HSFLOAT# +# SIZEOF_HSFLOAT# + gbyteAlign _ _ = ALIGNMENT_HSFLOAT# + +#if SIZEOF_HSDOUBLE == 4 +#define OFFSHIFT_D 2 +#else +#define OFFSHIFT_D 3 +#endif + +instance GPrimBytes (URec Double) where + gfromBytes _ _ ps off ba + = UDouble (indexWord8ArrayAsDouble# ba (off +# roundUpInt ps ALIGNMENT_HSDOUBLE#)) + greadBytes _ _ ps mba off s + = case readWord8ArrayAsDouble# mba (off +# roundUpInt ps ALIGNMENT_HSDOUBLE#) s of + (# s1, r #) -> (# s1, UDouble r #) + gwriteBytes _ _ ps mba off x + = writeWord8ArrayAsDouble# mba (off +# roundUpInt ps ALIGNMENT_HSDOUBLE#) (uDouble# x) + greadAddr _ _ ps a s + = case readDoubleOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSDOUBLE#)) 0# s of + (# s', x #) -> (# s', UDouble x #) + gwriteAddr _ _ ps x a + = writeDoubleOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSDOUBLE#)) 0# (uDouble# x) + gbyteSize _ _ ps _ = roundUpInt ps ALIGNMENT_HSDOUBLE# +# SIZEOF_HSDOUBLE# + gbyteAlign _ _ = ALIGNMENT_HSDOUBLE# + +-- I believe Char is always 31 bit, but checking this does not hurt +#if SIZEOF_HSCHAR == 2 +#define OFFSHIFT_C 1 +#elif SIZEOF_HSCHAR == 4 +#define OFFSHIFT_C 2 +#else +#define OFFSHIFT_C 3 +#endif + +instance GPrimBytes (URec Char) where + gfromBytes _ _ ps off ba + = UChar (indexWord8ArrayAsWideChar# ba (off +# roundUpInt ps ALIGNMENT_HSCHAR#)) + greadBytes _ _ ps mba off s + = case readWord8ArrayAsWideChar# mba (off +# roundUpInt ps ALIGNMENT_HSCHAR#) s of + (# s1, r #) -> (# s1, UChar r #) + gwriteBytes _ _ ps mba off x + = writeWord8ArrayAsWideChar# mba (off +# roundUpInt ps ALIGNMENT_HSCHAR#) (uChar# x) + greadAddr _ _ ps a s + = case readWideCharOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSCHAR#)) 0# s of + (# s', x #) -> (# s', UChar x #) + gwriteAddr _ _ ps x a + = writeWideCharOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSCHAR#)) 0# (uChar# x) + gbyteSize _ _ ps _ = roundUpInt ps ALIGNMENT_HSCHAR# +# SIZEOF_HSCHAR# + gbyteAlign _ _ = ALIGNMENT_HSCHAR# + +#if SIZEOF_HSPTR == 4 +#define OFFSHIFT_P 2 +#else +#define OFFSHIFT_P 3 +#endif + +instance GPrimBytes (URec (Ptr ())) where + gfromBytes _ _ ps off ba + = UAddr (indexWord8ArrayAsAddr# ba (off +# roundUpInt ps ALIGNMENT_HSPTR#)) + greadBytes _ _ ps mba off s + = case readWord8ArrayAsAddr# mba (off +# roundUpInt ps ALIGNMENT_HSPTR#) s of + (# s1, r #) -> (# s1, UAddr r #) + gwriteBytes _ _ ps mba off x + = writeWord8ArrayAsAddr# mba (off +# roundUpInt ps ALIGNMENT_HSPTR#) (uAddr# x) + greadAddr _ _ ps a s + = case readAddrOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSPTR#)) 0# s of + (# s', x #) -> (# s', UAddr x #) + gwriteAddr _ _ ps x a + = writeAddrOffAddr# (plusAddr# a (roundUpInt ps ALIGNMENT_HSPTR#)) 0# (uAddr# x) + gbyteSize _ _ ps _ = roundUpInt ps ALIGNMENT_HSPTR# +# SIZEOF_HSPTR# + gbyteAlign _ _ = ALIGNMENT_HSPTR# + + + + +-------------------------------------------------------------------------------- +-- Basic instances +-------------------------------------------------------------------------------- + + +instance PrimBytes Word where + type PrimFields Word = '[] + getBytes (W# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSWORD# s0 of + (# s1, marr #) -> case writeWordArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = W# (indexWord8ArrayAsWord# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsWord# mba off s of (# s', r #) -> (# s', W# r #) + {-# INLINE readBytes #-} + writeBytes mba off (W# x) + = writeWord8ArrayAsWord# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readWordOffAddr# a 0# s of (# s', x #) -> (# s', W# x #) + {-# INLINE readAddr #-} + writeAddr (W# x) a + = writeWordOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSWORD# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSWORD# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = W# (indexWordArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWordArray# mba i s of (# s', x #) -> (# s', W# x #) + {-# INLINE readArray #-} + writeArray mba i (W# x) = writeWordArray# mba i x + {-# INLINE writeArray #-} + + +instance PrimBytes Int where + type PrimFields Int = '[] + getBytes (I# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSINT# s0 of + (# s1, marr #) -> case writeIntArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = I# (indexWord8ArrayAsInt# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsInt# mba off s of (# s', r #) -> (# s', I# r #) + {-# INLINE readBytes #-} + writeBytes mba off (I# x) + = writeWord8ArrayAsInt# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readIntOffAddr# a 0# s of (# s', x #) -> (# s', I# x #) + {-# INLINE readAddr #-} + writeAddr (I# x) a + = writeIntOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSINT# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSINT# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = I# (indexIntArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readIntArray# mba i s of (# s', x #) -> (# s', I# x #) + {-# INLINE readArray #-} + writeArray mba i (I# x) = writeIntArray# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Float where + type PrimFields Float = '[] + getBytes (F# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSFLOAT# s0 of + (# s1, marr #) -> case writeFloatArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = F# (indexWord8ArrayAsFloat# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsFloat# mba off s of (# s', r #) -> (# s', F# r #) + {-# INLINE readBytes #-} + writeBytes mba off (F# x) + = writeWord8ArrayAsFloat# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readFloatOffAddr# a 0# s of (# s', x #) -> (# s', F# x #) + {-# INLINE readAddr #-} + writeAddr (F# x) a + = writeFloatOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSFLOAT# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSFLOAT# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = F# (indexFloatArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readFloatArray# mba i s of (# s', x #) -> (# s', F# x #) + {-# INLINE readArray #-} + writeArray mba i (F# x) = writeFloatArray# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Double where + type PrimFields Double = '[] + getBytes (D# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSDOUBLE# s0 of + (# s1, marr #) -> case writeDoubleArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = D# (indexWord8ArrayAsDouble# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsDouble# mba off s of (# s', r #) -> (# s', D# r #) + {-# INLINE readBytes #-} + writeBytes mba off (D# x) + = writeWord8ArrayAsDouble# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readDoubleOffAddr# a 0# s of (# s', x #) -> (# s', D# x #) + {-# INLINE readAddr #-} + writeAddr (D# x) a + = writeDoubleOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSDOUBLE# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSDOUBLE# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = D# (indexDoubleArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readDoubleArray# mba i s of (# s', x #) -> (# s', D# x #) + {-# INLINE readArray #-} + writeArray mba i (D# x) = writeDoubleArray# mba i x + {-# INLINE writeArray #-} + + +instance PrimBytes (Ptr a) where + type PrimFields (Ptr a) = '[] + getBytes (Ptr x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSPTR# s0 of + (# s1, marr #) -> case writeAddrArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = Ptr (indexWord8ArrayAsAddr# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsAddr# mba off s of (# s', r #) -> (# s', Ptr r #) + {-# INLINE readBytes #-} + writeBytes mba off (Ptr x) + = writeWord8ArrayAsAddr# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readAddrOffAddr# a 0# s of (# s', x #) -> (# s', Ptr x #) + {-# INLINE readAddr #-} + writeAddr (Ptr x) a + = writeAddrOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSPTR# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSPTR# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = Ptr (indexAddrArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readAddrArray# mba i s of (# s', x #) -> (# s', Ptr x #) + {-# INLINE readArray #-} + writeArray mba i (Ptr x) = writeAddrArray# mba i x + {-# INLINE writeArray #-} + + +instance PrimBytes Int8 where + type PrimFields Int8 = '[] + getBytes (I8# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT8# s0 of + (# s1, marr #) -> case writeInt8Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba = indexArray ba off + {-# INLINE fromBytes #-} + readBytes = readArray + {-# INLINE readBytes #-} + writeBytes = writeArray + {-# INLINE writeBytes #-} + readAddr a s + = case readInt8OffAddr# a 0# s of (# s', x #) -> (# s', I8# x #) + {-# INLINE readAddr #-} + writeAddr (I8# x) a + = writeInt8OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT8# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT8# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = I8# (indexInt8Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt8Array# mba i s of (# s', x #) -> (# s', I8# x #) + {-# INLINE readArray #-} + writeArray mba i (I8# x) = writeInt8Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Int16 where + type PrimFields Int16 = '[] + getBytes (I16# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT16# s0 of + (# s1, marr #) -> case writeInt16Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = I16# (indexWord8ArrayAsInt16# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsInt16# mba off s of (# s', r #) -> (# s', I16# r #) + {-# INLINE readBytes #-} + writeBytes mba off (I16# x) + = writeWord8ArrayAsInt16# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readInt16OffAddr# a 0# s of (# s', x #) -> (# s', I16# x #) + {-# INLINE readAddr #-} + writeAddr (I16# x) a + = writeInt16OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT16# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT16# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = I16# (indexInt16Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt16Array# mba i s of (# s', x #) -> (# s', I16# x #) + {-# INLINE readArray #-} + writeArray mba i (I16# x) = writeInt16Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Int32 where + type PrimFields Int32 = '[] + getBytes (I32# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT32# s0 of + (# s1, marr #) -> case writeInt32Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = I32# (indexWord8ArrayAsInt32# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsInt32# mba off s of (# s', r #) -> (# s', I32# r #) + {-# INLINE readBytes #-} + writeBytes mba off (I32# x) + = writeWord8ArrayAsInt32# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readInt32OffAddr# a 0# s of (# s', x #) -> (# s', I32# x #) + {-# INLINE readAddr #-} + writeAddr (I32# x) a + = writeInt32OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT32# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT32# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = I32# (indexInt32Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt32Array# mba i s of (# s', x #) -> (# s', I32# x #) + {-# INLINE readArray #-} + writeArray mba i (I32# x) = writeInt32Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Int64 where + type PrimFields Int64 = '[] + getBytes (I64# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_INT64# s0 of + (# s1, marr #) -> case writeInt64Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = I64# (indexWord8ArrayAsInt64# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsInt64# mba off s of (# s', r #) -> (# s', I64# r #) + {-# INLINE readBytes #-} + writeBytes mba off (I64# x) + = writeWord8ArrayAsInt64# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readInt64OffAddr# a 0# s of (# s', x #) -> (# s', I64# x #) + {-# INLINE readAddr #-} + writeAddr (I64# x) a + = writeInt64OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_INT64# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_INT64# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = I64# (indexInt64Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readInt64Array# mba i s of (# s', x #) -> (# s', I64# x #) + {-# INLINE readArray #-} + writeArray mba i (I64# x) = writeInt64Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word8 where + type PrimFields Word8 = '[] + getBytes (W8# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD8# s0 of + (# s1, marr #) -> case writeWord8Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba = indexArray ba off + {-# INLINE fromBytes #-} + readBytes = readArray + {-# INLINE readBytes #-} + writeBytes = writeArray + {-# INLINE writeBytes #-} + readAddr a s + = case readWord8OffAddr# a 0# s of (# s', x #) -> (# s', W8# x #) + {-# INLINE readAddr #-} + writeAddr (W8# x) a + = writeWord8OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD8# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD8# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = W8# (indexWord8Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord8Array# mba i s of (# s', x #) -> (# s', W8# x #) + {-# INLINE readArray #-} + writeArray mba i (W8# x) = writeWord8Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word16 where + type PrimFields Word16 = '[] + getBytes (W16# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD16# s0 of + (# s1, marr #) -> case writeWord16Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = W16# (indexWord8ArrayAsWord16# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsWord16# mba off s of (# s', r #) -> (# s', W16# r #) + {-# INLINE readBytes #-} + writeBytes mba off (W16# x) + = writeWord8ArrayAsWord16# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readWord16OffAddr# a 0# s of (# s', x #) -> (# s', W16# x #) + {-# INLINE readAddr #-} + writeAddr (W16# x) a + = writeWord16OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD16# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD16# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = W16# (indexWord16Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord16Array# mba i s of (# s', x #) -> (# s', W16# x #) + {-# INLINE readArray #-} + writeArray mba i (W16# x) = writeWord16Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word32 where + type PrimFields Word32 = '[] + getBytes (W32# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD32# s0 of + (# s1, marr #) -> case writeWord32Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = W32# (indexWord8ArrayAsWord32# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsWord32# mba off s of (# s', r #) -> (# s', W32# r #) + {-# INLINE readBytes #-} + writeBytes mba off (W32# x) + = writeWord8ArrayAsWord32# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readWord32OffAddr# a 0# s of (# s', x #) -> (# s', W32# x #) + {-# INLINE readAddr #-} + writeAddr (W32# x) a + = writeWord32OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD32# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD32# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = W32# (indexWord32Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord32Array# mba i s of (# s', x #) -> (# s', W32# x #) + {-# INLINE readArray #-} + writeArray mba i (W32# x) = writeWord32Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Word64 where + type PrimFields Word64 = '[] + getBytes (W64# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_WORD64# s0 of + (# s1, marr #) -> case writeWord64Array# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = W64# (indexWord8ArrayAsWord64# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsWord64# mba off s of (# s', r #) -> (# s', W64# r #) + {-# INLINE readBytes #-} + writeBytes mba off (W64# x) + = writeWord8ArrayAsWord64# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readWord64OffAddr# a 0# s of (# s', x #) -> (# s', W64# x #) + {-# INLINE readAddr #-} + writeAddr (W64# x) a + = writeWord64OffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_WORD64# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_WORD64# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = W64# (indexWord64Array# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWord64Array# mba i s of (# s', x #) -> (# s', W64# x #) + {-# INLINE readArray #-} + writeArray mba i (W64# x) = writeWord64Array# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes Char where + type PrimFields Char = '[] + getBytes (C# x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSCHAR# s0 of + (# s1, marr #) -> case writeWideCharArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = C# (indexWord8ArrayAsWideChar# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsWideChar# mba off s of (# s', r #) -> (# s', C# r #) + {-# INLINE readBytes #-} + writeBytes mba off (C# x) + = writeWord8ArrayAsWideChar# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readWideCharOffAddr# a 0# s of (# s', x #) -> (# s', C# x #) + {-# INLINE readAddr #-} + writeAddr (C# x) a + = writeWideCharOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSCHAR# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSCHAR# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = C# (indexWideCharArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readWideCharArray# mba i s of (# s', x #) -> (# s', C# x #) + {-# INLINE readArray #-} + writeArray mba i (C# x) = writeWideCharArray# mba i x + {-# INLINE writeArray #-} + +instance PrimBytes (Idx (x :: k)) where + type PrimFields (Idx x) = '[] + getBytes = unsafeCoerce# (getBytes @Word) + {-# INLINE getBytes #-} + fromBytes = unsafeCoerce# (fromBytes @Word) + {-# INLINE fromBytes #-} + readBytes = unsafeCoerce# (readBytes @Word) + {-# INLINE readBytes #-} + writeBytes = unsafeCoerce# (writeBytes @Word) + {-# INLINE writeBytes #-} + readAddr = unsafeCoerce# (readAddr @Word) + {-# INLINE readAddr #-} + writeAddr = unsafeCoerce# (writeAddr @Word) + {-# INLINE writeAddr #-} + byteSize = unsafeCoerce# (byteSize @Word) + {-# INLINE byteSize #-} + byteAlign = unsafeCoerce# (byteAlign @Word) + {-# INLINE byteAlign #-} + byteFieldOffset b = unsafeCoerce# (byteFieldOffset @Word b) + {-# INLINE byteFieldOffset #-} + indexArray = unsafeCoerce# (indexArray @Word) + {-# INLINE indexArray #-} + readArray = unsafeCoerce# (readArray @Word) + {-# INLINE readArray #-} + writeArray = unsafeCoerce# (writeArray @Word) + {-# INLINE writeArray #-} + +anyList :: forall (k :: Type) (xs :: [k]) + . RepresentableList xs => [Any] +anyList = unsafeCoerce# (tList @_ @xs) +{-# INLINE anyList #-} + +instance RepresentableList xs => PrimBytes (Idxs (xs :: [k])) where + type PrimFields (Idxs xs) = '[] + fromBytes off ba = unsafeCoerce# (go off (anyList @_ @xs)) + where + go _ [] = [] + go i (_ : ls) = W# (indexWord8ArrayAsWord# ba i) : go (i +# SIZEOF_HSWORD#) ls + {-# INLINE fromBytes #-} + readBytes mba = unsafeCoerce# (go (anyList @_ @xs)) + where + go [] _ s0 = (# s0, [] #) + go (_ : ls) i s0 + | (# s1, w #) <- readWord8ArrayAsWord# mba i s0 + , (# s2, ws #) <- go ls (i +# SIZEOF_HSWORD#) s1 + = (# s2, W# w : ws #) + {-# INLINE readBytes #-} + writeBytes mba off = go off . listIdxs + where + go _ [] s = s + go i (W# x :xs) s = go (i +# SIZEOF_HSWORD#) xs (writeWord8ArrayAsWord# mba i x s) + {-# INLINE writeBytes #-} + readAddr addr = unsafeCoerce# (go addr (anyList @_ @xs)) + where + go :: forall s . Addr# -> [Any] -> State# s -> (# State# s, [Word] #) + go _ [] s0 = (# s0, [] #) + go i (_ : ls) s0 + | (# s1, w #) <- readWordOffAddr# i 0# s0 + , (# s2, xs #) <- go (plusAddr# i SIZEOF_HSWORD#) ls s1 + = (# s2, W# w : xs #) + {-# INLINE readAddr #-} + writeAddr is addr + = go addr (listIdxs is) + where + go :: forall s . Addr# -> [Word] -> State# s -> State# s + go _ [] s = s + go i (W# x :xs) s = go (plusAddr# i SIZEOF_HSWORD#) xs + (writeWordOffAddr# i 0# x s) + {-# INLINE writeAddr #-} + byteSize _ = case dimVal (order' @_ @xs) of + W# n -> byteSize (undefined :: Idx x) *# word2Int# n + {-# INLINE byteSize #-} + byteAlign _ = byteAlign (undefined :: Idx x) + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba off + | n@(W# n#) <- dimVal (order' @_ @xs) + = unsafeCoerce# (go (off *# word2Int# n#) n) + where + go _ 0 = [] + go i n = W# (indexWordArray# ba i) : go (i +# 1#) (n-1) + {-# INLINE indexArray #-} + readArray mba off s + | n@(W# n#) <- dimVal (order' @_ @xs) + = unsafeCoerce# (go (off *# word2Int# n#) n s) + where + go _ 0 s0 = (# s0, [] #) + go i n s0 + | (# s1, w #) <- readWordArray# mba i s0 + , (# s2, xs #) <- go (i +# 1#) (n-1) s1 + = (# s2, W# w : xs #) + {-# INLINE readArray #-} + writeArray mba off is + | W# n# <- dimVal (order' @_ @xs) + = go (off *# word2Int# n#) (listIdxs is) + where + go _ [] s = s + go i (W# x :xs) s = go (i +# 1#) xs (writeWordArray# mba i x s) + {-# INLINE writeArray #-} + +type family TupleFields (n :: Nat) (xs :: [Type]) :: [Symbol] where + TupleFields _ '[] = '[] + TupleFields n (_ ': xs) = ShowNat n ': TupleFields (n + 1) xs + +instance ( RepresentableList xs + , L.All PrimBytes xs + ) => PrimBytes (TL.Tuple xs) where + type PrimFields (TL.Tuple xs) = TupleFields 1 xs + getBytes = unsafeCoerce# (getBytes @(TS.Tuple xs)) + {-# INLINE getBytes #-} + fromBytes = unsafeCoerce# (fromBytes @(TS.Tuple xs)) + {-# INLINE fromBytes #-} + readBytes = unsafeCoerce# (readBytes @(TS.Tuple xs)) + {-# INLINE readBytes #-} + writeBytes = unsafeCoerce# (writeBytes @(TS.Tuple xs)) + {-# INLINE writeBytes #-} + readAddr = unsafeCoerce# (readAddr @(TS.Tuple xs)) + {-# INLINE readAddr #-} + writeAddr = unsafeCoerce# (writeAddr @(TS.Tuple xs)) + {-# INLINE writeAddr #-} + byteSize = unsafeCoerce# (byteSize @(TS.Tuple xs)) + {-# INLINE byteSize #-} + byteAlign = unsafeCoerce# (byteAlign @(TS.Tuple xs)) + {-# INLINE byteAlign #-} + byteFieldOffset p = unsafeCoerce# (byteFieldOffset @(TS.Tuple xs) p) + {-# INLINE byteFieldOffset #-} + indexArray = unsafeCoerce# (indexArray @(TS.Tuple xs)) + {-# INLINE indexArray #-} + readArray = unsafeCoerce# (readArray @(TS.Tuple xs)) + {-# INLINE readArray #-} + writeArray = unsafeCoerce# (writeArray @(TS.Tuple xs)) + {-# INLINE writeArray #-} + +instance ( RepresentableList xs + , L.All PrimBytes xs + ) => PrimBytes (TS.Tuple xs) where + type PrimFields (TS.Tuple xs) = TupleFields 1 xs + fromBytes off ba = go 0# (tList @_ @xs) + where + go :: L.All PrimBytes ds + => Int# -> TypeList ds -> TS.Tuple ds + go _ Empty = Empty + go n (t :* ts@TypeList) + | x <- undefP t + , n' <- roundUpInt n (byteAlign x) + = TS.Id (fromBytes (off +# n') ba) :* go (n' +# byteSize x) ts + {-# INLINE fromBytes #-} + readBytes mb off = go mb 0# (tList @_ @xs) + where + go :: L.All PrimBytes ds + => MutableByteArray# s + -> Int# -> TypeList ds -> State# s -> (# State# s, TS.Tuple ds #) + go _ _ Empty s0 = (# s0, Empty #) + go mba n (t :* ts@TypeList) s0 + | x <- undefP t + , n' <- roundUpInt n (byteAlign x) + = case readBytes mba (off +# n') s0 of + (# s1, r #) -> case go mba (n' +# byteSize x) ts s1 of + (# s2, rs #) -> (# s2, TS.Id r :* rs #) + {-# INLINE readBytes #-} + writeBytes mba off tup = go mba 0# tup (types tup) + where + go :: L.All PrimBytes ds => MutableByteArray# s + -> Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s + go _ _ _ Empty s = s + go mb n (TS.Id x :* xs) (_ :* ts@TypeList) s + | n' <- roundUpInt n (byteAlign x) + = go mb (n' +# byteSize x) xs ts (writeBytes mb (off +# n') x s) + {-# INLINE writeBytes #-} + readAddr addr = go 0# (tList @_ @xs) + where + go :: L.All PrimBytes ds + => Int# -> TypeList ds -> State# s -> (# State# s, TS.Tuple ds #) + go _ Empty s0 = (# s0, Empty #) + go n (t :* ts@TypeList) s0 + | x <- undefP t + , n' <- roundUpInt n (byteAlign x) + = case readAddr (plusAddr# addr n') s0 of + (# s1, r #) -> case go (n' +# byteSize x) ts s1 of + (# s2, rs #) -> (# s2, TS.Id r :* rs #) + {-# INLINE readAddr #-} + writeAddr tup addr = go 0# tup (types tup) + where + go :: L.All PrimBytes ds + => Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s + go _ _ Empty s = s + go n (TS.Id x :* xs) (_ :* ts@TypeList) s + | n' <- roundUpInt n (byteAlign x) + = go (n' +# byteSize x) xs ts (writeAddr x (plusAddr# addr n') s) + {-# INLINE writeAddr #-} + byteSize _ = go 0# 1# (tList @_ @xs) + where + go :: L.All PrimBytes ys => Int# -> Int# -> TypeList ys -> Int# + go s a Empty = s `roundUpInt` a + go s a (p :* ps) = let x = undefP p + xa = byteAlign x + in go ( roundUpInt s xa +# byteSize x) + ( maxInt a xa ) ps + {-# INLINE byteSize #-} + byteAlign _ = go (tList @_ @xs) + where + go :: L.All PrimBytes ys => TypeList ys -> Int# + go Empty = 0# + go (p :* ps) = maxInt (byteAlign (undefP p)) (go ps) + {-# INLINE byteAlign #-} + byteFieldOffset name _ + | Just n <- readMaybe $ symbolVal' name + = go (n-1) 0# (tList @_ @xs) + | otherwise = negateInt# 1# + where + go :: L.All PrimBytes ys => Word -> Int# -> TypeList ys -> Int# + go 0 s (p :* _) = s `roundUpInt` byteAlign (undefP p) + go n s (p :* ps) = let x = undefP p + in go (n-1) ( roundUpInt s (byteAlign x) +# byteSize x) ps + go _ _ Empty = negateInt# 1# + {-# INLINE byteFieldOffset #-} + + +undefP :: Proxy p -> p +undefP = const undefined +{-# INLINE undefP #-} + + +instance PrimBytes () +instance PrimBytes a => PrimBytes (Maybe a) +instance ( PrimBytes a, PrimBytes b ) => PrimBytes (Either a b) +instance ( PrimBytes a, PrimBytes b ) + => PrimBytes (a, b) +instance ( PrimBytes a, PrimBytes b, PrimBytes c ) + => PrimBytes (a, b, c) +instance ( PrimBytes a, PrimBytes b, PrimBytes c, PrimBytes d ) + => PrimBytes (a, b, c, d) +instance ( PrimBytes a, PrimBytes b, PrimBytes c, PrimBytes d, PrimBytes e ) + => PrimBytes (a, b, c, d, e) +instance ( PrimBytes a, PrimBytes b, PrimBytes c, PrimBytes d, PrimBytes e + , PrimBytes f ) + => PrimBytes (a, b, c, d, e, f) +instance ( PrimBytes a, PrimBytes b, PrimBytes c, PrimBytes d, PrimBytes e + , PrimBytes f, PrimBytes g ) + => PrimBytes (a, b, c, d, e, f, g) + + +-- | Find out which basic GHC type it is at runtime. +-- It is used for @DataFrame@ backend specialization: +-- by matching a @PrimTag a@ against its constructors, you can figure out +-- a specific implementation of @Backend a ds@ +-- (e.g. whether this is a specialized float array, or a generic polymorphic array). +-- For non-basic types it defaults to `PTagOther`. +data PrimTag a where + PTagFloat :: PrimTag Float + PTagDouble :: PrimTag Double + PTagInt :: PrimTag Int + PTagInt8 :: PrimTag Int8 + PTagInt16 :: PrimTag Int16 + PTagInt32 :: PrimTag Int32 + PTagInt64 :: PrimTag Int64 + PTagWord :: PrimTag Word + PTagWord8 :: PrimTag Word8 + PTagWord16 :: PrimTag Word16 + PTagWord32 :: PrimTag Word32 + PTagWord64 :: PrimTag Word64 + PTagChar :: PrimTag Char + PTagPtr :: PrimTag (Ptr a) + PTagOther :: PrimTag a + +deriving instance Show (PrimTag a) + + +-- | Find out which basic GHC type it is at runtime. +class PrimTagged a where + -- | This function allows to find out a type by comparing its tag + primTag' :: a -> PrimTag a + +-- | This function allows to find out a type by comparing its tag. +-- This is needed for backend specialization, to infer array instances. +-- For non-basic types it defaults to `PTagOther`. +primTag :: PrimBytes a => a -> PrimTag a +primTag = primTag' +{-# INLINE primTag #-} + +instance {-# OVERLAPPABLE #-} PrimTagged a where + primTag' = const PTagOther + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Float where + primTag' = const PTagFloat + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Double where + primTag' = const PTagDouble + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int where + primTag' = const PTagInt + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int8 where + primTag' = const PTagInt8 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int16 where + primTag' = const PTagInt16 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int32 where + primTag' = const PTagInt32 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Int64 where + primTag' = const PTagInt64 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word where + primTag' = const PTagWord + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word8 where + primTag' = const PTagWord8 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word16 where + primTag' = const PTagWord16 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word32 where + primTag' = const PTagWord32 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Word64 where + primTag' = const PTagWord64 + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged Char where + primTag' = const PTagChar + {-# INLINE primTag' #-} + +instance {-# OVERLAPPING #-} PrimTagged (Ptr a) where + primTag' = const PTagPtr + {-# INLINE primTag' #-} + + + +#if !(MIN_VERSION_base(4,12,0)) +-- these functions were introduced in base-4.12.0 + +writeWord8ArrayAsWideChar# :: MutableByteArray# d -> Int# -> Char# -> State# d -> State# d +writeWord8ArrayAsWideChar# mba off = writeWideCharArray# mba (uncheckedIShiftRL# off OFFSHIFT_C#) +{-# INLINE writeWord8ArrayAsWideChar# #-} + +writeWord8ArrayAsAddr# :: MutableByteArray# d -> Int# -> Addr# -> State# d -> State# d +writeWord8ArrayAsAddr# mba off = writeAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) +{-# INLINE writeWord8ArrayAsAddr# #-} + +writeWord8ArrayAsFloat# :: MutableByteArray# d -> Int# -> Float# -> State# d -> State# d +writeWord8ArrayAsFloat# mba off = writeFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) +{-# INLINE writeWord8ArrayAsFloat# #-} + +writeWord8ArrayAsDouble# :: MutableByteArray# d -> Int# -> Double# -> State# d -> State# d +writeWord8ArrayAsDouble# mba off = writeDoubleArray# mba (uncheckedIShiftRL# off OFFSHIFT_D#) +{-# INLINE writeWord8ArrayAsDouble# #-} + +writeWord8ArrayAsInt16# :: MutableByteArray# d -> Int# -> Int# -> State# d -> State# d +writeWord8ArrayAsInt16# mba off = writeInt16Array# mba (uncheckedIShiftRL# off 1#) +{-# INLINE writeWord8ArrayAsInt16# #-} + +writeWord8ArrayAsInt32# :: MutableByteArray# d -> Int# -> Int# -> State# d -> State# d +writeWord8ArrayAsInt32# mba off = writeInt32Array# mba (uncheckedIShiftRL# off 2#) +{-# INLINE writeWord8ArrayAsInt32# #-} + +writeWord8ArrayAsInt64# :: MutableByteArray# d -> Int# -> Int# -> State# d -> State# d +writeWord8ArrayAsInt64# mba off = writeInt64Array# mba (uncheckedIShiftRL# off 3#) +{-# INLINE writeWord8ArrayAsInt64# #-} + +writeWord8ArrayAsInt# :: MutableByteArray# d -> Int# -> Int# -> State# d -> State# d +writeWord8ArrayAsInt# mba off = writeIntArray# mba (uncheckedIShiftRL# off OFFSHIFT_I#) +{-# INLINE writeWord8ArrayAsInt# #-} + +writeWord8ArrayAsWord16# :: MutableByteArray# d -> Int# -> Word# -> State# d -> State# d +writeWord8ArrayAsWord16# mba off = writeWord16Array# mba (uncheckedIShiftRL# off 1#) +{-# INLINE writeWord8ArrayAsWord16# #-} + +writeWord8ArrayAsWord32# :: MutableByteArray# d -> Int# -> Word# -> State# d -> State# d +writeWord8ArrayAsWord32# mba off = writeWord32Array# mba (uncheckedIShiftRL# off 2#) +{-# INLINE writeWord8ArrayAsWord32# #-} + +writeWord8ArrayAsWord64# :: MutableByteArray# d -> Int# -> Word# -> State# d -> State# d +writeWord8ArrayAsWord64# mba off = writeWord64Array# mba (uncheckedIShiftRL# off 3#) +{-# INLINE writeWord8ArrayAsWord64# #-} + +writeWord8ArrayAsWord# :: MutableByteArray# d -> Int# -> Word# -> State# d -> State# d +writeWord8ArrayAsWord# mba off = writeWordArray# mba (uncheckedIShiftRL# off OFFSHIFT_W#) +{-# INLINE writeWord8ArrayAsWord# #-} + +readWord8ArrayAsWideChar# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Char# #) +readWord8ArrayAsWideChar# mba off = readWideCharArray# mba (uncheckedIShiftRL# off OFFSHIFT_C#) +{-# INLINE readWord8ArrayAsWideChar# #-} + +readWord8ArrayAsAddr# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Addr# #) +readWord8ArrayAsAddr# mba off = readAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) +{-# INLINE readWord8ArrayAsAddr# #-} + +readWord8ArrayAsFloat# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Float# #) +readWord8ArrayAsFloat# mba off = readFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) +{-# INLINE readWord8ArrayAsFloat# #-} + +readWord8ArrayAsDouble# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Double# #) +readWord8ArrayAsDouble# mba off = readDoubleArray# mba (uncheckedIShiftRL# off OFFSHIFT_D#) +{-# INLINE readWord8ArrayAsDouble# #-} + +readWord8ArrayAsInt16# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Int# #) +readWord8ArrayAsInt16# mba off = readInt16Array# mba (uncheckedIShiftRL# off 1#) +{-# INLINE readWord8ArrayAsInt16# #-} + +readWord8ArrayAsInt32# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Int# #) +readWord8ArrayAsInt32# mba off = readInt32Array# mba (uncheckedIShiftRL# off 2#) +{-# INLINE readWord8ArrayAsInt32# #-} + +readWord8ArrayAsInt64# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Int# #) +readWord8ArrayAsInt64# mba off = readInt64Array# mba (uncheckedIShiftRL# off 3#) +{-# INLINE readWord8ArrayAsInt64# #-} + +readWord8ArrayAsInt# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Int# #) +readWord8ArrayAsInt# mba off = readIntArray# mba (uncheckedIShiftRL# off OFFSHIFT_I#) +{-# INLINE readWord8ArrayAsInt# #-} + +readWord8ArrayAsWord16# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Word# #) +readWord8ArrayAsWord16# mba off = readWord16Array# mba (uncheckedIShiftRL# off 1#) +{-# INLINE readWord8ArrayAsWord16# #-} + +readWord8ArrayAsWord32# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Word# #) +readWord8ArrayAsWord32# mba off = readWord32Array# mba (uncheckedIShiftRL# off 2#) +{-# INLINE readWord8ArrayAsWord32# #-} + +readWord8ArrayAsWord64# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Word# #) +readWord8ArrayAsWord64# mba off = readWord64Array# mba (uncheckedIShiftRL# off 3#) +{-# INLINE readWord8ArrayAsWord64# #-} + +readWord8ArrayAsWord# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Word# #) +readWord8ArrayAsWord# mba off = readWordArray# mba (uncheckedIShiftRL# off OFFSHIFT_W#) +{-# INLINE readWord8ArrayAsWord# #-} + +indexWord8ArrayAsWideChar# :: ByteArray# -> Int# -> Char# +indexWord8ArrayAsWideChar# ba off = indexWideCharArray# ba (uncheckedIShiftRL# off OFFSHIFT_C#) +{-# INLINE indexWord8ArrayAsWideChar# #-} + +indexWord8ArrayAsAddr# :: ByteArray# -> Int# -> Addr# +indexWord8ArrayAsAddr# ba off = indexAddrArray# ba (uncheckedIShiftRL# off OFFSHIFT_P#) +{-# INLINE indexWord8ArrayAsAddr# #-} + +indexWord8ArrayAsFloat# :: ByteArray# -> Int# -> Float# +indexWord8ArrayAsFloat# ba off = indexFloatArray# ba (uncheckedIShiftRL# off OFFSHIFT_F#) +{-# INLINE indexWord8ArrayAsFloat# #-} + +indexWord8ArrayAsDouble# :: ByteArray# -> Int# -> Double# +indexWord8ArrayAsDouble# ba off = indexDoubleArray# ba (uncheckedIShiftRL# off OFFSHIFT_D#) +{-# INLINE indexWord8ArrayAsDouble# #-} + +indexWord8ArrayAsInt16# :: ByteArray# -> Int# -> Int# +indexWord8ArrayAsInt16# ba off = indexInt16Array# ba (uncheckedIShiftRL# off 1#) +{-# INLINE indexWord8ArrayAsInt16# #-} + +indexWord8ArrayAsInt32# :: ByteArray# -> Int# -> Int# +indexWord8ArrayAsInt32# ba off = indexInt32Array# ba (uncheckedIShiftRL# off 2#) +{-# INLINE indexWord8ArrayAsInt32# #-} + +indexWord8ArrayAsInt64# :: ByteArray# -> Int# -> Int# +indexWord8ArrayAsInt64# ba off = indexInt64Array# ba (uncheckedIShiftRL# off 3#) +{-# INLINE indexWord8ArrayAsInt64# #-} + +indexWord8ArrayAsInt# :: ByteArray# -> Int# -> Int# +indexWord8ArrayAsInt# ba off = indexIntArray# ba (uncheckedIShiftRL# off OFFSHIFT_I#) +{-# INLINE indexWord8ArrayAsInt# #-} + +indexWord8ArrayAsWord16# :: ByteArray# -> Int# -> Word# +indexWord8ArrayAsWord16# ba off = indexWord16Array# ba (uncheckedIShiftRL# off 1#) +{-# INLINE indexWord8ArrayAsWord16# #-} + +indexWord8ArrayAsWord32# :: ByteArray# -> Int# -> Word# +indexWord8ArrayAsWord32# ba off = indexWord32Array# ba (uncheckedIShiftRL# off 2#) +{-# INLINE indexWord8ArrayAsWord32# #-} + +indexWord8ArrayAsWord64# :: ByteArray# -> Int# -> Word# +indexWord8ArrayAsWord64# ba off = indexWord64Array# ba (uncheckedIShiftRL# off 3#) +{-# INLINE indexWord8ArrayAsWord64# #-} + +indexWord8ArrayAsWord# :: ByteArray# -> Int# -> Word# +indexWord8ArrayAsWord# ba off = indexWordArray# ba (uncheckedIShiftRL# off OFFSHIFT_W#) +{-# INLINE indexWord8ArrayAsWord# #-} + +#endif diff --git a/src/Numeric/ProductOrd.hs b/src/Numeric/ProductOrd.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/ProductOrd.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.ProductOrd +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- +-- Compare product types -- partial order. +-- +----------------------------------------------------------------------------- +module Numeric.ProductOrd (ProductOrder (..), PartialOrdering (..), fromOrdering) where + + +import Data.Data +import Data.Kind (Type) +import Data.Monoid as Mon (Monoid (..)) +import Data.Semigroup as Sem (Semigroup (..), stimesIdempotentMonoid) +import GHC.Generics + +import Numeric.TypedList + +-- | Partial order for comparing product types -- +-- [product order](https://en.wikipedia.org/wiki/Product_order). +class ProductOrder a where + -- | Same as `compare`, but may return @Incomparable@. + cmp :: a -> a -> PartialOrdering + +-- | Similar to `Ordering`, but may be @Incomparable@. +data PartialOrdering = PLT | PEQ | PGT | Incomparable + deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Enum, Bounded ) + +-- | Extend `Ordering` with @Incomparable@ option. +fromOrdering :: Ordering -> PartialOrdering +fromOrdering LT = PLT +fromOrdering EQ = PEQ +fromOrdering GT = PGT +{-# INLINE fromOrdering #-} + +instance Sem.Semigroup PartialOrdering where + Incomparable <> _ = Incomparable + _ <> Incomparable = Incomparable + PLT <> PGT = Incomparable + PGT <> PLT = Incomparable + PLT <> _ = PLT + PGT <> _ = PGT + PEQ <> y = y + + stimes = stimesIdempotentMonoid + +instance Mon.Monoid PartialOrdering where + mempty = PEQ +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + +instance All Ord (Map f xs) + => ProductOrder (TypedList (f :: k -> Type) (xs :: [k])) where + cmp U U = PEQ + cmp (a :* as) (b :* bs) = fromOrdering (compare a b) <> cmp as bs + + +cmp' :: Ord a => a -> a -> PartialOrdering +cmp' a b = fromOrdering (compare a b) +{-# INLINE cmp' #-} + +instance (Ord a1, Ord a2) + => ProductOrder (a1, a2) where + cmp (a1, a2) + (b1, b2) + = cmp' a1 b1 <> cmp' a2 b2 + +instance (Ord a1, Ord a2, Ord a3) + => ProductOrder (a1, a2, a3) where + cmp (a1, a2, a3) + (b1, b2, b3) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + +instance (Ord a1, Ord a2, Ord a3, Ord a4) + => ProductOrder (a1, a2, a3, a4) where + cmp (a1, a2, a3, a4) + (b1, b2, b3, b4) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + <> cmp' a4 b4 + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5) + => ProductOrder (a1, a2, a3, a4, a5) where + cmp (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + <> cmp' a4 b4 <> cmp' a5 b5 + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6) + => ProductOrder (a1, a2, a3, a4, a5, a6) where + cmp (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + <> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6 + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7) + => ProductOrder (a1, a2, a3, a4, a5, a6, a7) where + cmp (a1, a2, a3, a4, a5, a6, a7) + (b1, b2, b3, b4, b5, b6, b7) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + <> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6 + <> cmp' a7 b7 + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8) + => ProductOrder (a1, a2, a3, a4, a5, a6, a7, a8) where + cmp (a1, a2, a3, a4, a5, a6, a7, a8) + (b1, b2, b3, b4, b5, b6, b7, b8) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + <> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6 + <> cmp' a7 b7 <> cmp' a8 b8 + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8, Ord a9) + => ProductOrder (a1, a2, a3, a4, a5, a6, a7, a8, a9) where + cmp (a1, a2, a3, a4, a5, a6, a7, a8, a9) + (b1, b2, b3, b4, b5, b6, b7, b8, b9) + = cmp' a1 b1 <> cmp' a2 b2 <> cmp' a3 b3 + <> cmp' a4 b4 <> cmp' a5 b5 <> cmp' a6 b6 + <> cmp' a7 b7 <> cmp' a8 b8 <> cmp' a9 b9 diff --git a/src/Numeric/ProductOrd/NonTransitive.hs b/src/Numeric/ProductOrd/NonTransitive.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/ProductOrd/NonTransitive.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.ProductOrd.NonTransitive +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- +-- Compare product types using non-transitive `Ord` instances: +-- +-- * \( a = b \) and \( b = c \) __does not mean__ \( a = c \); +-- * but, if nor \( a > b \) neither \( b > a \), then \( a = b \). +-- +-- To remind yourself that `ProductOrd` is not fully faithful, you may +-- import it qualified, e.g. +-- +-- > import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +-- +----------------------------------------------------------------------------- +module Numeric.ProductOrd.NonTransitive (ProductOrd (..), toOrdering) where + +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Bits (Bits, FiniteBits) +import Data.Coerce +import Data.Data +import Data.Foldable +import Data.Kind (Type) +import Data.Monoid as Mon (Monoid (..)) +import Data.Semigroup as Sem (Semigroup (..)) +import Foreign.Storable (Storable) +import GHC.Generics + +import Numeric.ProductOrd +import Numeric.TypedList + +{-| + Redefine `Ord` instance for a type which is a cartesian product -- + as a partial __[product order](https://en.wikipedia.org/wiki/Product_order)__. + + Since vanilla Haskell `Ord` class is always about total order, @ProductOrd@ + instance is not particularly correct. + However, it turns out to be very useful for comparing vector or tuple-like types. + + The implementation of `ProductOrd` in this module + workarounds this by using a __non-transitive `Eq` instance__: + \[ + a = b \iff \neg (a > b) \land \neg (b > a) + \] + + Another inconsistency with the Haskell Report is the `min` and `max` functions; + these are simply element-wise minimum and maximum here. + Thus, these instances preserve important properties like + @min a b <= a && min a b <= b@, but do not preserve + a property that @min a b == a || min a b == b@. + + All of this is really useful in geometry applications and for calculating things + like [Pareto dominance](https://en.wikipedia.org/wiki/Pareto_efficiency), + but should be used with care. + Remember about this if you want to put a @ProductOrd@ into a @Set@ or a @Map@! + -} +newtype ProductOrd a = ProductOrd { getProductOrd :: a } + deriving ( Show, Read, Data, Typeable, Generic, Generic1 + , Num, Enum, Bounded, Floating, Fractional + , Semigroup, Monoid, Storable, Traversable) + +deriving instance (Ord (ProductOrd a), Integral a) => Integral (ProductOrd a) +deriving instance (Ord (ProductOrd a), Bits a) => Bits (ProductOrd a) +deriving instance (Ord (ProductOrd a), FiniteBits a) => FiniteBits (ProductOrd a) +deriving instance (Ord (ProductOrd a), Real a) => Real (ProductOrd a) +deriving instance (Ord (ProductOrd a), RealFrac a) => RealFrac (ProductOrd a) +deriving instance (Ord (ProductOrd a), RealFloat a) => RealFloat (ProductOrd a) + +instance Foldable ProductOrd where + foldMap = coerce + elem = k (==) + where + k :: (a -> a -> Bool) -> a -> ProductOrd a -> Bool + k = coerce + foldl = coerce + foldl' = coerce + foldl1 _ = coerce + foldr f z (ProductOrd x) = f x z + foldr' = foldr + foldr1 _ = coerce + length _ = 1 + maximum = coerce + minimum = coerce + null _ = False + product = coerce + sum = coerce + toList (ProductOrd x) = [x] + +instance Functor ProductOrd where + fmap = coerce + +instance Applicative ProductOrd where + pure = ProductOrd + (<*>) = coerce + +instance Monad ProductOrd where + m >>= k = k (getProductOrd m) + +instance MonadFix ProductOrd where + mfix f = ProductOrd (fix (getProductOrd . f)) + +instance MonadZip ProductOrd where + mzipWith = coerce + munzip = coerce + +{-# ANN module "HLint: ignore Redundant compare" #-} +instance Ord (ProductOrd a) => Eq (ProductOrd a) where + a == b = compare a b == EQ + {-# INLINE (==) #-} + +instance All Ord (Map f xs) + => Ord (ProductOrd (TypedList (f :: k -> Type) (xs :: [k]))) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd U >= ProductOrd U = True + ProductOrd (a :* as) >= ProductOrd (b :* bs) + = a >= b && ProductOrd as >= ProductOrd bs + ProductOrd U <= ProductOrd U = True + ProductOrd (a :* as) <= ProductOrd (b :* bs) + = a <= b && ProductOrd as <= ProductOrd bs + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + min (ProductOrd U) (ProductOrd U) = ProductOrd U + min (ProductOrd (a :* as)) (ProductOrd (b :* bs)) + = ProductOrd (min a b :* getProductOrd (min (ProductOrd as) (ProductOrd bs))) + max (ProductOrd U) (ProductOrd U) = ProductOrd U + max (ProductOrd (a :* as)) (ProductOrd (b :* bs)) + = ProductOrd (max a b :* getProductOrd (max (ProductOrd as) (ProductOrd bs))) + +instance (Ord a1, Ord a2) => Ord (ProductOrd (a1, a2)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2) >= ProductOrd (b1, b2) + = a1 >= b1 && a2 >= b2 + {-# INLINE (>=) #-} + ProductOrd (a1, a2) <= ProductOrd (b1, b2) + = a1 <= b1 && a2 <= b2 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2)) (ProductOrd (b1, b2)) + = ProductOrd (min a1 b1, min a2 b2) + {-# INLINE min #-} + max (ProductOrd (a1, a2)) (ProductOrd (b1, b2)) + = ProductOrd (max a1 b1, max a2 b2) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3) => Ord (ProductOrd (a1, a2, a3)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3) >= ProductOrd (b1, b2, b3) + = a1 >= b1 && a2 >= b2 && a3 >= b3 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3) <= ProductOrd (b1, b2, b3) + = a1 <= b1 && a2 <= b2 && a3 <= b3 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3)) (ProductOrd (b1, b2, b3)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3)) (ProductOrd (b1, b2, b3)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4) + => Ord (ProductOrd (a1, a2, a3, a4)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4) >= ProductOrd (b1, b2, b3, b4) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4) <= ProductOrd (b1, b2, b3, b4) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4)) (ProductOrd (b1, b2, b3, b4)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4)) (ProductOrd (b1, b2, b3, b4)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5) + => Ord (ProductOrd (a1, a2, a3, a4, a5)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5) >= ProductOrd (b1, b2, b3, b4, b5) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5) <= ProductOrd (b1, b2, b3, b4, b5) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5)) (ProductOrd (b1, b2, b3, b4, b5)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5)) (ProductOrd (b1, b2, b3, b4, b5)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6) >= ProductOrd (b1, b2, b3, b4, b5, b6) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6) <= ProductOrd (b1, b2, b3, b4, b5, b6) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6)) (ProductOrd (b1, b2, b3, b4, b5, b6)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6)) (ProductOrd (b1, b2, b3, b4, b5, b6)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6, a7)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7) >= ProductOrd (b1, b2, b3, b4, b5, b6, b7) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 && a7 >= b7 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7) <= ProductOrd (b1, b2, b3, b4, b5, b6, b7) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 && a7 <= b7 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6, a7)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6, min a7 b7) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6, a7)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6, max a7 b7) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8) >= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 && a7 >= b7 && a8 >= b8 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8) <= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 && a7 <= b7 && a8 <= b8 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6, min a7 b7, min a8 b8) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6, max a7 b7, max a8 b8) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8, Ord a9) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9) >= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 && a7 >= b7 && a8 >= b8 && a9 >= b9 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9) <= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 && a7 <= b7 && a8 <= b8 && a9 <= b9 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6, min a7 b7, min a8 b8, min a9 b9) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6, max a7 b7, max a8 b8, max a9 b9) + {-# INLINE max #-} + +-- | Treat `Incomparable` as EQ (non-transitive equality). +toOrdering :: PartialOrdering -> Ordering +toOrdering PLT = LT +toOrdering PGT = GT +toOrdering _ = EQ diff --git a/src/Numeric/ProductOrd/Partial.hs b/src/Numeric/ProductOrd/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/ProductOrd/Partial.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.ProductOrd.Partial +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- +-- Compare product types using partial `Ord` instances: +-- +-- * if nor \( a > b \), nor \( b > a \), neither, \( a = b \), +-- then @compare a b == undefined@ +-- +-- To remind yourself that `ProductOrd` is partial, you may +-- import it qualified, e.g. +-- +-- > import qualified Numeric.ProductOrd.Partial as Partial +-- +----------------------------------------------------------------------------- +module Numeric.ProductOrd.Partial (ProductOrd (..), toOrdering) where + +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Bits (Bits, FiniteBits) +import Data.Coerce +import Data.Data +import Data.Foldable +import Data.Kind (Type) +import Data.Monoid as Mon (Monoid (..)) +import Data.Semigroup as Sem (Semigroup (..)) +import Foreign.Storable (Storable) +import GHC.Generics + +import Numeric.ProductOrd +import Numeric.TypedList + +{-| + Redefine `Ord` instance for a type which is a cartesian product -- + as a partial __[product order](https://en.wikipedia.org/wiki/Product_order)__. + + Since vanilla Haskell `Ord` class is always about total order, @ProductOrd@ + instance is not particularly correct. + However, it turns out to be very useful for comparing vector or tuple-like types. + + The implementation of `ProductOrd` in this module + workarounds this by using a __partial @compare@ function in an `Eq` instance__: + \[ + \neg (a > b) \land \neg (b > a) \land \neg (a = b) + \Rightarrow \mathtt{compare\ a\ b == undefined} + \] + + Another inconsistency with the Haskell Report is the `min` and `max` functions; + these are simply element-wise minimum and maximum here. + Thus, these instances preserve important properties like + @min a b <= a && min a b <= b@, but do not preserve + a property that @min a b == a || min a b == b@. + + All of this is really useful in geometry applications and for calculating things + like [Pareto dominance](https://en.wikipedia.org/wiki/Pareto_efficiency), + but should be used with care. + In particular, never use @ProductOrd@ as a key to a @Set@ or a @Map@! + -} +newtype ProductOrd a = ProductOrd { getProductOrd :: a } + deriving ( Eq, Show, Read, Data, Typeable, Generic, Generic1 + , Num, Enum, Bounded, Floating, Fractional + , Semigroup, Monoid, Storable, Traversable + , Bits, FiniteBits) + +deriving instance (Ord (ProductOrd a), Integral a) => Integral (ProductOrd a) +deriving instance (Ord (ProductOrd a), Real a) => Real (ProductOrd a) +deriving instance (Ord (ProductOrd a), RealFrac a) => RealFrac (ProductOrd a) +deriving instance (Ord (ProductOrd a), RealFloat a) => RealFloat (ProductOrd a) + +instance Foldable ProductOrd where + foldMap = coerce + elem = k (==) + where + k :: (a -> a -> Bool) -> a -> ProductOrd a -> Bool + k = coerce + foldl = coerce + foldl' = coerce + foldl1 _ = coerce + foldr f z (ProductOrd x) = f x z + foldr' = foldr + foldr1 _ = coerce + length _ = 1 + maximum = coerce + minimum = coerce + null _ = False + product = coerce + sum = coerce + toList (ProductOrd x) = [x] + +instance Functor ProductOrd where + fmap = coerce + +instance Applicative ProductOrd where + pure = ProductOrd + (<*>) = coerce + +instance Monad ProductOrd where + m >>= k = k (getProductOrd m) + +instance MonadFix ProductOrd where + mfix f = ProductOrd (fix (getProductOrd . f)) + +instance MonadZip ProductOrd where + mzipWith = coerce + munzip = coerce + +instance {-# INCOHERENT #-} + All Ord (Map f xs) + => Eq (ProductOrd (TypedList (f :: k -> Type) (xs :: [k]))) where + ProductOrd U == ProductOrd U = True + ProductOrd (a :* as) == ProductOrd (b :* bs) + = a == b && ProductOrd as == ProductOrd bs + +instance All Ord (Map f xs) + => Ord (ProductOrd (TypedList (f :: k -> Type) (xs :: [k]))) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd U >= ProductOrd U = True + ProductOrd (a :* as) >= ProductOrd (b :* bs) + = a >= b && ProductOrd as >= ProductOrd bs + ProductOrd U <= ProductOrd U = True + ProductOrd (a :* as) <= ProductOrd (b :* bs) + = a <= b && ProductOrd as <= ProductOrd bs + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + min (ProductOrd U) (ProductOrd U) = ProductOrd U + min (ProductOrd (a :* as)) (ProductOrd (b :* bs)) + = ProductOrd (min a b :* getProductOrd (min (ProductOrd as) (ProductOrd bs))) + max (ProductOrd U) (ProductOrd U) = ProductOrd U + max (ProductOrd (a :* as)) (ProductOrd (b :* bs)) + = ProductOrd (max a b :* getProductOrd (max (ProductOrd as) (ProductOrd bs))) + +instance (Ord a1, Ord a2) => Ord (ProductOrd (a1, a2)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2) >= ProductOrd (b1, b2) + = a1 >= b1 && a2 >= b2 + {-# INLINE (>=) #-} + ProductOrd (a1, a2) <= ProductOrd (b1, b2) + = a1 <= b1 && a2 <= b2 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2)) (ProductOrd (b1, b2)) + = ProductOrd (min a1 b1, min a2 b2) + {-# INLINE min #-} + max (ProductOrd (a1, a2)) (ProductOrd (b1, b2)) + = ProductOrd (max a1 b1, max a2 b2) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3) => Ord (ProductOrd (a1, a2, a3)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3) >= ProductOrd (b1, b2, b3) + = a1 >= b1 && a2 >= b2 && a3 >= b3 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3) <= ProductOrd (b1, b2, b3) + = a1 <= b1 && a2 <= b2 && a3 <= b3 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3)) (ProductOrd (b1, b2, b3)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3)) (ProductOrd (b1, b2, b3)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4) + => Ord (ProductOrd (a1, a2, a3, a4)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4) >= ProductOrd (b1, b2, b3, b4) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4) <= ProductOrd (b1, b2, b3, b4) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4)) (ProductOrd (b1, b2, b3, b4)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4)) (ProductOrd (b1, b2, b3, b4)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5) + => Ord (ProductOrd (a1, a2, a3, a4, a5)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5) >= ProductOrd (b1, b2, b3, b4, b5) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5) <= ProductOrd (b1, b2, b3, b4, b5) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5)) (ProductOrd (b1, b2, b3, b4, b5)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5)) (ProductOrd (b1, b2, b3, b4, b5)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6) >= ProductOrd (b1, b2, b3, b4, b5, b6) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6) <= ProductOrd (b1, b2, b3, b4, b5, b6) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6)) (ProductOrd (b1, b2, b3, b4, b5, b6)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6)) (ProductOrd (b1, b2, b3, b4, b5, b6)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6, a7)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7) >= ProductOrd (b1, b2, b3, b4, b5, b6, b7) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 && a7 >= b7 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7) <= ProductOrd (b1, b2, b3, b4, b5, b6, b7) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 && a7 <= b7 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6, a7)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6, min a7 b7) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6, a7)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6, max a7 b7) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8) >= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 && a7 >= b7 && a8 >= b8 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8) <= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 && a7 <= b7 && a8 <= b8 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6, min a7 b7, min a8 b8) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6, max a7 b7, max a8 b8) + {-# INLINE max #-} + +instance (Ord a1, Ord a2, Ord a3, Ord a4, Ord a5, Ord a6, Ord a7, Ord a8, Ord a9) + => Ord (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9)) where + ProductOrd x > ProductOrd y = cmp x y == PGT + {-# INLINE (>) #-} + ProductOrd x < ProductOrd y = cmp x y == PLT + {-# INLINE (<) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9) >= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9) + = a1 >= b1 && a2 >= b2 && a3 >= b3 && a4 >= b4 && a5 >= b5 && a6 >= b6 && a7 >= b7 && a8 >= b8 && a9 >= b9 + {-# INLINE (>=) #-} + ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9) <= ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9) + = a1 <= b1 && a2 <= b2 && a3 <= b3 && a4 <= b4 && a5 <= b5 && a6 <= b6 && a7 <= b7 && a8 <= b8 && a9 <= b9 + {-# INLINE (<=) #-} + compare (ProductOrd a) (ProductOrd b) = toOrdering $ cmp a b + {-# INLINE compare #-} + min (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9)) + = ProductOrd (min a1 b1, min a2 b2, min a3 b3, min a4 b4, min a5 b5, min a6 b6, min a7 b7, min a8 b8, min a9 b9) + {-# INLINE min #-} + max (ProductOrd (a1, a2, a3, a4, a5, a6, a7, a8, a9)) (ProductOrd (b1, b2, b3, b4, b5, b6, b7, b8, b9)) + = ProductOrd (max a1 b1, max a2 b2, max a3 b3, max a4 b4, max a5 b5, max a6 b6, max a7 b7, max a8 b8, max a9 b9) + {-# INLINE max #-} + +-- | Treat `Incomparable` as error (partial function). +toOrdering :: PartialOrdering -> Ordering +toOrdering PLT = LT +toOrdering PGT = GT +toOrdering PEQ = EQ +toOrdering Incomparable = error "incomparable items (this is a partial function)" diff --git a/src/Numeric/Quaternion.hs b/src/Numeric/Quaternion.hs --- a/src/Numeric/Quaternion.hs +++ b/src/Numeric/Quaternion.hs @@ -1,14 +1,9 @@ ----------------------------------------------------------------------------- -- | --- Module : Numeric.Quaternion --- Copyright : (c) Artem Chirkin --- License : BSD3 -- --- Maintainer : chirkin@arch.ethz.ch --- -- Quaternion operations implemented for Floats and Doubles. -- --- The types `QDouble` and `QFloat` have the same representation as corresponding `Vector t 4`. +-- The types `QDouble` and `QFloat` have the same representation as corresponding @Vector t 4@. -- This means, you can do a cheap conversion between the types. -- -- However, arithmetic instances, such as Num and Floating are implemented in substentially different ways. @@ -19,17 +14,20 @@ -- -- All other numeric operations for vectors are element-wise, but for quaternions I have implemented -- the actual quaternion math. --- Some of the operations (such as trigonometric operations) are ambiguous for quaternions; --- the general rules I follow: --- --- 1. Preserve imaginary vector axis same if possible; --- 2. If both @+q@ and @-q@ are possible, prefer real value positive (@re q >= 0@). +-- In most of the cases, you can think of these as being operations on complex numbers, +-- where the role of imaginary @i@ is played by a 3D vector. +-- Some of the operations are ambiguous for quaternions; +-- for example \( \sqrt{-1} = \pm i \), but also \( \sqrt{-1} = \pm j \), +-- and \( \sqrt{-1} = \pm k \), and any other unit quaterion with zero real part. +-- In cases like this, I stick to the @i@-th axis: \( \sqrt{-1} := i \) ----------------------------------------------------------------------------- module Numeric.Quaternion ( Quaternion (..) + , Quater(Quater) , QDouble, QFloat ) where -import Numeric.Quaternion.Class -import Numeric.Quaternion.QFloat -import Numeric.Quaternion.QDouble +import Numeric.DataFrame.Internal.Backend () +import Numeric.Quaternion.Internal +import Numeric.Quaternion.Internal.QDouble +import Numeric.Quaternion.Internal.QFloat diff --git a/src/Numeric/Quaternion/Class.hs b/src/Numeric/Quaternion/Class.hs deleted file mode 100644 --- a/src/Numeric/Quaternion/Class.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -module Numeric.Quaternion.Class - ( Quaternion (..) - ) where - -import Numeric.Matrix (Matrix) -import Numeric.Vector (Vector) - --- | Quaternion operations -class Quaternion t where - -- | Quaternion data type. The ordering of coordinates is @x y z w@, - -- where @w@ is an argument, and @x y z@ are components of a 3D vector - data Quater t - -- | Set the quaternion in format (x,y,z,w) - packQ :: t -> t -> t -> t -> Quater t - -- | Get the values of the quaternion in format (x,y,z,w) - unpackQ :: Quater t -> (t,t,t,t) - -- | Set the quaternion from 3D axis vector and argument - fromVecNum :: Vector t 3 -> t -> Quater t - -- | Set the quaternion from 4D vector in format (x,y,z,w) - fromVec4 :: Vector t 4 -> Quater t - -- | Transform the quaternion to 4D vector in format (x,y,z,w) - toVec4 :: Quater t -> Vector t 4 - -- | Get scalar square of the quaternion. - -- - -- >> realToFrac (square q) == q * conjugate q - square :: Quater t -> t - -- | Imagine part of quaternion (orientation vector) - im :: Quater t -> Quater t - -- | Real part of the quaternion - re :: Quater t -> Quater t - -- | Get imagenery 3D vector of the quaternion - imVec :: Quater t -> Vector t 3 - -- | Real part of the quaternion into number - taker :: Quater t -> t - -- | i-th component - takei :: Quater t -> t - -- | j-th component - takej :: Quater t -> t - -- | k-th component - takek :: Quater t -> t - -- | Conjugate quaternion (negate imaginary part) - conjugate :: Quater t -> Quater t - -- | Rotates and scales vector in 3D using quaternion. - -- Let @q = (cos (a\/2), sin (a\/2) * v)@; then the rotation angle is @a@, and the axis of rotation is @v@. - -- Scaling is proportional to @|v|^2@. - -- - -- >>> rotScale q x == q * x * (conjugate q) - rotScale :: Quater t -> Vector t 3 -> Vector t 3 - -- | Creates a quaternion @q@ from two vectors @a@ and @b@. - -- @rotScale q a == b@ - getRotScale :: Vector t 3 -> Vector t 3 -> Quater t - -- | Creates a rotation versor from an axis vector and an angle in radians. - -- Result is always a unit quaternion (versor). - -- If the argument vector is zero, then result is a real unit quaternion. - axisRotation :: Vector t 3 -> t -> Quater t - -- | Quaternion rotation angle - -- - -- >>> q /= 0 ==> axisRotation (imVec q) (qArg q) == signum q - qArg :: Quater t -> t - -- | Create a quaternion from a rotation matrix. - -- Note, that rotations of `q` and `-q` are equivalent, there result of this function may be - -- ambiguious. I decided to force its real part be positive: - -- - -- >>> taker (fromMatrix33 m) >= 0 - fromMatrix33 :: Matrix t 3 3 -> Quater t - -- | Create a quaternion from a homogenious coordinates trasform matrix. - -- Ignores matrix translation transform. - -- Note, that rotations of `q` and `-q` are equivalent, there result of this function may be - -- ambiguious. I decided to force its real part be positive: - -- - -- >>> taker (fromMatrix44 m) >= 0 - fromMatrix44 :: Matrix t 4 4 -> Quater t - -- | Create a rotation matrix from a quaternion. - -- Note, that rotations of `q` and `-q` are equivalent, so the following property holds: - -- - -- >>> toMatrix33 q == toMatrix33 (-q) - toMatrix33 :: Quater t -> Matrix t 3 3 - -- | Create a homogenious coordinates trasform matrix from a quaternion. - -- Translation of the output matrix is zero. - -- Note, that rotations of `q` and `-q` are equivalent, so the following property holds: - -- - -- >>> toMatrix44 q == toMatrix44 (-q) - toMatrix44 :: Quater t -> Matrix t 4 4 diff --git a/src/Numeric/Quaternion/Internal.hs b/src/Numeric/Quaternion/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Quaternion/Internal.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} +module Numeric.Quaternion.Internal + ( Quaternion (..), Quater(Quater) + ) where + +import Numeric.Matrix.Internal (Matrix) +import Numeric.Vector.Internal (Vector) +import Text.Read + +-- | @(x,y,z,w)@ of a quaternion +pattern Quater :: Quaternion t => t -> t -> t -> t -> Quater t +pattern Quater a b c d <- (unpackQ# -> (# a, b, c, d #)) + where + Quater = packQ +{-# COMPLETE Quater #-} + +-- | Quaternion operations +class Quaternion t where + -- | Quaternion data type. The ordering of coordinates is @(x,y,z,w)@, + -- where @w@ is the argument, and @x y z@ are the components of a 3D vector + data Quater t + -- | Set the quaternion in format @(x,y,z,w)@ + packQ :: t -> t -> t -> t -> Quater t + -- | Get the values of the quaternion in format @(x,y,z,w)@ + unpackQ# :: Quater t -> (# t, t, t, t #) + -- | Set the quaternion from 3D axis vector and argument + fromVecNum :: Vector t 3 -> t -> Quater t + -- | Set the quaternion from 4D vector in format @(x,y,z,w)@ + fromVec4 :: Vector t 4 -> Quater t + -- | Transform the quaternion to 4D vector in format @(x,y,z,w)@ + toVec4 :: Quater t -> Vector t 4 + -- | Get scalar square of the quaternion. + -- + -- >>> realToFrac (square q) == q * conjugate q + square :: Quater t -> t + -- | Imaginary part of the quaternion (orientation vector) + im :: Quater t -> Quater t + -- | Real part of the quaternion + re :: Quater t -> Quater t + -- | Imaginary part of the quaternion as a 3D vector + imVec :: Quater t -> Vector t 3 + -- | Real part of the quaternion as a scalar + taker :: Quater t -> t + -- | i-th component + takei :: Quater t -> t + -- | j-th component + takej :: Quater t -> t + -- | k-th component + takek :: Quater t -> t + -- | Conjugate quaternion (negate imaginary part) + conjugate :: Quater t -> Quater t + -- | Rotates and scales vector in 3D using quaternion. + -- Let \( q = c (\cos \frac{\alpha}{2}, v \sin \frac{\alpha}{2}) \) + -- , \( c > 0 \), \( {|v|}^2 = 1 \); + -- then the rotation angle is \( \alpha \), and the axis of rotation is \(v\). + -- Scaling is proportional to \( c^2 \). + -- + -- >>> rotScale q x == q * x * (conjugate q) + rotScale :: Quater t -> Vector t 3 -> Vector t 3 + -- | Creates a quaternion @q@ from two vectors @a@ and @b@, + -- such that @rotScale q a == b@. + getRotScale :: Vector t 3 -> Vector t 3 -> Quater t + -- | Creates a rotation versor from an axis vector and an angle in radians. + -- Result is always a unit quaternion (versor). + -- If the argument vector is zero, then result is a real unit quaternion. + axisRotation :: Vector t 3 -> t -> Quater t + -- | Quaternion rotation angle \( \alpha \) + -- (where \( q = c (\cos \frac{\alpha}{2}, v \sin \frac{\alpha}{2}) \) + -- , \( c > 0 \), \( {|v|}^2 = 1 \)). + -- + -- >>> q /= 0 ==> axisRotation (imVec q) (qArg q) == signum q + qArg :: Quater t -> t + -- | Create a quaternion from a rotation matrix. + -- Note, that rotations of \(q\) and \(-q\) are equivalent, there result of this + -- function may be ambiguious. Assume the sign of the result to be chosen arbitrarily. + fromMatrix33 :: Matrix t 3 3 -> Quater t + -- | Create a quaternion from a homogenious coordinates trasform matrix. + -- Ignores matrix translation transform. + -- Note, that rotations of \(q\) and \(-q\) are equivalent, there result of this + -- function may be ambiguious. Assume the sign of the result to be chosen arbitrarily. + fromMatrix44 :: Matrix t 4 4 -> Quater t + -- | Create a rotation matrix from a quaternion. + -- Note, that rotations of \(q\) and \(-q\) are equivalent, so the following property holds: + -- + -- >>> toMatrix33 q == toMatrix33 (-q) + toMatrix33 :: Quater t -> Matrix t 3 3 + -- | Create a homogenious coordinates trasform matrix from a quaternion. + -- Translation of the output matrix is zero. + -- Note, that rotations of \(q\) and \(-q\) are equivalent, so the following property holds: + -- + -- >>> toMatrix44 q == toMatrix44 (-q) + toMatrix44 :: Quater t -> Matrix t 4 4 + + +instance (Show t, Quaternion t, Ord t, Num t) => Show (Quater t) where + showsPrec p (Quater x y z w) + = case finS of + SEmpty -> showChar '0' + Simple -> finF + SParen -> showParen (p > 6) finF + where + (finS, finF) = go SEmpty + [(w, Nothing), (x, Just 'i'), (y, Just 'j'), (z, Just 'k')] + go :: ShowState -> [(t, Maybe Char)] -> (ShowState, ShowS) + go s ((v,l):xs) + | (s0, f0) <- showComponent s v l + , (s', f') <- go s0 xs + = (s', f0 . f') + go s [] = (s, id) + showLabel Nothing = id + showLabel (Just c) = showChar c + showComponent :: ShowState -> t -> Maybe Char -> (ShowState, ShowS) + showComponent sState val mLabel = case (sState, compare val 0) of + (_ , EQ) -> ( sState, id ) + (SEmpty, GT) -> ( Simple, shows val . showLabel mLabel ) + (SEmpty, LT) -> ( SParen, shows val . showLabel mLabel ) + (_ , GT) -> ( SParen + , showString " + " . shows val . showLabel mLabel ) + (_ , LT) -> ( SParen + , showString " - " . shows (negate val) . showLabel mLabel ) + + +data ShowState = SEmpty | Simple | SParen + deriving Eq + +instance (Read t, Quaternion t, Num t) => Read (Quater t) where + readPrec = parens $ readPrec >>= go id 0 0 0 0 + where + go :: (t -> t) -> t -> t -> t -> t -> t -> ReadPrec (Quater t) + go f x y z w new = + let def = pure (Quater x y z (f new)) + withLabel EOF = def + withLabel (Ident "i") + = (lexP >>= proceed (f new) y z w) <++ pure (Quater (f new) y z w) + withLabel (Ident "j") + = (lexP >>= proceed x (f new) z w) <++ pure (Quater x (f new) z w) + withLabel (Ident "k") + = (lexP >>= proceed x y (f new) w) <++ pure (Quater x y (f new) w) + withLabel l = proceed x y z (f new) l + in (lexP >>= withLabel) <++ def + proceed :: t -> t -> t -> t -> Lexeme -> ReadPrec (Quater t) + proceed x y z w (Symbol "+") = readPrec >>= go id x y z w + proceed x y z w (Symbol "-") = readPrec >>= go negate x y z w + proceed x y z w EOF = pure (Quater x y z w) + proceed _ _ _ _ _ = pfail + + readListPrec = readListPrecDefault + readList = readListDefault diff --git a/src/Numeric/Quaternion/Internal/QDouble.hs b/src/Numeric/Quaternion/Internal/QDouble.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Quaternion/Internal/QDouble.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Numeric.Quaternion.Internal.QDouble + ( QDouble, Quater (..) + ) where + +import qualified Control.Monad.ST as ST +import Data.Coerce (coerce) +import Numeric.DataFrame.Internal.PrimArray +import qualified Numeric.DataFrame.ST as ST +import Numeric.DataFrame.Type +import Numeric.PrimBytes (PrimBytes) +import Numeric.Quaternion.Internal +import Numeric.Scalar.Internal +import Numeric.Vector.Internal + +type QDouble = Quater Double + +deriving instance PrimBytes (Quater Double) +deriving instance PrimArray Double (Quater Double) + +instance Quaternion Double where + newtype Quater Double = QDouble Vec4d + {-# INLINE packQ #-} + packQ = coerce (vec4 :: Double -> Double -> Double -> Double -> Vec4d) + {-# INLINE unpackQ# #-} + unpackQ# = coerce (unpackV4# :: Vec4d -> (# Double, Double, Double, Double #)) + {-# INLINE fromVecNum #-} + fromVecNum (unpackV3# -> (# x, y, z #)) = packQ x y z + {-# INLINE fromVec4 #-} + fromVec4 = coerce + {-# INLINE toVec4 #-} + toVec4 = coerce + {-# INLINE square #-} + square (unpackQ# -> (# x, y, z, w #)) = (x * x) + (y * y) + (z * z) + (w * w) + {-# INLINE im #-} + im (unpackQ# -> (# x, y, z, _ #)) = packQ x y z 0.0 + {-# INLINE re #-} + re (unpackQ# -> (# _, _, _, w #)) = packQ 0.0 0.0 0.0 w + {-# INLINE imVec #-} + imVec (unpackQ# -> (# x, y, z, _ #)) = vec3 x y z + {-# INLINE taker #-} + taker (unpackQ# -> (# _, _, _, w #)) = w + {-# INLINE takei #-} + takei (unpackQ# -> (# x, _, _, _ #)) = x + {-# INLINE takej #-} + takej (unpackQ# -> (# _, y, _, _ #)) = y + {-# INLINE takek #-} + takek (unpackQ# -> (# _, _, z, _ #)) = z + {-# INLINE conjugate #-} + conjugate (unpackQ# -> (# x, y, z, w #)) + = packQ (negate x) (negate y) (negate z) w + {-# INLINE rotScale #-} + rotScale (unpackQ# -> (# i, j, k, t #)) + (unpackV3# -> (# x, y, z #)) + = let l = t*t - i*i - j*j - k*k + d = 2.0 * ( i*x + j*y + k*z) + t2 = t * 2.0 + in vec3 (l*x + d*i + t2 * (z*j - y*k)) + (l*y + d*j + t2 * (x*k - z*i)) + (l*z + d*k + t2 * (y*i - x*j)) + {-# INLINE getRotScale #-} + getRotScale a b = case (# unpackV3# a, unpackV3# b #) of + (# _, (# 0, 0, 0 #) #) -> packQ 0.0 0.0 0.0 0.0 + (# (# 0, 0, 0 #), _ #) -> let x = (1 / 0 :: Double) in packQ x x x x + (# (# a1, a2, a3 #), (# b1, b2, b3 #) #) -> + let ma = sqrt (a1*a1 + a2*a2 + a3*a3) + mb = sqrt (b1*b1 + b2*b2 + b3*b3) + d = a1*b1 + a2*b2 + a3*b3 + c = sqrt (ma*mb + d) + ma2 = ma * 1.4142135623730951 -- sqrt 2.0 + r = recip (ma2 * c) + c' = sqrt (mb / ma) -- ratio of a and b for corner cases + r' = recip (sqrt ( negate (a1*b1 + a2*b2) )) + in case unpackV3# (cross a b) of + (# 0, 0, 0 #) + -- if a and b face the same direction, q is fully real + | d >= 0 -> packQ 0 0 0 c' + -- if a and b face opposite directions, find an orthogonal vector + -- prerequisites: w == 0 and a·(x,y,z) == 0 + -- corner cases: only one vector component is non-zero + | b1 == 0 -> packQ c' 0 0 0 + -- otherwise set the last component to zero, + -- and get an orthogonal vector in 2D. + | otherwise -> packQ (-b2*r') (b1*r') 0 0 + -- NB: here we have some precision troubles + -- when a and b are close to parallel and opposite. + (# t1, t2, t3 #) -> packQ (t1 * r) (t2 * r) (t3 * r) (c / ma2) + {-# INLINE axisRotation #-} + axisRotation v a = case unpackV3# v of + (# 0, 0, 0 #) -> packQ 0.0 0.0 0.0 (if abs a < pi then 1 else -1) + (# x, y, z #) -> + let c = cos (a * 0.5) + s = sin (a * 0.5) + / sqrt (x*x + y*y + z*z) + in packQ (x * s) (y * s) (z * s) c + {-# INLINE qArg #-} + qArg (unpackQ# -> (# x, y, z, w #)) = 2 * atan2 (sqrt (x*x + y*y + z*z)) w + {-# INLINE fromMatrix33 #-} + fromMatrix33 m = fromM 1 + (ix# 0# m) (ix# 1# m) (ix# 2# m) + (ix# 3# m) (ix# 4# m) (ix# 5# m) + (ix# 6# m) (ix# 7# m) (ix# 8# m) + + {-# INLINE fromMatrix44 #-} + fromMatrix44 m = fromM (ix# 15# m) + (ix# 0# m) (ix# 1# m) (ix# 2# m) + (ix# 4# m) (ix# 5# m) (ix# 6# m) + (ix# 8# m) (ix# 9# m) (ix# 10# m) + + {-# INLINE toMatrix33 #-} + toMatrix33 (unpackQ# -> (# 0.0, 0.0, 0.0, w #)) + = let x = w * w + f 0 = (# 3 :: Int , x #) + f k = (# k-1, 0 #) + in case gen# (CumulDims [9,3,1]) f 0 of + (# _, m #) -> m -- diag (scalar (w * w)) + toMatrix33 (unpackQ# -> (# x', y', z', w' #)) = + let x = scalar x' + y = scalar y' + z = scalar z' + w = scalar w' + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) + ST.unsafeFreezeDataFrame df + {-# INLINE toMatrix44 #-} + toMatrix44 (unpackQ# -> (# 0.0, 0.0, 0.0, w #)) = ST.runST $ do + df <- ST.newDataFrame + mapM_ (flip (ST.writeDataFrameOff df) 0) [0..15] + let w2 = scalar (w * w) + ST.writeDataFrameOff df 0 w2 + ST.writeDataFrameOff df 5 w2 + ST.writeDataFrameOff df 10 w2 + ST.writeDataFrameOff df 15 1 + ST.unsafeFreezeDataFrame df + toMatrix44 (unpackQ# -> (# x', y', z', w' #)) = + let x = scalar x' + y = scalar y' + z = scalar z' + w = scalar w' + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 0 + ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 7 0 + ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) + ST.writeDataFrameOff df 11 0 + ST.writeDataFrameOff df 12 0 + ST.writeDataFrameOff df 13 0 + ST.writeDataFrameOff df 14 0 + ST.writeDataFrameOff df 15 1 + ST.unsafeFreezeDataFrame df + + +{- Calculate quaternion from a 3x3 matrix. + + First argument is a constant; it is either 1 for a 3x3 matrix, + or m44 for a 4x4 matrix. I just need to multiply all components by + this number. + + Further NB for the formulae: + + d == square q == det m ** (1/3) + t == trace m == 4 w w - d + m01 - m10 == 4 z w + m20 - m02 == 4 y w + m12 - m21 == 4 x w + m01 + m10 == 4 x y + m20 + m02 == 4 x z + m12 + m21 == 4 y z + m00 == + x x - y y - z z + w w + m11 == - x x + y y - z z + w w + m22 == - x x - y y + z z + w w + 4 x x == d + m00 - m11 - m22 + 4 y y == d - m00 + m11 - m22 + 4 z z == d - m00 - m11 + m22 + 4 w w == d + m00 + m11 + m22 + -} +fromM :: Double + -> Double -> Double -> Double + -> Double -> Double -> Double + -> Double -> Double -> Double + -> QDouble +fromM c' + m00 m01 m02 + m10 m11 m12 + m20 m21 m22 + | t > 0 + = let dd = sqrt ( d + t ) + is = c / dd + in packQ ((m12 - m21)*is) ((m20 - m02)*is) ((m01 - m10)*is) (c*dd) + | m00 > m11 && m00 > m22 + = let dd = sqrt ( d + m00 - m11 - m22 ) + is = c / dd + in packQ (c*dd) ((m01 + m10)*is) ((m02 + m20)*is) ((m12 - m21)*is) + | m11 > m22 + = let dd = sqrt ( d - m00 + m11 - m22 ) + is = c / dd + in packQ ((m01 + m10)*is) (c*dd) ((m12 + m21)*is) ((m20 - m02)*is) + | otherwise + = let dd = sqrt ( d - m00 - m11 + m22 ) + is = c / dd + in packQ ((m02 + m20)*is) ((m12 + m21)*is) (c*dd) ((m01 - m10)*is) + + where + -- normalizing constant + c = recip $ 2 * sqrt c' + -- trace + t = m00 + m11 + m22 + -- cubic root of determinant + d = ( m00 * ( m11 * m22 - m12 * m21 ) + - m01 * ( m10 * m22 - m12 * m20 ) + + m02 * ( m10 * m21 - m11 * m20 ) + ) ** 0.33333333333333333333333333333333 + + + + +instance Num QDouble where + QDouble a + QDouble b + = QDouble (a + b) + {-# INLINE (+) #-} + QDouble a - QDouble b + = QDouble (a - b) + {-# INLINE (-) #-} + (unpackQ# -> (# a1, a2, a3, a4 #)) * (unpackQ# -> (# b1, b2, b3, b4 #)) + = packQ + ((a4 * b1) + + (a1 * b4) + + (a2 * b3) - + (a3 * b2) + ) + ((a4 * b2) - + (a1 * b3) + + (a2 * b4) + + (a3 * b1) + ) + ((a4 * b3) + + (a1 * b2) - + (a2 * b1) + + (a3 * b4) + ) + ((a4 * b4) - + (a1 * b1) - + (a2 * b2) - + (a3 * b3) + ) + {-# INLINE (*) #-} + negate (QDouble a) = QDouble (negate a) + {-# INLINE negate #-} + abs = packQ 0.0 0.0 0.0 . sqrt . square + {-# INLINE abs #-} + signum q@(unpackQ# -> (# x, y, z, w #)) + = case square q of + 0.0 -> packQ 0.0 0.0 0.0 0.0 + qd -> case recip (sqrt qd) of + s -> packQ (x * s) (y * s) (z * s) (w * s) + {-# INLINE signum #-} + fromInteger = packQ 0.0 0.0 0.0 . fromInteger + {-# INLINE fromInteger #-} + + +instance Fractional QDouble where + {-# INLINE recip #-} + recip q@(unpackQ# -> (# x, y, z, w #)) = case negate (recip (square q)) of + c -> packQ (x * c) (y * c) (z * c) (negate (w * c)) + {-# INLINE (/) #-} + a / b = a * recip b + {-# INLINE fromRational #-} + fromRational = packQ 0.0 0.0 0.0 . fromRational + + +instance Floating QDouble where + {-# INLINE pi #-} + pi = packQ 0.0 0.0 0.0 3.141592653589793 + {-# INLINE exp #-} + exp (unpackQ# -> (# x, y, z, w #)) + = case (# (x * x) + + (y * y) + + (z * z) + , exp w + #) of + (# 0.0, et #) -> packQ 0.0 0.0 0.0 et + (# mv2, et #) -> case sqrt mv2 of + mv -> case et * sin mv / mv of + l -> packQ (x * l) (y * l) (z * l) (et * cos mv) + {-# INLINE log #-} + log = log' (Vec3 1 0 0) + {-# INLINE sqrt #-} + sqrt = sqrt' (Vec3 1 0 0) + {-# INLINE sin #-} + sin (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (sin w) + mv2 -> case sqrt mv2 of + mv -> case cos w * sinh mv / mv of + l -> packQ (x * l) (y * l) (z * l) (sin w * cosh mv) + {-# INLINE cos #-} + cos (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (cos w) + mv2 -> case sqrt mv2 of + mv -> case sin w * sinh mv / negate mv of + l -> packQ (x * l) (y * l) (z * l) (cos w * cosh mv) + {-# INLINE tan #-} + tan (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (tan w) + mv2 -> + let mv = sqrt mv2 + chv = cosh mv + shv = sinh mv + ct = cos w + st = sin w + cq = recip ( (ct * ct * chv * chv) + (st * st * shv * shv) ) + l = chv * shv * cq / mv + in packQ (x * l) (y * l) (z * l) (ct * st * cq) + {-# INLINE sinh #-} + sinh (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (sinh w) + mv2 -> case sqrt mv2 of + mv -> case cosh w * sin mv / mv of + l -> packQ (x * l) (y * l) (z * l) (sinh w * cos mv) + {-# INLINE cosh #-} + cosh (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (cosh w) + mv2 -> case sqrt mv2 of + mv -> case sinh w * sin mv / mv of + l -> packQ (x * l) (y * l) (z * l) (cosh w * cos mv) + {-# INLINE tanh #-} + tanh (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (tanh w) + mv2 -> + let mv = sqrt mv2 + cv = cos mv + sv = sin mv + cht = cosh w + sht = sinh w + cq = recip ( (cht * cht * cv * cv) + (sht * sht * sv * sv) ) + l = cv * sv * cq / mv + in packQ (x * l) (y * l) (z * l) (cht * sht * cq) + {-# INLINE asin #-} + asin q = -i * log' axis (i*q + sqrt' axis (1 - q*q)) + where + axis = sigVec q + i = fromVecNum axis 0 + {-# INLINE acos #-} + acos q = pi/2 - asin q + {-# INLINE atan #-} + -- atan q = i / 2 * log ( (i + q) / (i - q) ) + atan (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0 -> packQ 0 0 0 (atan w) + v2 -> + let v = sqrt v2 + w2 = w*w + vw2 = w2 + v2 + t = 1 + vw2 + c = 0.25 * log ((t + 2*v) / (t - 2*v)) / v + in packQ (c*x) (c*y) (c*z) $ 0.5 * atan2 (2*w) (1 - vw2) + {-# INLINE asinh #-} + -- The original formula: + -- asinh q = log (q + sqrt (q*q + 1)) + -- below is a more numerically stable version. + asinh (unpackQ# -> (# x, y, z, w #)) + | v2 == 0 + = packQ 0 0 0 (asinh w) + | w == 0 + = if v2 <= 1 + then let c = asin v / v + in packQ (c*x) (c*y) (c*z) 0 + else let c = 0.5 * pi / v + w' = 0.5 * log (2*v2 - 1 + 2 * v * sqrt ( v2 - 1 )) + in packQ (c*x) (c*y) (c*z) w' + | otherwise + = let c = atan2 v t / v + w' = 0.5 * log ( t2 + v2) - log t + + if w >= 0 + then log ( t + w ) + else log 2 + log w2 - log ( t - w ) - log ( r + w2 + v2 - 1 ) + in packQ (c*x) (c*y) (c*z) w' + where + v2 = (x * x) + (y * y) + (z * z) + v = sqrt v2 + w2 = w*w + wvp1 = w2 - v2 + 1 + r = sqrt $ wvp1*wvp1 + 4*w2*v2 + t = sqrt $ ( r + wvp1 ) * 0.5 + t2 = t*t + {-# INLINE acosh #-} + -- note, log (q + sqrt (q*q - 1)) would not work, because that would not + -- be the principal value. + acosh q = log' axis (q + sqrt' axis (q + 1) * sqrt' axis (q - 1)) + where + axis = sigVec q + {-# INLINE atanh #-} + atanh q = 0.5 * log' (sigVec q) ((1+q)/(1-q)) + +-- If q is negative real, provide a fallback axis to align log. +log' :: Vec3d -> QDouble -> QDouble +log' r (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 | w >= 0 + -> packQ 0.0 0.0 0.0 (log w) + | Vec3 rx ry rz <- r + -> packQ (pi*rx) (pi*ry) (pi*rz) (log (negate w)) + mv2 -> case (# sqrt (mv2 + (w * w)), sqrt mv2 #) of + (# mq, mv #) -> case atan2 mv w / mv of + l -> packQ (x * l) (y * l) (z * l) (log mq) + + +-- If q is negative real, provide a fallback axis to align sqrt. +sqrt' :: Vec3d -> QDouble -> QDouble +sqrt' r (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 | w >= 0 + -> packQ 0.0 0.0 0.0 (sqrt w) + | Vec3 rx ry rz <- r + , sw <- sqrt (negate w) + -> packQ (sw*rx) (sw*ry) (sw*rz) 0 + mv2 -> + let mq = sqrt (mv2 + w * w) + l2 = sqrt mq + tq = w / (mq * 2.0) + sina = sqrt (0.5 - tq) * l2 / sqrt mv2 + in packQ (x * sina) (y * sina) (z * sina) (sqrt (0.5 + tq) * l2) + +sigVec :: QDouble -> Vec3d +sigVec (unpackQ# -> (# x, y, z, _ #)) + = case sqrt ((x * x) + (y * y) + (z * z)) of + 0 -> vec3 1 0 0 + l -> vec3 (x/l) (y/l) (z/l) + +instance Eq QDouble where + {-# INLINE (==) #-} + QDouble a == QDouble b = a == b + {-# INLINE (/=) #-} + QDouble a /= QDouble b = a /= b diff --git a/src/Numeric/Quaternion/Internal/QFloat.hs b/src/Numeric/Quaternion/Internal/QFloat.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Quaternion/Internal/QFloat.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Numeric.Quaternion.Internal.QFloat + ( QFloat, Quater (..) + ) where + +import qualified Control.Monad.ST as ST +import Data.Coerce (coerce) +import Numeric.DataFrame.Internal.PrimArray +import qualified Numeric.DataFrame.ST as ST +import Numeric.DataFrame.Type +import Numeric.PrimBytes (PrimBytes) +import Numeric.Quaternion.Internal +import Numeric.Scalar.Internal +import Numeric.Vector.Internal + +type QFloat = Quater Float + +deriving instance PrimBytes (Quater Float) +deriving instance PrimArray Float (Quater Float) + +instance Quaternion Float where + newtype Quater Float = QFloat Vec4f + {-# INLINE packQ #-} + packQ = coerce (vec4 :: Float -> Float -> Float -> Float -> Vec4f) + {-# INLINE unpackQ# #-} + unpackQ# = coerce (unpackV4# :: Vec4f -> (# Float, Float, Float, Float #)) + {-# INLINE fromVecNum #-} + fromVecNum (unpackV3# -> (# x, y, z #)) = packQ x y z + {-# INLINE fromVec4 #-} + fromVec4 = coerce + {-# INLINE toVec4 #-} + toVec4 = coerce + {-# INLINE square #-} + square (unpackQ# -> (# x, y, z, w #)) = (x * x) + (y * y) + (z * z) + (w * w) + {-# INLINE im #-} + im (unpackQ# -> (# x, y, z, _ #)) = packQ x y z 0.0 + {-# INLINE re #-} + re (unpackQ# -> (# _, _, _, w #)) = packQ 0.0 0.0 0.0 w + {-# INLINE imVec #-} + imVec (unpackQ# -> (# x, y, z, _ #)) = vec3 x y z + {-# INLINE taker #-} + taker (unpackQ# -> (# _, _, _, w #)) = w + {-# INLINE takei #-} + takei (unpackQ# -> (# x, _, _, _ #)) = x + {-# INLINE takej #-} + takej (unpackQ# -> (# _, y, _, _ #)) = y + {-# INLINE takek #-} + takek (unpackQ# -> (# _, _, z, _ #)) = z + {-# INLINE conjugate #-} + conjugate (unpackQ# -> (# x, y, z, w #)) + = packQ (negate x) (negate y) (negate z) w + {-# INLINE rotScale #-} + rotScale (unpackQ# -> (# i, j, k, t #)) + (unpackV3# -> (# x, y, z #)) + = let l = t*t - i*i - j*j - k*k + d = 2.0 * ( i*x + j*y + k*z) + t2 = t * 2.0 + in vec3 (l*x + d*i + t2 * (z*j - y*k)) + (l*y + d*j + t2 * (x*k - z*i)) + (l*z + d*k + t2 * (y*i - x*j)) + {-# INLINE getRotScale #-} + getRotScale a b = case (# unpackV3# a, unpackV3# b #) of + (# _, (# 0, 0, 0 #) #) -> packQ 0.0 0.0 0.0 0.0 + (# (# 0, 0, 0 #), _ #) -> let x = (1 / 0 :: Float) in packQ x x x x + (# (# a1, a2, a3 #), (# b1, b2, b3 #) #) -> + let ma = sqrt (a1*a1 + a2*a2 + a3*a3) + mb = sqrt (b1*b1 + b2*b2 + b3*b3) + d = a1*b1 + a2*b2 + a3*b3 + c = sqrt (ma*mb + d) + ma2 = ma * 1.4142135623730951 -- sqrt 2.0 + r = recip (ma2 * c) + c' = sqrt (mb / ma) -- ratio of a and b for corner cases + r' = recip (sqrt ( negate (a1*b1 + a2*b2) )) + in case unpackV3# (cross a b) of + (# 0, 0, 0 #) + -- if a and b face the same direction, q is fully real + | d >= 0 -> packQ 0 0 0 c' + -- if a and b face opposite directions, find an orthogonal vector + -- prerequisites: w == 0 and a·(x,y,z) == 0 + -- corner cases: only one vector component is non-zero + | b1 == 0 -> packQ c' 0 0 0 + -- otherwise set the last component to zero, + -- and get an orthogonal vector in 2D. + | otherwise -> packQ (-b2*r') (b1*r') 0 0 + -- NB: here we have some precision troubles + -- when a and b are close to parallel and opposite. + (# t1, t2, t3 #) -> packQ (t1 * r) (t2 * r) (t3 * r) (c / ma2) + {-# INLINE axisRotation #-} + axisRotation v a = case unpackV3# v of + (# 0, 0, 0 #) -> packQ 0.0 0.0 0.0 (if abs a < pi then 1 else -1) + (# x, y, z #) -> + let c = cos (a * 0.5) + s = sin (a * 0.5) + / sqrt (x*x + y*y + z*z) + in packQ (x * s) (y * s) (z * s) c + {-# INLINE qArg #-} + qArg (unpackQ# -> (# x, y, z, w #)) = 2 * atan2 (sqrt (x*x + y*y + z*z)) w + {-# INLINE fromMatrix33 #-} + fromMatrix33 m = fromM 1 + (ix# 0# m) (ix# 1# m) (ix# 2# m) + (ix# 3# m) (ix# 4# m) (ix# 5# m) + (ix# 6# m) (ix# 7# m) (ix# 8# m) + + {-# INLINE fromMatrix44 #-} + fromMatrix44 m = fromM (ix# 15# m) + (ix# 0# m) (ix# 1# m) (ix# 2# m) + (ix# 4# m) (ix# 5# m) (ix# 6# m) + (ix# 8# m) (ix# 9# m) (ix# 10# m) + + {-# INLINE toMatrix33 #-} + toMatrix33 (unpackQ# -> (# 0.0, 0.0, 0.0, w #)) + = let x = w * w + f 0 = (# 3 :: Int , x #) + f k = (# k-1, 0 #) + in case gen# (CumulDims [9,3,1]) f 0 of + (# _, m #) -> m -- diag (scalar (w * w)) + toMatrix33 (unpackQ# -> (# x', y', z', w' #)) = + let x = scalar x' + y = scalar y' + z = scalar z' + w = scalar w' + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) + ST.unsafeFreezeDataFrame df + {-# INLINE toMatrix44 #-} + toMatrix44 (unpackQ# -> (# 0.0, 0.0, 0.0, w #)) = ST.runST $ do + df <- ST.newDataFrame + mapM_ (flip (ST.writeDataFrameOff df) 0) [0..15] + let w2 = scalar (w * w) + ST.writeDataFrameOff df 0 w2 + ST.writeDataFrameOff df 5 w2 + ST.writeDataFrameOff df 10 w2 + ST.writeDataFrameOff df 15 1 + ST.unsafeFreezeDataFrame df + toMatrix44 (unpackQ# -> (# x', y', z', w' #)) = + let x = scalar x' + y = scalar y' + z = scalar z' + w = scalar w' + x2 = x * x + y2 = y * y + z2 = z * z + w2 = w * w + l2 = x2 + y2 + z2 + w2 + in ST.runST $ do + df <- ST.newDataFrame + ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) + ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) + ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) + ST.writeDataFrameOff df 3 0 + ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) + ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) + ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) + ST.writeDataFrameOff df 7 0 + ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) + ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) + ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) + ST.writeDataFrameOff df 11 0 + ST.writeDataFrameOff df 12 0 + ST.writeDataFrameOff df 13 0 + ST.writeDataFrameOff df 14 0 + ST.writeDataFrameOff df 15 1 + ST.unsafeFreezeDataFrame df + + +{- Calculate quaternion from a 3x3 matrix. + + First argument is a constant; it is either 1 for a 3x3 matrix, + or m44 for a 4x4 matrix. I just need to multiply all components by + this number. + + Further NB for the formulae: + + d == square q == det m ** (1/3) + t == trace m == 4 w w - d + m01 - m10 == 4 z w + m20 - m02 == 4 y w + m12 - m21 == 4 x w + m01 + m10 == 4 x y + m20 + m02 == 4 x z + m12 + m21 == 4 y z + m00 == + x x - y y - z z + w w + m11 == - x x + y y - z z + w w + m22 == - x x - y y + z z + w w + 4 x x == d + m00 - m11 - m22 + 4 y y == d - m00 + m11 - m22 + 4 z z == d - m00 - m11 + m22 + 4 w w == d + m00 + m11 + m22 + -} +fromM :: Float + -> Float -> Float -> Float + -> Float -> Float -> Float + -> Float -> Float -> Float + -> QFloat +fromM c' + m00 m01 m02 + m10 m11 m12 + m20 m21 m22 + | t > 0 + = let dd = sqrt ( d + t ) + is = c / dd + in packQ ((m12 - m21)*is) ((m20 - m02)*is) ((m01 - m10)*is) (c*dd) + | m00 > m11 && m00 > m22 + = let dd = sqrt ( d + m00 - m11 - m22 ) + is = c / dd + in packQ (c*dd) ((m01 + m10)*is) ((m02 + m20)*is) ((m12 - m21)*is) + | m11 > m22 + = let dd = sqrt ( d - m00 + m11 - m22 ) + is = c / dd + in packQ ((m01 + m10)*is) (c*dd) ((m12 + m21)*is) ((m20 - m02)*is) + | otherwise + = let dd = sqrt ( d - m00 - m11 + m22 ) + is = c / dd + in packQ ((m02 + m20)*is) ((m12 + m21)*is) (c*dd) ((m01 - m10)*is) + + where + -- normalizing constant + c = recip $ 2 * sqrt c' + -- trace + t = m00 + m11 + m22 + -- cubic root of determinant + d = ( m00 * ( m11 * m22 - m12 * m21 ) + - m01 * ( m10 * m22 - m12 * m20 ) + + m02 * ( m10 * m21 - m11 * m20 ) + ) ** 0.33333333333333333333333333333333 + + + + +instance Num QFloat where + QFloat a + QFloat b + = QFloat (a + b) + {-# INLINE (+) #-} + QFloat a - QFloat b + = QFloat (a - b) + {-# INLINE (-) #-} + (unpackQ# -> (# a1, a2, a3, a4 #)) * (unpackQ# -> (# b1, b2, b3, b4 #)) + = packQ + ((a4 * b1) + + (a1 * b4) + + (a2 * b3) - + (a3 * b2) + ) + ((a4 * b2) - + (a1 * b3) + + (a2 * b4) + + (a3 * b1) + ) + ((a4 * b3) + + (a1 * b2) - + (a2 * b1) + + (a3 * b4) + ) + ((a4 * b4) - + (a1 * b1) - + (a2 * b2) - + (a3 * b3) + ) + {-# INLINE (*) #-} + negate (QFloat a) = QFloat (negate a) + {-# INLINE negate #-} + abs = packQ 0.0 0.0 0.0 . sqrt . square + {-# INLINE abs #-} + signum q@(unpackQ# -> (# x, y, z, w #)) + = case square q of + 0.0 -> packQ 0.0 0.0 0.0 0.0 + qd -> case recip (sqrt qd) of + s -> packQ (x * s) (y * s) (z * s) (w * s) + {-# INLINE signum #-} + fromInteger = packQ 0.0 0.0 0.0 . fromInteger + {-# INLINE fromInteger #-} + + +instance Fractional QFloat where + {-# INLINE recip #-} + recip q@(unpackQ# -> (# x, y, z, w #)) = case negate (recip (square q)) of + c -> packQ (x * c) (y * c) (z * c) (negate (w * c)) + {-# INLINE (/) #-} + a / b = a * recip b + {-# INLINE fromRational #-} + fromRational = packQ 0.0 0.0 0.0 . fromRational + + +instance Floating QFloat where + {-# INLINE pi #-} + pi = packQ 0.0 0.0 0.0 3.141592653589793 + {-# INLINE exp #-} + exp (unpackQ# -> (# x, y, z, w #)) + = case (# (x * x) + + (y * y) + + (z * z) + , exp w + #) of + (# 0.0, et #) -> packQ 0.0 0.0 0.0 et + (# mv2, et #) -> case sqrt mv2 of + mv -> case et * sin mv / mv of + l -> packQ (x * l) (y * l) (z * l) (et * cos mv) + {-# INLINE log #-} + log = log' (Vec3 1 0 0) + {-# INLINE sqrt #-} + sqrt = sqrt' (Vec3 1 0 0) + {-# INLINE sin #-} + sin (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (sin w) + mv2 -> case sqrt mv2 of + mv -> case cos w * sinh mv / mv of + l -> packQ (x * l) (y * l) (z * l) (sin w * cosh mv) + {-# INLINE cos #-} + cos (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (cos w) + mv2 -> case sqrt mv2 of + mv -> case sin w * sinh mv / negate mv of + l -> packQ (x * l) (y * l) (z * l) (cos w * cosh mv) + {-# INLINE tan #-} + tan (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (tan w) + mv2 -> + let mv = sqrt mv2 + chv = cosh mv + shv = sinh mv + ct = cos w + st = sin w + cq = recip ( (ct * ct * chv * chv) + (st * st * shv * shv) ) + l = chv * shv * cq / mv + in packQ (x * l) (y * l) (z * l) (ct * st * cq) + {-# INLINE sinh #-} + sinh (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (sinh w) + mv2 -> case sqrt mv2 of + mv -> case cosh w * sin mv / mv of + l -> packQ (x * l) (y * l) (z * l) (sinh w * cos mv) + {-# INLINE cosh #-} + cosh (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (cosh w) + mv2 -> case sqrt mv2 of + mv -> case sinh w * sin mv / mv of + l -> packQ (x * l) (y * l) (z * l) (cosh w * cos mv) + {-# INLINE tanh #-} + tanh (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 -> packQ 0.0 0.0 0.0 (tanh w) + mv2 -> + let mv = sqrt mv2 + cv = cos mv + sv = sin mv + cht = cosh w + sht = sinh w + cq = recip ( (cht * cht * cv * cv) + (sht * sht * sv * sv) ) + l = cv * sv * cq / mv + in packQ (x * l) (y * l) (z * l) (cht * sht * cq) + {-# INLINE asin #-} + asin q = -i * log' axis (i*q + sqrt' axis (1 - q*q)) + where + axis = sigVec q + i = fromVecNum axis 0 + {-# INLINE acos #-} + acos q = pi/2 - asin q + {-# INLINE atan #-} + -- atan q = i / 2 * log ( (i + q) / (i - q) ) + atan (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0 -> packQ 0 0 0 (atan w) + v2 -> + let v = sqrt v2 + w2 = w*w + vw2 = w2 + v2 + t = 1 + vw2 + c = 0.25 * log ((t + 2*v) / (t - 2*v)) / v + in packQ (c*x) (c*y) (c*z) $ 0.5 * atan2 (2*w) (1 - vw2) + {-# INLINE asinh #-} + -- The original formula: + -- asinh q = log (q + sqrt (q*q + 1)) + -- below is a more numerically stable version. + asinh (unpackQ# -> (# x, y, z, w #)) + | v2 == 0 + = packQ 0 0 0 (asinh w) + | w == 0 + = if v2 <= 1 + then let c = asin v / v + in packQ (c*x) (c*y) (c*z) 0 + else let c = 0.5 * pi / v + w' = 0.5 * log (2*v2 - 1 + 2 * v * sqrt ( v2 - 1 )) + in packQ (c*x) (c*y) (c*z) w' + | otherwise + = let c = atan2 v t / v + w' = 0.5 * log ( t2 + v2) - log t + + if w >= 0 + then log ( t + w ) + else log 2 + log w2 - log ( t - w ) - log ( r + w2 + v2 - 1 ) + in packQ (c*x) (c*y) (c*z) w' + where + v2 = (x * x) + (y * y) + (z * z) + v = sqrt v2 + w2 = w*w + wvp1 = w2 - v2 + 1 + r = sqrt $ wvp1*wvp1 + 4*w2*v2 + t = sqrt $ ( r + wvp1 ) * 0.5 + t2 = t*t + {-# INLINE acosh #-} + -- note, log (q + sqrt (q*q - 1)) would not work, because that would not + -- be the principal value. + acosh q = log' axis (q + sqrt' axis (q + 1) * sqrt' axis (q - 1)) + where + axis = sigVec q + {-# INLINE atanh #-} + atanh q = 0.5 * log ((1+q)/(1-q)) + +-- If q is negative real, provide a fallback axis to align log. +log' :: Vec3f -> QFloat -> QFloat +log' r (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 | w >= 0 + -> packQ 0.0 0.0 0.0 (log w) + | Vec3 rx ry rz <- r + -> packQ (pi*rx) (pi*ry) (pi*rz) (log (negate w)) + mv2 -> case (# sqrt (mv2 + (w * w)), sqrt mv2 #) of + (# mq, mv #) -> case atan2 mv w / mv of + l -> packQ (x * l) (y * l) (z * l) (log mq) + + +-- If q is negative real, provide a fallback axis to align sqrt. +sqrt' :: Vec3f -> QFloat -> QFloat +sqrt' r (unpackQ# -> (# x, y, z, w #)) + = case (x * x) + (y * y) + (z * z) of + 0.0 | w >= 0 + -> packQ 0.0 0.0 0.0 (sqrt w) + | Vec3 rx ry rz <- r + , sw <- sqrt (negate w) + -> packQ (sw*rx) (sw*ry) (sw*rz) 0 + mv2 -> + let mq = sqrt (mv2 + w * w) + l2 = sqrt mq + tq = w / (mq * 2.0) + sina = sqrt (0.5 - tq) * l2 / sqrt mv2 + in packQ (x * sina) (y * sina) (z * sina) (sqrt (0.5 + tq) * l2) + +sigVec :: QFloat -> Vec3f +sigVec (unpackQ# -> (# x, y, z, _ #)) + = case sqrt ((x * x) + (y * y) + (z * z)) of + 0 -> vec3 1 0 0 + l -> vec3 (x/l) (y/l) (z/l) + +instance Eq QFloat where + {-# INLINE (==) #-} + QFloat a == QFloat b = a == b + {-# INLINE (/=) #-} + QFloat a /= QFloat b = a /= b diff --git a/src/Numeric/Quaternion/QDouble.hs b/src/Numeric/Quaternion/QDouble.hs deleted file mode 100644 --- a/src/Numeric/Quaternion/QDouble.hs +++ /dev/null @@ -1,559 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Quaternion.QDouble - ( QDouble, Quater (..) - ) where - -import Data.Coerce (coerce) -import GHC.Exts - -import qualified Control.Monad.ST as ST -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.Family.DoubleX3 -import Numeric.DataFrame.Internal.Array.Family.DoubleX4 -import qualified Numeric.DataFrame.ST as ST -import Numeric.DataFrame.Type -import Numeric.Dimensions -import qualified Numeric.Dimensions.Fold as ST -import Numeric.PrimBytes (PrimBytes) -import Numeric.Quaternion.Class -import Numeric.Scalar -import Numeric.Vector - - -type QDouble = Quater Double - -deriving instance PrimBytes (Quater Double) -deriving instance PrimArray Double (Quater Double) - -instance Quaternion Double where - newtype Quater Double = QDouble DoubleX4 - {-# INLINE packQ #-} - packQ (D# x) (D# y) (D# z) (D# w) = QDouble (DoubleX4# x y z w) - {-# INLINE unpackQ #-} - unpackQ (QDouble (DoubleX4# x y z w)) = (D# x, D# y, D# z, D# w) - {-# INLINE fromVecNum #-} - fromVecNum (SingleFrame (DoubleX3# x y z)) (D# w) = QDouble (DoubleX4# x y z w) - {-# INLINE fromVec4 #-} - fromVec4 = coerce - {-# INLINE toVec4 #-} - toVec4 = coerce - {-# INLINE square #-} - square q = D# (qdot q) - {-# INLINE im #-} - im (QDouble (DoubleX4# x y z _)) = QDouble (DoubleX4# x y z 0.0##) - {-# INLINE re #-} - re (QDouble (DoubleX4# _ _ _ w)) = QDouble (DoubleX4# 0.0## 0.0## 0.0## w) - {-# INLINE imVec #-} - imVec (QDouble (DoubleX4# x y z _)) = SingleFrame (DoubleX3# x y z) - {-# INLINE taker #-} - taker (QDouble (DoubleX4# _ _ _ w)) = D# w - {-# INLINE takei #-} - takei (QDouble (DoubleX4# x _ _ _)) = D# x - {-# INLINE takej #-} - takej (QDouble (DoubleX4# _ y _ _)) = D# y - {-# INLINE takek #-} - takek (QDouble (DoubleX4# _ _ z _)) = D# z - {-# INLINE conjugate #-} - conjugate (QDouble (DoubleX4# x y z w)) = QDouble (DoubleX4# - (negateDouble# x) - (negateDouble# y) - (negateDouble# z) w) - {-# INLINE rotScale #-} - rotScale (QDouble (DoubleX4# i j k t)) - (SingleFrame (DoubleX3# x y z)) - = let l = t*##t -## i*##i -## j*##j -## k*##k - d = 2.0## *## ( i*##x +## j*##y +## k*##z) - t2 = t *## 2.0## - in SingleFrame - ( DoubleX3# - (l*##x +## d*##i +## t2 *## (z*##j -## y*##k)) - (l*##y +## d*##j +## t2 *## (x*##k -## z*##i)) - (l*##z +## d*##k +## t2 *## (y*##i -## x*##j)) - ) - {-# INLINE getRotScale #-} - getRotScale _ (SingleFrame (DoubleX3# 0.0## 0.0## 0.0##)) - = QDouble (DoubleX4# 0.0## 0.0## 0.0## 0.0##) - getRotScale (SingleFrame (DoubleX3# 0.0## 0.0## 0.0##)) _ - = case infty of D# x -> QDouble (DoubleX4# x x x x) - getRotScale a@(SingleFrame (DoubleX3# a1 a2 a3)) - b@(SingleFrame (DoubleX3# b1 b2 b3)) - = let ma = sqrtDouble# (a1*##a1 +## a2*##a2 +## a3*##a3) - mb = sqrtDouble# (b1*##b1 +## b2*##b2 +## b3*##b3) - d = a1*##b1 +## a2*##b2 +## a3*##b3 - c = sqrtDouble# (ma*##mb +## d) - ma2 = ma *## sqrtDouble# 2.0## - r = 1.0## /## (ma2 *## c) - in case cross a b of - SingleFrame (DoubleX3# 0.0## 0.0## 0.0##) -> - if isTrue# (d >## 0.0##) - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# (mb /## ma))) - -- Shall we move result from k to i component? - else QDouble (DoubleX4# 0.0## 0.0## (sqrtDouble# (mb /## ma)) 0.0##) - SingleFrame (DoubleX3# t1 t2 t3) -> QDouble - ( DoubleX4# - (t1 *## r) - (t2 *## r) - (t3 *## r) - (c /## ma2) - ) - {-# INLINE axisRotation #-} - axisRotation (SingleFrame (DoubleX3# 0.0## 0.0## 0.0##)) _ - = QDouble (DoubleX4# 0.0## 0.0## 0.0## 1.0##) - axisRotation (SingleFrame (DoubleX3# x y z)) (D# a) - = let c = cosDouble# (a *## 0.5##) - s = sinDouble# (a *## 0.5##) - /## sqrtDouble# (x*##x +## y*##y +## z*##z) - in QDouble - ( DoubleX4# - (x *## s) - (y *## s) - (z *## s) - c - ) - {-# INLINE qArg #-} - qArg (QDouble (DoubleX4# x y z w)) - = case atan2 (D# (sqrtDouble# (x*##x +## y*##y +## z*##z))) - (D# w) of - D# a -> D# (a *## 2.0##) - {-# INLINE fromMatrix33 #-} - fromMatrix33 m - = let d = - ( ix 0# m *## ( ix 4# m *## ix 8# m -## ix 5# m *## ix 7# m ) - -## ix 1# m *## ( ix 3# m *## ix 8# m -## ix 5# m *## ix 6# m ) - +## ix 2# m *## ( ix 3# m *## ix 7# m -## ix 4# m *## ix 6# m ) - ) **## 0.33333333333333333333333333333333## - in QDouble - ( DoubleX4# - (sqrtDouble# (max# 0.0## (d +## ix 0# m -## ix 4# m -## ix 8# m )) *## sign# (ix 5# m -## ix 7# m) *## 0.5##) - (sqrtDouble# (max# 0.0## (d -## ix 0# m +## ix 4# m -## ix 8# m )) *## sign# (ix 6# m -## ix 2# m) *## 0.5##) - (sqrtDouble# (max# 0.0## (d -## ix 0# m -## ix 4# m +## ix 8# m )) *## sign# (ix 1# m -## ix 3# m) *## 0.5##) - (sqrtDouble# (max# 0.0## (d +## ix 0# m +## ix 4# m +## ix 8# m )) *## 0.5##) - ) - {-# INLINE fromMatrix44 #-} - fromMatrix44 m - = let d = - ( ix 0# m *## ( ix 5# m *## ix 10# m -## ix 6# m *## ix 9# m ) - -## ix 1# m *## ( ix 4# m *## ix 10# m -## ix 6# m *## ix 8# m ) - +## ix 2# m *## ( ix 4# m *## ix 9# m -## ix 5# m *## ix 8# m ) - ) **## 0.33333333333333333333333333333333## - c = 0.5## /## ix 15# m - in QDouble - ( DoubleX4# - (sqrtDouble# (max# 0.0## (d +## ix 0# m -## ix 5# m -## ix 10# m )) *## sign# (ix 6# m -## ix 9# m) *## c) - (sqrtDouble# (max# 0.0## (d -## ix 0# m +## ix 5# m -## ix 10# m )) *## sign# (ix 8# m -## ix 2# m) *## c) - (sqrtDouble# (max# 0.0## (d -## ix 0# m -## ix 5# m +## ix 10# m )) *## sign# (ix 1# m -## ix 4# m) *## c) - (sqrtDouble# (max# 0.0## (d +## ix 0# m +## ix 5# m +## ix 10# m )) *## c) - ) - {-# INLINE toMatrix33 #-} - toMatrix33 (QDouble (DoubleX4# 0.0## 0.0## 0.0## w)) - = let x = D# (w *## w) - f 0 = (# 3 :: Int , x #) - f k = (# k-1, 0 #) - in case gen# 9# f 0 of - (# _, m #) -> m -- diag (scalar (D# (w *## w))) - toMatrix33 (QDouble (DoubleX4# x' y' z' w')) = - let x = scalar (D# x') - y = scalar (D# y') - z = scalar (D# z') - w = scalar (D# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) - ST.unsafeFreezeDataFrame df - {-# INLINE toMatrix44 #-} - toMatrix44 (QDouble (DoubleX4# 0.0## 0.0## 0.0## w)) = ST.runST $ do - df <- ST.newDataFrame - ST.overDimOff_ (dims :: Dims '[4,4]) (\i -> ST.writeDataFrameOff df i 0) 0 1 - let w2 = scalar (D# (w *## w)) - ST.writeDataFrameOff df 0 w2 - ST.writeDataFrameOff df 5 w2 - ST.writeDataFrameOff df 10 w2 - ST.writeDataFrameOff df 15 1 - ST.unsafeFreezeDataFrame df - toMatrix44 (QDouble (DoubleX4# x' y' z' w')) = - let x = scalar (D# x') - y = scalar (D# y') - z = scalar (D# z') - w = scalar (D# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 0 - ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 7 0 - ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) - ST.writeDataFrameOff df 11 0 - ST.writeDataFrameOff df 12 0 - ST.writeDataFrameOff df 13 0 - ST.writeDataFrameOff df 14 0 - ST.writeDataFrameOff df 15 1 - ST.unsafeFreezeDataFrame df - -qdot :: QDouble -> Double# -qdot (QDouble (DoubleX4# x y z w)) = (x *## x) +## - (y *## y) +## - (z *## z) +## - (w *## w) -{-# INLINE qdot #-} - -infty :: Double -infty = read "Infinity" - -max# :: Double# -> Double# -> Double# -max# a b | isTrue# (a >## b) = a - | otherwise = b -{-# INLINE max# #-} - -sign# :: Double# -> Double# -sign# a | isTrue# (a >## 0.0##) = 1.0## - | isTrue# (a <## 0.0##) = negateDouble# 1.0## - | otherwise = 0.0## -{-# INLINE sign# #-} - -ix :: PrimArray Double a => Int# -> a -> Double# -ix i a = case ix# i a of D# r -> r -{-# INLINE ix #-} - --------------------------------------------------------------------------- --- Num --------------------------------------------------------------------------- - -instance Num QDouble where - QDouble a + QDouble b - = QDouble (a + b) - {-# INLINE (+) #-} - QDouble a - QDouble b - = QDouble (a - b) - {-# INLINE (-) #-} - QDouble (DoubleX4# a1 a2 a3 a4) * QDouble (DoubleX4# b1 b2 b3 b4) - = QDouble - ( DoubleX4# - ((a4 *## b1) +## - (a1 *## b4) +## - (a2 *## b3) -## - (a3 *## b2) - ) - ((a4 *## b2) -## - (a1 *## b3) +## - (a2 *## b4) +## - (a3 *## b1) - ) - ((a4 *## b3) +## - (a1 *## b2) -## - (a2 *## b1) +## - (a3 *## b4) - ) - ((a4 *## b4) -## - (a1 *## b1) -## - (a2 *## b2) -## - (a3 *## b3) - ) - ) - {-# INLINE (*) #-} - negate (QDouble a) = QDouble (negate a) - {-# INLINE negate #-} - abs q = QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# (qdot q))) - {-# INLINE abs #-} - signum q@(QDouble (DoubleX4# x y z w)) - = case qdot q of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## 0.0##) - qd -> case 1.0## /## sqrtDouble# qd of - s -> QDouble - ( DoubleX4# - (x *## s) - (y *## s) - (z *## s) - (w *## s) - ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of - D# x -> QDouble (DoubleX4# 0.0## 0.0## 0.0## x) - {-# INLINE fromInteger #-} - - - --------------------------------------------------------------------------- --- Fractional --------------------------------------------------------------------------- - -instance Fractional QDouble where - {-# INLINE recip #-} - recip q@(QDouble (DoubleX4# x y z w)) = case -1.0## /## qdot q of - c -> QDouble - ( DoubleX4# - (x *## c) - (y *## c) - (z *## c) - (negateDouble# (w *## c)) - ) - {-# INLINE (/) #-} - a / b = a * recip b - {-# INLINE fromRational #-} - fromRational q = case fromRational q of - D# x -> QDouble (DoubleX4# 0.0## 0.0## 0.0## x) - --------------------------------------------------------------------------- --- Doubleing --------------------------------------------------------------------------- - -instance Floating QDouble where - {-# INLINE pi #-} - pi = QDouble (DoubleX4# 0.0## 0.0## 0.0## - 3.141592653589793##) - {-# INLINE exp #-} - exp (QDouble (DoubleX4# x y z w)) - = case (# (x *## x) +## - (y *## y) +## - (z *## z) - , expDouble# w - #) of - (# 0.0##, et #) -> QDouble (DoubleX4# 0.0## 0.0## 0.0## et) - (# mv2, et #) -> case sqrtDouble# mv2 of - mv -> case et *## sinDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (et *## cosDouble# mv) - ) - {-# INLINE log #-} - log (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> if isTrue# (w >=## 0.0##) - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (logDouble# w)) - else QDouble (DoubleX4# 3.141592653589793## 0.0## 0.0## - (logDouble# (negateDouble# w))) - mv2 -> case (# sqrtDouble# (mv2 +## (w *## w)) - , sqrtDouble# mv2 - #) of - (# mq, mv #) -> case atan2 (D# mv) (D# w) / D# mv of - D# l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (logDouble# mq) - ) - {-# INLINE sqrt #-} - sqrt (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> if isTrue# (w >=## 0.0##) - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (sqrtDouble# w)) - else QDouble (DoubleX4# (sqrtDouble# (negateDouble# w)) 0.0## 0.0## 0.0##) - mv2 -> - let mq = sqrtDouble# (mv2 +## w *## w) - l2 = sqrtDouble# mq - tq = w /## (mq *## 2.0##) - sina = sqrtDouble# (0.5## -## tq) *## l2 /## sqrtDouble# mv2 - in QDouble - ( DoubleX4# - (x *## sina) - (y *## sina) - (z *## sina) - (sqrtDouble# (0.5## +## tq) *## l2) - ) - {-# INLINE sin #-} - sin (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (sinDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case cosDouble# w *## sinhDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (sinDouble# w *## coshDouble# mv) - ) - {-# INLINE cos #-} - cos (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (cosDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case sinDouble# w *## sinhDouble# mv - /## negateDouble# mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (cosDouble# w *## coshDouble# mv) - ) - {-# INLINE tan #-} - tan (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (tanDouble# w)) - mv2 -> - let mv = sqrtDouble# mv2 - chv = coshDouble# mv - shv = sinhDouble# mv - ct = cosDouble# w - st = sinDouble# w - cq = 1.0## /## - ( (ct *## ct *## chv *## chv) - +## - (st *## st *## shv *## shv) - ) - l = chv *## shv *## cq - /## mv - in QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (ct *## st *## cq) - ) - {-# INLINE sinh #-} - sinh (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (sinhDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case coshDouble# w *## sinDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (sinhDouble# w *## cosDouble# mv) - ) - {-# INLINE cosh #-} - cosh (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (coshDouble# w)) - mv2 -> case sqrtDouble# mv2 of - mv -> case sinhDouble# w *## sinDouble# mv - /## mv of - l -> QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (coshDouble# w *## cosDouble# mv) - ) - {-# INLINE tanh #-} - tanh (QDouble (DoubleX4# x y z w)) - = case (x *## x) +## - (y *## y) +## - (z *## z) of - 0.0## -> QDouble (DoubleX4# 0.0## 0.0## 0.0## (tanhDouble# w)) - mv2 -> - let mv = sqrtDouble# mv2 - cv = cosDouble# mv - sv = sinDouble# mv - cht = coshDouble# w - sht = sinhDouble# w - cq = 1.0## /## - ( (cht *## cht *## cv *## cv) - +## - (sht *## sht *## sv *## sv) - ) - l = cv *## sv *## cq - /## mv - in QDouble - ( DoubleX4# - (x *## l) - (y *## l) - (z *## l) - (cht *## sht *## cq) - ) - {-# INLINE asin #-} - asin q = -i * log (i*q + sqrt (1 - q*q)) - where - i = case signum . im $ q of - 0 -> QDouble (DoubleX4# 1.0## 0.0## 0.0## 0.0##) - i' -> i' - {-# INLINE acos #-} - acos q = pi/2 - asin q - {-# INLINE atan #-} - atan q@(QDouble (DoubleX4# _ _ _ w)) - = if square imq == 0 - then QDouble (DoubleX4# 0.0## 0.0## 0.0## (atanDouble# w)) - else i / 2 * log ( (i + q) / (i - q) ) - where - i = signum imq - imq = im q - {-# INLINE asinh #-} - asinh q = log (q + sqrt (q*q + 1)) - {-# INLINE acosh #-} - acosh q = log (q + sqrt (q*q - 1)) - {-# INLINE atanh #-} - atanh q = 0.5 * log ((1+q)/(1-q)) - --------------------------------------------------------------------------- --- Eq --------------------------------------------------------------------------- - -instance Eq QDouble where - {-# INLINE (==) #-} - QDouble a == QDouble b = a == b - {-# INLINE (/=) #-} - QDouble a /= QDouble b = a /= b - - - --------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------- - -instance Show QDouble where - show (QDouble (DoubleX4# x y z w)) = - show (D# w) ++ ss x ++ "i" - ++ ss y ++ "j" - ++ ss z ++ "k" - where - ss a# = case D# a# of - a -> if a >= 0 then " + " ++ show a - else " - " ++ show (negate a) diff --git a/src/Numeric/Quaternion/QFloat.hs b/src/Numeric/Quaternion/QFloat.hs deleted file mode 100644 --- a/src/Numeric/Quaternion/QFloat.hs +++ /dev/null @@ -1,579 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.Quaternion.QFloat - ( QFloat, Quater (..) - ) where - -import Data.Coerce (coerce) -import GHC.Exts - -import qualified Control.Monad.ST as ST -import Numeric.DataFrame.Internal.Array.Class -import Numeric.DataFrame.Internal.Array.Family.FloatX3 -import Numeric.DataFrame.Internal.Array.Family.FloatX4 -import qualified Numeric.DataFrame.ST as ST -import Numeric.DataFrame.Type -import Numeric.Dimensions -import qualified Numeric.Dimensions.Fold as ST -import Numeric.PrimBytes (PrimBytes) -import Numeric.Quaternion.Class -import Numeric.Scalar -import Numeric.Vector - - -type QFloat = Quater Float - -deriving instance PrimBytes (Quater Float) -deriving instance PrimArray Float (Quater Float) - -instance Quaternion Float where - newtype Quater Float = QFloat FloatX4 - {-# INLINE packQ #-} - packQ (F# x) (F# y) (F# z) (F# w) = QFloat (FloatX4# x y z w) - {-# INLINE unpackQ #-} - unpackQ (QFloat (FloatX4# x y z w)) = (F# x, F# y, F# z, F# w) - {-# INLINE fromVecNum #-} - fromVecNum (SingleFrame (FloatX3# x y z)) (F# w) = QFloat (FloatX4# x y z w) - {-# INLINE fromVec4 #-} - fromVec4 = coerce - {-# INLINE toVec4 #-} - toVec4 = coerce - {-# INLINE square #-} - square q = F# (qdot q) - {-# INLINE im #-} - im (QFloat (FloatX4# x y z _)) = QFloat (FloatX4# x y z 0.0#) - {-# INLINE re #-} - re (QFloat (FloatX4# _ _ _ w)) = QFloat (FloatX4# 0.0# 0.0# 0.0# w) - {-# INLINE imVec #-} - imVec (QFloat (FloatX4# x y z _)) = SingleFrame (FloatX3# x y z) - {-# INLINE taker #-} - taker (QFloat (FloatX4# _ _ _ w)) = F# w - {-# INLINE takei #-} - takei (QFloat (FloatX4# x _ _ _)) = F# x - {-# INLINE takej #-} - takej (QFloat (FloatX4# _ y _ _)) = F# y - {-# INLINE takek #-} - takek (QFloat (FloatX4# _ _ z _)) = F# z - {-# INLINE conjugate #-} - conjugate (QFloat (FloatX4# x y z w)) = QFloat (FloatX4# - (negateFloat# x) - (negateFloat# y) - (negateFloat# z) w) - {-# INLINE rotScale #-} - rotScale (QFloat (FloatX4# i j k t)) - (SingleFrame (FloatX3# x y z)) - = let l = t*%t -% i*%i -% j*%j -% k*%k - d = 2.0# *% ( i*%x +% j*%y +% k*%z) - t2 = t *% 2.0# - in SingleFrame - ( FloatX3# - (l*%x +% d*%i +% t2 *% (z*%j -% y*%k)) - (l*%y +% d*%j +% t2 *% (x*%k -% z*%i)) - (l*%z +% d*%k +% t2 *% (y*%i -% x*%j)) - ) - {-# INLINE getRotScale #-} - getRotScale _ (SingleFrame (FloatX3# 0.0# 0.0# 0.0#)) - = QFloat (FloatX4# 0.0# 0.0# 0.0# 0.0#) - getRotScale (SingleFrame (FloatX3# 0.0# 0.0# 0.0#)) _ - = case infty of F# x -> QFloat (FloatX4# x x x x) - getRotScale a@(SingleFrame (FloatX3# a1 a2 a3)) - b@(SingleFrame (FloatX3# b1 b2 b3)) - = let ma = sqrtFloat# (a1*%a1 +% a2*%a2 +% a3*%a3) - mb = sqrtFloat# (b1*%b1 +% b2*%b2 +% b3*%b3) - d = a1*%b1 +% a2*%b2 +% a3*%b3 - c = sqrtFloat# (ma*%mb +% d) - ma2 = ma *% sqrtFloat# 2.0# - r = 1.0# /% (ma2 *% c) - in case cross a b of - SingleFrame (FloatX3# 0.0# 0.0# 0.0#) -> - if isTrue# (gtFloat# d 0.0#) - then QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# (mb /% ma))) - -- Shall we move result from k to i component? - else QFloat (FloatX4# 0.0# 0.0# (sqrtFloat# (mb /% ma)) 0.0#) - SingleFrame (FloatX3# t1 t2 t3) -> QFloat - ( FloatX4# - (t1 *% r) - (t2 *% r) - (t3 *% r) - (c /% ma2) - ) - {-# INLINE axisRotation #-} - axisRotation (SingleFrame (FloatX3# 0.0# 0.0# 0.0#)) _ - = QFloat (FloatX4# 0.0# 0.0# 0.0# 1.0#) - axisRotation (SingleFrame (FloatX3# x y z)) (F# a) - = let c = cosFloat# (a *% 0.5#) - s = sinFloat# (a *% 0.5#) - /% sqrtFloat# (x*%x +% y*%y +% z*%z) - in QFloat - ( FloatX4# - (x *% s) - (y *% s) - (z *% s) - c - ) - {-# INLINE qArg #-} - qArg (QFloat (FloatX4# x y z w)) - = case atan2 (F# (sqrtFloat# (x*%x +% y*%y +% z*%z))) - (F# w) of - F# a -> F# (a *% 2.0#) - {-# INLINE fromMatrix33 #-} - fromMatrix33 m - = let d = powerFloat# - ( ix 0# m *% ( ix 4# m *% ix 8# m -% ix 5# m *% ix 7# m ) - -% ix 1# m *% ( ix 3# m *% ix 8# m -% ix 5# m *% ix 6# m ) - +% ix 2# m *% ( ix 3# m *% ix 7# m -% ix 4# m *% ix 6# m ) - ) 0.33333333333333333333333333333333# - in QFloat - ( FloatX4# - (sqrtFloat# (max# 0.0# (d +% ix 0# m -% ix 4# m -% ix 8# m )) *% sign# (ix 5# m -% ix 7# m) *% 0.5#) - (sqrtFloat# (max# 0.0# (d -% ix 0# m +% ix 4# m -% ix 8# m )) *% sign# (ix 6# m -% ix 2# m) *% 0.5#) - (sqrtFloat# (max# 0.0# (d -% ix 0# m -% ix 4# m +% ix 8# m )) *% sign# (ix 1# m -% ix 3# m) *% 0.5#) - (sqrtFloat# (max# 0.0# (d +% ix 0# m +% ix 4# m +% ix 8# m )) *% 0.5#) - ) - {-# INLINE fromMatrix44 #-} - fromMatrix44 m - = let d = powerFloat# - ( ix 0# m *% ( ix 5# m *% ix 10# m -% ix 6# m *% ix 9# m ) - -% ix 1# m *% ( ix 4# m *% ix 10# m -% ix 6# m *% ix 8# m ) - +% ix 2# m *% ( ix 4# m *% ix 9# m -% ix 5# m *% ix 8# m ) - ) 0.33333333333333333333333333333333# - c = 0.5# /% ix 15# m - in QFloat - ( FloatX4# - (sqrtFloat# (max# 0.0# (d +% ix 0# m -% ix 5# m -% ix 10# m )) *% sign# (ix 6# m -% ix 9# m) *% c) - (sqrtFloat# (max# 0.0# (d -% ix 0# m +% ix 5# m -% ix 10# m )) *% sign# (ix 8# m -% ix 2# m) *% c) - (sqrtFloat# (max# 0.0# (d -% ix 0# m -% ix 5# m +% ix 10# m )) *% sign# (ix 1# m -% ix 4# m) *% c) - (sqrtFloat# (max# 0.0# (d +% ix 0# m +% ix 5# m +% ix 10# m )) *% c) - ) - {-# INLINE toMatrix33 #-} - toMatrix33 (QFloat (FloatX4# 0.0# 0.0# 0.0# w)) - = let x = F# (w *% w) - f 0 = (# 3 :: Int , x #) - f k = (# k-1, 0 #) - in case gen# 9# f 0 of - (# _, m #) -> m -- diag (scalar (F# (w *% w))) - toMatrix33 (QFloat (FloatX4# x' y' z' w')) = - let x = scalar (F# x') - y = scalar (F# y') - z = scalar (F# z') - w = scalar (F# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 4 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 5 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 6 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 7 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 8 $ l2 - 2*(y2 + x2) - ST.unsafeFreezeDataFrame df - {-# INLINE toMatrix44 #-} - toMatrix44 (QFloat (FloatX4# 0.0# 0.0# 0.0# w)) = ST.runST $ do - df <- ST.newDataFrame - ST.overDimOff_ (dims :: Dims '[4,4]) (\i -> ST.writeDataFrameOff df i 0) 0 1 - let w2 = scalar (F# (w *% w)) - ST.writeDataFrameOff df 0 w2 - ST.writeDataFrameOff df 5 w2 - ST.writeDataFrameOff df 10 w2 - ST.writeDataFrameOff df 15 1 - ST.unsafeFreezeDataFrame df - toMatrix44 (QFloat (FloatX4# x' y' z' w')) = - let x = scalar (F# x') - y = scalar (F# y') - z = scalar (F# z') - w = scalar (F# w') - x2 = x * x - y2 = y * y - z2 = z * z - w2 = w * w - l2 = x2 + y2 + z2 + w2 - in ST.runST $ do - df <- ST.newDataFrame - ST.writeDataFrameOff df 0 $ l2 - 2*(z2 + y2) - ST.writeDataFrameOff df 1 $ 2*(x*y + z*w) - ST.writeDataFrameOff df 2 $ 2*(x*z - y*w) - ST.writeDataFrameOff df 3 0 - ST.writeDataFrameOff df 4 $ 2*(x*y - z*w) - ST.writeDataFrameOff df 5 $ l2 - 2*(z2 + x2) - ST.writeDataFrameOff df 6 $ 2*(y*z + x*w) - ST.writeDataFrameOff df 7 0 - ST.writeDataFrameOff df 8 $ 2*(x*z + y*w) - ST.writeDataFrameOff df 9 $ 2*(y*z - x*w) - ST.writeDataFrameOff df 10 $ l2 - 2*(y2 + x2) - ST.writeDataFrameOff df 11 0 - ST.writeDataFrameOff df 12 0 - ST.writeDataFrameOff df 13 0 - ST.writeDataFrameOff df 14 0 - ST.writeDataFrameOff df 15 0 - ST.unsafeFreezeDataFrame df - -qdot :: QFloat -> Float# -qdot (QFloat (FloatX4# x y z w)) = (x *% x) +% - (y *% y) +% - (z *% z) +% - (w *% w) -{-# INLINE qdot #-} - -(*%) :: Float# -> Float# -> Float# -(*%) = timesFloat# -{-# INLINE (*%) #-} -infixl 7 *% - -(-%) :: Float# -> Float# -> Float# -(-%) = minusFloat# -{-# INLINE (-%) #-} -infixl 6 -% - -(+%) :: Float# -> Float# -> Float# -(+%) = plusFloat# -{-# INLINE (+%) #-} -infixl 6 +% - -(/%) :: Float# -> Float# -> Float# -(/%) = divideFloat# -{-# INLINE (/%) #-} -infixl 7 /% - -infty :: Float -infty = read "Infinity" - -max# :: Float# -> Float# -> Float# -max# a b | isTrue# (gtFloat# a b) = a - | otherwise = b -{-# INLINE max# #-} - -sign# :: Float# -> Float# -sign# a | isTrue# (gtFloat# a 0.0#) = 1.0# - | isTrue# (ltFloat# a 0.0#) = negateFloat# 1.0# - | otherwise = 0.0# -{-# INLINE sign# #-} - -ix :: PrimArray Float a => Int# -> a -> Float# -ix i a = case ix# i a of F# r -> r -{-# INLINE ix #-} - --------------------------------------------------------------------------- --- Num --------------------------------------------------------------------------- - -instance Num QFloat where - QFloat a + QFloat b - = QFloat (a + b) - {-# INLINE (+) #-} - QFloat a - QFloat b - = QFloat (a - b) - {-# INLINE (-) #-} - QFloat (FloatX4# a1 a2 a3 a4) * QFloat (FloatX4# b1 b2 b3 b4) - = QFloat - ( FloatX4# - ((a4 *% b1) +% - (a1 *% b4) +% - (a2 *% b3) -% - (a3 *% b2) - ) - ((a4 *% b2) -% - (a1 *% b3) +% - (a2 *% b4) +% - (a3 *% b1) - ) - ((a4 *% b3) +% - (a1 *% b2) -% - (a2 *% b1) +% - (a3 *% b4) - ) - ((a4 *% b4) -% - (a1 *% b1) -% - (a2 *% b2) -% - (a3 *% b3) - ) - ) - {-# INLINE (*) #-} - negate (QFloat a) = QFloat (negate a) - {-# INLINE negate #-} - abs q = QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# (qdot q))) - {-# INLINE abs #-} - signum q@(QFloat (FloatX4# x y z w)) - = case qdot q of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# 0.0#) - qd -> case 1.0# /% sqrtFloat# qd of - s -> QFloat - ( FloatX4# - (x *% s) - (y *% s) - (z *% s) - (w *% s) - ) - {-# INLINE signum #-} - fromInteger n = case fromInteger n of - F# x -> QFloat (FloatX4# 0.0# 0.0# 0.0# x) - {-# INLINE fromInteger #-} - - - --------------------------------------------------------------------------- --- Fractional --------------------------------------------------------------------------- - -instance Fractional QFloat where - {-# INLINE recip #-} - recip q@(QFloat (FloatX4# x y z w)) = case -1.0# /% qdot q of - c -> QFloat - ( FloatX4# - (x *% c) - (y *% c) - (z *% c) - (negateFloat# (w *% c)) - ) - {-# INLINE (/) #-} - a / b = a * recip b - {-# INLINE fromRational #-} - fromRational q = case fromRational q of - F# x -> QFloat (FloatX4# 0.0# 0.0# 0.0# x) - --------------------------------------------------------------------------- --- Floating --------------------------------------------------------------------------- - -instance Floating QFloat where - {-# INLINE pi #-} - pi = QFloat (FloatX4# 0.0# 0.0# 0.0# - 3.141592653589793#) - {-# INLINE exp #-} - exp (QFloat (FloatX4# x y z w)) - = case (# (x *% x) +% - (y *% y) +% - (z *% z) - , expFloat# w - #) of - (# 0.0#, et #) -> QFloat (FloatX4# 0.0# 0.0# 0.0# et) - (# mv2, et #) -> case sqrtFloat# mv2 of - mv -> case et *% sinFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (et *% cosFloat# mv) - ) - {-# INLINE log #-} - log (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> if isTrue# (w `geFloat#` 0.0#) - then QFloat (FloatX4# 0.0# 0.0# 0.0# (logFloat# w)) - else QFloat (FloatX4# 3.141592653589793# 0.0# 0.0# - (logFloat# (negateFloat# w))) - mv2 -> case (# sqrtFloat# (mv2 +% (w *% w)) - , sqrtFloat# mv2 - #) of - (# mq, mv #) -> case atan2 (F# mv) (F# w) / F# mv of - F# l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (logFloat# mq) - ) - {-# INLINE sqrt #-} - sqrt (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> if isTrue# (w `geFloat#` 0.0#) - then QFloat (FloatX4# 0.0# 0.0# 0.0# (sqrtFloat# w)) - else QFloat (FloatX4# (sqrtFloat# (negateFloat# w)) 0.0# 0.0# 0.0#) - mv2 -> - let mq = sqrtFloat# (mv2 +% w *% w) - l2 = sqrtFloat# mq - tq = w /% (mq *% 2.0#) - sina = sqrtFloat# (0.5# -% tq) *% l2 /% sqrtFloat# mv2 - in QFloat - ( FloatX4# - (x *% sina) - (y *% sina) - (z *% sina) - (sqrtFloat# (0.5# +% tq) *% l2) - ) - {-# INLINE sin #-} - sin (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (sinFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case cosFloat# w *% sinhFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (sinFloat# w *% coshFloat# mv) - ) - {-# INLINE cos #-} - cos (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (cosFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case sinFloat# w *% sinhFloat# mv - /% negateFloat# mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (cosFloat# w *% coshFloat# mv) - ) - {-# INLINE tan #-} - tan (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (tanFloat# w)) - mv2 -> - let mv = sqrtFloat# mv2 - chv = coshFloat# mv - shv = sinhFloat# mv - ct = cosFloat# w - st = sinFloat# w - cq = 1.0# /% - ( (ct *% ct *% chv *% chv) - +% - (st *% st *% shv *% shv) - ) - l = chv *% shv *% cq - /% mv - in QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (ct *% st *% cq) - ) - {-# INLINE sinh #-} - sinh (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (sinhFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case coshFloat# w *% sinFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (sinhFloat# w *% cosFloat# mv) - ) - {-# INLINE cosh #-} - cosh (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (coshFloat# w)) - mv2 -> case sqrtFloat# mv2 of - mv -> case sinhFloat# w *% sinFloat# mv - /% mv of - l -> QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (coshFloat# w *% cosFloat# mv) - ) - {-# INLINE tanh #-} - tanh (QFloat (FloatX4# x y z w)) - = case (x *% x) +% - (y *% y) +% - (z *% z) of - 0.0# -> QFloat (FloatX4# 0.0# 0.0# 0.0# (tanhFloat# w)) - mv2 -> - let mv = sqrtFloat# mv2 - cv = cosFloat# mv - sv = sinFloat# mv - cht = coshFloat# w - sht = sinhFloat# w - cq = 1.0# /% - ( (cht *% cht *% cv *% cv) - +% - (sht *% sht *% sv *% sv) - ) - l = cv *% sv *% cq - /% mv - in QFloat - ( FloatX4# - (x *% l) - (y *% l) - (z *% l) - (cht *% sht *% cq) - ) - {-# INLINE asin #-} - asin q = -i * log (i*q + sqrt (1 - q*q)) - where - i = case signum . im $ q of - 0 -> QFloat (FloatX4# 1.0# 0.0# 0.0# 0.0#) - i' -> i' - {-# INLINE acos #-} - acos q = pi/2 - asin q - {-# INLINE atan #-} - atan q@(QFloat (FloatX4# _ _ _ w)) - = if square imq == 0 - then QFloat (FloatX4# 0.0# 0.0# 0.0# (atanFloat# w)) - else i / 2 * log ( (i + q) / (i - q) ) - where - i = signum imq - imq = im q - {-# INLINE asinh #-} - asinh q = log (q + sqrt (q*q + 1)) - {-# INLINE acosh #-} - acosh q = log (q + sqrt (q*q - 1)) - {-# INLINE atanh #-} - atanh q = 0.5 * log ((1+q)/(1-q)) - --------------------------------------------------------------------------- --- Eq --------------------------------------------------------------------------- - -instance Eq QFloat where - {-# INLINE (==) #-} - QFloat a == QFloat b = a == b - {-# INLINE (/=) #-} - QFloat a /= QFloat b = a /= b - - - --------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------- - -instance Show QFloat where - show (QFloat (FloatX4# x y z w)) = - show (F# w) ++ ss x ++ "i" - ++ ss y ++ "j" - ++ ss z ++ "k" - where - ss a# = case F# a# of - a -> if a >= 0 then " + " ++ show a - else " - " ++ show (negate a) diff --git a/src/Numeric/Scalar.hs b/src/Numeric/Scalar.hs --- a/src/Numeric/Scalar.hs +++ b/src/Numeric/Scalar.hs @@ -1,41 +1,8 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MonoLocalBinds #-} -- | Scalar is an alias to zero-dimensional DataFrame module Numeric.Scalar ( Scalar, unScalar, scalar, fromScalar , Scf, Scd, Sci, Scw ) where - -import GHC.Base (unsafeCoerce#) -import Numeric.DataFrame.Family (DataFrame) -import Numeric.DataFrame.SubSpace (SubSpace (ewgen)) -import Numeric.Dim (Nat) - --- | Alias for zero-dimensional DataFrame -type Scalar t = DataFrame t ('[] :: [Nat]) -type Scf = Scalar Float -type Scd = Scalar Double -type Sci = Scalar Int -type Scw = Scalar Word - --- | Convert scalar back to ordinary type -unScalar :: Scalar t -> t --- rely on that Scalar is just two times newtype alias to t -unScalar = unsafeCoerce# -{-# INLINE unScalar #-} - --- | Convert any type to scalar wrapper -scalar :: t -> Scalar t --- rely on that Scalar is just two times newtype alias to t -scalar = unsafeCoerce# -{-# INLINE scalar #-} - --- | Broadcast scalar value onto a whole data frame -fromScalar :: SubSpace t '[] ds ds - => Scalar t -> DataFrame t ds -fromScalar = ewgen -{-# INLINE fromScalar #-} +import Numeric.DataFrame.Internal.Backend () +import Numeric.Scalar.Internal diff --git a/src/Numeric/Scalar/Internal.hs b/src/Numeric/Scalar/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Scalar/Internal.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE PatternSynonyms #-} +-- | Scalar is an alias to zero-dimensional DataFrame +module Numeric.Scalar.Internal + ( Scalar, unScalar, scalar, fromScalar + , Scf, Scd, Sci, Scw + , pattern S + ) where + + +import Data.Type.Lits (Nat) +import GHC.Base (unsafeCoerce#) +import Numeric.DataFrame.SubSpace (SubSpace (ewgen)) +import Numeric.DataFrame.Type (DataFrame, pattern S) + +-- | Alias for zero-dimensional DataFrame +type Scalar t = DataFrame t ('[] :: [Nat]) +type Scf = Scalar Float +type Scd = Scalar Double +type Sci = Scalar Int +type Scw = Scalar Word + +-- | Convert scalar back to ordinary type +unScalar :: Scalar t -> t +-- rely on that Scalar is just two times newtype alias to t +unScalar = unsafeCoerce# +{-# INLINE unScalar #-} + +-- | Convert any type to scalar wrapper +scalar :: t -> Scalar t +-- rely on that Scalar is just two times newtype alias to t +scalar = unsafeCoerce# +{-# INLINE scalar #-} + +-- | Broadcast scalar value onto a whole data frame +fromScalar :: SubSpace t ds '[] ds + => Scalar t -> DataFrame t ds +fromScalar = ewgen +{-# INLINE fromScalar #-} diff --git a/src/Numeric/Semigroup.hs b/src/Numeric/Semigroup.hs deleted file mode 100644 --- a/src/Numeric/Semigroup.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Numeric.Semigroup --- Copyright : (c) Artem Chirkin --- License : BSD3 --- --- Maintainer : chirkin@arch.ethz.ch --- --- Re-export most of "Data.Semigroup" with a few changes --- and new definitions. --- --- The main initiative behind this module is to provide more strict --- alternatives to widely used semigroups. --- For example, 'Data.Semigroup.Option' has lazy @(\<\>)@ implementation, --- which causes memory leaks in large foldMaps. --- ------------------------------------------------------------------------------ -module Numeric.Semigroup - ( Semigroup(..) - , stimesMonoid - , stimesIdempotent - , stimesIdempotentMonoid - , mtimesDefault - , foldMap' - -- * Semigroups - , Min(..) - , Max(..) - , First(..) - , Last(..) - , WrappedMonoid(..) - -- * Re-exported monoids from Data.Monoid - , Monoid(..) - , Dual(..) - , Endo(..) - , All(..) - , Any(..) - , Sum(..) - , Product(..) - -- * A better monoid for Maybe - , Option (..) - , option, fromOption, toOption - -- * Difference lists of a semigroup - , diff - , cycle1 - -- * ArgMin, ArgMax - , Arg(..) - , ArgMin - , ArgMax - , MinMax (..) - , minMax, mmDiff, mmAvg - ) where - -import Data.Semigroup hiding (Option (..), option) -import Data.Foldable (foldl') -import Data.Data -import Control.Applicative -import Control.Monad.Fix -import GHC.Generics - --- | 'Option' is effectively 'Maybe' with a better instance of --- 'Monoid', built off of an underlying 'Semigroup' instead of an --- underlying 'Monoid'. --- --- This version of 'Option' data type is more strict than the one from --- "Data.Semigroup". -newtype Option a = Option { getOption :: Maybe a } - deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1 - , Functor, Alternative, Applicative, Monad, MonadFix) - --- | Fold an 'Option' case-wise, just like 'maybe'. --- Eagerly evaluates the value before returning! -option :: b -> (a -> b) -> Option a -> b -option !b _ (Option Nothing) = b -option _ f (Option (Just !a)) = f a - --- | Get value from 'Option' with default value. --- Eagerly evaluates the value before returning! -fromOption :: a -> Option a -> a -fromOption !a (Option Nothing) = a -fromOption _ (Option (Just !a)) = a - --- | Wrap a value into 'Option' container. --- Eagerly evaluates the value before wrapping! -toOption :: a -> Option a -toOption !a = Option (Just a) - - -instance Foldable Option where - foldMap _ (Option Nothing) = mempty - foldMap f (Option (Just !a)) = f a - -instance Traversable Option where - traverse _ (Option Nothing) = pure (Option Nothing) - traverse f (Option (Just !a)) = (\ !b -> Option (Just b)) <$> f a - -instance Semigroup a => Semigroup (Option a) where - Option Nothing <> Option Nothing = Option Nothing - Option Nothing <> Option (Just !a) = Option (Just a) - Option (Just !a) <> Option Nothing = Option (Just a) - Option (Just !a) <> Option (Just !b) = Option (Just $! a <> b) - - stimes _ (Option Nothing) = Option Nothing - stimes n (Option (Just a)) = case compare n 0 of - LT -> errorWithoutStackTrace "stimes: Option, negative multiplier" - EQ -> Option Nothing - GT -> Option (Just $! stimes n a) - -instance Semigroup a => Monoid (Option a) where - mappend = (<>) - mempty = Option Nothing - - - --- | Evaluate minimum and maximum at the same time. --- Arithmetics and semigroup operations are eager, --- functorial operations are lazy. --- --- This data type is especially useful for calculating bounds --- of foldable containers with numeric data using @foldMap minMax@. -data MinMax a = MinMax a a - deriving (Eq, Read, Show, Data, Typeable, Generic, Generic1) - -minMax :: a -> MinMax a -minMax !a = MinMax a a - -mmDiff :: Num a => MinMax a -> a -mmDiff (MinMax !x !y) = y - x - -mmAvg :: Fractional a => MinMax a -> a -mmAvg (MinMax !x !y) = 0.5 * (x+y) - -strictMinMax :: a -> a -> MinMax a -strictMinMax !a !b = MinMax a b - -instance Ord a => Semigroup (MinMax a) where - (MinMax !x1 !y1) <> (MinMax !x2 !y2) = strictMinMax (min x1 x2) (max y1 y2) - - -- 'MinMax' is idempotent. - -- Also we don't care if @n@ is not positive. - stimes _ (MinMax !x !y) = MinMax x y - - - -instance (Ord a, Bounded a) => Monoid (MinMax a) where - -- | Empty instance of minmax is an invalid value @min >= max@. - -- However, this gives a good monoid append behavior. - mempty = strictMinMax maxBound minBound - mappend = (<>) - - -instance Functor MinMax where - fmap f (MinMax a b) = MinMax (f a) (f b) - -instance Applicative MinMax where - pure a = MinMax a a - MinMax f g <*> MinMax a b = MinMax (f a) (g b) - -instance Monad MinMax where - return = pure - MinMax a b >>= m = case (m a, m b) of - (MinMax x _, MinMax _ y) -> MinMax x y - -instance MonadFix MinMax where - mfix mf = let MinMax x _ = mf x - MinMax _ y = mf y - in MinMax x y - -instance Bounded a => Bounded (MinMax a) where - minBound = strictMinMax minBound minBound - maxBound = strictMinMax maxBound maxBound - --- | MinMax checks whether bounds overlap. --- --- * Strict inequality means that intervals do not overlap. --- * Non-strict inequality means non-strict inequality in both constructor arguments. --- * `EQ` means intervals overlap -instance Ord a => Ord (MinMax a) where - MinMax _ amax < MinMax bmin _ = amax < bmin - MinMax amin _ > MinMax _ bmax = amin > bmax - MinMax amin amax <= MinMax bmin bmax = amin <= bmin && amax <= bmax - MinMax amin amax >= MinMax bmin bmax = amin >= bmin && amax >= bmax - -- | A contraversal decision was made here: implementing `compare` operation. - -- `compare` returns GT or LT only if bounds do not overlap and returns EQ otherwise. - compare (MinMax amin amax) (MinMax bmin bmax) - | amin > bmax = GT - | bmin > amax = LT - | otherwise = EQ - min (MinMax amin amax) (MinMax bmin bmax) = strictMinMax (min amin bmin) (min amax bmax) - max (MinMax amin amax) (MinMax bmin bmax) = strictMinMax (max amin bmin) (max amax bmax) - -instance (Num a, Ord a) => Num (MinMax a) where - (MinMax !x1 !y1) + (MinMax !x2 !y2) = strictMinMax (x1+x2) (y1+y2) - (MinMax !x1 !y1) - (MinMax !x2 !y2) = strictMinMax (x1-y2) (y1-x2) - (MinMax !x1 !y1) * (MinMax !x2 !y2) = strictMinMax (x1*x2) (y1*y2) - abs (MinMax !x !y) = case (abs x, abs y) of - (!ax, !ay) -> strictMinMax (min ax ay) (max ax ay) - negate (MinMax !x !y) = strictMinMax (negate y) (negate x) - signum (MinMax !x !y) = strictMinMax (signum x) (signum y) - fromInteger = minMax . fromInteger - - --- | Map each element of the structure to a monoid, --- and combine the results. --- --- This function differs from @Data.Foldable.foldMap@ in that uses @foldl'@ --- instead of @foldr@ inside. --- This makes this function suitable for Monoids with strict `mappend` operation. --- For example, --- --- > foldMap' Sum $ take 1000000000 ([1..] :: [Int]) --- --- runs in constant memory, whereas normal @foldMap@ would cause a memory leak there. -foldMap' :: (Foldable t, Monoid m) => (a -> m) -> t a -> m -foldMap' f = foldl' (flip $ mappend . f) mempty -{-# INLINE foldMap' #-} diff --git a/src/Numeric/Vector.hs b/src/Numeric/Vector.hs --- a/src/Numeric/Vector.hs +++ b/src/Numeric/Vector.hs @@ -1,184 +1,18 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -- | Vector is an alias to a DataFrame with order 1. module Numeric.Vector - ( -- * Type aliases + ( -- * Type aliases Vector , Vec2f, Vec3f, Vec4f, Vec2d, Vec3d, Vec4d , Vec2i, Vec3i, Vec4i, Vec2w, Vec3w, Vec4w + -- * Vector constructors + , Vector2 (..), Vector3 (..), Vector4 (..) + , DataFrame(Vec2, Vec3, Vec4) -- * Common operations , (.*.), dot, (·) , normL1, normL2, normLPInf, normLNInf, normLP , normalized - , vec2, vec3, vec4 , det2, cross, (×) - , unpackV2, unpackV3, unpackV4 ) where -import Numeric.DataFrame.SubSpace -import Numeric.DataFrame.Type -import Numeric.Scalar - --------------------------------------------------------------------------------- --- * Vector type --------------------------------------------------------------------------------- - -type Vector (t :: l) (n :: k) = DataFrame t '[n] - -type Vec2f = Vector Float 2 -type Vec3f = Vector Float 3 -type Vec4f = Vector Float 4 -type Vec2d = Vector Double 2 -type Vec3d = Vector Double 3 -type Vec4d = Vector Double 4 -type Vec2i = Vector Int 2 -type Vec3i = Vector Int 3 -type Vec4i = Vector Int 4 -type Vec2w = Vector Word 2 -type Vec3w = Vector Word 3 -type Vec4w = Vector Word 4 - - --- | Scalar product -- sum of Vecs' components products, --- propagated into whole Vec -(.*.) :: ( Num t - , Num (Vector t n) - , SubSpace t '[] '[n] '[n] - ) - => Vector t n -> Vector t n -> Vector t n -(.*.) a b = fromScalar . ewfoldl (+) 0 $ a * b -infixl 7 .*. - --- | Scalar product -- sum of Vecs' components products -- a scalar -dot :: ( Num t - , Num (Vector t n) - , SubSpace t '[] '[n] '[n] - ) - => Vector t n -> Vector t n -> Scalar t -dot a b = ewfoldl (+) 0 $ a * b - --- | Dot product of two vectors -infixl 7 · -(·) :: ( Num t - , Num (Vector t n) - , SubSpace t '[] '[n] '[n] - ) - => Vector t n -> Vector t n -> Scalar t -(·) = dot -{-# INLINE (·) #-} - - --- | Sum of absolute values -normL1 :: ( Num t, SubSpace t '[] '[n] '[n] ) - => Vector t n -> Scalar t -normL1 = ewfoldr (\a -> (abs a +)) 0 - --- | hypot function (square root of squares) -normL2 :: ( Floating t , SubSpace t '[] '[n] '[n] ) - => Vector t n -> Scalar t -normL2 = sqrt . ewfoldr (\a -> (a*a +)) 0 - --- | Normalize vector w.r.t. Euclidean metric (L2). -normalized :: ( Floating t , Fractional (Vector t n), SubSpace t '[] '[n] '[n] ) - => Vector t n -> Vector t n -normalized v = v / n - where - n = fromScalar . sqrt $ ewfoldr (\a -> (a*a +)) 0 v - --- | Maximum of absolute values -normLPInf :: ( Ord t, Num t , SubSpace t '[] '[n] '[n] ) - => Vector t n -> Scalar t -normLPInf = ewfoldr (max . abs) 0 - --- | Minimum of absolute values -normLNInf :: ( Ord t, Num t , SubSpace t '[] '[n] '[n] ) - => Vector t n -> Scalar t -normLNInf x = ewfoldr (min . abs) (abs $ x ! Idx 1 :* U) x - --- | Norm in Lp space -normLP :: ( Floating t , SubSpace t '[] '[n] '[n] ) - => Int -> Vector t n -> Scalar t -normLP i' = (**ri) . ewfoldr (\a -> (a**i +)) 0 - where - i = fromIntegral i' - ri = recip i -{-# INLINE [2] normLP #-} -{-# RULES -"normLP/L1" normLP 1 = normL1 -"normLP/L2" normLP 2 = normL2 - #-} - --- | Compose a 2D vector -vec2 :: SubSpace t '[] '[2] '[2] => t -> t -> Vector t 2 -vec2 a b = iwgen f - where - f (1 :* U) = scalar a - f _ = scalar b - --- | Take a determinant of a matrix composed from two 2D vectors. --- Like a cross product in 2D. -det2 :: ( Num t, SubSpace t '[] '[2] '[2] ) - => Vector t 2 -> Vector t 2 -> Scalar t -det2 a b = (a ! 1 :* U) * (b ! 2 :* U) - - (a ! 2 :* U) * (b ! 1 :* U) - --- | Compose a 3D vector -vec3 :: SubSpace t '[] '[3] '[3] => t -> t -> t -> Vector t 3 -vec3 a b c = iwgen f - where - f (1 :* U) = scalar a - f (2 :* U) = scalar b - f _ = scalar c - --- | Cross product -cross :: ( Num t, SubSpace t '[] '[3] '[3] ) - => Vector t 3 -> Vector t 3 -> Vector t 3 -cross a b = vec3 ( unScalar - $ (a ! 2 :* U) * (b ! 3 :* U) - - (a ! 3 :* U) * (b ! 2 :* U) ) - ( unScalar - $ (a ! 3 :* U) * (b ! 1 :* U) - - (a ! 1 :* U) * (b ! 3 :* U) ) - ( unScalar - $ (a ! 1 :* U) * (b ! 2 :* U) - - (a ! 2 :* U) * (b ! 1 :* U) ) - - --- | Cross product for two vectors in 3D -infixl 7 × -(×) :: ( Num t, SubSpace t '[] '[3] '[3] ) - => Vector t 3 -> Vector t 3 -> Vector t 3 -(×) = cross -{-# INLINE (×) #-} - - --- | Compose a 4D vector -vec4 :: SubSpace t '[] '[4] '[4] - => t -> t -> t -> t -> Vector t 4 -vec4 a b c d = iwgen f - where - f (1 :* U) = scalar a - f (2 :* U) = scalar b - f (3 :* U) = scalar c - f _ = scalar d - - -unpackV2 :: SubSpace t '[] '[2] '[2] - => Vector t 2 -> (t, t) -unpackV2 v = (unScalar $ v ! 1, unScalar $ v ! 2) -{-# INLINE unpackV2 #-} - - -unpackV3 :: SubSpace t '[] '[3] '[3] - => Vector t 3 -> (t, t, t) -unpackV3 v = (unScalar $ v ! 1, unScalar $ v ! 2, unScalar $ v ! 3) -{-# INLINE unpackV3 #-} - - -unpackV4 :: SubSpace t '[] '[4] '[4] - => Vector t 4 -> (t, t, t, t) -unpackV4 v = (unScalar $ v ! 1, unScalar $ v ! 2, unScalar $ v ! 3, unScalar $ v ! 4) -{-# INLINE unpackV4 #-} +import Numeric.DataFrame.Internal.Backend () +import Numeric.Vector.Internal diff --git a/src/Numeric/Vector/Internal.hs b/src/Numeric/Vector/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Vector/Internal.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Numeric.Vector.Internal + ( -- * Type aliases + Vector + , Vec2f, Vec3f, Vec4f, Vec2d, Vec3d, Vec4d + , Vec2i, Vec3i, Vec4i, Vec2w, Vec3w, Vec4w + -- * Vector constructors + , Vector2 (..), Vector3 (..), Vector4 (..) + , DataFrame(Vec2, Vec3, Vec4) + -- * Common operations + , (.*.), dot, (·) + , normL1, normL2, normLPInf, normLNInf, normLP + , normalized + , det2, cross, (×) + ) where + +import Numeric.DataFrame.SubSpace +import Numeric.DataFrame.Type +import Numeric.Scalar.Internal + + + +type Vector (t :: l) (n :: k) = DataFrame t '[n] + +type Vec2f = Vector Float 2 +type Vec3f = Vector Float 3 +type Vec4f = Vector Float 4 +type Vec2d = Vector Double 2 +type Vec3d = Vector Double 3 +type Vec4d = Vector Double 4 +type Vec2i = Vector Int 2 +type Vec3i = Vector Int 3 +type Vec4i = Vector Int 4 +type Vec2w = Vector Word 2 +type Vec3w = Vector Word 3 +type Vec4w = Vector Word 4 + + +pattern Vec4 :: Vector4 t => t -> t -> t -> t -> Vector t 4 +pattern Vec4 a b c d <- (unpackV4# -> (# a, b, c, d #)) + where + Vec4 = vec4 +{-# COMPLETE Vec4 #-} + +pattern Vec3 :: Vector3 t => t -> t -> t -> Vector t 3 +pattern Vec3 a b c <- (unpackV3# -> (# a, b, c #)) + where + Vec3 = vec3 +{-# COMPLETE Vec3 #-} + +pattern Vec2 :: Vector2 t => t -> t -> Vector t 2 +pattern Vec2 a b <- (unpackV2# -> (# a, b #)) + where + Vec2 = vec2 +{-# COMPLETE Vec2 #-} + +-- | Packing and unpacking 2D vectors +class Vector2 t where + -- | Compose a 2D vector + vec2 :: t -> t -> Vector t 2 + -- | Unpack 2D vector elements + unpackV2# :: Vector t 2 -> (# t, t #) + +-- | Packing and unpacking 3D vectors +class Vector3 t where + -- | Compose a 3D vector + vec3 :: t -> t -> t -> Vector t 3 + -- | Unpack 3D vector elements + unpackV3# :: Vector t 3 -> (# t, t, t #) + +-- | Packing and unpacking 4D vectors +class Vector4 t where + -- | Compose a 4D vector + vec4 :: t -> t -> t -> t -> Vector t 4 + -- | Unpack 4D vector elements + unpackV4# :: Vector t 4 -> (# t, t, t, t #) + +instance {-# OVERLAPPABLE #-} SubSpace t '[2] '[] '[2] => Vector2 t where + vec2 a b = iwgen f + where + f (0 :* U) = scalar a + f _ = scalar b + {-# INLINE vec2 #-} + unpackV2# v = + (# unScalar (indexOffset# 0# v) + , unScalar (indexOffset# 1# v) #) + {-# INLINE unpackV2# #-} + +instance {-# OVERLAPPABLE #-} SubSpace t '[3] '[] '[3] => Vector3 t where + vec3 a b c = iwgen f + where + f (0 :* U) = scalar a + f (1 :* U) = scalar b + f _ = scalar c + {-# INLINE vec3 #-} + unpackV3# v = + (# unScalar (indexOffset# 0# v) + , unScalar (indexOffset# 1# v) + , unScalar (indexOffset# 2# v) #) + {-# INLINE unpackV3# #-} + +instance {-# OVERLAPPABLE #-} SubSpace t '[4] '[] '[4] => Vector4 t where + vec4 a b c d = iwgen f + where + f (0 :* U) = scalar a + f (1 :* U) = scalar b + f (2 :* U) = scalar c + f _ = scalar d + {-# INLINE vec4 #-} + unpackV4# v = + (# unScalar (indexOffset# 0# v) + , unScalar (indexOffset# 1# v) + , unScalar (indexOffset# 2# v) + , unScalar (indexOffset# 3# v) #) + {-# INLINE unpackV4# #-} + + + +-- | Scalar product -- sum of Vecs' components products, +-- propagated into whole Vec +(.*.) :: ( Num t + , Num (Vector t n) + , SubSpace t '[n] '[] '[n] + ) + => Vector t n -> Vector t n -> Vector t n +(.*.) a b = fromScalar . ewfoldl (+) 0 $ a * b +infixl 7 .*. + +-- | Scalar product -- sum of Vecs' components products -- a scalar +dot :: ( Num t + , Num (Vector t n) + , SubSpace t '[n] '[] '[n] + ) + => Vector t n -> Vector t n -> Scalar t +dot a b = ewfoldl (+) 0 $ a * b + +-- | Dot product of two vectors +infixl 7 · +(·) :: ( Num t + , Num (Vector t n) + , SubSpace t '[n] '[] '[n] + ) + => Vector t n -> Vector t n -> Scalar t +(·) = dot +{-# INLINE (·) #-} + + +-- | Sum of absolute values +normL1 :: ( Num t, SubSpace t '[n] '[] '[n] ) + => Vector t n -> Scalar t +normL1 = ewfoldr (\a -> (abs a +)) 0 + +-- | hypot function (square root of squares) +normL2 :: ( Floating t , SubSpace t '[n] '[] '[n] ) + => Vector t n -> Scalar t +normL2 = sqrt . ewfoldr (\a -> (a*a +)) 0 + +-- | Normalize vector w.r.t. Euclidean metric (L2). +normalized :: ( Floating t , Fractional (Vector t n), SubSpace t '[n] '[] '[n] ) + => Vector t n -> Vector t n +normalized v = v / n + where + n = fromScalar . sqrt $ ewfoldr (\a -> (a*a +)) 0 v + +-- | Maximum of absolute values +normLPInf :: ( Ord t, Num t , SubSpace t '[n] '[] '[n] ) + => Vector t n -> Scalar t +normLPInf = ewfoldr (max . abs) 0 + +-- | Minimum of absolute values +normLNInf :: ( Ord t, Num t , SubSpace t '[n] '[] '[n] ) + => Vector t n -> Scalar t +normLNInf x = ewfoldr (min . abs) (scalar . abs $ ixOff 0 x) x + +-- | Norm in Lp space +normLP :: ( Floating t , SubSpace t '[n] '[] '[n] ) + => Int -> Vector t n -> Scalar t +normLP i' = (**ri) . ewfoldr (\a -> (a**i +)) 0 + where + i = fromIntegral i' + ri = recip i +{-# INLINE [2] normLP #-} +{-# RULES +"normLP/L1" normLP 1 = normL1 +"normLP/L2" normLP 2 = normL2 + #-} + +-- | Take a determinant of a matrix composed from two 2D vectors. +-- Like a cross product in 2D. +det2 :: ( Num t, SubSpace t '[2] '[] '[2] ) + => Vector t 2 -> Vector t 2 -> Scalar t +det2 a b = (a ! 0 :* U) * (b ! 1 :* U) + - (a ! 1 :* U) * (b ! 0 :* U) + +-- | Cross product +cross :: ( Num t, SubSpace t '[3] '[] '[3] ) + => Vector t 3 -> Vector t 3 -> Vector t 3 +cross a b = vec3 ( unScalar + $ (a ! 1 :* U) * (b ! 2 :* U) + - (a ! 2 :* U) * (b ! 1 :* U) ) + ( unScalar + $ (a ! 2 :* U) * (b ! 0 :* U) + - (a ! 0 :* U) * (b ! 2 :* U) ) + ( unScalar + $ (a ! 0 :* U) * (b ! 1 :* U) + - (a ! 1 :* U) * (b ! 0 :* U) ) + + +-- | Cross product for two vectors in 3D +infixl 7 × +(×) :: ( Num t, SubSpace t '[3] '[] '[3] ) + => Vector t 3 -> Vector t 3 -> Vector t 3 +(×) = cross +{-# INLINE (×) #-} diff --git a/test/Numeric/DataFrame/Arbitraries.hs b/test/Numeric/DataFrame/Arbitraries.hs --- a/test/Numeric/DataFrame/Arbitraries.hs +++ b/test/Numeric/DataFrame/Arbitraries.hs @@ -1,61 +1,114 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Provide instance of Arbitrary for all DataFrame types. -- Also, this module is an example of fancy type inference and DataFrame -- traversals with monadic actions. module Numeric.DataFrame.Arbitraries where -import Test.QuickCheck +import Test.QuickCheck +import Data.Kind (Type) +import Data.Semigroup hiding (All) import Numeric.DataFrame import Numeric.Dimensions -import Numeric.PrimBytes +import Numeric.Quaternion +import qualified Numeric.Tuple.Lazy as LT +import qualified Numeric.Tuple.Strict as ST -instance (Arbitrary t, PrimBytes t, Dimensions ds) + +maxDims :: Word +maxDims = 5 + +maxDimSize :: Word +maxDimSize = 7 + +fromScalarChanceFactor :: Int +fromScalarChanceFactor = 5 + + +instance (Quaternion t, Arbitrary t, Num t) => Arbitrary (Quater t) where + arbitrary = sequence + [ Quater <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Quater <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Quater <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Quater <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Quater <$> arbitrary <*> pure 0 <*> pure 0 <*> pure 0 + , Quater <$> pure 0 <*> arbitrary <*> pure 0 <*> pure 0 + , Quater <$> pure 0 <*> pure 0 <*> arbitrary <*> pure 0 + , Quater <$> pure 0 <*> pure 0 <*> pure 0 <*> arbitrary + , Quater <$> arbitrary <*> arbitrary <*> pure 0 <*> pure 0 + , Quater <$> arbitrary <*> pure 0 <*> arbitrary <*> pure 0 + , Quater <$> arbitrary <*> pure 0 <*> pure 0 <*> arbitrary + , Quater <$> pure 0 <*> arbitrary <*> arbitrary <*> pure 0 + , Quater <$> pure 0 <*> arbitrary <*> pure 0 <*> arbitrary + , Quater <$> pure 0 <*> pure 0 <*> arbitrary <*> arbitrary + , Quater <$> arbitrary <*> arbitrary <*> arbitrary <*> pure 0 + , Quater <$> arbitrary <*> arbitrary <*> pure 0 <*> arbitrary + , Quater <$> arbitrary <*> pure 0 <*> arbitrary <*> arbitrary + , Quater <$> pure 0 <*> arbitrary <*> arbitrary <*> arbitrary + ] >>= elements + + shrink (Quater x y z t) + -- shrink either real or the whole imaginary part + = ($) <$> zipWith3 Quater (shrink x) (shrink y) (shrink z) <*> shrink t + + + +instance (Arbitrary t, PrimBytes t, Num t, Ord t, Dimensions ds) => Arbitrary (DataFrame t (ds :: [Nat])) where arbitrary | -- First, we need to find out exact array implementation to use -- inside this DataFrame. -- We need to do that whenever exact value of ds is not known - E <- inferASing' @t @ds - -- Then, we need to get basic byte manipulation type classes, such as - -- PrimBytes and PrimArray. - , E <- inferPrim' @t @ds + Dict <- inferKnownBackend @t @ds -- After that, GHC can infer all necessary fancy things like SubSpace -- to do complex operations on sub-dimensions of a DataFrame. -- -- Note, we could put SubSpace into constraints of this instance as well. -- That would render the above lines unnecessary, but would make -- inference more difficult later. - = arbitrary >>= elementWise @_ @_ @ds f . ewgen . scalar + = do + full <- (1 < ) <$> choose (1, fromScalarChanceFactor) + if full -- I want to check fromScalar code path sometimes + then arbitrary >>= elementWise @_ @ds @'[] f . ewgen . scalar + else fromScalar . scalar <$> arbitrary where f :: Arbitrary a => Scalar a -> Gen (Scalar a) f _ = scalar <$> arbitrary - shrink - | E <- inferASing' @t @ds - , E <- inferPrim' @t @ds - = elementWise @_ @_ @ds f - where - -- Unfortunately, Scalar is not a proper second-rank data type - -- (it is just type alias for DataFrame t []). - -- So it cannot be functor or traversable. - f :: Arbitrary a => Scalar a -> [Scalar a] - f = fmap scalar . shrink . unScalar + shrink df + | Dict <- inferKnownBackend @t @ds + , mma <- ewfoldMap @t @ds @'[] @ds + ((\x -> if x == 0 then Nothing else Just (Max x)) . abs) df + = case mma of + Nothing + -> [] -- all-zero is the most primitive DF possible + Just (Max ma) + -> [ ewmap (\x -> if abs x == ma then 0 else x) df + , ewmap (scalar . withAbs . unScalar) df + ] + where + withAbs :: t -> t + withAbs x + | abs x <= 1 = 0 + | otherwise = signum x * closest2 (abs x) 1 + closest2 :: t -> t -> t + closest2 x b = if x <= b * 2 then b else closest2 x (b*2) -instance (All Arbitrary ts, All PrimBytes ts, RepresentableList ts, Dimensions ds) +instance ( All Arbitrary ts, All PrimBytes ts, All Num ts, All Ord ts + , RepresentableList ts, Dimensions ds) => Arbitrary (DataFrame ts (ds :: [Nat])) where -- We create arbitrary MultiFrame by combining several SingleFrames. -- SingleFrames are "variables" or "columns" of a MultiFrame that are @@ -71,28 +124,22 @@ at <- arbitrary ats' <- arbitrary @(DataFrame ts' ds) return (at :*: ats') - shrink Z = [] -- MultiFrame is a newtype wrapper on a TypedList. -- Thus, we can always recover RepresentableList ts by using function @types@ shrink (at :*: ats@(MultiFrame ats')) | TypeList <- types ats' = (:*:) <$> shrink at <*> shrink ats + shrink _ = [] -maxDims :: Word -maxDims = 5 - -maxDimSize :: Word -maxDimSize = 7 - instance KnownDim a => Arbitrary (Dim (N a)) where - arbitrary = return $ Dn (dim @_ @a) + arbitrary = return $ Dn (dim @a) shrink _ = [] instance KnownDim m => Arbitrary (Dim (XN m)) where arbitrary = do dimN <- choose (dimVal' @m, maxDims) - case constrain @m (someDimVal dimN) of + case constrainDim @XNat @(XN m) (someDimVal dimN) of Nothing -> error "impossible argument" Just d -> return d shrink _ = [] @@ -117,42 +164,111 @@ arbitrary = (:*) <$> arbitrary <*> arbitrary shrink _ = [] -instance (Arbitrary t, PrimBytes t) +instance (Arbitrary t, PrimBytes t, Num t, Ord t) => Arbitrary (SomeDataFrame t) where arbitrary = do -- Generate random dimension list + SomeDims ds <- arbitrary -- and pattern-match against it with Dims pattern. -- This gives Dimensions ds evidence immediately. - SomeDims (Dims :: Dims ds) <- arbitrary - -- We also need to figure out an array implementation... - case inferASing' @t @ds of - -- ... and generating a random DataFrame becomes a one-liner - E -> SomeDataFrame <$> arbitrary @(DataFrame t ds) - shrink _ = [] + case ds of + -- We also need to figure out an array implementation... + (Dims :: Dims ds) -> case inferKnownBackend @t @ds of + -- ... and generating a random DataFrame becomes a one-liner + Dict -> SomeDataFrame <$> arbitrary @(DataFrame t ds) + shrink (SomeDataFrame df) = SomeDataFrame <$> shrink df -- All same as above, just change constraints a bit -instance (All Arbitrary ts, All PrimBytes ts, RepresentableList ts) +instance ( All Arbitrary ts, All PrimBytes ts, All Num ts, All Ord ts + , RepresentableList ts) => Arbitrary (SomeDataFrame ts) where arbitrary = do - SomeDims (Dims :: Dims ds) <- arbitrary - case inferASing' @ts @ds of - E -> SomeDataFrame <$> arbitrary @(DataFrame ts ds) - shrink _ = [] + SomeDims ds <- arbitrary + case ds of + (Dims :: Dims ds) -> case inferKnownBackend @ts @ds of + Dict -> SomeDataFrame <$> arbitrary @(DataFrame ts ds) + shrink (SomeDataFrame df) = SomeDataFrame <$> shrink df -instance ( Arbitrary t, PrimBytes t +instance ( Arbitrary t, PrimBytes t, Num t, Ord t , Arbitrary (Dims xs), All KnownXNatType xs) => Arbitrary (DataFrame t (xs :: [XNat])) where arbitrary = do - XDims (_ :: Dims ds) <- arbitrary @(Dims xs) - case inferASing' @t @ds of - E -> XFrame <$> arbitrary @(DataFrame t ds) + ds <- arbitrary @(Dims xs) + case ds of + XDims (_ :: Dims ds) -> case inferKnownBackend @t @ds of + Dict -> XFrame <$> arbitrary @(DataFrame t ds) shrink (XFrame df) = XFrame <$> shrink df -instance ( All Arbitrary ts, All PrimBytes ts, RepresentableList ts +instance ( All Arbitrary ts, All PrimBytes ts, All Num ts, All Ord ts + , RepresentableList ts , Arbitrary (Dims xs), All KnownXNatType xs) => Arbitrary (DataFrame ts (xs :: [XNat])) where arbitrary = do - XDims (_ :: Dims ds) <- arbitrary @(Dims xs) - case inferASing' @ts @ds of - E -> XFrame <$> arbitrary @(DataFrame ts ds) + ds <- arbitrary @(Dims xs) + case ds of + XDims (_ :: Dims ds) -> case inferKnownBackend @ts @ds of + Dict -> XFrame <$> arbitrary @(DataFrame ts ds) shrink (XFrame df) = XFrame <$> shrink df + + +instance KnownDim n => Arbitrary (Idx n) where + arbitrary = elements [0..] + +instance Dimensions ns => Arbitrary (Idxs ns) where + arbitrary = go (Dims @ns) + where + go :: forall (bs :: [Nat]) . Dims bs -> Gen (Idxs bs) + go U = pure U + go (D :* bs) = (:*) <$> arbitrary <*> go bs + +instance (RepresentableList xs, All Arbitrary xs) => Arbitrary (ST.Tuple xs) where + arbitrary = go (tList @Type @xs) + where + go :: forall (bs :: [Type]) + . All Arbitrary bs + => TypeList bs -> Gen (ST.Tuple bs) + go U = pure U + go (_ :* bs) = (ST.:$) <$> arbitrary <*> go bs + +instance (RepresentableList xs, All Arbitrary xs) => Arbitrary (LT.Tuple xs) where + arbitrary = go (tList @Type @xs) + where + go :: forall (bs :: [Type]) + . All Arbitrary bs + => TypeList bs -> Gen (LT.Tuple bs) + go U = pure U + go (_ :* bs) = (LT.:$) <$> arbitrary <*> go bs + +data AnyMatrix +data NonSingular + +data SomeSquareMatrix prop t + = forall (n :: Nat) + . (KnownDim n, KnownBackend t '[n], KnownBackend t '[n, n]) + => SSM (DataFrame t '[n,n]) + +instance (Show t, PrimBytes t) => Show (SomeSquareMatrix prop t) where + show (SSM df) = show df + +instance (Arbitrary t, PrimBytes t, Num t, Ord t) + => Arbitrary (SomeSquareMatrix AnyMatrix t) where + arbitrary = do + dx <- arbitrary @(Dim (XN 2)) + case dx of + Dx (D :: Dim n) -> case inferKnownBackend @t @'[n] of + Dict -> SSM <$> arbitrary @(DataFrame t '[n,n]) + shrink (SSM df)= SSM <$> shrink df + +instance (Arbitrary t, PrimBytes t, Num t, Ord t) + => Arbitrary (SomeSquareMatrix NonSingular t) where + arbitrary = do + SSM (someMat :: DataFrame t '[n, n]) <- arbitrary @(SomeSquareMatrix AnyMatrix t) + -- https://en.wikipedia.org/wiki/Diagonally_dominant_matrix + return . SSM $ + iwmap @t @'[n] @'[n] @'[n,n] + @t @'[n] @'[n,n] + ( \i v -> + let s = ewfoldl (\a -> (a +) . abs) 1 v + in update i s v + ) someMat + shrink _ = [] diff --git a/test/Numeric/DataFrame/BasicTest.hs b/test/Numeric/DataFrame/BasicTest.hs --- a/test/Numeric/DataFrame/BasicTest.hs +++ b/test/Numeric/DataFrame/BasicTest.hs @@ -15,7 +15,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -26,38 +26,112 @@ module Numeric.DataFrame.BasicTest (runTests) where import Numeric.DataFrame -import Numeric.DataFrame.Arbitraries () -import Numeric.Dimensions +import Numeric.DataFrame.Arbitraries () +import qualified Numeric.ProductOrd.NonTransitive as NonTransitive +import qualified Numeric.ProductOrd.Partial as Partial import Test.QuickCheck +{-# ANN module "HLint: ignore Use <" #-} +{-# ANN module "HLint: ignore Use >" #-} +{-# ANN module "HLint: ignore Use >=" #-} +{-# ANN module "HLint: ignore Use <=" #-} +{-# ANN module "HLint: ignore Redundant compare" #-} -prop_Comparisons :: SomeDataFrame '[Float, Float] -> Bool -prop_Comparisons (SomeDataFrame (x :*: y :*: Z)) - | E <- inferOrd x - , E <- inferFractional x - = and - [ abs x >= abs x / 2 - , abs x <= abs x + abs y - , x <= x, x <= x - , x >= x, y >= y - , x == x, y == y - , x < x + 1, x > x - 1 - , abs x >= x, abs (-x) >= (-x) - , x > y ===> x >= y - , x < y ===> x <= y - , not (x >= y) ===> not (x > y) - , not (x <= y) ===> not (x < y) - , x == y ===> and [ not (x > y), not (y < x), x >= y, y <= x ] - , x >= y && x <= y ===> x == y +(===>) :: Bool -> Bool -> Bool +a ===> b = not a || b +infix 2 ===> + +prop_vanillaOrdTransitivity :: SomeDataFrame '[Double, Double, Double] -> Property +prop_vanillaOrdTransitivity (SomeDataFrame (x :*: y :*: z :*: Z)) + = property $ (x <= y) && (y <= z) ===> x <= z + +vanillaOrdComparisons :: Ord t => t -> t -> Property +vanillaOrdComparisons x y + = conjoin + [ counterexample "(x < y) == (compare x y == LT)" + $ (x < y) == (compare x y == LT) + , counterexample "(x > y) == (compare x y == GT)" + $ (x > y) == (compare x y == GT) + , counterexample "(x == y) == (compare x y == EQ)" + $ (x == y) == (compare x y == EQ) + , counterexample "min x y == if x <= y then x else y" + $ min x y == if x <= y then x else y + , counterexample "max x y == if x >= y then x else y" + $ max x y == if x >= y then x else y ] - where - a ===> b = not a || b - infix 2 ===> + +comparisons :: (Ord t, Num t) => t -> t -> Property +comparisons x y + = conjoin + [ counterexample "abs x <= abs x + abs y" $ abs x <= abs x + abs y + , counterexample "x <= x" $ x <= x + , counterexample "y <= y" $ y <= y + , counterexample "x >= x" $ x >= x + , counterexample "y >= y" $ y >= y + , counterexample "x == x" $ x == x + , counterexample "y == y" $ y == y + , counterexample "(x > y) == (y < x)" + $ (x > y) == (y < x) + , counterexample "(x >= y) == (y <= x)" + $ (x >= y) == (y <= x) + , counterexample "(x < y) == (x <= y && x /= y)" + $ (x < y) == (x <= y && x /= y) + , counterexample "(x > y) == (x >= y && x /= y)" + $ (x > y) == (x >= y && x /= y) + , counterexample "x < x + 1" $ abs x < 10000000 ===> x < x + 1 + , counterexample "x > x - 1" $ abs x < 10000000 ===> x > x - 1 + , counterexample "abs x >= x" $ abs x >= x + , counterexample "abs (-x) >= (-x)" $ abs (-x) >= (-x) + , counterexample "x > y ==> x >= y" + $ x > y ===> x >= y + , counterexample "x < y ==> x <= y" + $ x < y ===> x <= y + , counterexample "not (x >= y) ==> not (x > y)" + $ not (x >= y) ===> not (x > y) + , counterexample "not (x <= y) ==> not (x < y)" + $ not (x <= y) ===> not (x < y) + , counterexample "x == y ==> not GT or LT, but GE and LE" + $ x == y ===> and [ not (x > y), not (y < x), x >= y, y <= x ] + , counterexample "x >= y && x <= y ==> x == y" + $ x >= y && x <= y ===> x == y + ] + +prop_comparisonsVanillaOrdFloat :: SomeDataFrame '[Float, Float] -> Property +prop_comparisonsVanillaOrdFloat (SomeDataFrame (x :*: y :*: Z)) = + comparisons x y .&&. vanillaOrdComparisons x y +prop_comparisonsVanillaOrdDouble :: SomeDataFrame '[Double, Double] -> Property +prop_comparisonsVanillaOrdDouble (SomeDataFrame (x :*: y :*: Z)) = + comparisons x y .&&. vanillaOrdComparisons x y +prop_comparisonsVanillaOrdInt :: SomeDataFrame '[Int, Int] -> Property +prop_comparisonsVanillaOrdInt (SomeDataFrame (x :*: y :*: Z)) = + comparisons x y .&&. vanillaOrdComparisons x y + + +prop_comparisonsPPOrdFloat :: SomeDataFrame '[Float, Float] -> Property +prop_comparisonsPPOrdFloat (SomeDataFrame (x :*: y :*: Z)) + = comparisons (Partial.ProductOrd x) (Partial.ProductOrd y) +prop_comparisonsPPOrdDouble :: SomeDataFrame '[Double, Double] -> Property +prop_comparisonsPPOrdDouble (SomeDataFrame (x :*: y :*: Z)) + = comparisons (Partial.ProductOrd x) (Partial.ProductOrd y) +prop_comparisonsPPOrdInt :: SomeDataFrame '[Int, Int] -> Property +prop_comparisonsPPOrdInt (SomeDataFrame (x :*: y :*: Z)) + = comparisons (Partial.ProductOrd x) (Partial.ProductOrd y) + + +prop_comparisonsNTPOrdFloat :: SomeDataFrame '[Float, Float] -> Property +prop_comparisonsNTPOrdFloat (SomeDataFrame (x :*: y :*: Z)) + = comparisons (NonTransitive.ProductOrd x) (NonTransitive.ProductOrd y) +prop_comparisonsNTPOrdDouble :: SomeDataFrame '[Double, Double] -> Property +prop_comparisonsNTPOrdDouble (SomeDataFrame (x :*: y :*: Z)) + = comparisons (NonTransitive.ProductOrd x) (NonTransitive.ProductOrd y) +prop_comparisonsNTPOrdInt :: SomeDataFrame '[Int, Int] -> Property +prop_comparisonsNTPOrdInt (SomeDataFrame (x :*: y :*: Z)) + = comparisons (NonTransitive.ProductOrd x) (NonTransitive.ProductOrd y) + + prop_Numeric :: SomeDataFrame '[Int, Int] -> Bool prop_Numeric (SomeDataFrame (x :*: y :*: Z)) - | E <- inferOrd x - , E <- inferNum x = and [ x + x == 2 * x , x + y == y + x @@ -70,9 +144,7 @@ prop_Floating :: SomeDataFrame '[Double, Double] -> Bool prop_Floating (SomeDataFrame (x :*: y :*: Z)) - | E <- inferOrd x - , E <- inferFloating x - , lx <- log (0.01 + abs x) + | lx <- log (0.01 + abs x) , ly <- log (0.01 + abs y) , eps <- 0.001 = all ((eps >=) . abs) @@ -85,5 +157,6 @@ return [] -runTests :: IO Bool -runTests = $quickCheckAll +runTests :: Int -> IO Bool +runTests n = $forAllProperties + $ quickCheckWithResult stdArgs { maxSuccess = n } diff --git a/test/Numeric/DataFrame/SubSpaceTest.hs b/test/Numeric/DataFrame/SubSpaceTest.hs --- a/test/Numeric/DataFrame/SubSpaceTest.hs +++ b/test/Numeric/DataFrame/SubSpaceTest.hs @@ -8,10 +8,10 @@ module Numeric.DataFrame.SubSpaceTest (runTests) where -import Numeric.DataFrame -import Numeric.DataFrame.Arbitraries () -import Numeric.Dimensions -import Test.QuickCheck +import Numeric.DataFrame +import Numeric.DataFrame.Arbitraries () +import Numeric.Dimensions +import Test.QuickCheck type SFull = '[2,5,4,3,7] type SPref = '[2,5,4] @@ -19,31 +19,31 @@ prop_IndexDimMax :: DataFrame Int SPref -> DataFrame Int SSuff -> Bool prop_IndexDimMax x y = - ((maxBound `inSpaceOf` y) !. z) == x + (z ! (maxBound `inSpaceOf` x)) == y where - z = ewgen x :: DataFrame Int SFull + z = ewgen y :: DataFrame Int SFull -prop_IndexCustom1 :: DataFrame Word SPref -> Bool -prop_IndexCustom1 x = (1:*3 !. z) == x +prop_IndexCustom1 :: DataFrame Word SSuff -> Bool +prop_IndexCustom1 x = (z ! 1:*3:*2) == x where z = ewgen x :: DataFrame Word SFull - -prop_IndexCustom2 :: DataFrame Double SPref -> Bool -prop_IndexCustom2 x = (2:*2 !. z) %* eye == x - where - z = ewgen x :: DataFrame Double SFull +-- TODO:! +-- prop_IndexCustom2 :: DataFrame Double SSuff -> Bool +-- prop_IndexCustom2 x = (z ! 2:*2:*1) %* eye == x +-- where +-- z = ewgen x :: DataFrame Double SFull -prop_Foldlr :: DataFrame Double SPref -> Bool +prop_Foldlr :: DataFrame Double SSuff -> Bool prop_Foldlr x = abs (ewfoldl (+) 10 z - ewfoldr @_ @SPref (+) 0 z - 10) <= fromScalar (zmax * 0.0001) where z = ewgen x :: DataFrame Double SFull - zmax = ewfoldl @Double @'[] @SFull (max . abs) 0.001 z + zmax = ewfoldl @Double @SFull @'[] (max . abs) 0.001 z prop_Ewmap :: DataFrame Double SFull -> Bool -prop_Ewmap x = x * 2 == ewmap @_ @'[Head SFull] (*2) x +prop_Ewmap x = x * 2 == ewmap @_ @_ @'[Last SFull] (*2) x prop_ProdTranspose :: DataFrame Double '[2,6] -> DataFrame Double '[6,7] -> Bool prop_ProdTranspose x y = transpose (x %* y) == transpose y %* transpose x @@ -52,5 +52,6 @@ prop_Eye x = eye %* x == x && x %* eye == x return [] -runTests :: IO Bool -runTests = $quickCheckAll +runTests :: Int -> IO Bool +runTests n = $forAllProperties + $ quickCheckWithResult stdArgs { maxSuccess = n } diff --git a/test/Numeric/MatrixDoubleTest.hs b/test/Numeric/MatrixDoubleTest.hs --- a/test/Numeric/MatrixDoubleTest.hs +++ b/test/Numeric/MatrixDoubleTest.hs @@ -10,146 +10,161 @@ module Numeric.MatrixDoubleTest (runTests) where -import Data.Fixed -import Numeric.DataFrame -import Numeric.DataFrame.Arbitraries () -import Numeric.DataFrame.Internal.Array.Class -import Numeric.Dimensions -import Numeric.PrimBytes -import Test.QuickCheck +import Data.Fixed +import Data.Semigroup +import Numeric.DataFrame +import Numeric.DataFrame.Arbitraries +import Numeric.Dimensions +import Test.QuickCheck -eps :: Scd -eps = 0.0000001 +type TestElem = Double +type TestDF = DataFrame TestElem -dropW :: (SubSpace t '[] '[3] '[3], SubSpace t '[] '[4] '[4]) => Vector t 4 -> Vector t 3 -dropW v | (x,y,z,_) <- unpackV4 v = vec3 x y z +eps :: Scalar TestElem +eps = 0.000000001 +dropW :: (SubSpace t '[3] '[] '[3], SubSpace t '[4] '[] '[4]) + => Vector t 4 -> Vector t 3 +dropW (Vec4 x y z _) = Vec3 x y z + +-- | Most of the time, the error is proportional to the maginutude of the biggest element +maxElem :: (SubSpace TestElem ds '[] ds) + => TestDF (ds :: [Nat]) -> Scalar TestElem +maxElem = ewfoldl (\a -> max a . abs) 0 + +-- | For operations like @det@, the error is proportional to maximum possible product +-- over rows or columns +maxRows :: forall ds + . (SubSpace TestElem '[Head ds] (Tail ds) ds) + => TestDF (ds :: [Nat]) -> Scalar TestElem +maxRows = getProduct . ewfoldMap @_ @'[Head ds] @(Tail ds) @ds (Product . maxElem) + approxEq :: - forall (ds :: [Nat]). + forall (ds :: [Nat]) . ( Dimensions ds, - Num (DataFrame Double ds), - PrimBytes (DataFrame Double ds), - PrimArray Double (DataFrame Double ds) + Num (TestDF ds), + PrimBytes (TestDF ds), + PrimArray TestElem (TestDF ds) ) => - DataFrame Double ds -> DataFrame Double ds -> Bool -approxEq a b = (eps >=) . ewfoldl @_ @'[] max 0 . abs $ a - b + TestDF ds -> TestDF ds -> Bool +approxEq a b = maxElem (a - b) <= eps * m + where + m = maxElem a `max` maxElem b infix 4 `approxEq` -prop_detTranspose :: Matrix '[Double, Double] (XN 2) (XN 2) -> Bool -prop_detTranspose (XFrame (x :*: y :*: Z)) - | -- infer KnownDim for both dimensions of matrix x (and y) - KnownDims <- dims `inSpaceOf` x - = let m = diag (ewfoldl max 0 $ abs x) + x %* transpose y - a = det m +prop_detTranspose :: SomeSquareMatrix AnyMatrix TestElem -> Property +prop_detTranspose (SSM m) + = let a = det m b = det $ transpose m - in abs (a - b) / (abs a + abs b + 1) <= eps + n = (case dims `inSpaceOf` m of dn :* _ -> dimVal dn) :: Word + mag = eps * maxRows m * fromIntegral (product [1..n]) + in counterexample + (unlines + [ "failed det/transpose:" + , "m: " ++ show m + , "mT: " ++ show (transpose m) + , show a ++ " /= " ++ show b + ++ " (tolerance: " ++ show mag ++ ")." + ] + ) $ abs (a - b) <= mag -prop_inverse :: Matrix '[Double, Double] (XN 2) (XN 2) -> Bool -prop_inverse (XFrame (x :*: y :*: Z)) - | -- infer KnownDim for both dimensions of matrix x (and y) - (KnownDims :: Dims ns) <- dims `inSpaceOf` x - -- cumbersose inverse instance requires PrimBytes (Vector t n) - , E <- inferASing' @Double @'[Head ns] - , E <- inferPrim' @Double @'[Head ns] - = let m = diag base + x %* transpose y - mi = inverse m - err a b = ewfoldl max 0 (abs (b - a)) / base - base = ewfoldl max 0.5 (abs x) + ewfoldl max 0.5 (abs y) - in err eye (m %* mi) <= eps - && err eye (mi %* m) <= eps +prop_inverse :: SomeSquareMatrix NonSingular TestElem -> Property +prop_inverse (SSM m) + = let mi = inverse m + aeq a b = maxElem (b - a) <= eps * maxRows m + in counterexample ("failed inverse:" ++ + show (m, mi, m %* mi, mi %* m)) $ + aeq eye (m %* mi) && aeq eye (mi %* m) -prop_LU :: Matrix '[Double, Double] (XN 2) (XN 2) -> Bool -prop_LU (XFrame (x :*: y :*: Z)) - | -- infer KnownDim for both dimensions of matrix x (and y) - (KnownDims :: Dims ns) <- dims `inSpaceOf` x - -- cumbersose inverse instance requires PrimBytes (Vector t n) - , E <- inferASing' @Double @'[Head ns] - , E <- inferPrim' @Double @'[Head ns] - = let m = diag base + x %* transpose y - f = lu m - err a b = ewfoldl max 0 (abs (b - a)) / base - base = ewfoldl max 0.5 (abs x) + ewfoldl max 0.5 (abs y) - in err (luPerm f %* m) (luLower f %* luUpper f) <= eps +prop_LU :: SomeSquareMatrix NonSingular TestElem -> Bool +prop_LU (SSM m) + = let f = lu m + aeq a b = maxElem (b - a) <= eps * maxRows m + in aeq (luPerm f %* m) (luLower f %* luUpper f) -prop_translate3vs4 :: Vector Double 4 -> Bool +prop_translate3vs4 :: Vector TestElem 4 -> Bool prop_translate3vs4 v = translate4 v == translate3 (dropW v) - -prop_translate4 :: Vector Double 4 -> Vector Double 3 -> Bool -prop_translate4 a b = translate4 a %* toHomPoint b == toHomPoint (dropW a + b) -prop_translate3 :: Vector Double 3 -> Vector Double 3 -> Bool -prop_translate3 a b = translate3 a %* toHomPoint b == toHomPoint (a + b) +prop_translate4 :: Vector TestElem 4 -> Vector TestElem 3 -> Bool +prop_translate4 a b = toHomPoint b %* translate4 a == toHomPoint (dropW a + b) -prop_rotateX :: Vector Double 4 -> Bool -prop_rotateX v | (x,y,z,w) <- unpackV4 v = - and [ - rotateX (-2 * pi) %* v `approxEq` v, - rotateX (-1.5 * pi) %* v `approxEq` vec4 x (-z) y w, - rotateX (-pi) %* v `approxEq` vec4 x (-y) (-z) w, - rotateX (-0.5 * pi) %* v `approxEq` vec4 x z (-y) w, - rotateX 0 %* v `approxEq` v, - rotateX (0.5 * pi) %* v `approxEq` vec4 x (-z) y w, - rotateX pi %* v `approxEq` vec4 x (-y) (-z) w, - rotateX (1.5 * pi) %* v `approxEq` vec4 x z (-y) w, - rotateX (2 * pi) %* v `approxEq` v +prop_translate3 :: Vector TestElem 3 -> Vector TestElem 3 -> Bool +prop_translate3 a b = toHomPoint b %* translate3 a == toHomPoint (a + b) + +prop_rotateX :: Vector TestElem 4 -> Property +prop_rotateX v@(Vec4 x y z w) = + conjoin [ + v %* rotateX (-2 * pi) `approxEq` v, + v %* rotateX (-1.5 * pi) `approxEq` vec4 x (-z) y w, + v %* rotateX (-pi) `approxEq` vec4 x (-y) (-z) w, + v %* rotateX (-0.5 * pi) `approxEq` vec4 x z (-y) w, + v %* rotateX 0 `approxEq` v, + v %* rotateX (0.5 * pi) `approxEq` vec4 x (-z) y w, + v %* rotateX pi `approxEq` vec4 x (-y) (-z) w, + v %* rotateX (1.5 * pi) `approxEq` vec4 x z (-y) w, + v %* rotateX (2 * pi) `approxEq` v ] -prop_rotateY :: Vector Double 4 -> Bool -prop_rotateY v | (x,y,z,w) <- unpackV4 v = - and [ - rotateY (-2 * pi) %* v `approxEq` v, - rotateY (-1.5 * pi) %* v `approxEq` vec4 z y (-x) w, - rotateY (-pi) %* v `approxEq` vec4 (-x) y (-z) w, - rotateY (-0.5 * pi) %* v `approxEq` vec4 (-z) y x w, - rotateY 0 %* v `approxEq` v, - rotateY (0.5 * pi) %* v `approxEq` vec4 z y (-x) w, - rotateY pi %* v `approxEq` vec4 (-x) y (-z) w, - rotateY (1.5 * pi) %* v `approxEq` vec4 (-z) y x w, - rotateY (2 * pi) %* v `approxEq` v +prop_rotateY :: Vector TestElem 4 -> Property +prop_rotateY v@(Vec4 x y z w) = + conjoin [ + v %* rotateY (-2 * pi) `approxEq` v, + v %* rotateY (-1.5 * pi) `approxEq` vec4 z y (-x) w, + v %* rotateY (-pi) `approxEq` vec4 (-x) y (-z) w, + v %* rotateY (-0.5 * pi) `approxEq` vec4 (-z) y x w, + v %* rotateY 0 `approxEq` v, + v %* rotateY (0.5 * pi) `approxEq` vec4 z y (-x) w, + v %* rotateY pi `approxEq` vec4 (-x) y (-z) w, + v %* rotateY (1.5 * pi) `approxEq` vec4 (-z) y x w, + v %* rotateY (2 * pi) `approxEq` v ] -prop_rotateZ :: Vector Double 4 -> Bool -prop_rotateZ v | (x,y,z,w) <- unpackV4 v = - and [ - rotateZ (-2 * pi) %* v `approxEq` v, - rotateZ (-1.5 * pi) %* v `approxEq` vec4 (-y) x z w, - rotateZ (-pi) %* v `approxEq` vec4 (-x) (-y) z w, - rotateZ (-0.5 * pi) %* v `approxEq` vec4 y (-x) z w, - rotateZ 0 %* v `approxEq` v, - rotateZ (0.5 * pi) %* v `approxEq` vec4 (-y) x z w, - rotateZ pi %* v `approxEq` vec4 (-x) (-y) z w, - rotateZ (1.5 * pi) %* v `approxEq` vec4 y (-x) z w, - rotateZ (2 * pi) %* v `approxEq` v +prop_rotateZ :: Vector TestElem 4 -> Property +prop_rotateZ v@(Vec4 x y z w) = + conjoin [ + v %* rotateZ (-2 * pi) `approxEq` v, + v %* rotateZ (-1.5 * pi) `approxEq` vec4 (-y) x z w, + v %* rotateZ (-pi) `approxEq` vec4 (-x) (-y) z w, + v %* rotateZ (-0.5 * pi) `approxEq` vec4 y (-x) z w, + v %* rotateZ 0 `approxEq` v, + v %* rotateZ (0.5 * pi) `approxEq` vec4 (-y) x z w, + v %* rotateZ pi `approxEq` vec4 (-x) (-y) z w, + v %* rotateZ (1.5 * pi) `approxEq` vec4 y (-x) z w, + v %* rotateZ (2 * pi) `approxEq` v ] -prop_rotate :: Double -> Bool +prop_rotate :: TestElem -> Property prop_rotate a = - and [ + conjoin [ rotate (vec3 1 0 0) a `approxEq` rotateX a, rotate (vec3 0 1 0) a `approxEq` rotateY a, rotate (vec3 0 0 1) a `approxEq` rotateZ a ] -prop_rotateEuler :: Double -> Double -> Double -> Bool -prop_rotateEuler pitch yaw roll = rotateEuler pitch yaw roll `approxEq` rotateX pitch %* rotateY yaw %* rotateZ roll +prop_rotateEuler :: TestElem -> TestElem -> TestElem -> Bool +prop_rotateEuler pitch yaw roll = + rotateEuler pitch yaw roll `approxEq` rotateZ roll %* rotateY yaw %* rotateX pitch -prop_lookAt :: Vector Double 3 -> Vector Double 3 -> Vector Double 3 -> Bool +prop_lookAt :: Vector TestElem 3 -> Vector TestElem 3 -> Vector TestElem 3 -> Property prop_lookAt up cam foc = - and [ - (normalized . fromHom $ m %* toHomPoint foc) `approxEq` vec3 0 0 (-1), - fromHom (m %* toHomPoint cam) `approxEq` 0, - fromHom (m %* toHomVector xb) `approxEq` vec3 1 0 0, - fromHom (m %* toHomVector yb) `approxEq` vec3 0 1 0, - fromHom (m %* toHomVector zb) `approxEq` vec3 0 0 1 + (apart cam foc && apart up cam) ==> + conjoin [ + (normalized . fromHom $ toHomPoint foc %* m) `approxEq` vec3 0 0 (-1), + fromHom (toHomPoint cam %* m) `approxEq` 0, + fromHom (toHomVector xb %* m) `approxEq` vec3 1 0 0, + fromHom (toHomVector yb %* m) `approxEq` vec3 0 1 0, + fromHom (toHomVector zb %* m) `approxEq` vec3 0 0 1 ] where + apart :: Vector TestElem 3 -> Vector TestElem 3 -> Bool + apart a b = maxElem (a - b) > 0.01 * (maxElem a `max` maxElem b) m = lookAt up cam foc zb = normalized $ cam - foc xb = normalized $ up `cross` zb yb = zb `cross` xb -prop_perspective :: Double -> Double -> Double -> Double -> Bool +prop_perspective :: TestElem -> TestElem -> TestElem -> TestElem -> Bool prop_perspective a b c d = and [ projectTo 0 0 n `approxEq` vec3 0 0 (-1), @@ -171,9 +186,9 @@ hpd = tan (fovy * 0.5) -- height/distance wpd = aspect * hpd -- width/distance m = perspective n f fovy aspect - projectTo x' y' z = fromHom $ m %* vec4 (x' * wpd * z) (y' * hpd * z) (-z) 1 + projectTo x' y' z = fromHom $ vec4 (x' * wpd * z) (y' * hpd * z) (-z) 1 %* m -prop_orthogonal :: Double -> Double -> Double -> Double -> Bool +prop_orthogonal :: TestElem -> TestElem -> TestElem -> TestElem -> Bool prop_orthogonal a b c d = and [ projectTo 0 0 n `approxEq` vec3 0 0 (-1), @@ -193,20 +208,21 @@ w = 1.0 + mod' c 9999.0 -- Width in range [1, 10000) h = 1.0 + mod' d 9999.0 -- Height in range [1, 10000) m = orthogonal n f w h - projectTo x' y' z = fromHom $ m %* vec4 (x' * w * 0.5) (y' * h * 0.5) (-z) 1 + projectTo x' y' z = fromHom $ vec4 (x' * w * 0.5) (y' * h * 0.5) (-z) 1 %* m -prop_toHomPoint :: Vector Double 3 -> Bool -prop_toHomPoint v | (x,y,z) <- unpackV3 v = toHomPoint v == vec4 x y z 1 +prop_toHomPoint :: Vector TestElem 3 -> Bool +prop_toHomPoint v@(Vec3 x y z) = toHomPoint v == vec4 x y z 1 -prop_toHomVector :: Vector Double 3 -> Bool -prop_toHomVector v | (x,y,z) <- unpackV3 v = toHomVector v == vec4 x y z 0 +prop_toHomVector :: Vector TestElem 3 -> Bool +prop_toHomVector v@(Vec3 x y z) = toHomVector v == vec4 x y z 0 -prop_fromHom :: Vector Double 4 -> Bool -prop_fromHom v | (x,y,z,w) <- unpackV4 v = +prop_fromHom :: Vector TestElem 4 -> Bool +prop_fromHom v@(Vec4 x y z w) = case w of 0 -> fromHom v == vec3 x y z _ -> fromHom v `approxEq` vec3 (x/w) (y/w) (z/w) return [] -runTests :: IO Bool -runTests = $quickCheckAll +runTests :: Int -> IO Bool +runTests n = $forAllProperties + $ quickCheckWithResult stdArgs { maxSuccess = n } diff --git a/test/Numeric/MatrixFloatTest.hs b/test/Numeric/MatrixFloatTest.hs --- a/test/Numeric/MatrixFloatTest.hs +++ b/test/Numeric/MatrixFloatTest.hs @@ -10,146 +10,167 @@ module Numeric.MatrixFloatTest (runTests) where -import Data.Fixed -import Numeric.DataFrame -import Numeric.DataFrame.Arbitraries () -import Numeric.DataFrame.Internal.Array.Class -import Numeric.Dimensions -import Numeric.PrimBytes -import Test.QuickCheck +import Data.Fixed +import Data.Semigroup +import Numeric.DataFrame +import Numeric.DataFrame.Arbitraries +import Numeric.Dimensions +import Test.QuickCheck -eps :: Scf -eps = 0.01 +type TestElem = Float +type TestDF = DataFrame TestElem -dropW :: (SubSpace t '[] '[3] '[3], SubSpace t '[] '[4] '[4]) => Vector t 4 -> Vector t 3 -dropW v | (x,y,z,_) <- unpackV4 v = vec3 x y z +eps :: Scalar TestElem +eps = 0.00001 +dropW :: (SubSpace t '[3] '[] '[3], SubSpace t '[4] '[] '[4]) + => Vector t 4 -> Vector t 3 +dropW (Vec4 x y z _) = Vec3 x y z + +-- | Most of the time, the error is proportional to the maginutude of the biggest element +maxElem :: (SubSpace TestElem ds '[] ds) + => TestDF (ds :: [Nat]) -> Scalar TestElem +maxElem = ewfoldl (\a -> max a . abs) 0 + +-- | For operations like @det@, the error is proportional to maximum possible product +-- over rows or columns +maxRows :: forall ds + . (SubSpace TestElem '[Head ds] (Tail ds) ds) + => TestDF (ds :: [Nat]) -> Scalar TestElem +maxRows = getProduct . ewfoldMap @_ @'[Head ds] @(Tail ds) @ds (Product . maxElem) + approxEq :: - forall (ds :: [Nat]). + forall (ds :: [Nat]) . ( Dimensions ds, - Num (DataFrame Float ds), - PrimBytes (DataFrame Float ds), - PrimArray Float (DataFrame Float ds) + Num (TestDF ds), + PrimBytes (TestDF ds), + PrimArray TestElem (TestDF ds) ) => - DataFrame Float ds -> DataFrame Float ds -> Bool -approxEq a b = (eps >=) . ewfoldl @_ @'[] max 0 . abs $ a - b + TestDF ds -> TestDF ds -> Bool +approxEq a b = maxElem (a - b) <= eps * m + where + m = maxElem a `max` maxElem b infix 4 `approxEq` -prop_detTranspose :: Matrix '[Float, Float] (XN 2) (XN 2) -> Bool -prop_detTranspose (XFrame (x :*: y :*: Z)) - | -- infer KnownDim for both dimensions of matrix x (and y) - KnownDims <- dims `inSpaceOf` x - = let m = diag (ewfoldl max 0 $ abs x) + x %* transpose y - a = det m +prop_detTranspose :: SomeSquareMatrix AnyMatrix TestElem -> Property +prop_detTranspose (SSM m) + = let a = det m b = det $ transpose m - in abs (a - b) / (abs a + abs b + 1) <= eps + n = (case dims `inSpaceOf` m of dn :* _ -> dimVal dn) :: Word + mag = eps * maxRows m * fromIntegral (product [1..n]) + in counterexample + (unlines + [ "failed det/transpose:" + , "m: " ++ show m + , "mT: " ++ show (transpose m) + , show a ++ " /= " ++ show b + ++ " (tolerance: " ++ show mag ++ ")." + ] + ) $ abs (a - b) <= mag -prop_inverse :: Matrix '[Float, Float] (XN 2) (XN 2) -> Bool -prop_inverse (XFrame (x :*: y :*: Z)) - | -- infer KnownDim for both dimensions of matrix x (and y) - (KnownDims :: Dims ns) <- dims `inSpaceOf` x - -- cumbersose inverse instance requires PrimBytes (Vector t n) - , E <- inferASing' @Float @'[Head ns] - , E <- inferPrim' @Float @'[Head ns] - = let m = diag base + x %* transpose y - mi = inverse m - err a b = ewfoldl max 0 (abs (b - a)) / base - base = ewfoldl max 0.5 (abs x) + ewfoldl max 0.5 (abs y) - in err eye (m %* mi) <= eps - && err eye (mi %* m) <= eps +prop_inverse :: SomeSquareMatrix NonSingular TestElem -> Property +prop_inverse (SSM m) + = let mi = inverse m + aeq a b = maxElem (b - a) <= eps * maxRows m + in counterexample ("failed inverse:" ++ + show (m, mi, m %* mi, mi %* m)) $ + aeq eye (m %* mi) && aeq eye (mi %* m) -prop_LU :: Matrix '[Float, Float] (XN 2) (XN 2) -> Bool -prop_LU (XFrame (x :*: y :*: Z)) - | -- infer KnownDim for both dimensions of matrix x (and y) - (KnownDims :: Dims ns) <- dims `inSpaceOf` x - -- cumbersose inverse instance requires PrimBytes (Vector t n) - , E <- inferASing' @Float @'[Head ns] - , E <- inferPrim' @Float @'[Head ns] - = let m = diag base + x %* transpose y - f = lu m - err a b = ewfoldl max 0 (abs (b - a)) / base - base = ewfoldl max 0.5 (abs x) + ewfoldl max 0.5 (abs y) - in err (luPerm f %* m) (luLower f %* luUpper f) <= eps +-- TODO: improve lu! +-- lu factorization is very unstable in some cases +-- +-- >>> m = unsafeFromFlatList (Dims @'[4,4]) 0 [1,0,1,-2, 0,-1,1,2, 2,-4,2,-2, 4,-8,-2,2 ] :: Mat44f +-- >>> det m == 0 +-- >>> det (transpose m) == 60 +prop_LU :: SomeSquareMatrix NonSingular TestElem -> Bool +prop_LU (SSM m) + = let f = lu m + aeq a b = maxElem (b - a) <= eps * maxRows m + in aeq (luPerm f %* m) (luLower f %* luUpper f) -prop_translate3vs4 :: Vector Float 4 -> Bool +prop_translate3vs4 :: Vector TestElem 4 -> Bool prop_translate3vs4 v = translate4 v == translate3 (dropW v) - -prop_translate4 :: Vector Float 4 -> Vector Float 3 -> Bool -prop_translate4 a b = translate4 a %* toHomPoint b == toHomPoint (dropW a + b) -prop_translate3 :: Vector Float 3 -> Vector Float 3 -> Bool -prop_translate3 a b = translate3 a %* toHomPoint b == toHomPoint (a + b) +prop_translate4 :: Vector TestElem 4 -> Vector TestElem 3 -> Bool +prop_translate4 a b = toHomPoint b %* translate4 a == toHomPoint (dropW a + b) -prop_rotateX :: Vector Float 4 -> Bool -prop_rotateX v | (x,y,z,w) <- unpackV4 v = - and [ - rotateX (-2 * pi) %* v `approxEq` v, - rotateX (-1.5 * pi) %* v `approxEq` vec4 x (-z) y w, - rotateX (-pi) %* v `approxEq` vec4 x (-y) (-z) w, - rotateX (-0.5 * pi) %* v `approxEq` vec4 x z (-y) w, - rotateX 0 %* v `approxEq` v, - rotateX (0.5 * pi) %* v `approxEq` vec4 x (-z) y w, - rotateX pi %* v `approxEq` vec4 x (-y) (-z) w, - rotateX (1.5 * pi) %* v `approxEq` vec4 x z (-y) w, - rotateX (2 * pi) %* v `approxEq` v +prop_translate3 :: Vector TestElem 3 -> Vector TestElem 3 -> Bool +prop_translate3 a b = toHomPoint b %* translate3 a == toHomPoint (a + b) + +prop_rotateX :: Vector TestElem 4 -> Property +prop_rotateX v@(Vec4 x y z w) = + conjoin [ + v %* rotateX (-2 * pi) `approxEq` v, + v %* rotateX (-1.5 * pi) `approxEq` vec4 x (-z) y w, + v %* rotateX (-pi) `approxEq` vec4 x (-y) (-z) w, + v %* rotateX (-0.5 * pi) `approxEq` vec4 x z (-y) w, + v %* rotateX 0 `approxEq` v, + v %* rotateX (0.5 * pi) `approxEq` vec4 x (-z) y w, + v %* rotateX pi `approxEq` vec4 x (-y) (-z) w, + v %* rotateX (1.5 * pi) `approxEq` vec4 x z (-y) w, + v %* rotateX (2 * pi) `approxEq` v ] -prop_rotateY :: Vector Float 4 -> Bool -prop_rotateY v | (x,y,z,w) <- unpackV4 v = - and [ - rotateY (-2 * pi) %* v `approxEq` v, - rotateY (-1.5 * pi) %* v `approxEq` vec4 z y (-x) w, - rotateY (-pi) %* v `approxEq` vec4 (-x) y (-z) w, - rotateY (-0.5 * pi) %* v `approxEq` vec4 (-z) y x w, - rotateY 0 %* v `approxEq` v, - rotateY (0.5 * pi) %* v `approxEq` vec4 z y (-x) w, - rotateY pi %* v `approxEq` vec4 (-x) y (-z) w, - rotateY (1.5 * pi) %* v `approxEq` vec4 (-z) y x w, - rotateY (2 * pi) %* v `approxEq` v +prop_rotateY :: Vector TestElem 4 -> Property +prop_rotateY v@(Vec4 x y z w) = + conjoin [ + v %* rotateY (-2 * pi) `approxEq` v, + v %* rotateY (-1.5 * pi) `approxEq` vec4 z y (-x) w, + v %* rotateY (-pi) `approxEq` vec4 (-x) y (-z) w, + v %* rotateY (-0.5 * pi) `approxEq` vec4 (-z) y x w, + v %* rotateY 0 `approxEq` v, + v %* rotateY (0.5 * pi) `approxEq` vec4 z y (-x) w, + v %* rotateY pi `approxEq` vec4 (-x) y (-z) w, + v %* rotateY (1.5 * pi) `approxEq` vec4 (-z) y x w, + v %* rotateY (2 * pi) `approxEq` v ] -prop_rotateZ :: Vector Float 4 -> Bool -prop_rotateZ v | (x,y,z,w) <- unpackV4 v = - and [ - rotateZ (-2 * pi) %* v `approxEq` v, - rotateZ (-1.5 * pi) %* v `approxEq` vec4 (-y) x z w, - rotateZ (-pi) %* v `approxEq` vec4 (-x) (-y) z w, - rotateZ (-0.5 * pi) %* v `approxEq` vec4 y (-x) z w, - rotateZ 0 %* v `approxEq` v, - rotateZ (0.5 * pi) %* v `approxEq` vec4 (-y) x z w, - rotateZ pi %* v `approxEq` vec4 (-x) (-y) z w, - rotateZ (1.5 * pi) %* v `approxEq` vec4 y (-x) z w, - rotateZ (2 * pi) %* v `approxEq` v +prop_rotateZ :: Vector TestElem 4 -> Property +prop_rotateZ v@(Vec4 x y z w) = + conjoin [ + v %* rotateZ (-2 * pi) `approxEq` v, + v %* rotateZ (-1.5 * pi) `approxEq` vec4 (-y) x z w, + v %* rotateZ (-pi) `approxEq` vec4 (-x) (-y) z w, + v %* rotateZ (-0.5 * pi) `approxEq` vec4 y (-x) z w, + v %* rotateZ 0 `approxEq` v, + v %* rotateZ (0.5 * pi) `approxEq` vec4 (-y) x z w, + v %* rotateZ pi `approxEq` vec4 (-x) (-y) z w, + v %* rotateZ (1.5 * pi) `approxEq` vec4 y (-x) z w, + v %* rotateZ (2 * pi) `approxEq` v ] -prop_rotate :: Float -> Bool +prop_rotate :: TestElem -> Property prop_rotate a = - and [ + conjoin [ rotate (vec3 1 0 0) a `approxEq` rotateX a, rotate (vec3 0 1 0) a `approxEq` rotateY a, rotate (vec3 0 0 1) a `approxEq` rotateZ a ] -prop_rotateEuler :: Float -> Float -> Float -> Bool -prop_rotateEuler pitch yaw roll = rotateEuler pitch yaw roll `approxEq` rotateX pitch %* rotateY yaw %* rotateZ roll +prop_rotateEuler :: TestElem -> TestElem -> TestElem -> Bool +prop_rotateEuler pitch yaw roll = + rotateEuler pitch yaw roll `approxEq` rotateZ roll %* rotateY yaw %* rotateX pitch -prop_lookAt :: Vector Float 3 -> Vector Float 3 -> Vector Float 3 -> Bool +prop_lookAt :: Vector TestElem 3 -> Vector TestElem 3 -> Vector TestElem 3 -> Property prop_lookAt up cam foc = - and [ - (normalized . fromHom $ m %* toHomPoint foc) `approxEq` vec3 0 0 (-1), - fromHom (m %* toHomPoint cam) `approxEq` 0, - fromHom (m %* toHomVector xb) `approxEq` vec3 1 0 0, - fromHom (m %* toHomVector yb) `approxEq` vec3 0 1 0, - fromHom (m %* toHomVector zb) `approxEq` vec3 0 0 1 + (apart cam foc && apart up cam) ==> + conjoin [ + (normalized . fromHom $ toHomPoint foc %* m) `approxEq` vec3 0 0 (-1), + fromHom (toHomPoint cam %* m) `approxEq` 0, + fromHom (toHomVector xb %* m) `approxEq` vec3 1 0 0, + fromHom (toHomVector yb %* m) `approxEq` vec3 0 1 0, + fromHom (toHomVector zb %* m) `approxEq` vec3 0 0 1 ] where + apart :: Vector TestElem 3 -> Vector TestElem 3 -> Bool + apart a b = maxElem (a - b) > 0.01 * (maxElem a `max` maxElem b) m = lookAt up cam foc zb = normalized $ cam - foc xb = normalized $ up `cross` zb yb = zb `cross` xb -prop_perspective :: Float -> Float -> Float -> Float -> Bool +prop_perspective :: TestElem -> TestElem -> TestElem -> TestElem -> Bool prop_perspective a b c d = and [ projectTo 0 0 n `approxEq` vec3 0 0 (-1), @@ -171,9 +192,9 @@ hpd = tan (fovy * 0.5) -- height/distance wpd = aspect * hpd -- width/distance m = perspective n f fovy aspect - projectTo x' y' z = fromHom $ m %* vec4 (x' * wpd * z) (y' * hpd * z) (-z) 1 + projectTo x' y' z = fromHom $ vec4 (x' * wpd * z) (y' * hpd * z) (-z) 1 %* m -prop_orthogonal :: Float -> Float -> Float -> Float -> Bool +prop_orthogonal :: TestElem -> TestElem -> TestElem -> TestElem -> Bool prop_orthogonal a b c d = and [ projectTo 0 0 n `approxEq` vec3 0 0 (-1), @@ -193,20 +214,21 @@ w = 1.0 + mod' c 9999.0 -- Width in range [1, 10000) h = 1.0 + mod' d 9999.0 -- Height in range [1, 10000) m = orthogonal n f w h - projectTo x' y' z = fromHom $ m %* vec4 (x' * w * 0.5) (y' * h * 0.5) (-z) 1 + projectTo x' y' z = fromHom $ vec4 (x' * w * 0.5) (y' * h * 0.5) (-z) 1 %* m -prop_toHomPoint :: Vector Float 3 -> Bool -prop_toHomPoint v | (x,y,z) <- unpackV3 v = toHomPoint v == vec4 x y z 1 +prop_toHomPoint :: Vector TestElem 3 -> Bool +prop_toHomPoint v@(Vec3 x y z) = toHomPoint v == vec4 x y z 1 -prop_toHomVector :: Vector Float 3 -> Bool -prop_toHomVector v | (x,y,z) <- unpackV3 v = toHomVector v == vec4 x y z 0 +prop_toHomVector :: Vector TestElem 3 -> Bool +prop_toHomVector v@(Vec3 x y z) = toHomVector v == vec4 x y z 0 -prop_fromHom :: Vector Float 4 -> Bool -prop_fromHom v | (x,y,z,w) <- unpackV4 v = +prop_fromHom :: Vector TestElem 4 -> Bool +prop_fromHom v@(Vec4 x y z w) = case w of 0 -> fromHom v == vec3 x y z _ -> fromHom v `approxEq` vec3 (x/w) (y/w) (z/w) return [] -runTests :: IO Bool -runTests = $quickCheckAll +runTests :: Int -> IO Bool +runTests n = $forAllProperties + $ quickCheckWithResult stdArgs { maxSuccess = n } diff --git a/test/Numeric/PrimBytesTest.hs b/test/Numeric/PrimBytesTest.hs new file mode 100644 --- /dev/null +++ b/test/Numeric/PrimBytesTest.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +module Numeric.PrimBytesTest (runTests) where + +import Data.Int +import Data.Type.Lits +import Data.Word +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import GHC.Exts +import GHC.Generics +import GHC.Word +import Numeric.DataFrame.Arbitraries () +import Numeric.Dimensions +import Numeric.PrimBytes +import qualified Numeric.Tuple.Lazy as LT +import qualified Numeric.Tuple.Strict as ST +import Spec.Util +import Test.QuickCheck + +data Dummy + deriving (Generic, Show, Read, Eq, Ord) + +data Vertex a b c + = Vertex + { pos :: (a, a, a, a) + , norm :: (b, b, b) + , tex :: Either (b, b) (c, c, c) + , extraFloats :: (Float, Double) + } deriving (Generic, Show, Read, Eq, Ord) + +data ManyAlternatives a b c + = EmptyAlt + | FirstAlt a b b c + | SecondAlt a c + | AltN (Either a b) + | AltM (Maybe a) (Maybe b) (Maybe c) + | SecondEmptyAlt + | SomeWeirdChoice Word8 Word64 Int8 Char Word32 Int16 a + deriving (Generic, Show, Read, Eq, Ord) + +data MyUnboxedType a + = VeryUnboxed Word# Char# Int# Addr# Float# Double# + | NotSoUnboxed a a + | JustABitUnboxed Double# a Char# a + deriving (Generic, Eq, Ord) + +instance Show a => Show (MyUnboxedType a) where + show (VeryUnboxed w c i a f d) + = unwords [ "VeryUnboxed", show (W# w), show (I# i) + , show (C# c), show (Ptr a), show (F# f), show (D# d)] + show (NotSoUnboxed a b) + = unwords [ "NotSoUnboxed", show a, show b] + show (JustABitUnboxed d x c y) + = unwords [ "JustABitUnboxed ", show (D# d), show x, show (C# c), show y] + + +instance (PrimBytes a, PrimBytes b, PrimBytes c) + => PrimBytes (Vertex a b c) +instance (PrimBytes a, PrimBytes b, PrimBytes c) + => PrimBytes (ManyAlternatives a b c) +instance (PrimBytes a) + => PrimBytes (MyUnboxedType a) +instance (PrimBytes a, PrimBytes b, PrimBytes c) => Storable (Vertex a b c) where + sizeOf = bSizeOf + alignment = bAlignOf + peekElemOff = bPeekElemOff + pokeElemOff = bPokeElemOff + peekByteOff = bPeekByteOff + pokeByteOff = bPokeByteOff + peek = bPeek + poke = bPoke +instance (PrimBytes a, PrimBytes b, PrimBytes c) => Storable (ManyAlternatives a b c) where + sizeOf = bSizeOf + alignment = bAlignOf + peekElemOff = bPeekElemOff + pokeElemOff = bPokeElemOff + peekByteOff = bPeekByteOff + pokeByteOff = bPokeByteOff + peek = bPeek + poke = bPoke +instance PrimBytes a => Storable (MyUnboxedType a) where + sizeOf = bSizeOf + alignment = bAlignOf + peekElemOff = bPeekElemOff + pokeElemOff = bPokeElemOff + peekByteOff = bPeekByteOff + pokeByteOff = bPokeByteOff + peek = bPeek + poke = bPoke + +instance Arbitrary (Ptr Dummy) where + arbitrary = intPtrToPtr . IntPtr <$> arbitrary + +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Vertex a b c) where + arbitrary = Vertex <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (ManyAlternatives a b c) where + arbitrary = choose (1, 7 :: Int) >>= \case + 1 -> pure EmptyAlt + 2 -> FirstAlt <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + 3 -> SecondAlt <$> arbitrary <*> arbitrary + 4 -> AltN <$> arbitrary + 5 -> AltM <$> arbitrary <*> arbitrary <*> arbitrary + 6 -> pure SecondEmptyAlt + _ -> SomeWeirdChoice <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (MyUnboxedType a) where + arbitrary = choose (1, 3 :: Int) >>= \case + 1 -> do + W# w <- arbitrary + C# c <- arbitrary + I# i <- arbitrary + Ptr a <- arbitrary :: Gen (Ptr Dummy) + F# f <- arbitrary + D# d <- arbitrary + return $ VeryUnboxed w c i a f d + 2 -> NotSoUnboxed <$> arbitrary <*> arbitrary + _ -> do + C# c <- arbitrary + D# d <- arbitrary + x <- arbitrary + y <- arbitrary + return $ JustABitUnboxed d x c y + +showByteArray :: Int# -> ByteArray# -> [Word8] +showByteArray size ba = go 0# + where + go i + | isTrue# (i <# size) = W8# (indexWord8Array# ba i) : go (i +# 1#) + | otherwise = [] + +showMutableByteArray :: Int# -> MutableByteArray# s + -> State# s -> (# State# s, [Word8] #) +showMutableByteArray size mba = go 0# + where + go i s0 + | isTrue# (i <# size) + , (# s1, w #) <- readWord8Array# mba i s0 + , (# s2, ws #) <- go (i +# 1#) s1 + = (# s2, W8# w : ws #) + | otherwise = (# s0, [] #) + +-- | The most basic property +fromToBytesId :: (PrimBytes a, Eq a, Show a) => a -> Property +fromToBytesId v = counterexample msg $ + v === fromBytes (byteOffset v) bytes + where + bytes = getBytes v + byteList = showByteArray (byteOffset v +# byteSize v) bytes + msg = unlines + [ "byteOffset: " ++ show (I# (byteOffset v)) + , "byteAlign: " ++ show (I# (byteAlign v)) + , "byteSize: " ++ show (I# (byteSize v)) + , "Array content: " ++ show byteList + ] + +-- | Pointers +fromToPtrId :: (PrimBytes a, Eq a, Show a) => a -> Property +fromToPtrId v = ioProperty . allocaBytes (bSizeOf v) $ \ptr -> do + bPoke ptr v + v1 <- bPeek ptr + return (v === v1) + +-- | Byte offsets +readWriteBytesId :: (PrimBytes a, Eq a, Show a) => Int -> a -> Property +readWriteBytesId off' v = case runRW# go of (# _, r #) -> r + where + -- reasonably small offset aligned to a multiple of @byteAlign v@ + off = case abs off' `mod` 100 of I# i -> i *# byteAlign v + -- write and read the value from an array by a specified offset + go :: forall s . State# s -> (# State# s, Property #) + go s0 + | (# s1, mba #) <- newByteArray# (byteSize v +# off) s0 + , s2 <- writeBytes mba off v s1 + , (# s3, w #) <- readBytes mba off s2 + , (# s4, byteList #) <- showMutableByteArray (byteSize v +# off) mba s3 + , (# s5, ba #) <- unsafeFreezeByteArray# mba s4 + , u <- fromBytes off ba + , msg <- unlines + [ "Offset 'off': " ++ show (I# off) + , "byteOffset: " ++ show (I# (byteOffset v)) + , "byteAlign: " ++ show (I# (byteAlign v)) + , "byteSize: " ++ show (I# (byteSize v)) + , "Array content: " ++ show byteList + ] + = (# s5, counterexample msg (v === w .&&. v == u) #) + +-- | Elem offsets +readWriteArrayId :: (PrimBytes a, Eq a, Show a) => Int -> Int -> a -> Property +readWriteArrayId n' i' v = case runRW# go of (# _, r #) -> r + where + -- allocate reasonably small number of elements + n = case abs n' `mod` 30 of I# x -> x +# 1# + i = case abs i' `mod` I# n of I# x -> x + -- write and read the value from an array by a specified offset + go :: forall s . State# s -> (# State# s, Property #) + go s0 + | (# s1, mba #) <- newByteArray# (n *# byteSize v) s0 + , s2 <- writeArray mba i v s1 + , (# s3, w #) <- readArray mba i s2 + , (# s4, byteList #) <- showMutableByteArray (n *# byteSize v) mba s3 + , (# s5, ba #) <- unsafeFreezeByteArray# mba s4 + , u <- indexArray ba i + , msg <- unlines + [ "Array size: " ++ show (I# n) + , "Array index: " ++ show (I# i) + , "byteOffset: " ++ show (I# (byteOffset v)) + , "byteAlign: " ++ show (I# (byteAlign v)) + , "byteSize: " ++ show (I# (byteSize v)) + , "Array content: " ++ show byteList + ] + = (# s5, counterexample msg (v === w .&&. v == u) #) + + +-- | Working this elem offsets and byte offsets together +mixedTransformsId :: (PrimBytes a, Eq a, Show a) => Int -> Int -> a -> Property +mixedTransformsId n' i' v = case runRW# go of (# _, r #) -> r + where + -- allocate reasonably small number of elements + n = case abs n' `mod` 30 of I# x -> x +# 2# + i = case abs i' `mod` (I# n - 1) of I# x -> x -- i+1 is always a valid index + i1 = i +# 1# + -- write and read the value from an array by a specified offset + go :: forall s . State# s -> (# State# s, Property #) + go s0 + | (# s1, mba #) <- newByteArray# (n *# byteSize v) s0 + , s2 <- writeArray mba i1 v s1 + , s3 <- writeBytes mba (i *# byteSize v) v s2 + , (# s4, w #) <- readArray mba i s3 + , (# s5, u #) <- readBytes mba (i1 *# byteSize v) s4 + , (# s6, byteList #) <- showMutableByteArray (n *# byteSize v) mba s5 + , msg <- unlines + [ "Array size: " ++ show (I# n) + , "Array index: " ++ show (I# i) + , "byteOffset: " ++ show (I# (byteOffset v)) + , "byteAlign: " ++ show (I# (byteAlign v)) + , "byteSize: " ++ show (I# (byteSize v)) + , "Array content: " ++ show byteList + ] + = (# s6, counterexample msg (v === w .&&. v == u) #) + + +class SamePrimRep a b where + convert :: a -> b + +-- | Some times should have the same PrimBytes representation +samePrimRepId :: forall a b + . ( PrimBytes a, PrimBytes b, Eq b, Show b, SamePrimRep a b) + => Int -> a -> b -> Property +samePrimRepId off' a b = case runRW# go of (# _, r #) -> r + where + f = convert @a @b -- monomorphise it to avoid type errors + -- reasonably small offset aligned to a multiple of @byteAlign a@ + off = case abs off' `mod` 100 of I# i -> i *# byteAlign a + -- write and read the value from an array by a specified offset + go :: forall s . State# s -> (# State# s, Property #) + go s0 + | (# s1, mba #) <- newByteArray# (off +# byteSize a +# byteSize b) s0 + , s2 <- writeBytes mba off a s1 + , s3 <- writeBytes mba (off +# byteSize a) b s2 + , (# s4, a' #) <- readBytes mba off s3 + , (# s5, b' #) <- readBytes mba (off +# byteSize b) s4 + , (# s6, bl #) <- showMutableByteArray (off +# byteSize a +# byteSize b) mba s5 + , msg <- unlines + [ "Offset 'off': " ++ show (I# off) + , "byteOffset: " ++ show (I# (byteOffset a), I# (byteOffset b)) + , "byteAlign: " ++ show (I# (byteAlign a), I# (byteAlign b)) + , "byteSize: " ++ show (I# (byteSize a), I# (byteSize b)) + , "Array content: " ++ show bl + ] + = (# s6, counterexample msg (f a === a' .&&. b === f b') #) + +-- Check whether @byteFieldOffset@ calculates correct field offsets +vertexFields :: ( PrimBytes a, Eq a, Show a + , PrimBytes b, Eq b, Show b + , PrimBytes c, Eq c, Show c) + => Vertex a b c -> Property +vertexFields v + | ba <- getBytes v + , off <- byteOffset v + = conjoin + [ counterexample "pos" $ pos v === fromBytes + (off +# byteFieldOffset (proxy# @Symbol @"pos") v) ba + , counterexample "norm" $ norm v === fromBytes + (off +# byteFieldOffset (proxy# @Symbol @"norm") v) ba + , counterexample "tex" $ tex v === fromBytes + (off +# byteFieldOffset (proxy# @Symbol @"tex") v) ba + , counterexample "extraFloats" $ extraFloats v === fromBytes + (off +# byteFieldOffset (proxy# @Symbol @"extraFloats") v) ba + ] + + + +-- a list of types to test the properties against +type SingleVarTypes = + '[ Word8, Word16, Word32, Word64, Word + , Int8, Int16, Int32, Int64, Int + , Char, Double, Float + , Vertex Double Float Char + , Vertex Word8 Double Int16 + , Vertex Word16 Word32 Word64 + , Vertex Int64 Int8 Int32 + , ManyAlternatives Word8 Double Double + , ManyAlternatives Float Double Int16 + , Maybe Int + , Either Int32 Double + , MyUnboxedType (Either (Either () Char) Float) + , MyUnboxedType () + , Ptr Dummy + , Idx 7 + , Idxs ('[] :: [Nat]) + , Idxs '[5, 3, 12] + , ST.Tuple '[Double, Word8, Word8, Word8, Maybe Float] + , LT.Tuple '[] + , LT.Tuple '[Int, Int8, Either Float Double] + ] + +-- I can substitute these in place of parameters of Vertex or ManyAlternatives +type TypeTriples = + '[ '(Double, Float, Char) + , '(Word8, Double, Int16) + , '(Word16, Word32, Word64) + , '(Word16, Word32, Word64) + , '(Int64, Int8, Int32) + , '(Float, Char, Char) + ] + +instance SamePrimRep a (ST.Tuple '[a]) where + convert a = a ST.:$ U +instance SamePrimRep (a,b) (ST.Tuple '[a,b]) where + convert (a, b) = a ST.:$ b ST.:$ U +instance SamePrimRep (a,b,c) (ST.Tuple '[a,b,c]) where + convert (a, b, c) = a ST.:$ b ST.:$ c ST.:$ U +instance SamePrimRep (a,b,c,d) (ST.Tuple '[a,b,c,d]) where + convert (a, b, c, d) = a ST.:$ b ST.:$ c ST.:$ d ST.:$ U +instance SamePrimRep (a,b,c,d,e) (ST.Tuple '[a,b,c,d,e]) where + convert (a, b, c, d, e) = a ST.:$ b ST.:$ c ST.:$ d ST.:$ e ST.:$ U + +instance SamePrimRep a (LT.Tuple '[a]) where + convert a = a LT.:$ U +instance SamePrimRep (a,b) (LT.Tuple '[a,b]) where + convert (a, b) = a LT.:$ b LT.:$ U +instance SamePrimRep (a,b,c) (LT.Tuple '[a,b,c]) where + convert (a, b, c) = a LT.:$ b LT.:$ c LT.:$ U +instance SamePrimRep (a,b,c,d) (LT.Tuple '[a,b,c,d]) where + convert (a, b, c, d) = a LT.:$ b LT.:$ c LT.:$ d LT.:$ U +instance SamePrimRep (a,b,c,d,e) (LT.Tuple '[a,b,c,d,e]) where + convert (a, b, c, d, e) = a LT.:$ b LT.:$ c LT.:$ d LT.:$ e LT.:$ U + +instance SamePrimRep (Maybe a) (Either () a) where + convert (Just a) = Right a + convert Nothing = Left () + +type SamePrimRepTypes = + '[ '( (Word, Double), ST.Tuple '[Word, Double] ) + , '( (Double, Word8, Word8, Word8, Maybe Float) + , ST.Tuple '[Double, Word8, Word8, Word8, Maybe Float] ) + , '( (Word8, Int16, Word32, Either (Either Double Float) Int) + , LT.Tuple '[Word8, Int16, Word32, Either (Either Double Float) Int] ) + , '( Maybe Float, Either () Float) + , '( Maybe Double, Either () Double) + ] + +return [] -- this is for $testWithTypes + +prop_fromToBytesId :: Property +prop_fromToBytesId = $(testWithTypes 'fromToBytesId ''SingleVarTypes) + +prop_fromToPtrId :: Property +prop_fromToPtrId = $(testWithTypes 'fromToPtrId ''SingleVarTypes) + +prop_readWriteBytesId :: Property +prop_readWriteBytesId = $(testWithTypes 'readWriteBytesId ''SingleVarTypes) + +prop_readWriteArrayId :: Property +prop_readWriteArrayId = $(testWithTypes 'readWriteArrayId ''SingleVarTypes) + +prop_mixedTransformsId :: Property +prop_mixedTransformsId = $(testWithTypes 'mixedTransformsId ''SingleVarTypes) + +prop_samePrimRepId :: Property +prop_samePrimRepId = $(testWithTypes 'samePrimRepId ''SamePrimRepTypes) + +prop_vertexFields :: Property +prop_vertexFields = $(testWithTypes 'vertexFields ''TypeTriples) + + +return [] -- this is for $forAllProperties +runTests :: Int -> IO Bool +runTests n = $forAllProperties + $ quickCheckWithResult stdArgs { maxSuccess = n } diff --git a/test/Numeric/QuaterDoubleTest.hs b/test/Numeric/QuaterDoubleTest.hs new file mode 100644 --- /dev/null +++ b/test/Numeric/QuaterDoubleTest.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module Numeric.QuaterDoubleTest (runTests) where + +import Numeric.DataFrame.Arbitraries () +import Numeric.Quaternion +import Numeric.Scalar +import Numeric.Vector +import Test.QuickCheck + +type T = Double + +eps :: T +eps = 1e-7 + +-- | Some non-linear function are very unstable; +-- it would be a downting task to determine the uncertainty precisely. +-- Instead, I just make sure the numbers are not so big to find at least +-- the most obvious bugs. +smaller :: Quater T -> Quater T +smaller q@(Quater x y z w) + = if square q >= 1 then Quater (f x) (f y) (f z) (f w) else q + where + f :: T -> T + f a | abs a > 2 = signum a * log (abs a) + | otherwise = a + +(=~=) :: Quater T -> Quater T -> Property +(=~=) = approxEq eps +infix 4 =~= + +-- Even lower precision - for naturally fragile operations +approxEq :: T -> Quater T -> Quater T -> Property +approxEq e a b = property $ err <= c * scalar e + where + v1 = toVec4 a + v2 = toVec4 b + c = 1 `max` normL1 v1 `max` normL1 v2 + err = normL1 $ v1 - v2 + +prop_Eq :: Quater T -> Bool +prop_Eq q = and + [ q == q + , Quater (takei q) (takej q) (takek q) (taker q) == q + , fromVecNum (imVec q) (taker q) == q + , im q + re q == q + , fromVec4 (toVec4 q) == q + ] + +prop_DoubleConjugate :: Quater T -> Property +prop_DoubleConjugate q = property $ conjugate (conjugate q) == q + +prop_Square :: Quater T -> Property +prop_Square q = q * conjugate q =~= realToFrac (square q) + +prop_RotScale :: Quater T -> Vector T 3 -> Property +prop_RotScale q v = fromVecNum (rotScale q v) 0 =~= q * fromVecNum v 0 * conjugate q + +prop_GetRotScale :: Vector T 3 -> Vector T 3 -> Property +prop_GetRotScale a b + = a /= 0 ==> approxEq eps' (fromVecNum (rotScale q a) 0) (fromVecNum b 0) + where + q = getRotScale a b + -- when a and b are almost opposite, precision of getRotScale suffers a lot + -- compensate it by increasing eps: + eps' = if cross a b == 0 + then eps + else eps / (max eps . min 1 . unScalar $ + 1 + normalized a `dot` normalized b) + +prop_InverseRotScale :: Quater T -> Vector T 3 -> Property +prop_InverseRotScale q v + = square q > eps ==> fromVecNum (rotScale (1/q) (rotScale q v)) 0 =~= fromVecNum v 0 + +prop_NegateToMatrix33 :: Quater T -> Bool +prop_NegateToMatrix33 q = toMatrix33 q == toMatrix33 (negate q) + +prop_NegateToMatrix44 :: Quater T -> Bool +prop_NegateToMatrix44 q = toMatrix44 q == toMatrix44 (negate q) + +prop_FromToMatrix33 :: Quater T -> Property +prop_FromToMatrix33 q + = q /= 0 ==> fromMatrix33 (toMatrix33 q) =~= q + .||. fromMatrix33 (toMatrix33 q) =~= negate q + +prop_FromToMatrix44 :: Quater T -> Property +prop_FromToMatrix44 q + = q /= 0 ==> fromMatrix44 (toMatrix44 q) =~= q + .||. fromMatrix44 (toMatrix44 q) =~= negate q + + +prop_RotationArg :: Quater T -> Property +prop_RotationArg q | q == 0 = axisRotation (imVec q) (qArg q) =~= 1 + | otherwise = axisRotation (imVec q) (qArg q) =~= signum q + +prop_UnitQ :: Quater T -> Property +prop_UnitQ q + = square q > eps ==> realToFrac (square (q / q)) =~= 1 + + +prop_ExpLog :: Quater T -> Property +prop_ExpLog q | square q < eps = log (exp q) =~= q + | otherwise = exp (log q) =~= q + +prop_SinAsin :: Quater T -> Property +prop_SinAsin q = sin (asin q') =~= q' + where + q' = signum q + +prop_CosAcos :: Quater T -> Property +prop_CosAcos q = cos (acos q') =~= q' + where + q' = signum q + +prop_TanAtan :: Quater T -> Property +prop_TanAtan q = tan (atan q') =~= q' + where + q' = sqrt (smaller q) -- because this inverse fun is fragile + +prop_SinhAsinh :: Quater T -> Property +prop_SinhAsinh q = sinh (asinh q') =~= q' + where + q' = sqrt (smaller q) -- because this inverse fun is fragile + +prop_CoshAcosh :: Quater T -> Property +prop_CoshAcosh q = cosh (acosh q) =~= q + +prop_TanhAtanh :: Quater T -> Property +prop_TanhAtanh q = tanh (atanh q') =~= q' + where + q' = sqrt (smaller q) -- because this inverse fun is fragile + +prop_SqrtSqr :: Quater T -> Property +prop_SqrtSqr q = sqrt q * sqrt q =~= q + +prop_SinCos :: Quater T -> Property +prop_SinCos q = sin q' * sin q' + cos q' * cos q' =~= 1 + where + q' = sqrt (smaller q) -- because it involves exponents + +prop_SinhCosh :: Quater T -> Property +prop_SinhCosh q = cosh q' * cosh q' - sinh q' * sinh q' =~= 1 + where + q' = sqrt (smaller q) -- because it involves exponents + +prop_ReadShow :: Quater T -> Bool +prop_ReadShow q = q == read (show q) + +return [] +runTests :: Int -> IO Bool +runTests n = $forAllProperties + $ quickCheckWithResult stdArgs { maxSuccess = n } diff --git a/test/Numeric/QuaterFloatTest.hs b/test/Numeric/QuaterFloatTest.hs new file mode 100644 --- /dev/null +++ b/test/Numeric/QuaterFloatTest.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module Numeric.QuaterFloatTest (runTests) where + +import Numeric.DataFrame.Arbitraries () +import Numeric.Quaternion +import Numeric.Scalar +import Numeric.Vector +import Test.QuickCheck + +type T = Float + +eps :: T +eps = 1e-3 + +-- | Some non-linear function are very unstable; +-- it would be a downting task to determine the uncertainty precisely. +-- Instead, I just make sure the numbers are not so big to find at least +-- the most obvious bugs. +smaller :: Quater T -> Quater T +smaller q@(Quater x y z w) + = if square q >= 1 then Quater (f x) (f y) (f z) (f w) else q + where + f :: T -> T + f a | abs a > 2 = signum a * log (abs a) + | otherwise = a + +(=~=) :: Quater T -> Quater T -> Property +(=~=) = approxEq eps +infix 4 =~= + +-- Even lower precision - for naturally fragile operations +approxEq :: T -> Quater T -> Quater T -> Property +approxEq e a b = property $ err <= c * scalar e + where + v1 = toVec4 a + v2 = toVec4 b + c = 1 `max` normL1 v1 `max` normL1 v2 + err = normL1 $ v1 - v2 + +prop_Eq :: Quater T -> Bool +prop_Eq q = and + [ q == q + , Quater (takei q) (takej q) (takek q) (taker q) == q + , fromVecNum (imVec q) (taker q) == q + , im q + re q == q + , fromVec4 (toVec4 q) == q + ] + +prop_DoubleConjugate :: Quater T -> Property +prop_DoubleConjugate q = property $ conjugate (conjugate q) == q + +prop_Square :: Quater T -> Property +prop_Square q = q * conjugate q =~= realToFrac (square q) + +prop_RotScale :: Quater T -> Vector T 3 -> Property +prop_RotScale q v = fromVecNum (rotScale q v) 0 =~= q * fromVecNum v 0 * conjugate q + +prop_GetRotScale :: Vector T 3 -> Vector T 3 -> Property +prop_GetRotScale a b + = a /= 0 ==> approxEq eps' (fromVecNum (rotScale q a) 0) (fromVecNum b 0) + where + q = getRotScale a b + -- when a and b are almost opposite, precision of getRotScale suffers a lot + -- compensate it by increasing eps: + eps' = if cross a b == 0 + then eps + else eps / (max eps . min 1 . unScalar $ + 1 + normalized a `dot` normalized b) + +prop_InverseRotScale :: Quater T -> Vector T 3 -> Property +prop_InverseRotScale q v + = square q > eps ==> fromVecNum (rotScale (1/q) (rotScale q v)) 0 =~= fromVecNum v 0 + +prop_NegateToMatrix33 :: Quater T -> Bool +prop_NegateToMatrix33 q = toMatrix33 q == toMatrix33 (negate q) + +prop_NegateToMatrix44 :: Quater T -> Bool +prop_NegateToMatrix44 q = toMatrix44 q == toMatrix44 (negate q) + +prop_FromToMatrix33 :: Quater T -> Property +prop_FromToMatrix33 q + = q /= 0 ==> fromMatrix33 (toMatrix33 q) =~= q + .||. fromMatrix33 (toMatrix33 q) =~= negate q + +prop_FromToMatrix44 :: Quater T -> Property +prop_FromToMatrix44 q + = q /= 0 ==> fromMatrix44 (toMatrix44 q) =~= q + .||. fromMatrix44 (toMatrix44 q) =~= negate q + + +prop_RotationArg :: Quater T -> Property +prop_RotationArg q | q == 0 = axisRotation (imVec q) (qArg q) =~= 1 + | otherwise = axisRotation (imVec q) (qArg q) =~= signum q + +prop_UnitQ :: Quater T -> Property +prop_UnitQ q + = square q > eps ==> realToFrac (square (q / q)) =~= 1 + + +prop_ExpLog :: Quater T -> Property +prop_ExpLog q | square q < eps = log (exp q) =~= q + | otherwise = exp (log q) =~= q + +prop_SinAsin :: Quater T -> Property +prop_SinAsin q = sin (asin q') =~= q' + where + q' = signum q + +prop_CosAcos :: Quater T -> Property +prop_CosAcos q = cos (acos q') =~= q' + where + q' = signum q + +prop_TanAtan :: Quater T -> Property +prop_TanAtan q = tan (atan q') =~= q' + where + q' = sqrt (smaller q) -- because this inverse fun is fragile + +prop_SinhAsinh :: Quater T -> Property +prop_SinhAsinh q = sinh (asinh q') =~= q' + where + q' = sqrt (smaller q) -- because this inverse fun is fragile + +prop_CoshAcosh :: Quater T -> Property +prop_CoshAcosh q = cosh (acosh q) =~= q + +prop_TanhAtanh :: Quater T -> Property +prop_TanhAtanh q = tanh (atanh q') =~= q' + where + q' = sqrt (smaller q) -- because this inverse fun is fragile + +prop_SqrtSqr :: Quater T -> Property +prop_SqrtSqr q = sqrt q * sqrt q =~= q + +prop_SinCos :: Quater T -> Property +prop_SinCos q = sin q' * sin q' + cos q' * cos q' =~= 1 + where + q' = sqrt (smaller q) -- because it involves exponents + +prop_SinhCosh :: Quater T -> Property +prop_SinhCosh q = cosh q' * cosh q' - sinh q' * sinh q' =~= 1 + where + q' = sqrt (smaller q) -- because it involves exponents + +prop_ReadShow :: Quater T -> Bool +prop_ReadShow q = q == read (show q) + +return [] +runTests :: Int -> IO Bool +runTests n = $forAllProperties + $ quickCheckWithResult stdArgs { maxSuccess = n } diff --git a/test/Numeric/QuaternionTest.hs b/test/Numeric/QuaternionTest.hs deleted file mode 100644 --- a/test/Numeric/QuaternionTest.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Numeric.QuaternionTest (runTests) where - -import Test.QuickCheck -import Numeric.Quaternion -import Numeric.Vector - - -instance (Quaternion t, Arbitrary t) => Arbitrary (Quater t) where - arbitrary = packQ <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - shrink q | (x,y,z,t) <- unpackQ q = packQ <$> shrink x <*> shrink y <*> shrink z <*> shrink t - -instance Arbitrary Vec3d where - arbitrary = vec3 <$> arbitrary <*> arbitrary <*> arbitrary - shrink v | (x,y,z) <- unpackV3 v = vec3 <$> shrink x <*> shrink y <*> shrink z - - -(=~=) :: (Quaternion a, Num a, Ord a, Num (Quater a), Fractional a) => Quater a -> Quater a -> Bool -(=~=) a b = taker (abs (a - b)) <= eps - where - s = max 1e-6 $ max (taker (abs a)) (taker (abs b)) - eps = s * 1e-6 -infix 4 =~= - - -prop_Eq :: QDouble -> Bool -prop_Eq q = and - [ (\(x,y,z,t) -> packQ x y z t) (unpackQ q) == q - , packQ (takei q) (takej q) (takek q) (taker q) == q - , fromVecNum (imVec q) (taker q) == q - , im q + re q == q - ] - - -prop_DoubleConjugate :: QDouble -> Bool -prop_DoubleConjugate q = conjugate (conjugate q) == q - -prop_Square :: QDouble -> Bool -prop_Square q = q * conjugate q =~= realToFrac (square q) - - -prop_RotScale :: QDouble -> Vec3d -> Bool -prop_RotScale q v = fromVecNum (rotScale q v) 0 =~= q * fromVecNum v 0 * conjugate q - -prop_GetRotScale :: Vec3d -> Vec3d -> Bool -prop_GetRotScale a b = fromVecNum (rotScale q a) 0 =~= fromVecNum b 0 - where - q = getRotScale a b - - -prop_InverseRotScale :: QDouble -> Vec3d -> Bool -prop_InverseRotScale q v | q /= 0 = fromVecNum (rotScale (1/q) (rotScale q v)) 0 =~= fromVecNum v 0 - | otherwise = True - -prop_FromToMatrix33 :: QDouble -> Bool -prop_FromToMatrix33 q | q == 0 = True - | otherwise = fromMatrix33 (toMatrix33 (signum q)) =~= signum q * signum (re q) - -prop_FromToMatrix44 :: QDouble -> Bool -prop_FromToMatrix44 q | q == 0 = True - | otherwise = fromMatrix44 (toMatrix44 (signum q)) =~= signum q * signum (re q) - -prop_RotationArg :: QDouble -> Bool -prop_RotationArg q | q == 0 = axisRotation (imVec q) (qArg q) =~= 1 - | otherwise = axisRotation (imVec q) (qArg q) =~= signum q - - -prop_UnitQ :: QDouble -> Bool -prop_UnitQ q | q == 0 = True - | otherwise = realToFrac (square (q / q)) =~= (1 :: QDouble) - - -prop_ExpLog :: QDouble -> Bool -prop_ExpLog q | q == 0 = log (exp q) == q - | otherwise = exp (log q) =~= q - -prop_SinAsin :: QDouble -> Bool -prop_SinAsin q = sin (asin q') =~= q' - where - q' = signum q - -prop_CosAcos :: QDouble -> Bool -prop_CosAcos q = cos (acos q') =~= q' - where - q' = signum q - -prop_TanAtan :: QDouble -> Bool -prop_TanAtan q = tan (atan q') =~= q' - where -- protect agains big numbers and rounding errors - q' = if square q >= 1e6 then signum q else q - - -prop_SinhAsinh :: QDouble -> Bool -prop_SinhAsinh q = sinh (asinh q') =~= q' - where -- protect agains big numbers and rounding errors - q' = if square q >= 1e6 then signum q else q - -prop_CoshAcosh :: QDouble -> Bool -prop_CoshAcosh q = cosh (acosh q') =~= q' - where -- protect agains big numbers and rounding errors - q' = if square q >= 1e6 then signum q else q - -prop_TanhAtanh :: QDouble -> Bool -prop_TanhAtanh q = tanh (atanh q') =~= q' - where -- protect agains big numbers and rounding errors - q' = if square q >= 1e6 then signum q else q - -prop_SinCos :: QDouble -> Bool -prop_SinCos q = sin q' * sin q' + cos q' * cos q' =~= 1 - where - q' = signum q - -prop_SinhCosh :: QDouble -> Bool -prop_SinhCosh q = cosh q' * cosh q' - sinh q' * sinh q' =~= 1 - where - q' = signum q - -return [] -runTests :: IO Bool -runTests = $quickCheckAll diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,24 +1,30 @@ module Main (tests, main) where -import Distribution.TestSuite -import System.Exit +import Distribution.TestSuite +import System.Exit import qualified Numeric.DataFrame.BasicTest import qualified Numeric.DataFrame.SubSpaceTest import qualified Numeric.MatrixDoubleTest import qualified Numeric.MatrixFloatTest -import qualified Numeric.QuaternionTest +import qualified Numeric.PrimBytesTest +import qualified Numeric.QuaterDoubleTest +import qualified Numeric.QuaterFloatTest -- | Collection of tests in detailed-0.9 format tests :: IO [Test] tests = return - [ test "DataFrame.Basic" Numeric.DataFrame.BasicTest.runTests - , test "DataFrame.SubSpace" Numeric.DataFrame.SubSpaceTest.runTests - , test "MatrixDouble" Numeric.MatrixDoubleTest.runTests - , test "MatrixFloat" Numeric.MatrixFloatTest.runTests - , test "Quaternion" Numeric.QuaternionTest.runTests + [ test "DataFrame.Basic" $ Numeric.DataFrame.BasicTest.runTests n + , test "DataFrame.SubSpace" $ Numeric.DataFrame.SubSpaceTest.runTests n + , test "MatrixDouble" $ Numeric.MatrixDoubleTest.runTests n + , test "MatrixFloat" $ Numeric.MatrixFloatTest.runTests n + , test "QuaterDouble" $ Numeric.QuaterDoubleTest.runTests n + , test "QuaterFloat" $ Numeric.QuaterFloatTest.runTests n + , test "PrimBytes" $ Numeric.PrimBytesTest.runTests n ] + where + n = 1000 :: Int @@ -26,16 +32,17 @@ -- | Run tests as exitcode-stdio-1.0 main :: IO () main = do + putStrLn "" ts <- tests - trs <- mapM (\(Test ti) ->(,) (name ti) <$> run ti) ts - case filter (not . isGood) trs of + trs <- mapM (\(Test ti) -> (,) (name ti) <$> run ti) ts + case filter (not . isGood . snd) trs of [] -> exitSuccess xs -> do putStrLn $ "Failed tests: " ++ unwords (fmap fst xs) exitFailure where - isGood (_, Finished Pass) = True - isGood _ = False + isGood (Finished Pass) = True + isGood _ = False -- | Convert QuickCheck props into Cabal tests diff --git a/test/Spec/Util.hs b/test/Spec/Util.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Util.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Spec.Util (propWithTypes, testWithTypes) where + +import Control.Applicative +import Control.Monad +import Data.Monoid +import Language.Haskell.TH +import Test.QuickCheck +-- import Language.Haskell.TH.Syntax + +-- | Test a property with several types. +-- +-- The first argument is the name of a @Testable@ function +-- +-- The second argument is expected to be a type synonym of kind [k] -- +-- the variants of type arguments to apply to a fun +-- +-- Kind @k@ here should match the kind of type variable of the testable function, +-- (or a promoted n-tuple or a promoted list of such variables.) +testWithTypes :: Name -- ^ Function with a few type variables + -> Name -- ^ Name of a type with kind [k] + -> ExpQ +testWithTypes fName tyNames = do + typeLists <- getTypes tyNames + let props = (\ts -> mkProp ts $ foldl AppTypeE (VarE fName) ts) <$> typeLists + [e| conjoin $(listE props) |] + where + mkProp :: [Type] -> Exp -> ExpQ + mkProp ts ex + = let qe = pure ex :: ExpQ + qs = litE . stringL $ unlines ["Tested with types:", pprint ts] + in [e| property ( counterexample $qs $qe ) |] + +-- | Assuming the argument is a type synonym for a list of types, unpack it. +getTypes :: Name -> Q [[Type]] +getTypes tyNames = + reify tyNames >>= unpackTyConI >>= unpackFamList >>= traverse unpackAppType + where + unpackTyConI :: Info -> Q Type + unpackTyConI (TyConI (TySynD _ [] t)) = pure t + unpackTyConI i = error $ + "getTypes/unpackTyConI:" + ++ "Expected a type synonym with no arguments, but got something else " + ++ show i + unpackFamList :: Type -> Q [Type] + unpackFamList t + | Just ts <- unpackPList t = pure ts + | otherwise = error $ + "getTypes/unpackFamList:" + ++ "Expected a promoted (type) list inside the type synonym, but got " + ++ show t + unpackAppType :: Type -> Q [Type] + unpackAppType t + | Just ts <- unpackPList t = pure ts + | Just ts <- unpackPTuple t = pure ts + | otherwise = pure [t] + unpackPTuple :: Type -> Maybe [Type] + unpackPTuple (PromotedTupleT _) = pure [] + unpackPTuple (AppT t r) = (++ [r]) <$> unpackPTuple t + unpackPTuple (ParensT t) = unpackPTuple t + unpackPTuple (SigT t _) = unpackPTuple t + unpackPTuple _ = Nothing + unpackPList :: Type -> Maybe [Type] + unpackPList PromotedNilT = pure [] + unpackPList (AppT (AppT PromotedConsT r) t) = (r:) <$> unpackPList t + unpackPList (ParensT t) = unpackPList t + unpackPList (SigT t _) = unpackPList t + unpackPList _ = Nothing + + +-- | Make several properties by applying types +propWithTypes :: Name -- ^ Function with a few type variables + -> [[Name]] -- ^ All specific types to test it on. + -> DecsQ +propWithTypes fName tyNames + = fmap join . sequence + $ zipWith3 mkDecl funNames funTypes appliedExpressions + where + appliedExpressions :: [ExpQ] + appliedExpressions + = foldl (\e -> appTypeE e . conT) (varE fName) <$> tyNames + funNames :: [Q Name] + funNames + = newName . foldl (\n -> (n ++) . nameBase) ("prop_" ++ nameBase fName) <$> tyNames + funTypes :: [TypeQ] + funTypes + = (\ns -> fmap (subtTyVars (map ConT ns)) ) <$> tyNames <*> [infoType <$> reify fName] + mkDecl qn qt qe = do + n <- qn + sequence + [ sigD n qt + , funD n [(\e -> Clause [] (NormalB e) []) <$> qe] + ] + + +-- | Get a type of something at the term level (e.g. function, var, constructor). +infoType :: Info -> Type +infoType (ClassOpI _ t _) = t +infoType (DataConI _ t _) = t +infoType (VarI _ t _) = t +infoType _ = undefined + +-- | Substitute at most as many type variables as given types in the list. +-- +-- For every type in a list @ts@, the function looks for the first occurrence +-- of any type variable and substitutes all its occurrences in the target type. +-- +-- Returns the original type if it has no type variables. +subtTyVars :: [Type] -> Type -> Type +subtTyVars = flip (foldl f) + where + f t x + | Just v <- findFirstTyVar t + = substTyVar v x t + | otherwise = t + +-- | Substitute all occurrences of a type variable +substTyVar :: Name -- ^ TyVar name + -> Type -- ^ Substitution + -> Type -- ^ Original type + -> Type +substTyVar x y (ForallT vs ctx t) + = ForallT (remVar vs) (ctx >>= substOrRemove) (substTyVar x y t) + where + thisVar :: TyVarBndr -> Bool + thisVar (PlainTV n) = n == x + thisVar (KindedTV n _) = n == x + remVar :: [TyVarBndr] -> [TyVarBndr] + remVar = filter (not . thisVar) + substOrRemove p + = let p' = substTyVar x y p + in if findFirstTyVar p' == Nothing then [] else [p] +substTyVar x y (AppT t1 t2) = AppT (substTyVar x y t1) (substTyVar x y t2) +substTyVar x y (SigT t1 t2) = SigT (substTyVar x y t1) (substTyVar x y t2) +substTyVar x y v@(VarT n) = if n == x then y else v +substTyVar x y (InfixT t1 n t2) = InfixT (substTyVar x y t1) n (substTyVar x y t2) +substTyVar x y (UInfixT t1 n t2) = UInfixT (substTyVar x y t1) n (substTyVar x y t2) +substTyVar x y (ParensT t) = ParensT (substTyVar x y t) +substTyVar _ _ t = t + +findFirstTyVar :: Type -> Maybe Name +findFirstTyVar (ForallT (PlainTV n:_) _ _) = Just n +findFirstTyVar (ForallT (KindedTV n _:_) _ _) = Just n +findFirstTyVar (ForallT [] ctx t) + = getFirst (foldMap (First . findFirstTyVar) ctx) <|> findFirstTyVar t +findFirstTyVar (AppT t1 t2) = findFirstTyVar t1 <|> findFirstTyVar t2 +findFirstTyVar (SigT t1 k1) = findFirstTyVar t1 <|> findFirstTyVar k1 +findFirstTyVar (VarT n) = Just n +findFirstTyVar (InfixT t1 _ t2) = findFirstTyVar t1 <|> findFirstTyVar t2 +findFirstTyVar (UInfixT t1 _ t2) = findFirstTyVar t1 <|> findFirstTyVar t2 +findFirstTyVar (ParensT t) = findFirstTyVar t +findFirstTyVar _ = Nothing