diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,6 @@ +run-test: + runhaskell Setup configure --user --enable-tests -fbuildExamples + runhaskell Setup build + runhaskell Setup haddock + ./dist/build/lapack-test/lapack-test + ./dist/build/lapack-economic/lapack-economic diff --git a/example/EconomicAllocation.hs b/example/EconomicAllocation.hs new file mode 100644 --- /dev/null +++ b/example/EconomicAllocation.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TypeOperators #-} +module Main where + +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix (ZeroInt, (#>), (|||)) +import Numeric.LAPACK.Format ((##)) + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((:+:)((:+:))) +import Data.Function.HT (nest) + + +type ZeroInt2 = ZeroInt:+:ZeroInt +type Vector sh = Vector.Vector sh Double +type Matrix height width = Matrix.General height width Double +type SquareMatrix size = Square.Square size Double + + +balances :: Vector ZeroInt2 +balances = + Vector.fromList (Matrix.zeroInt 2 :+: Matrix.zeroInt 2) + [100000, 90000, -50000, -120000] + +expenses :: Matrix ZeroInt ZeroInt2 +expenses = + Matrix.fromList (Matrix.zeroInt 2) (Matrix.zeroInt 2 :+: Matrix.zeroInt 2) $ + [16000, 4000, 8000, 12000, + 10000, 30000, 40000, 20000] + +normalize :: + (Eq height, Shape.C height, Shape.C width) => + Matrix height width -> Matrix height width +normalize x = Matrix.scaleRows (Array.map recip (Matrix.rowSums x)) x + + +subtractIdentity :: (Eq sh, Shape.C sh) => SquareMatrix sh -> SquareMatrix sh +subtractIdentity x = Matrix.sub x $ Square.identityFrom x + +completeIdSquare :: Matrix ZeroInt2 ZeroInt -> SquareMatrix ZeroInt2 +completeIdSquare x = + Square.fromGeneral $ + (Matrix.takeLeftColumns $ Matrix.fromFull $ Square.identityFromHeight x) + ||| + x + +iterationMatrix :: SquareMatrix ZeroInt2 +iterationMatrix = + completeIdSquare $ Matrix.transpose $ normalize expenses + +iterated :: Vector ZeroInt2 +iterated = nest 30 (iterationMatrix #>) balances + + + +compensated :: Vector ZeroInt +compensated = + let a = Matrix.transpose $ normalize expenses + p = Matrix.takeTopRows a + k = Square.fromGeneral $ Matrix.takeBottomRows a + x = Vector.takeLeft balances + y = Vector.takeRight balances + in Vector.sub x $ p #> Matrix.solveVector (subtractIdentity k) y + + +main :: IO () +main = do + Array.mapShape (Shape.ZeroBased . Shape.size) iterated ## "%10.2f" + compensated ## "%10.2f" diff --git a/lapack.cabal b/lapack.cabal --- a/lapack.cabal +++ b/lapack.cabal @@ -1,5 +1,5 @@ Name: lapack -Version: 0.1 +Version: 0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -17,7 +17,7 @@ . * Based on @comfort-array@: Allows to precisely express one-column or one-row matrices, - as well as dense, square, triangular, banded and symmetric matrices. + as well as dense, square, triangular, banded, symmetric and block matrices. . * Support all data types that are supported by LAPACK, i.e. Float, Double, Complex Float, Complex Double @@ -26,6 +26,8 @@ . * Dependency only on BLAS and LAPACK, no GSL . + * Works with matrices and vectors with zero dimensions. + . * Separate formatting operator @(##)@: Works better for tuples of matrices and vectors than 'show'. 'Show' is used for code one-liners @@ -33,11 +35,17 @@ . See also: @hmatrix@. Tested-With: GHC==7.4.2, GHC==7.8.4, GHC==8.2.2 -Cabal-Version: >=1.6 +Cabal-Version: >=1.8 Build-Type: Simple +Extra-Source-Files: + Makefile +Flag buildExamples + description: Build example executables + default: False + Source-Repository this - Tag: 0.1 + Tag: 0.2 Type: darcs Location: http://hub.darcs.net/thielema/lapack/ @@ -48,10 +56,16 @@ Library Build-Depends: lapack-ffi >=0.0.1 && <0.1, - blas-ffi >=0.0 && <0.1, - netlib-ffi >=0.1 && <0.2, - comfort-array >=0.0.1 && <0.1, + blas-ffi >=0.0 && <0.2, + netlib-ffi >=0.1.1 && <0.2, + comfort-array >=0.2 && <0.3, + guarded-allocation >=0.0 && <0.1, + boxes >=0.1.5 && <0.2, + deepseq >=1.3 && <1.5, + lazyio >=0.1 && <0.2, transformers >=0.3 && <0.6, + tfp >=1.0.1 && <1.1, + fixed-length >=0.2 && <0.3, non-empty >=0.3 && <0.4, utility-ht >=0.0.10 && <0.1, base >=4.5 && <5 @@ -60,24 +74,102 @@ Hs-Source-Dirs: src Exposed-Modules: Numeric.LAPACK.Matrix + Numeric.LAPACK.Matrix.Extent Numeric.LAPACK.Matrix.Shape Numeric.LAPACK.Matrix.Square Numeric.LAPACK.Matrix.Hermitian + Numeric.LAPACK.Matrix.HermitianPositiveDefinite Numeric.LAPACK.Matrix.Triangular + Numeric.LAPACK.Matrix.Banded + Numeric.LAPACK.Matrix.BandedHermitian + Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite Numeric.LAPACK.Vector + Numeric.LAPACK.Scalar Numeric.LAPACK.Orthogonal - Numeric.LAPACK.Linear.General - Numeric.LAPACK.Linear.HermitianPositiveDefinite - Numeric.LAPACK.Linear.Hermitian - Numeric.LAPACK.Linear.Triangular - Numeric.LAPACK.Eigen.General - Numeric.LAPACK.Eigen.Hermitian - Numeric.LAPACK.Eigen.Triangular + Numeric.LAPACK.Orthogonal.Householder + Numeric.LAPACK.Permutation + Numeric.LAPACK.Linear.LowerUpper Numeric.LAPACK.Singular + Numeric.LAPACK.ShapeStatic + Numeric.LAPACK.Format Other-Modules: + Numeric.LAPACK.Orthogonal.Private + Numeric.LAPACK.Linear.Private + Numeric.LAPACK.Split + Numeric.LAPACK.Permutation.Private + Numeric.LAPACK.Matrix.Square.Basic + Numeric.LAPACK.Matrix.Square.Linear + Numeric.LAPACK.Matrix.Square.Eigen Numeric.LAPACK.Matrix.Triangular.Private + Numeric.LAPACK.Matrix.Triangular.Basic + Numeric.LAPACK.Matrix.Triangular.Linear + Numeric.LAPACK.Matrix.Triangular.Eigen + Numeric.LAPACK.Matrix.Hermitian.Private + Numeric.LAPACK.Matrix.Hermitian.Basic + Numeric.LAPACK.Matrix.Hermitian.Linear + Numeric.LAPACK.Matrix.Hermitian.Eigen + Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear + Numeric.LAPACK.Matrix.Symmetric.Private + Numeric.LAPACK.Matrix.Banded.Basic + Numeric.LAPACK.Matrix.Banded.Linear + Numeric.LAPACK.Matrix.BandedHermitian.Basic + Numeric.LAPACK.Matrix.BandedHermitian.Eigen + Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear Numeric.LAPACK.Matrix.Shape.Private + Numeric.LAPACK.Matrix.Extent.Private + Numeric.LAPACK.Matrix.Extent.Kind Numeric.LAPACK.Matrix.Multiply + Numeric.LAPACK.Matrix.Divide + Numeric.LAPACK.Matrix.Basic Numeric.LAPACK.Matrix.Private Numeric.LAPACK.Private - Numeric.LAPACK.Format + Numeric.LAPACK.Wrapper + +Test-Suite lapack-test + Type: exitcode-stdio-1.0 + Build-Depends: + lapack, + netlib-ffi, + tfp, + comfort-array, + QuickCheck >=2.5 && <3, + ChasingBottoms >=1.2.2 && <1.4, + transformers, + semigroups >=0.18.3 && <0.19, + non-empty >=0.3.1, + utility-ht, + base + + GHC-Options: -Wall + Hs-Source-Dirs: test + Main-Is: Main.hs + Other-Modules: + Test.Shape + Test.Permutation + Test.Vector + Test.Matrix + Test.Square + Test.Triangular + Test.Hermitian + Test.Orthogonal + Test.Banded + Test.BandedHermitian + Test.Banded.Utility + Test.Singular + Test.Generator + Test.Format + Test.Utility + +Executable lapack-economic + If flag(buildExamples) + Build-Depends: + lapack, + comfort-array, + utility-ht, + base + Else + Buildable: False + + GHC-Options: -Wall + Hs-Source-Dirs: example + Main-Is: EconomicAllocation.hs diff --git a/src/Numeric/LAPACK/Eigen/General.hs b/src/Numeric/LAPACK/Eigen/General.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Eigen/General.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Eigen.General ( - values, - schur, - decompose, - ComplexOf, - ) where - -import Numeric.LAPACK.Matrix.Square (Square) - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor,ColumnMajor)) -import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Private - (ComplexOf, RealOf, zero, withAutoWorkspaceInfo, - copyToTemp, copyToColumnMajor, allocArray) - -import qualified Numeric.LAPACK.FFI.Complex as LapackComplex -import qualified Numeric.LAPACK.FFI.Real as LapackReal -import qualified Numeric.BLAS.FFI.Complex as BlasComplex -import qualified Numeric.BLAS.FFI.Real as BlasReal -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Internal as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) - -import System.IO.Unsafe (unsafePerformIO) - -import Foreign.Marshal.Array (advancePtr, peekArray) -import Foreign.C.Types (CInt, CChar) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, nullPtr, nullFunPtr, castPtr) -import Foreign.Storable (Storable) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) - -import Data.Complex (Complex) - - -values :: - (Shape.C sh, Class.Floating a) => - Square sh a -> Vector sh (ComplexOf a) -values = - getValues $ - Class.switchFloating - (Values valuesAux) (Values valuesAux) - (Values valuesAux) (Values valuesAux) - -type Values_ sh a = Square sh a -> Vector sh (ComplexOf a) - -newtype Values sh a = Values {getValues :: Values_ sh a} - -valuesAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - Values_ sh a -valuesAux (Array (MatrixShape.Square _order size) a) = - Array.unsafeCreateWithSize size $ \n wPtr -> do - let lda = n - evalContT $ do - jobvsPtr <- Call.char 'N' - sortPtr <- Call.char 'N' - aPtr <- copyToTemp (n*n) a - ldaPtr <- Call.cint lda - sdimPtr <- Call.alloca - let vsPtr = nullPtr - ldvsPtr <- Call.cint n - let bworkPtr = nullPtr - liftIO $ withAutoWorkspaceInfo "gees" $ \workPtr lworkPtr infoPtr -> - gees - jobvsPtr sortPtr n aPtr ldaPtr sdimPtr - wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr - - -{- | -If @(q,r) = schur a@, then @a = q \<#\> r \<#\> adjoint q@, -where @q@ is unitary (orthogonal) -and @r@ is a right-upper triangular matrix for complex @a@ -and a 1x1-or-2x2-block upper triangular matrix for real @a@. -With @getDiagonal r@ you get all eigenvalues of @a@ if @a@ is complex -and the real parts of the eigenvalues if @a@ is real. -Complex conjugated eigenvalues of a real matrix @a@ -are encoded as 2x2 blocks along the diagonal. --} -schur :: - (Shape.C sh, Class.Floating a) => - Square sh a -> (Square sh a, Square sh a) -schur = - getSchur $ - Class.switchFloating - (Schur schurAux) (Schur schurAux) - (Schur schurAux) (Schur schurAux) - -type Schur_ sh a = Square sh a -> (Square sh a, Square sh a) - -newtype Schur sh a = Schur {getSchur :: Schur_ sh a} - -schurAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - Schur_ sh a -schurAux (Array (MatrixShape.Square order size) a) = unsafePerformIO $ do - let n = Shape.size size - let lda = n - let sh = MatrixShape.Square ColumnMajor size - evalContT $ do - jobvsPtr <- Call.char 'V' - sortPtr <- Call.char 'N' - aPtr <- ContT $ withForeignPtr a - (s,sPtr) <- allocArray sh - liftIO $ copyToColumnMajor order n n aPtr sPtr - ldaPtr <- Call.cint lda - sdimPtr <- Call.alloca - wPtr <- Call.allocaArray n - (vs,vsPtr) <- allocArray sh - ldvsPtr <- Call.cint n - let bworkPtr = nullPtr - liftIO $ withAutoWorkspaceInfo "gees" $ \workPtr lworkPtr infoPtr -> - gees - jobvsPtr sortPtr n sPtr ldaPtr sdimPtr - wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr - return (vs, s) - - - -type GEES_ ar a = - Ptr CChar -> Ptr CChar -> Int -> Ptr a -> Ptr CInt -> - Ptr CInt -> Ptr (Complex ar) -> Ptr a -> Ptr CInt -> - Ptr a -> Ptr CInt -> Ptr Bool -> Ptr CInt -> IO () - -newtype GEES a = GEES {getGEES :: GEES_ (RealOf a) a} - -gees :: Class.Floating a => GEES_ (RealOf a) a -gees = - getGEES $ - Class.switchFloating - (GEES geesReal) (GEES geesReal) (GEES geesComplex) (GEES geesComplex) - -geesReal :: Class.Real a => GEES_ a a -geesReal - jobvsPtr sortPtr n aPtr ldaPtr sdimPtr - wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr = - evalContT $ do - let selectPtr = nullFunPtr - nPtr <- Call.cint n - wrPtr <- Call.allocaArray n - wiPtr <- Call.allocaArray n - liftIO $ - LapackReal.gees - jobvsPtr sortPtr selectPtr nPtr aPtr ldaPtr sdimPtr - wrPtr wiPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr - liftIO $ zipComplex n wrPtr wiPtr wPtr - -geesComplex :: Class.Real a => GEES_ a (Complex a) -geesComplex - jobvsPtr sortPtr n aPtr ldaPtr sdimPtr - wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr = - evalContT $ do - let selectPtr = nullFunPtr - nPtr <- Call.cint n - rworkPtr <- Call.allocaArray n - liftIO $ - LapackComplex.gees - jobvsPtr sortPtr selectPtr nPtr aPtr ldaPtr sdimPtr - wPtr vsPtr ldvsPtr workPtr lworkPtr rworkPtr bworkPtr infoPtr - - - -{- | -@(vr,d,vl) = Eigen.decompose a@ - -Counterintuitively, @vr@ contains the right eigenvectors -and @vl@ contains the left eigenvectors as columns. -The idea is to provide a decomposition of @a@. -If @a@ is diagonalizable, then @vr@ and @vl@ are almost inverse to each other. -More precisely, @adjoint vl \<#\> vr@ is a diagonal matrix. -This is because all eigenvectors are normalized to Euclidean norm 1. -With the following scaling, the decomposition becomes perfect: - -> let scal = Array.map recip $ getDiagonal $ adjoint vl <#> vr -> a == vr <#> diagonal d <#> diagonal scal <#> adjoint vl - -If @a@ is non-diagonalizable then some columns of @vr@ and @vl@ are left zero -and the above property does not hold. --} -decompose :: - (Shape.C sh, Class.Floating a) => - Square sh a -> - (Square sh (ComplexOf a), - Vector sh (ComplexOf a), - Square sh (ComplexOf a)) -decompose = - getDecompose $ - Class.switchFloating - (Decompose decomposeReal) - (Decompose decomposeReal) - (Decompose decomposeComplex) - (Decompose decomposeComplex) - -newtype Decompose sh a = - Decompose { - getDecompose :: - Square sh a -> - (Square sh (ComplexOf a), - Vector sh (ComplexOf a), - Square sh (ComplexOf a)) - } - -decomposeReal :: - (Shape.C sh, Class.Real a) => - Square sh a -> - (Square sh (Complex a), Vector sh (Complex a), Square sh (Complex a)) -decomposeReal (Array (MatrixShape.Square order size) a) = - unsafePerformIO $ do - let n = Shape.size size - let lda = n - evalContT $ do - jobvlPtr <- Call.char 'V' - jobvrPtr <- Call.char 'V' - nPtr <- Call.cint n - aPtr <- copyToTemp (n*n) a - ldaPtr <- Call.cint lda - wrPtr <- Call.allocaArray n - wiPtr <- Call.allocaArray n - vlPtr <- Call.allocaArray (n*n) - ldvlPtr <- Call.cint n - vrPtr <- Call.allocaArray (n*n) - ldvrPtr <- Call.cint n - liftIO $ withAutoWorkspaceInfo "geev" $ - LapackReal.geev - jobvlPtr jobvrPtr nPtr aPtr ldaPtr - wrPtr wiPtr vlPtr ldvlPtr vrPtr ldvrPtr - (w,wPtr) <- allocArray size - liftIO $ zipComplex n wrPtr wiPtr wPtr - let sh = MatrixShape.Square ColumnMajor size - (vlc,vlcPtr) <- allocArray sh - (vrc,vrcPtr) <- allocArray sh - liftIO $ eigenvectorsToComplex n wiPtr vlPtr vlcPtr - liftIO $ eigenvectorsToComplex n wiPtr vrPtr vrcPtr - return $ - case order of - RowMajor -> (vlc, w, vrc) - ColumnMajor -> (vrc, w, vlc) - -eigenvectorsToComplex :: - (Eq a, Class.Real a) => - Int -> Ptr a -> Ptr a -> Ptr (Complex a) -> IO () -eigenvectorsToComplex n wiPtr vPtr vcPtr = evalContT $ do - nPtr <- Call.cint n - zeroPtr <- Call.real zero - inc0Ptr <- Call.cint 0 - inc1Ptr <- Call.cint 1 - inc2Ptr <- Call.cint 2 - liftIO $ do - let go _ _ [] = return () - go xPtr yPtr (False:wi) = do - let yrPtr = castPtr yPtr - let yiPtr = advancePtr yrPtr 1 - BlasReal.copy nPtr xPtr inc1Ptr yrPtr inc2Ptr - BlasReal.copy nPtr zeroPtr inc0Ptr yiPtr inc2Ptr - go (advancePtr xPtr n) (advancePtr yPtr n) wi - go xPtr yPtr (True:True:wi) = do - let xrPtr = xPtr - let xiPtr = advancePtr xPtr n - let yrPtr = castPtr yPtr - let yiPtr = advancePtr yrPtr 1 - let y1Ptr = advancePtr yPtr n - BlasReal.copy nPtr xrPtr inc1Ptr yrPtr inc2Ptr - BlasReal.copy nPtr xiPtr inc1Ptr yiPtr inc2Ptr - BlasComplex.copy nPtr yPtr inc1Ptr y1Ptr inc1Ptr - LapackComplex.lacgv nPtr y1Ptr inc1Ptr - go (advancePtr xPtr (2*n)) (advancePtr yPtr (2*n)) wi - go _xPtr _yPtr wi = - error $ "eigenvectorToComplex: invalid non-real pattern " ++ show wi - go vPtr vcPtr . map (zero/=) =<< peekArray n wiPtr - -decomposeComplex :: - (Shape.C sh, Class.Real a) => - Square sh (Complex a) -> - (Square sh (Complex a), Vector sh (Complex a), Square sh (Complex a)) -decomposeComplex (Array (MatrixShape.Square order size) a) = - unsafePerformIO $ do - let n = Shape.size size - let lda = n - evalContT $ do - jobvlPtr <- Call.char 'V' - jobvrPtr <- Call.char 'V' - nPtr <- Call.cint n - aPtr <- copyToTemp (n*n) a - ldaPtr <- Call.cint lda - (w,wPtr) <- allocArray size - let sh = MatrixShape.Square ColumnMajor size - (vl,vlPtr) <- allocArray sh - ldvlPtr <- Call.cint n - (vr,vrPtr) <- allocArray sh - ldvrPtr <- Call.cint n - rworkPtr <- Call.allocaArray (2*n) - liftIO $ withAutoWorkspaceInfo "geev" $ \workPtr lworkPtr infoPtr -> - LapackComplex.geev - jobvlPtr jobvrPtr nPtr aPtr ldaPtr - wPtr vlPtr ldvlPtr vrPtr ldvrPtr - workPtr lworkPtr rworkPtr infoPtr - return $ - case order of - RowMajor -> (vl, w, vr) - ColumnMajor -> (vr, w, vl) - - -zipComplex :: - (Class.Real a) => Int -> Ptr a -> Ptr a -> Ptr (Complex a) -> IO () -zipComplex n vr vi vc = - evalContT $ do - nPtr <- Call.cint n - incxPtr <- Call.cint 1 - incyPtr <- Call.cint 2 - let yPtr = castPtr vc - liftIO $ BlasReal.copy nPtr vr incxPtr yPtr incyPtr - liftIO $ BlasReal.copy nPtr vi incxPtr (advancePtr yPtr 1) incyPtr diff --git a/src/Numeric/LAPACK/Eigen/Hermitian.hs b/src/Numeric/LAPACK/Eigen/Hermitian.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Eigen/Hermitian.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Eigen.Hermitian ( - values, - decompose, - ) where - -import Numeric.LAPACK.Matrix.Hermitian (Hermitian) -import Numeric.LAPACK.Matrix.Square (Square) - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Shape.Private - (Order(ColumnMajor), uploFromOrder, triangleSize) -import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Private (RealOf, copyToTemp, allocArray) - -import qualified Numeric.LAPACK.FFI.Complex as LapackComplex -import qualified Numeric.LAPACK.FFI.Real as LapackReal -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Internal as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) - -import System.IO.Unsafe (unsafePerformIO) - -import Foreign.Marshal.Alloc (alloca) -import Foreign.C.Types (CInt, CChar) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (Storable, peek) - -import Control.Monad.Trans.Cont (evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) - -import Text.Printf (printf) - -import Data.Complex (Complex) - - -values :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> Vector sh (RealOf a) -values = - getValues $ - Class.switchFloating - (Values valuesAux) (Values valuesAux) - (Values valuesAux) (Values valuesAux) - -newtype Values sh a = - Values {getValues :: Hermitian sh a -> Vector sh (RealOf a)} - -valuesAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - Hermitian sh a -> Vector sh ar -valuesAux (Array (MatrixShape.Hermitian order size) a) = - Array.unsafeCreateWithSize size $ \n wPtr -> do - evalContT $ do - jobzPtr <- Call.char 'N' - uploPtr <- Call.char $ uploFromOrder order - aPtr <- copyToTemp (triangleSize n) a - let zPtr = nullPtr - ldzPtr <- Call.cint (max 1 n) - liftIO $ withInfo "hpev" $ - hpev jobzPtr uploPtr n aPtr wPtr zPtr ldzPtr - - -{- | -For symmetric eigenvalue problems, @Eigen.decompose@ and @schur@ coincide. --} -decompose :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) -decompose = - getDecompose $ - Class.switchFloating - (Decompose decomposeAux) (Decompose decomposeAux) - (Decompose decomposeAux) (Decompose decomposeAux) - -type Decompose_ sh a = Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) - -newtype Decompose sh a = Decompose {getDecompose :: Decompose_ sh a} - -decomposeAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - Decompose_ sh a -decomposeAux (Array (MatrixShape.Hermitian order size) a) = unsafePerformIO $ do - let n = Shape.size size - let shZ = MatrixShape.Square ColumnMajor size - evalContT $ do - jobzPtr <- Call.char 'V' - uploPtr <- Call.char $ uploFromOrder order - aPtr <- copyToTemp (triangleSize n) a - (w,wPtr) <- allocArray size - (z,zPtr) <- allocArray shZ - ldzPtr <- Call.cint n - liftIO $ withInfo "hpev" $ - hpev jobzPtr uploPtr n aPtr wPtr zPtr ldzPtr - return (z, w) - - -withInfo :: String -> (Ptr CInt -> IO ()) -> IO () -withInfo name computation = alloca $ \infoPtr -> do - computation infoPtr - info <- fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ - printf "%s: %d off-diagonal elements not converging" name info - - -type HPEV_ ar a = - Ptr CChar -> Ptr CChar -> Int -> Ptr a -> Ptr ar -> - Ptr a -> Ptr CInt -> Ptr CInt -> IO () - -newtype HPEV a = HPEV {getHPEV :: HPEV_ (RealOf a) a} - -hpev :: Class.Floating a => HPEV_ (RealOf a) a -hpev = - getHPEV $ - Class.switchFloating - (HPEV spevReal) (HPEV spevReal) (HPEV hpevComplex) (HPEV hpevComplex) - -spevReal :: Class.Real a => HPEV_ a a -spevReal jobzPtr uploPtr n apPtr wPtr zPtr ldzPtr infoPtr = - evalContT $ do - nPtr <- Call.cint n - workPtr <- Call.allocaArray (3*n) - liftIO $ - LapackReal.spev - jobzPtr uploPtr nPtr apPtr wPtr zPtr ldzPtr workPtr infoPtr - -hpevComplex :: Class.Real a => HPEV_ a (Complex a) -hpevComplex jobzPtr uploPtr n apPtr wPtr zPtr ldzPtr infoPtr = - evalContT $ do - nPtr <- Call.cint n - workPtr <- Call.allocaArray (max 1 (2*n-1)) - rworkPtr <- Call.allocaArray (max 1 (3*n-2)) - liftIO $ - LapackComplex.hpev - jobzPtr uploPtr nPtr apPtr wPtr zPtr ldzPtr workPtr rworkPtr infoPtr diff --git a/src/Numeric/LAPACK/Eigen/Triangular.hs b/src/Numeric/LAPACK/Eigen/Triangular.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Eigen/Triangular.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Eigen.Triangular ( - values, - decompose, - ) where - -import qualified Numeric.LAPACK.Matrix.Triangular as Triangular -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Triangular.Private - (unpackZero, pack, unpackToTemp, fillTriangle, - forPointers, rowMajorPointers) -import Numeric.LAPACK.Matrix.Triangular (Triangular) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(ColumnMajor,RowMajor), caseUplo, uploOrder, triangleSize) -import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Private (zero, lacgv, allocArray) - -import qualified Numeric.LAPACK.FFI.Complex as LapackComplex -import qualified Numeric.LAPACK.FFI.Real as LapackReal -import qualified Numeric.BLAS.FFI.Generic as BlasGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) - -import System.IO.Unsafe (unsafePerformIO) - -import Foreign.Marshal.Alloc (alloca) -import Foreign.C.Types (CInt, CChar) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek) - -import Control.Monad.Trans.Cont (evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) - -import Text.Printf (printf) - -import Data.Complex (Complex) - - -values :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Triangular uplo sh a -> Vector sh a -values = Triangular.getDiagonal - - -{- | -@(vr,d,vlAdj) = TriEigen.decompose a@ - -Counterintuitively, @vr@ contains the right eigenvectors as columns -and @vlAdj@ contains the left conjugated eigenvectors as rows. -The idea is to provide a decomposition of @a@. -If @a@ is diagonalizable, then @vr@ and @vlAdj@ -are almost inverse to each other. -More precisely, @vlAdj \<#\> vr@ is a diagonal matrix. -This is because the eigenvectors are not normalized. -With the following scaling, the decomposition becomes perfect: - -> let scal = Array.map recip $ getDiagonal $ vlAdj <#> vr -> a == vr <#> diagonal d <#> diagonal scal <#> vlAdj - -If @a@ is non-diagonalizable -then some columns of @vr@ and corresponding rows of @vlAdj@ are left zero -and the above property does not hold. --} -decompose :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Triangular uplo sh a -> - (Triangular uplo sh a, Vector sh a, Triangular uplo sh a) -decompose a = - let (vr,vl) = decomposePlain a - in (vr, values a, vl) - -decomposePlain :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Triangular uplo sh a -> (Triangular uplo sh a, Triangular uplo sh a) -decomposePlain (Array (MatrixShape.Triangular uplo order sh) a) = - unsafePerformIO $ do - let n = Shape.size sh - let n2 = n*n - let triSize = triangleSize n - evalContT $ do - sidePtr <- Call.char 'B' - howManyPtr <- Call.char 'A' - let selectPtr = nullPtr - let unpk = - case uploOrder uplo order of - ColumnMajor -> unpackZero ColumnMajor - RowMajor -> unpackZeroRowMajor - aPtr <- unpackToTemp unpk n a - ldaPtr <- Call.cint n - vlPtr <- Call.allocaArray n2 - vrPtr <- Call.allocaArray n2 - mmPtr <- Call.cint n - mPtr <- Call.alloca - liftIO $ withInfo "trevc" $ - trevc sidePtr howManyPtr selectPtr n - aPtr ldaPtr vlPtr ldaPtr vrPtr ldaPtr mmPtr mPtr - (vl,vlpPtr) <- - allocArray $ - MatrixShape.Triangular uplo (uploOrder uplo RowMajor) sh - (vr,vrpPtr) <- - allocArray $ - MatrixShape.Triangular uplo (uploOrder uplo ColumnMajor) sh - sizePtr <- Call.cint triSize - incPtr <- Call.cint 1 - liftIO $ do - pack ColumnMajor n vrPtr vrpPtr - pack RowMajor n vlPtr vlpPtr - lacgv sizePtr vlpPtr incPtr - return $ caseUplo uplo (vl,vr) (vr,vl) - - -unpackZeroRowMajor :: Class.Floating a => Int -> Ptr a -> Ptr a -> IO () -unpackZeroRowMajor n packedPtr fullPtr = do - fillTriangle zero RowMajor n fullPtr - unpackRowMajor n packedPtr fullPtr - -unpackRowMajor :: Class.Floating a => Int -> Ptr a -> Ptr a -> IO () -unpackRowMajor n packedPtr fullPtr = evalContT $ do - incxPtr <- Call.cint 1 - incyPtr <- Call.cint n - liftIO $ - forPointers (rowMajorPointers n fullPtr packedPtr) $ - \nPtr (dstPtr,srcPtr) -> - BlasGen.copy nPtr srcPtr incxPtr dstPtr incyPtr - - -withInfo :: String -> (Ptr CInt -> IO ()) -> IO () -withInfo name computation = alloca $ \infoPtr -> do - computation infoPtr - info <- fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ - printf "%s: %d off-diagonal elements not converging" name info - - -type TREVC_ a = - Ptr CChar -> Ptr CChar -> Ptr Bool -> - Int -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> - Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () - -newtype TREVC a = TREVC {getTREVC :: TREVC_ a} - -trevc :: Class.Floating a => TREVC_ a -trevc = - getTREVC $ - Class.switchFloating - (TREVC trevcReal) (TREVC trevcReal) - (TREVC trevcComplex) (TREVC trevcComplex) - -trevcReal :: Class.Real a => TREVC_ a -trevcReal sidePtr howmnyPtr selectPtr n - tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr infoPtr = - evalContT $ do - nPtr <- Call.cint n - workPtr <- Call.allocaArray (3*n) - liftIO $ - LapackReal.trevc sidePtr howmnyPtr selectPtr nPtr - tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr workPtr infoPtr - -trevcComplex :: Class.Real a => TREVC_ (Complex a) -trevcComplex sidePtr howmnyPtr selectPtr n - tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr infoPtr = - evalContT $ do - nPtr <- Call.cint n - workPtr <- Call.allocaArray (2*n) - rworkPtr <- Call.allocaArray n - liftIO $ - LapackComplex.trevc sidePtr howmnyPtr selectPtr nPtr - tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr - workPtr rworkPtr infoPtr diff --git a/src/Numeric/LAPACK/Format.hs b/src/Numeric/LAPACK/Format.hs --- a/src/Numeric/LAPACK/Format.hs +++ b/src/Numeric/LAPACK/Format.hs @@ -1,114 +1,158 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Numeric.LAPACK.Format ( (##), Format(format), FormatArray(formatArray), + deflt, ) where import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Square as Square -import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor)) -import Numeric.LAPACK.Matrix.Private (General) +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor, ColumnMajor), Filled(Filled), UnaryProxy) +import Numeric.LAPACK.Matrix.Private (Full) +import Numeric.LAPACK.Scalar (conjugate) +import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) import qualified Numeric.Netlib.Class as Class +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num (integralFromProxy) + import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable (Array) +import qualified Text.PrettyPrint.Boxes as TextBox +import Text.PrettyPrint.Boxes (Box, (/+/)) import Text.Printf (PrintfArg, printf) +import qualified Data.List.Reverse.StrictSpine as ListRev +import qualified Data.List.Match as Match import qualified Data.List.HT as ListHT -import qualified Data.Complex as Complex -import Data.Monoid (Endo(Endo,appEndo)) +import qualified Data.List as List +import Data.Functor.Compose (Compose(Compose, getCompose)) +import Data.Foldable (foldMap) import Data.List (mapAccumL, transpose) import Data.Complex (Complex((:+))) +import Data.Maybe.HT (toMaybe) +import Data.Maybe (fromMaybe) +import Data.Char (isSpace) infix 0 ## (##) :: (Format a) => a -> String -> IO () -a ## fmt = putStr $ unlines $ format fmt a +a ## fmt = putStr $ trim $ TextBox.render $ format fmt a +trim :: String -> String +trim = unlines . map (ListRev.dropWhile isSpace) . lines + +deflt :: String +deflt = "%.4g" + + class Format a where - format :: String -> a -> [String] + format :: String -> a -> Box instance Format Int where - format _fmt a = [show a] + format _fmt = TextBox.text . show instance Format Float where - format fmt a = [printf fmt a] + format fmt = TextBox.text . printf fmt instance Format Double where - format fmt a = [printf fmt a] + format fmt = TextBox.text . printf fmt -instance (PrintfArg a, Class.Real a) => Format (Complex a) where - format fmt a = [printfComplex fmt a] +instance (Class.Real a) => Format (Complex a) where + format fmt = TextBox.text . concat . printfComplex fmt +instance (Format a) => Format [a] where + format fmt = TextBox.vsep 1 TextBox.right . map (format fmt) + instance (Format a, Format b) => Format (a,b) where - format fmt (a,b) = format fmt a ++ [""] ++ format fmt b + format fmt (a,b) = format fmt a /+/ format fmt b instance (Format a, Format b, Format c) => Format (a,b,c) where - format fmt (a,b,c) = - format fmt a ++ [""] ++ format fmt b ++ [""] ++ format fmt c + format fmt (a,b,c) = format fmt a /+/ format fmt b /+/ format fmt c instance (FormatArray sh, Class.Floating a) => Format (Array sh a) where format = formatArray class (Shape.C sh) => FormatArray sh where - formatArray :: (Class.Floating a) => String -> Array sh a -> [String] + {- + We use constraint @(Class.Floating a)@ and not @(Format a)@ + because it allows us to align the components of complex numbers. + -} + formatArray :: (Class.Floating a) => String -> Array sh a -> Box instance (Integral i) => FormatArray (Shape.ZeroBased i) where - formatArray fmt m = [unwords $ map (printfFloating fmt) $ Array.toList m] + formatArray = formatVector instance (Integral i) => FormatArray (Shape.OneBased i) where - formatArray fmt m = [unwords $ map (printfFloating fmt) $ Array.toList m] + formatArray = formatVector -instance (Shape.C sh) => FormatArray (MatrixShape.Square sh) where - formatArray fmt = formatGeneral fmt . Square.toGeneral +formatVector :: (Shape.C sh, Class.Floating a) => String -> Array sh a -> Box +formatVector fmt = + TextBox.hsep 1 TextBox.right . + map (TextBox.text . concat . printfFloating fmt) . Array.toList instance - (Shape.C height, Shape.C width) => - FormatArray (MatrixShape.General height width) where - formatArray = formatGeneral + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + FormatArray (MatrixShape.Full vert horiz height width) where + formatArray = formatFull -formatGeneral :: - (Shape.C height, Shape.C width, Class.Floating a) => - String -> General height width a -> [String] -formatGeneral fmt m = - let MatrixShape.General order height width = Array.shape m - in formatAligned $ formatRows fmt order (height,width) $ Array.toList m +formatFull :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + String -> Full vert horiz height width a -> Box +formatFull fmt m = + let MatrixShape.Full order extent = Array.shape m + in formatAligned (printfFloating fmt) $ + splitRows order (Extent.dimensions extent) $ Array.toList m instance - (Shape.C height, Shape.C width) => - FormatArray (MatrixShape.Householder height width) where + (Eq lower, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + FormatArray (MatrixShape.Split lower vert horiz height width) where formatArray = formatHouseholder formatHouseholder :: - (Shape.C height, Shape.C width, Class.Floating a) => - String -> Array (MatrixShape.Householder height width) a -> [String] + (Eq lower, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + String -> Array (MatrixShape.Split lower vert horiz height width) a -> Box formatHouseholder fmt m = - let MatrixShape.Householder order height width = Array.shape m - in formatSeparateTriangle $ - formatRows fmt order (height,width) $ Array.toList m + let MatrixShape.Split _ order extent = Array.shape m + in formatSeparateTriangle (printfFloating fmt) $ + splitRows order (Extent.dimensions extent) $ Array.toList m instance (Shape.C size) => FormatArray (MatrixShape.Hermitian size) where formatArray = formatHermitian formatHermitian :: (Shape.C size, Class.Floating a) => - String -> Array (MatrixShape.Hermitian size) a -> [String] + String -> Array (MatrixShape.Hermitian size) a -> Box formatHermitian fmt m = let MatrixShape.Hermitian order size = Array.shape m - in formatSeparateTriangle $ - map (map (printfFloating fmt)) $ - complementTriangle order (Shape.size size) $ Array.toList m + in formatSeparateTriangle (printfFloating fmt) $ + complementTriangle conjugate order (Shape.size size) $ Array.toList m -complementTriangle :: (Class.Floating a) => Order -> Int -> [a] -> [[a]] -complementTriangle order n xs = +formatSymmetric :: + (Shape.C size, Class.Floating a) => + String -> Array (MatrixShape.Symmetric size) a -> Box +formatSymmetric fmt m = + let MatrixShape.Triangular _diag (Filled, Filled) order size = Array.shape m + in formatSeparateTriangle (printfFloating fmt) $ + complementTriangle id order (Shape.size size) $ Array.toList m + +complementTriangle :: + (Class.Floating a) => (a -> a) -> Order -> Int -> [a] -> [[a]] +complementTriangle adapt order n xs = let mergeTriangles lower upper = - zipWith (++) (map (map conjugate . init) lower) upper + zipWith (++) (map (map adapt . init) lower) upper in case order of RowMajor -> let tri = slice (take n $ iterate pred n) xs @@ -118,49 +162,57 @@ let tri = slice (take n [1..]) xs in mergeTriangles tri (transpose tri) -conjugate :: (Class.Floating a) => a -> a -conjugate = - appEndo $ - Class.switchFloating - (Endo id) (Endo id) (Endo Complex.conjugate) (Endo Complex.conjugate) - instance - (MatrixShape.Uplo uplo, Shape.C size) => - FormatArray (MatrixShape.Triangular uplo size) where - formatArray = formatTriangular + (MatrixShape.Content lo, MatrixShape.Content up, + MatrixShape.TriDiag diag, Shape.C size) => + FormatArray (MatrixShape.Triangular lo diag up size) where + formatArray fmt = + getFormatTriangular $ + MatrixShape.switchDiagUpLoSym + (FormatTriangular $ \m -> + let MatrixShape.Triangular _diag _uplo order size = Array.shape m + n0 = Unary.unary TypeNum.u0 + in formatAligned (printfFloatingMaybe fmt) $ + formatBanded (n0,n0) order (size,size) $ Array.toList m) + (FormatTriangular $ formatTriangular fmt) + (FormatTriangular $ formatTriangular fmt) + (FormatTriangular $ + formatSymmetric fmt . + Array.mapShape MatrixShape.strictNonUnitDiagonal) +newtype FormatTriangular diag size a b lo up = + FormatTriangular { + getFormatTriangular :: + Array (MatrixShape.Triangular lo diag up size) a -> b + } + formatTriangular :: - (MatrixShape.Uplo uplo, Shape.C size, Class.Floating a) => - String -> Array (MatrixShape.Triangular uplo size) a -> [String] + (MatrixShape.TriDiag diag, MatrixShape.UpLo lo up, + Shape.C size, Class.Floating a) => + String -> Array (MatrixShape.Triangular lo diag up size) a -> Box formatTriangular fmt m = - let MatrixShape.Triangular uplo order size = Array.shape m - in formatAligned $ - MatrixShape.caseUplo uplo + let MatrixShape.Triangular _diag uplo order size = Array.shape m + in formatAligned (printfFloatingMaybe fmt) $ + MatrixShape.caseLoUp uplo padLowerTriangle padUpperTriangle order (Shape.size size) $ - map (printfFloating fmt) $ Array.toList m + Array.toList m -padUpperTriangle :: Order -> Int -> [String] -> [[String]] +padUpperTriangle :: Order -> Int -> [a] -> [[Maybe a]] padUpperTriangle order n xs = - case order of - RowMajor -> - zipWith (++) (iterate ("":) []) (slice (take n $ iterate pred n) xs) - ColumnMajor -> - transpose $ - zipWith (++) - (slice (take n [1..]) xs) - (reverse $ take n $ iterate ("":) []) + let mxs = map Just xs + nothings = iterate (Nothing:) [] + in case order of + RowMajor -> + zipWith (++) nothings (slice (take n $ iterate pred n) mxs) + ColumnMajor -> + transpose $ + zipWith (++) + (slice (take n [1..]) mxs) + (reverse $ take n nothings) -padLowerTriangle :: Order -> Int -> [String] -> [[String]] +padLowerTriangle :: Order -> Int -> [a] -> [[Maybe a]] padLowerTriangle order n xs = - case order of - RowMajor -> - map (take n) $ map (++ repeat "") $ slice (take n [1..]) xs - ColumnMajor -> - transpose $ - zipWith (++) (iterate ("":) []) (slice (take n $ iterate pred n) xs) - -_padLowerTriangle :: Order -> Int -> [a] -> [[a]] -_padLowerTriangle order n xs = + map (map Just) $ case order of RowMajor -> slice (take n [1..]) xs ColumnMajor -> @@ -171,50 +223,152 @@ slice ns xs = snd $ mapAccumL (\ys n -> let (vs,ws) = splitAt n ys in (ws,vs)) xs ns -formatSeparateTriangle :: [[String]] -> [String] -formatSeparateTriangle xss = - let strWidths = columnWidths xss - in zipWith - (\row xs -> - concat $ - zipWith (\col cell -> (if row==col then '|' else ' '):cell) [0..] $ - zipWith (ListHT.padLeft ' ') strWidths xs) - [(0::Int)..] xss +formatSeparateTriangle :: (a -> [String]) -> [[a]] -> Box +formatSeparateTriangle printFmt = + alignSeparated . map concat . + zipWith + (zipWith (\sep -> attachSeparators sep . printFmt)) + (ListHT.outerProduct + (\row col -> if row==col then Bar else Space) + [(0::Int)..] [0..]) -formatRows :: - (Class.Floating a, Shape.C height, Shape.C width) => - String -> Order -> (height, width) -> [a] -> [[String]] -formatRows fmt order (height,width) = - (case order of + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + FormatArray (MatrixShape.Banded sub super vert horiz height width) where + formatArray fmt m = + let MatrixShape.Banded offDiag order extent = Array.shape m + in formatAligned (printfFloatingMaybe fmt) $ + formatBanded offDiag order (Extent.dimensions extent) $ + Array.toList m + +formatBanded :: + (Shape.C height, Shape.C width, Unary.Natural sub, Unary.Natural super) => + (UnaryProxy sub, UnaryProxy super) -> Order -> + (height, width) -> [a] -> [[Maybe a]] +formatBanded (sub,super) order (height,width) xs = + let slices = + ListHT.sliceVertical (MatrixShape.bandedBreadth (sub,super)) xs + m = Shape.size height + n = Shape.size width + in case order of + RowMajor -> + map (take n) $ + zipWith (shiftRow Nothing) + (iterate (1+) (- integralFromProxy sub)) + (map (map Just) slices) + ColumnMajor -> + let ku = integralFromProxy super + in take m $ drop ku $ + foldr + (\col mat -> + zipWith (:) (map Just col ++ repeat Nothing) ([]:mat)) + (replicate (ku + m - n) []) + slices + + +instance + (Unary.Natural offDiag, Shape.C size) => + FormatArray (MatrixShape.BandedHermitian offDiag size) where + formatArray fmt m = + let MatrixShape.BandedHermitian offDiag order size = Array.shape m + in formatSeparateTriangle (printfFloatingMaybe fmt) $ + formatBandedHermitian offDiag order size $ Array.toList m + +formatBandedHermitian :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + UnaryProxy offDiag -> Order -> size -> [a] -> [[Maybe a]] +formatBandedHermitian offDiag order _size xs = + let k = integralFromProxy offDiag + slices = ListHT.sliceVertical (k + 1) xs + in case order of + RowMajor -> + foldr + (\row square -> + Match.take ([]:square) (map Just row) + : + zipWith (:) + (tail $ map (Just . conjugate) row ++ repeat Nothing) + square) + [] slices + ColumnMajor -> + zipWith (shiftRow Nothing) (iterate (1+) (-k)) $ map (map Just) $ + zipWith (++) + (map (map conjugate . init) slices) + (drop k $ + foldr + (\column band -> + zipWith (++) (map (:[]) column ++ repeat []) ([]:band)) + (replicate k []) + slices) + +shiftRow :: a -> Int -> [a] -> [a] +shiftRow pad k = if k<=0 then drop (-k) else (replicate k pad ++) + +splitRows :: + (Shape.C height, Shape.C width) => + Order -> (height, width) -> [a] -> [[a]] +splitRows order (height,width) = + case order of RowMajor -> ListHT.sliceVertical (Shape.size width) - ColumnMajor -> ListHT.sliceHorizontal (Shape.size height)) . - map (printfFloating fmt) + ColumnMajor -> ListHT.sliceHorizontal (Shape.size height) -formatAligned :: [[String]] -> [String] -formatAligned xss = - let strWidths = columnWidths xss - in map (unwords . zipWith (ListHT.padLeft ' ') strWidths) xss +formatAligned :: (a -> [String]) -> [[a]] -> Box +formatAligned printFmt = + alignSeparated . map (concatMap (attachSeparators Space . printFmt)) -columnWidths :: [[[a]]] -> [Int] -columnWidths xss = - case map (map length) xss of - [] -> [] - w:ws -> foldl (zipWith max) w ws +data Separator = Empty | Space | Bar + deriving (Eq, Ord, Show) -newtype Printf a = Printf {runPrintf :: String -> a -> String} +alignSeparated :: [[(Separator, String)]] -> Box +alignSeparated = + TextBox.hcat TextBox.top . + map (TextBox.vcat TextBox.right . map TextBox.text) . + concatMap ((\(seps,column) -> [map formatSeparator seps, column]) . unzip) . + List.unfoldr (viewLAll (Empty,"")) -printfFloating :: (Class.Floating a) => String -> a -> String -printfFloating = - runPrintf $ +viewLAll :: a -> [[a]] -> Maybe ([a], [[a]]) +viewLAll x0 xs = + toMaybe (any (not.null) xs) + (unzip $ map (fromMaybe (x0,[]) . ListHT.viewL) xs) + +formatSeparator :: Separator -> String +formatSeparator sep = case sep of Empty -> ""; Space -> " "; Bar -> "|" + +attachSeparators :: Separator -> [str] -> [(Separator, str)] +attachSeparators sep = zip (sep:repeat Empty) + + +printfFloating :: (Class.Floating a) => String -> a -> [String] +printfFloating fmt = + getFlip $ Class.switchFloating - (Printf printf) - (Printf printf) - (Printf printfComplex) - (Printf printfComplex) + (Flip $ (:[]) . printf fmt) + (Flip $ (:[]) . printf fmt) + (Flip $ printfComplex fmt) + (Flip $ printfComplex fmt) -printfComplex :: (PrintfArg a, Class.Real a) => String -> Complex a -> String -printfComplex fmt (r:+i) = +printfFloatingMaybe :: (Class.Floating a) => String -> Maybe a -> [String] +printfFloatingMaybe fmt = + getFlip $ getCompose $ + Class.switchFloating + (Compose $ Flip $ (:[]) . foldMap (printf fmt)) + (Compose $ Flip $ (:[]) . foldMap (printf fmt)) + (Compose $ Flip $ maybe ["",""] (printfComplex fmt)) + (Compose $ Flip $ maybe ["",""] (printfComplex fmt)) + +printfComplex :: (Class.Real a) => String -> Complex a -> [String] +printfComplex fmt = + getFlip $ getCompose $ + Class.switchReal + (Compose $ Flip $ printfComplexAux fmt) + (Compose $ Flip $ printfComplexAux fmt) + +printfComplexAux :: + (PrintfArg a, Class.Real a) => String -> Complex a -> [String] +printfComplexAux fmt (r:+i) = if i<0 || isNegativeZero i - then printf (fmt ++ "-i" ++ fmt) r (-i) - else printf (fmt ++ "+i" ++ fmt) r i + then [printf (fmt ++ "-") r, printf (fmt ++ "i") (-i)] + else [printf (fmt ++ "+") r, printf (fmt ++ "i") i] diff --git a/src/Numeric/LAPACK/Linear/General.hs b/src/Numeric/LAPACK/Linear/General.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Linear/General.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Linear.General ( - solve, - inverse, - ) where - -import Numeric.LAPACK.Matrix.Square (Square) -import Numeric.LAPACK.Matrix (General) - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor)) -import Numeric.LAPACK.Private (withAutoWorkspace, copyBlock, copyToColumnMajor) - -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Internal as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) - -import Foreign.Marshal.Alloc (alloca) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) - -import Text.Printf (printf) - - -solve :: - (Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Square sh a -> General sh nrhs a -> General sh nrhs a -solve - (Array (MatrixShape.Square orderA shA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - Array.unsafeCreate (MatrixShape.General ColumnMajor heightB widthB) $ - \xPtr -> do - Call.assert "Square.solve: height shapes mismatch" - (shA == heightB) - let n = Shape.size heightB - let nrhs = Shape.size widthB - let ldb = n - evalContT $ do - nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - aPtr <- ContT $ withForeignPtr a - atmpPtr <- Call.allocaArray (n*n) - ldaPtr <- Call.cint ldb - ipivPtr <- Call.allocaArray n - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint ldb - liftIO $ do - copyToColumnMajor orderA n n aPtr atmpPtr - copyToColumnMajor orderB n nrhs bPtr xPtr - withInfo "gesv" $ - LapackGen.gesv nPtr nrhsPtr atmpPtr ldaPtr ipivPtr xPtr ldbPtr - - -inverse :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a -inverse (Array shape@(MatrixShape.Square _order sh) a) = - Array.unsafeCreateWithSize shape $ \blockSize bPtr -> do - let n = Shape.size sh - evalContT $ do - nPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - ldbPtr <- Call.cint n - ipivPtr <- Call.allocaArray n - liftIO $ do - copyBlock blockSize aPtr bPtr - withInfo "getrf" $ LapackGen.getrf nPtr nPtr bPtr ldbPtr ipivPtr - withInfo "getri" $ \infoPtr -> - withAutoWorkspace $ \workPtr lworkPtr -> - LapackGen.getri nPtr bPtr ldbPtr ipivPtr workPtr lworkPtr infoPtr - - -withInfo :: String -> (Ptr CInt -> IO ()) -> IO () -withInfo name computation = alloca $ \infoPtr -> do - computation infoPtr - info <- fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ printf "%s: %d-th diagonal value is zero" name info diff --git a/src/Numeric/LAPACK/Linear/Hermitian.hs b/src/Numeric/LAPACK/Linear/Hermitian.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Linear/Hermitian.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Linear.Hermitian ( - solve, - inverse, - ) where - -import Numeric.LAPACK.Matrix.Hermitian (Hermitian) -import Numeric.LAPACK.Matrix (General) - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Triangular.Private (copyTriangleToTemp) -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), uploFromOrder) -import Numeric.LAPACK.Private (copyBlock, copyToColumnMajor) - -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Internal as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) - -import Foreign.Marshal.Alloc (alloca) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) - -import Text.Printf (printf) - - -solve :: - (Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Hermitian sh a -> General sh nrhs a -> General sh nrhs a -solve - (Array (MatrixShape.Hermitian orderA shA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - Array.unsafeCreate (MatrixShape.General ColumnMajor heightB widthB) $ - \xPtr -> do - Call.assert "Hermitian.solve: height shapes mismatch" - (shA == heightB) - let n = Shape.size heightB - let nrhs = Shape.size widthB - let ldb = n - evalContT $ do - uploPtr <- Call.char $ uploFromOrder orderA - nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - apPtr <- copyTriangleToTemp orderA n a - ipivPtr <- Call.allocaArray n - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint ldb - liftIO $ do - copyToColumnMajor orderB n nrhs bPtr xPtr - withInfo "hpsv" $ - LapackGen.hpsv uploPtr nPtr nrhsPtr apPtr ipivPtr xPtr ldbPtr - - -inverse :: - (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a -inverse (Array shape@(MatrixShape.Hermitian order sh) a) = - Array.unsafeCreateWithSize shape $ \triSize bPtr -> do - let n = Shape.size sh - evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - ipivPtr <- Call.allocaArray n - workPtr <- Call.allocaArray n - liftIO $ do - copyBlock triSize aPtr bPtr - withInfo "hptrf" $ LapackGen.hptrf uploPtr nPtr bPtr ipivPtr - withInfo "hptri" $ LapackGen.hptri uploPtr nPtr bPtr ipivPtr workPtr - - -withInfo :: String -> (Ptr CInt -> IO ()) -> IO () -withInfo name computation = alloca $ \infoPtr -> do - computation infoPtr - info <- fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ printf "%s: %d-th diagonal value is zero" name info diff --git a/src/Numeric/LAPACK/Linear/HermitianPositiveDefinite.hs b/src/Numeric/LAPACK/Linear/HermitianPositiveDefinite.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Linear/HermitianPositiveDefinite.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Linear.HermitianPositiveDefinite ( - solve, - inverse, - decompose, - ) where - -import Numeric.LAPACK.Matrix.Hermitian (Hermitian) -import Numeric.LAPACK.Matrix.Triangular (Upper) -import Numeric.LAPACK.Matrix (General) - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Triangular.Private (copyTriangleToTemp) -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), uploFromOrder) -import Numeric.LAPACK.Private (copyBlock, copyToColumnMajor) - -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Internal as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) - -import Foreign.Marshal.Alloc (alloca) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) - -import Text.Printf (printf) - - -solve :: - (Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Hermitian sh a -> General sh nrhs a -> General sh nrhs a -solve - (Array (MatrixShape.Hermitian orderA shA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - Array.unsafeCreate (MatrixShape.General ColumnMajor heightB widthB) $ - \xPtr -> do - Call.assert "Hermitian.solve: height shapes mismatch" - (shA == heightB) - let n = Shape.size heightB - let nrhs = Shape.size widthB - let ldb = n - evalContT $ do - uploPtr <- Call.char $ uploFromOrder orderA - nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - apPtr <- copyTriangleToTemp orderA n a - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint ldb - liftIO $ do - copyToColumnMajor orderB n nrhs bPtr xPtr - withInfo "ppsv" $ - LapackGen.ppsv uploPtr nPtr nrhsPtr apPtr xPtr ldbPtr - - -inverse :: - (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a -inverse - (Array shape@(MatrixShape.Hermitian order sh) a) = - Array.unsafeCreateWithSize shape $ \triSize bPtr -> do - evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint $ Shape.size sh - aPtr <- ContT $ withForeignPtr a - liftIO $ do - copyBlock triSize aPtr bPtr - withInfo "pptrf" $ LapackGen.pptrf uploPtr nPtr bPtr - withInfo "pptri" $ LapackGen.pptri uploPtr nPtr bPtr - -{- | -Cholesky decomposition --} -decompose :: - (Shape.C sh, Class.Floating a) => Hermitian sh a -> Upper sh a -decompose - (Array (MatrixShape.Hermitian order sh) a) = - Array.unsafeCreateWithSize - (MatrixShape.Triangular MatrixShape.Upper order sh) $ - \triSize bPtr -> do - evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint $ Shape.size sh - aPtr <- ContT $ withForeignPtr a - liftIO $ do - copyBlock triSize aPtr bPtr - withInfo "pptrf" $ LapackGen.pptrf uploPtr nPtr bPtr - - -withInfo :: String -> (Ptr CInt -> IO ()) -> IO () -withInfo name computation = alloca $ \infoPtr -> do - computation infoPtr - info <- fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ - printf "%s: minor of order %d not positive definite" name info diff --git a/src/Numeric/LAPACK/Linear/LowerUpper.hs b/src/Numeric/LAPACK/Linear/LowerUpper.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Linear/LowerUpper.hs @@ -0,0 +1,437 @@ +module Numeric.LAPACK.Linear.LowerUpper ( + LowerUpper, + Square, + Transposition(..), + Conjugation(..), + Inversion(..), + mapExtent, + fromMatrix, + toMatrix, + solve, + multiplyFullRight, + + determinant, + + extractP, + multiplyP, + + extractL, + wideExtractL, + wideMultiplyL, + wideSolveL, + + extractU, + tallExtractU, + tallMultiplyU, + tallSolveU, + + caseTallWide, + ) where + +import qualified Numeric.LAPACK.Matrix.Multiply as MM +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Permutation.Private as Perm +import qualified Numeric.LAPACK.Split as Split +import Numeric.LAPACK.Matrix.Triangular.Basic (UnitLower, Upper) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor, ColumnMajor), Triangle(Triangle)) +import Numeric.LAPACK.Matrix.Private + (Full, ZeroInt, zeroInt, + Transposition(NonTransposed, Transposed), + Conjugation(NonConjugated, Conjugated), + Inversion(NonInverted, Inverted), flipInversion) +import Numeric.LAPACK.Linear.Private (solver, withInfo) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Format (Format(format)) +import Numeric.LAPACK.Private + (pointerSeq, peekCInt, + copyBlock, copyTransposed, copyToColumnMajor) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.Marshal.Array (advancePtr) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (forM_) +import Control.Applicative ((<$>)) + + +data LowerUpper vert horiz height width a = + LowerUpper { + _pivot :: Vector ZeroInt CInt, + split_ :: + Array + (MatrixShape.Split MatrixShape.Triangle vert horiz height width) a + } deriving (Show) + +type Square sh = LowerUpper Extent.Small Extent.Small sh sh + +instance + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Format (LowerUpper vert horiz height width a) where + format fmt lu@(LowerUpper _ipiv m) = format fmt (extractP NonInverted lu, m) + +mapExtent :: + (Extent.C vertA, Extent.C horizA) => + (Extent.C vertB, Extent.C horizB) => + Extent.Map vertA horizA vertB horizB height width -> + LowerUpper vertA horizA height width a -> + LowerUpper vertB horizB height width a +mapExtent f (LowerUpper pivot split) = + LowerUpper pivot $ Array.mapShape (MatrixShape.splitMapExtent f) split + +{- | +@LowerUpper.fromMatrix a@ +computes the LU decomposition of matrix @a@ with row pivotisation. + +You can reconstruct @a@ from @lu@ depending on wether @a@ is tall or wide. + +> LU.multiplyP False lu $ LU.extractL lu <#> LU.tallExtractU lu +> LU.multiplyP False lu $ LU.wideExtractL lu <#> LU.extractU lu +-} +fromMatrix :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> + LowerUpper vert horiz height width a +fromMatrix (Array (MatrixShape.Full order extent) a) = + let (height,width) = Extent.dimensions extent + m = Shape.size height + n = Shape.size width + in uncurry LowerUpper $ + Array.unsafeCreateWithSizeAndResult (zeroInt $ min m n) $ \_ ipivPtr -> + ArrayIO.unsafeCreate + (MatrixShape.Split MatrixShape.Triangle ColumnMajor extent) $ \luPtr -> + + evalContT $ do + mPtr <- Call.cint m + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim m + liftIO $ do + copyToColumnMajor order m n aPtr luPtr + withInfo "getrf" $ LapackGen.getrf mPtr nPtr luPtr ldaPtr ipivPtr + +solve :: + (Extent.C vert, Extent.C horiz, Eq height, Shape.C height, Shape.C width, + Class.Floating a) => + Square height a -> + Full vert horiz height width a -> + Full vert horiz height width a +solve + (LowerUpper + (Array _ ipiv) + (Array (MatrixShape.Split MatrixShape.Triangle orderLU extentLU) lu)) = + + solver "LowerUpper.solve" (Extent.squareSize extentLU) $ + \n nPtr nrhsPtr xPtr ldxPtr -> do + let lda = n + transPtr <- Call.char 'N' + aPtr <- + case orderLU of + RowMajor -> do + aPtr <- ContT $ withForeignPtr lu + atmpPtr <- Call.allocaArray (n*n) + liftIO $ copyToColumnMajor orderLU n n aPtr atmpPtr + return atmpPtr + ColumnMajor -> ContT $ withForeignPtr lu + ldaPtr <- Call.leadingDim lda + ipivPtr <- ContT $ withForeignPtr ipiv + liftIO $ + withInfo "getrs" $ + LapackGen.getrs transPtr + nPtr nrhsPtr aPtr ldaPtr ipivPtr xPtr ldxPtr + +{- | +Caution: +@LU.determinant . LU.fromMatrix@ will fail for singular matrices. +-} +determinant :: (Shape.C sh, Class.Floating a, Eq a) => Square sh a -> a +determinant (LowerUpper ipiv split) = + let det = Split.determinantR split + in if Split.oddPermutation $ Array.toList ipiv then -det else det + + +extractP :: + (Extent.C vert, Extent.C horiz, Shape.C height) => + Inversion -> LowerUpper vert horiz height width a -> Perm.Permutation height +extractP inverted (LowerUpper ipiv (Array shape _)) = + Perm.fromPivots (flipInversion inverted) (MatrixShape.splitHeight shape) ipiv + +multiplyP :: + (Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB, + Eq height, Shape.C height, Shape.C widthA, Shape.C widthB, + Class.Floating a) => + Inversion -> + LowerUpper vertA horizA height widthA a -> + Full vertB horizB height widthB a -> + Full vertB horizB height widthB a +multiplyP inverted + (LowerUpper (Array shapeIPiv ipiv) + (Array (MatrixShape.Split _ _ extentLU) _lu)) + (Array shape@(MatrixShape.Full order extent) a) = + Array.unsafeCreate shape $ \bPtr -> do + + Call.assert "multiplyP: heights mismatch" + (Extent.height extentLU == Extent.height extent) + + let (height,width) = Extent.dimensions extent + let m = Shape.size height + let n = Shape.size width + let k = Shape.size shapeIPiv + + evalContT $ do + aPtr <- ContT $ withForeignPtr a + ipivPtr <- ContT $ withForeignPtr ipiv + liftIO $ copyBlock (n*m) aPtr bPtr + case order of + ColumnMajor -> do + nPtr <- Call.cint n + ldaPtr <- Call.leadingDim m + k1Ptr <- Call.cint 1 + k2Ptr <- Call.cint k + incxPtr <- + Call.cint $ + case inverted of + Inverted -> 1 + NonInverted -> -1 + liftIO $ + LapackGen.laswp nPtr bPtr ldaPtr k1Ptr k2Ptr ipivPtr incxPtr + RowMajor -> + liftIO $ swapColumns m bPtr $ take k $ + case inverted of + Inverted -> zip [0..] $ pointerSeq 1 ipivPtr + NonInverted -> + zip (iterate (subtract 1) (k-1)) $ + pointerSeq (-1) (advancePtr ipivPtr (k-1)) + +{-# INLINE swapColumns #-} +swapColumns :: + (Class.Floating a) => + Int -> Ptr a -> [(Int, Ptr CInt)] -> IO () +swapColumns m xPtr ptrs = evalContT $ do + mPtr <- Call.cint m + incPtr <- Call.cint 1 + let columnPtr k = advancePtr xPtr (m*k) + liftIO $ forM_ ptrs $ \(i,ipivPtr) -> do + j <- subtract 1 <$> peekCInt ipivPtr + BlasGen.swap mPtr (columnPtr i) incPtr (columnPtr j) incPtr + + + +extractL :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + LowerUpper vert horiz height width a -> + Full vert horiz height width a +extractL = Split.extractTriangle (Left Triangle) . split_ + +wideExtractL :: + (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => + LowerUpper Extent.Small horiz height width a -> UnitLower height a +wideExtractL = Split.wideExtractL . split_ + +{- | +@wideMultiplyL transposed lu a@ multiplies the square part of @lu@ +containing the lower triangular matrix with @a@. + +> wideMultiplyL False lu a == wideExtractL lu <#> a +> wideMultiplyL True lu a == wideExtractL (Tri.transposeUp lu) <#> a +-} +wideMultiplyL :: + (Extent.C horizA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + Shape.C widthA, Shape.C widthB, Class.Floating a) => + Transposition -> + LowerUpper Extent.Small horizA height widthA a -> + Full vert horiz height widthB a -> + Full vert horiz height widthB a +wideMultiplyL transposed = Split.wideMultiplyL transposed . split_ + +wideSolveL :: + (Extent.C horizA, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + Transposition -> Conjugation -> + LowerUpper Extent.Small horizA height width a -> + Full vert horiz height nrhs a -> Full vert horiz height nrhs a +wideSolveL transposed conjugated = + Split.wideSolveL transposed conjugated . split_ + + +extractU :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + LowerUpper vert horiz height width a -> + Full vert horiz height width a +extractU = Split.extractTriangle (Right Triangle) . split_ + +tallExtractU :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + LowerUpper vert Extent.Small height width a -> Upper width a +tallExtractU = Split.tallExtractR . split_ + +{- | +@tallMultiplyU transposed lu a@ multiplies the square part of @lu@ +containing the upper triangular matrix with @a@. + +> tallMultiplyU False lu a == tallExtractU lu <#> a +> tallMultiplyU True lu a == tallExtractU (Tri.transposeDown lu) <#> a +-} +tallMultiplyU :: + (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + Shape.C heightA, Shape.C widthB, Class.Floating a) => + Transposition -> + LowerUpper vertA Extent.Small heightA height a -> + Full vert horiz height widthB a -> + Full vert horiz height widthB a +tallMultiplyU transposed = Split.tallMultiplyR transposed . split_ + +tallSolveU :: + (Extent.C vertA, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => + Transposition -> Conjugation -> + LowerUpper vertA Extent.Small height width a -> + Full vert horiz width nrhs a -> Full vert horiz width nrhs a +tallSolveU transposed conjugated = + Split.tallSolveR transposed conjugated . split_ + + + +toMatrix :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + LowerUpper vert horiz height width a -> + Full vert horiz height width a +toMatrix = + getToMatrix $ + Extent.switchTagPair + (ToMatrix wideToMatrix) + (ToMatrix wideToMatrix) + (ToMatrix tallToMatrix) + (ToMatrix $ + either + (Matrix.fromFull . tallToMatrix) + (Matrix.fromFull . wideToMatrix) . + caseTallWide) + +newtype ToMatrix height width a vert horiz = + ToMatrix { + getToMatrix :: + LowerUpper vert horiz height width a -> + Full vert horiz height width a + } + +tallToMatrix :: + (Extent.C vert, Shape.C height, Shape.C width, Eq height, Eq width, + Class.Floating a) => + LowerUpper vert Extent.Small height width a -> + Full vert Extent.Small height width a +tallToMatrix a = + multiplyP NonInverted a $ Basic.transpose $ + tallMultiplyU Transposed a $ Basic.transpose $ extractL a + +wideToMatrix :: + (Extent.C horiz, Shape.C height, Shape.C width, Eq height, Eq width, + Class.Floating a) => + LowerUpper Extent.Small horiz height width a -> + Full Extent.Small horiz height width a +wideToMatrix a = + multiplyP NonInverted a $ wideMultiplyL NonTransposed a $ extractU a + + +multiplyFullRight :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, + Class.Floating a) => + LowerUpper vert horiz height fuse a -> + Full vert horiz fuse width a -> + Full vert horiz height width a +multiplyFullRight = + getMultiplyFullRight $ + Extent.switchTagPair + (MultiplyFullRight wideMultiplyFullRight) + (MultiplyFullRight wideMultiplyFullRight) + (MultiplyFullRight tallMultiplyFullRight) + (MultiplyFullRight $ + either tallMultiplyFullRight wideMultiplyFullRight . caseTallWide) + +newtype MultiplyFullRight height fuse width a vert horiz = + MultiplyFullRight { + getMultiplyFullRight :: + LowerUpper vert horiz height fuse a -> + Full vert horiz fuse width a -> + Full vert horiz height width a + } + +tallMultiplyFullRight :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, Eq height, Eq fuse, + Class.Floating a) => + LowerUpper vert Extent.Small height fuse a -> + Full vert horiz fuse width a -> + Full vert horiz height width a +tallMultiplyFullRight a = + multiplyP NonInverted a . + MM.multiply (Matrix.generalizeTall (extractL a)) . + tallMultiplyU NonTransposed a + +wideMultiplyFullRight :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, Eq height, Eq fuse, + Class.Floating a) => + LowerUpper Extent.Small horiz height fuse a -> + Full vert horiz fuse width a -> + Full vert horiz height width a +wideMultiplyFullRight a = + multiplyP NonInverted a . wideMultiplyL NonTransposed a . + MM.multiply (Matrix.generalizeWide (extractU a)) + + +type Tall = LowerUpper Extent.Big Extent.Small +type Wide = LowerUpper Extent.Small Extent.Big + +caseTallWide :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + LowerUpper vert horiz height width a -> + Either (Tall height width a) (Wide height width a) +caseTallWide (LowerUpper ipiv (Array shape a)) = + either + (Left . LowerUpper ipiv . flip Array a) + (Right . LowerUpper ipiv . flip Array a) $ + MatrixShape.caseTallWideSplit shape + + +_toRowMajor :: + (Extent.C vert, Extent.C horiz, Eq height, Shape.C height, Shape.C width, + Class.Floating a) => + LowerUpper vert horiz height width a -> + LowerUpper vert horiz height width a +_toRowMajor + (LowerUpper ipiv + arr@(Array (MatrixShape.Split MatrixShape.Triangle order extent) a)) = + LowerUpper ipiv $ + case order of + RowMajor -> arr + ColumnMajor -> + Array.unsafeCreate + (MatrixShape.Split MatrixShape.Triangle RowMajor extent) $ \bPtr -> + withForeignPtr a $ \aPtr -> do + let (height, width) = Extent.dimensions extent + let n = Shape.size width + let m = Shape.size height + copyTransposed n m aPtr n bPtr diff --git a/src/Numeric/LAPACK/Linear/Private.hs b/src/Numeric/LAPACK/Linear/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Linear/Private.hs @@ -0,0 +1,68 @@ +module Numeric.LAPACK.Linear.Private where + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor)) +import Numeric.LAPACK.Matrix.Private (Full) +import Numeric.LAPACK.Scalar (zero) +import Numeric.LAPACK.Private (copyToColumnMajor, peekCInt, argMsg) + +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.Marshal.Alloc (alloca) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + +import Text.Printf (printf) + + +solver :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq height, + Class.Floating a) => + String -> height -> + (Int -> Ptr CInt -> Ptr CInt -> Ptr a -> Ptr CInt -> ContT () IO ()) -> + Full vert horiz height width a -> + Full vert horiz height width a +solver name sh f (Array (MatrixShape.Full order extent) b) = + Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ + \xPtr -> do + let (height,width) = Extent.dimensions extent + Call.assert (name ++ ": height shapes mismatch") (sh == height) + let n = Shape.size height + let nrhs = Shape.size width + evalContT $ do + nPtr <- Call.cint n + nrhsPtr <- Call.cint nrhs + bPtr <- ContT $ withForeignPtr b + liftIO $ copyToColumnMajor order n nrhs bPtr xPtr + ldxPtr <- Call.leadingDim n + f n nPtr nrhsPtr xPtr ldxPtr + + +withDeterminantInfo :: + (Class.Floating a) => + String -> (Ptr CInt -> IO ()) -> IO a -> IO a +withDeterminantInfo name computation evaluation = alloca $ \infoPtr -> do + computation infoPtr + info <- peekCInt infoPtr + case compare info (0::Int) of + LT -> error $ printf argMsg name (-info) + GT -> return zero + EQ -> evaluation + + +withInfo :: String -> (Ptr CInt -> IO ()) -> IO () +withInfo = Private.withInfo diagonalMsg + +diagonalMsg :: String +diagonalMsg = "%d-th diagonal value is zero" diff --git a/src/Numeric/LAPACK/Linear/Triangular.hs b/src/Numeric/LAPACK/Linear/Triangular.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Linear/Triangular.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Linear.Triangular ( - solve, - inverse, - ) where - -import Numeric.LAPACK.Matrix.Triangular (Triangular) -import Numeric.LAPACK.Matrix (General) - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Shape.Private - (Order(ColumnMajor), - transposeFromOrder, uploFromOrder, uploOrder, triangleSize) -import Numeric.LAPACK.Private - (copyBlock, copyToTemp, copyToColumnMajor) - -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Internal as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) - -import Foreign.Marshal.Alloc (alloca) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) - -import Text.Printf (printf) - - -solve :: - (MatrixShape.Uplo uplo, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Triangular uplo sh a -> General sh nrhs a -> General sh nrhs a -solve - (Array (MatrixShape.Triangular uplo orderA shA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - Array.unsafeCreate (MatrixShape.General ColumnMajor heightB widthB) $ - \xPtr -> do - Call.assert "Triangular.solve: height shapes mismatch" (shA == heightB) - let n = Shape.size heightB - let nrhs = Shape.size widthB - let ldb = n - evalContT $ do - uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo orderA - transPtr <- Call.char $ transposeFromOrder orderA - diagPtr <- Call.char 'N' - nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - apPtr <- copyToTemp (triangleSize n) a - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint ldb - liftIO $ do - copyToColumnMajor orderB n nrhs bPtr xPtr - withInfo "tptrs" $ - LapackGen.tptrs uploPtr transPtr diagPtr - nPtr nrhsPtr apPtr xPtr ldbPtr - - -inverse :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Triangular uplo sh a -> Triangular uplo sh a -inverse (Array shape@(MatrixShape.Triangular uplo order sh) a) = - Array.unsafeCreateWithSize shape $ \triSize bPtr -> do - evalContT $ do - uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo order - diagPtr <- Call.char 'N' - nPtr <- Call.cint $ Shape.size sh - aPtr <- ContT $ withForeignPtr a - liftIO $ do - copyBlock triSize aPtr bPtr - withInfo "tptri" $ LapackGen.tptri uploPtr diagPtr nPtr bPtr - - -withInfo :: String -> (Ptr CInt -> IO ()) -> IO () -withInfo name computation = alloca $ \infoPtr -> do - computation infoPtr - info <- fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ printf "%s: %d-th diagonal element zero" name info diff --git a/src/Numeric/LAPACK/Matrix.hs b/src/Numeric/LAPACK/Matrix.hs --- a/src/Numeric/LAPACK/Matrix.hs +++ b/src/Numeric/LAPACK/Matrix.hs @@ -1,56 +1,84 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Numeric.LAPACK.Matrix ( - General, - (##), - Format, - FormatArray, + Full, + General, Tall, Wide, ZeroInt, zeroInt, transpose, adjoint, + Matrix.height, Matrix.width, + caseTallWide, fromScalar, toScalar, fromList, + mapExtent, fromFull, + generalizeTall, generalizeWide, identity, - diagonal, getDiagonal, - fromRows, fromRowsWithSize, - fromColumns, fromColumnsWithSize, - singleRow, singleColumn, - flattenRow, flattenColumn, - pickRow, pickColumn, - takeRows, takeColumns, - dropRows, dropColumns, + diagonal, + fromRowsNonEmpty, fromRowArray, fromRows, + fromColumnsNonEmpty, fromColumnArray, fromColumns, + Basic.singleRow, Basic.singleColumn, + Basic.flattenRow, Basic.flattenColumn, + toRows, toColumns, + toRowArray, toColumnArray, + takeRow, takeColumn, + takeRows, takeColumns, takeEqually, + dropRows, dropColumns, dropEqually, + takeTopRows, takeBottomRows, + takeLeftColumns, takeRightColumns, reverseRows, reverseColumns, fromRowMajor, toRowMajor, flatten, + forceOrder, adaptOrder, (|||), (===), + tensorProduct, + outer, + sumRank1, + + RealOf, + add, sub, rowSums, columnSums, scaleRows, scaleColumns, + scaleRowsComplex, scaleColumnsComplex, + scaleRowsReal, scaleColumnsReal, multiply, multiplyVector, Multiply, (<#>), MultiplyLeft, (<#), MultiplyRight, (#>), + + Solve, solve, solveVector, + Inverse, inverse, ) where import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Format (Format, FormatArray, (##)) +import qualified Numeric.LAPACK.Private as Private import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor)) import Numeric.LAPACK.Matrix.Multiply (Multiply((<#>)), MultiplyLeft((<#)), MultiplyRight((#>)), - transpose, multiplyVector, multiply, multiplyVectorUnchecked) -import Numeric.LAPACK.Matrix.Private (General, ZeroInt, zeroInt) + multiplyVector, multiply, multiplyVectorUnchecked) +import Numeric.LAPACK.Matrix.Divide + (Solve(solve), solveVector, Inverse(inverse)) +import Numeric.LAPACK.Matrix.Basic (transpose, scaleRows, scaleColumns) +import Numeric.LAPACK.Matrix.Private + (Full, Tall, Wide, General, argGeneral, ZeroInt, zeroInt, + mapExtent, fromFull, generalizeTall, generalizeWide) import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, zero, one) import Numeric.LAPACK.Private - (zero, one, pointerSeq, copyTransposed, copySubMatrix, copyBlock) + (pointerSeq, fill, copyTransposed, copySubMatrix, copyBlock) import qualified Numeric.LAPACK.FFI.Generic as LapackGen import qualified Numeric.BLAS.FFI.Generic as BlasGen import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class +import qualified Data.Array.Comfort.Boxed as BoxedArray import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Internal (Array(Array)) @@ -58,7 +86,7 @@ import Foreign.Marshal.Array (copyArray, advancePtr, pokeArray) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable, poke, peek) import System.IO.Unsafe (unsafePerformIO) @@ -67,31 +95,49 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.NonEmpty as NonEmpty +import Data.Complex (Complex) import Data.Foldable (forM_) import Data.Bool.HT (if') {- | conjugate transpose + +Problem: @adjoint a <#> a@ is always square, +but how to convince the type checker to choose the Square type? +Anser: Use @Hermitian.toSquare $ Hermitian.covariance a@ instead. -} adjoint :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> General width height a + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> Full horiz vert width height a adjoint = transpose . Vector.conjugate +{- | +Square matrices will be classified as 'Tall'. +-} +caseTallWide :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Full vert horiz height width a -> + Either (Tall height width a) (Wide height width a) +caseTallWide (Array shape a) = + either (Left . flip Array a) (Right . flip Array a) $ + MatrixShape.caseTallWide shape + + fromScalar :: (Storable a) => a -> General () () a fromScalar = Square.toGeneral . Square.fromScalar toScalar :: (Storable a) => General () () a -> a -toScalar (Array (MatrixShape.General _ () ()) a) = +toScalar = argGeneral $ \_ () () a -> unsafePerformIO $ withForeignPtr a peek fromList :: (Shape.C height, Shape.C width, Storable a) => height -> width -> [a] -> General height width a fromList height width = - Array.fromList (MatrixShape.General RowMajor height width) + Array.fromList (MatrixShape.general RowMajor height width) identity :: @@ -104,53 +150,48 @@ Vector sh a -> General sh sh a diagonal = Square.toGeneral . Square.diagonal -getDiagonal :: - (Shape.C sh, Eq sh, Class.Floating a) => - General sh sh a -> Vector sh a -getDiagonal = Square.getDiagonal . Square.fromGeneral - -singleRow :: Vector width a -> General () width a -singleRow (Array sh fptr) = - Array (MatrixShape.General RowMajor () sh) fptr - -singleColumn :: Vector width a -> General width () a -singleColumn (Array sh fptr) = - Array (MatrixShape.General ColumnMajor sh ()) fptr - -flattenRow :: General () width a -> Vector width a -flattenRow (Array (MatrixShape.General _ () sh) fptr) = Array sh fptr - -flattenColumn :: General width () a -> Vector width a -flattenColumn (Array (MatrixShape.General _ sh ()) fptr) = Array sh fptr - - -fromRows :: +fromRowsNonEmpty :: (Shape.C width, Eq width, Storable a) => NonEmpty.T [] (Vector width a) -> General ZeroInt width a -fromRows (NonEmpty.Cons row rows) = - fromRowsWithSize (Array.shape row) (row:rows) +fromRowsNonEmpty (NonEmpty.Cons row rows) = + fromRows (Array.shape row) (row:rows) -fromRowsWithSize :: +fromRowArray :: + (Shape.C height, Shape.C width, Eq width, Storable a) => + width -> BoxedArray.Array height (Vector width a) -> General height width a +fromRowArray width rows = + Array.reshape (MatrixShape.general RowMajor (BoxedArray.shape rows) width) $ + fromRows width $ BoxedArray.toList rows + +fromRows :: (Shape.C width, Eq width, Storable a) => width -> [Vector width a] -> General ZeroInt width a -fromRowsWithSize width rows = +fromRows width rows = Array.unsafeCreate - (MatrixShape.General RowMajor (zeroInt $ length rows) width) + (MatrixShape.general RowMajor (zeroInt $ length rows) width) (gather width rows) -fromColumns :: +fromColumnsNonEmpty :: (Shape.C height, Eq height, Storable a) => NonEmpty.T [] (Vector height a) -> General height ZeroInt a -fromColumns (NonEmpty.Cons column columns) = - fromColumnsWithSize (Array.shape column) (column:columns) +fromColumnsNonEmpty (NonEmpty.Cons column columns) = + fromColumns (Array.shape column) (column:columns) -fromColumnsWithSize :: +fromColumnArray :: + (Shape.C height, Eq height, Shape.C width, Storable a) => + height -> BoxedArray.Array width (Vector height a) -> General height width a +fromColumnArray height columns = + Array.reshape + (MatrixShape.general ColumnMajor height (BoxedArray.shape columns)) $ + fromColumns height $ BoxedArray.toList columns + +fromColumns :: (Shape.C height, Eq height, Storable a) => height -> [Vector height a] -> General height ZeroInt a -fromColumnsWithSize height columns = +fromColumns height columns = Array.unsafeCreate - (MatrixShape.General ColumnMajor height (zeroInt $ length columns)) + (MatrixShape.general ColumnMajor height (zeroInt $ length columns)) (gather height columns) gather :: @@ -162,31 +203,64 @@ \(dstRowPtr, Array.Array rowWidth srcFPtr) -> withForeignPtr srcFPtr $ \srcPtr -> do Call.assert - "Matrix.fromRows/fromColumns: non-matching vector size" + "Matrix.fromRows/fromColumnsNonEmpty: non-matching vector size" (width == rowWidth) copyArray dstRowPtr srcPtr widthSize -pickRow :: - (Shape.C height, Shape.C width, Shape.Index height ~ ix, +toRows :: + (Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.C width, Class.Floating a) => + Full vert horiz height width a -> [Vector width a] +toRows a = map (takeRow a) $ Shape.indices $ Matrix.height a + +toColumns :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.Indexed width, Class.Floating a) => + Full vert horiz height width a -> [Vector height a] +toColumns a = map (takeColumn a) $ Shape.indices $ Matrix.width a + +toRowArray :: + (Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.C width, Class.Floating a) => + Full vert horiz height width a -> BoxedArray.Array height (Vector width a) +toRowArray a = + let height = Matrix.height a + in BoxedArray.fromList height $ map (takeRow a) $ Shape.indices height + +toColumnArray :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.Indexed width, Class.Floating a) => + Full vert horiz height width a -> BoxedArray.Array width (Vector height a) +toColumnArray a = + let width = Matrix.width a + in BoxedArray.fromList width $ map (takeColumn a) $ Shape.indices width + + +takeRow :: + (Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.C width, Shape.Index height ~ ix, Class.Floating a) => - General height width a -> ix -> Vector width a -pickRow (Array (MatrixShape.General order height width) x) ix = - case order of - RowMajor -> pickConsecutive height width x ix - ColumnMajor -> pickScattered width height x ix + Full vert horiz height width a -> ix -> Vector width a +takeRow (Array (MatrixShape.Full order extent) x) ix = + let (height,width) = Extent.dimensions extent + in case order of + RowMajor -> pickConsecutive height width x ix + ColumnMajor -> pickScattered width height x ix -pickColumn :: - (Shape.C height, Shape.C width, Shape.Index width ~ ix, +takeColumn :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.Indexed width, Shape.Index width ~ ix, Class.Floating a) => - General height width a -> ix -> Vector height a -pickColumn (Array (MatrixShape.General order height width) x) ix = - case order of - RowMajor -> pickScattered height width x ix - ColumnMajor -> pickConsecutive width height x ix + Full vert horiz height width a -> ix -> Vector height a +takeColumn (Array (MatrixShape.Full order extent) x) ix = + let (height,width) = Extent.dimensions extent + in case order of + RowMajor -> pickScattered height width x ix + ColumnMajor -> pickConsecutive width height x ix pickConsecutive :: - (Shape.C height, Shape.C width, Shape.Index height ~ ix, + (Shape.Indexed height, Shape.C width, Shape.Index height ~ ix, Class.Floating a) => height -> width -> ForeignPtr a -> ix -> Vector width a pickConsecutive height width x ix = @@ -200,7 +274,7 @@ BlasGen.copy nPtr (advancePtr xPtr (n*offset)) incxPtr yPtr incyPtr pickScattered :: - (Shape.C height, Shape.C width, Shape.Index width ~ ix, + (Shape.C height, Shape.Indexed width, Shape.Index width ~ ix, Class.Floating a) => height -> width -> ForeignPtr a -> ix -> Vector height a pickScattered height width x ix = @@ -214,51 +288,153 @@ BlasGen.copy nPtr (advancePtr xPtr offset) incxPtr yPtr incyPtr -takeRows, dropRows :: - (Shape.C width, Class.Floating a) => - Int -> General ZeroInt width a -> General ZeroInt width a -takeRows k - (Array (MatrixShape.General order (Shape.ZeroBased heightA) width) a) = - let heightB = min k heightA +takeTopRows :: + (Extent.C vert, Shape.C height0, Shape.C height1, Shape.C width, + Class.Floating a) => + Full vert Extent.Big (height0:+:height1) width a -> + Full vert Extent.Big height0 width a +takeTopRows (Array (MatrixShape.Full order extentA) a) = + let (heightA@(heightB:+:_), width) = Extent.dimensions extentA + extentB = Extent.reduceWideHeight heightB extentA + ma = Shape.size heightA + mb = Shape.size heightB n = Shape.size width - in if' (k<0) (error "take: negative number") $ - Array.unsafeCreateWithSize - (MatrixShape.General order (Shape.ZeroBased heightB) width) $ + in Array.unsafeCreateWithSize (MatrixShape.Full order extentB) $ \blockSize bPtr -> withForeignPtr a $ \aPtr -> case order of RowMajor -> copyBlock blockSize aPtr bPtr - ColumnMajor -> copySubMatrix heightB n heightA aPtr heightB bPtr + ColumnMajor -> copySubMatrix mb n ma aPtr mb bPtr -dropRows k0 - (Array (MatrixShape.General order (Shape.ZeroBased heightA) width) a) = - let k = min k0 heightA - heightB = heightA - k +takeBottomRows :: + (Extent.C vert, Shape.C height0, Shape.C height1, Shape.C width, + Class.Floating a) => + Full vert Extent.Big (height0:+:height1) width a -> + Full vert Extent.Big height1 width a +takeBottomRows (Array (MatrixShape.Full order extentA) a) = + let (heightA@(height0:+:heightB), width) = Extent.dimensions extentA + extentB = Extent.reduceWideHeight heightB extentA + k = Shape.size height0 + ma = Shape.size heightA + mb = Shape.size heightB n = Shape.size width - in if' (k<0) (error "take: negative number") $ - Array.unsafeCreateWithSize - (MatrixShape.General order (Shape.ZeroBased heightB) width) $ + in Array.unsafeCreateWithSize (MatrixShape.Full order extentB) $ \blockSize bPtr -> withForeignPtr a $ \aPtr -> case order of RowMajor -> copyBlock blockSize (advancePtr aPtr (k*n)) bPtr - ColumnMajor -> - copySubMatrix heightB n heightA (advancePtr aPtr k) heightB bPtr + ColumnMajor -> copySubMatrix mb n ma (advancePtr aPtr k) mb bPtr +takeLeftColumns :: + (Extent.C vert, Shape.C height, Shape.C width0, Shape.C width1, + Class.Floating a) => + Full Extent.Big vert height (width0:+:width1) a -> + Full Extent.Big vert height width0 a +takeLeftColumns = transpose . takeTopRows . transpose +takeRightColumns :: + (Extent.C vert, Shape.C height, Shape.C width0, Shape.C width1, + Class.Floating a) => + Full Extent.Big vert height (width0:+:width1) a -> + Full Extent.Big vert height width1 a +takeRightColumns = transpose . takeBottomRows . transpose + + +splitRows :: + (Extent.C vert, Shape.C width, Class.Floating a) => + Int -> + Full vert Extent.Big ZeroInt width a -> + Full vert Extent.Big (ZeroInt:+:ZeroInt) width a +splitRows k = + Array.mapShape + (\(MatrixShape.Full order extentA) -> + let (Shape.ZeroBased heightA) = Extent.height extentA + heightB = min k heightA + in if' (k<0) (error "split: negative number") $ + MatrixShape.Full order $ + Extent.reduceWideHeight + (Shape.ZeroBased heightB :+: Shape.ZeroBased (heightA-heightB)) + extentA) + +takeRows, dropRows :: + (Extent.C vert, Shape.C width, Class.Floating a) => + Int -> + Full vert Extent.Big ZeroInt width a -> + Full vert Extent.Big ZeroInt width a +takeRows k = takeTopRows . splitRows k +dropRows k = takeBottomRows . splitRows k + takeColumns, dropColumns :: - (Shape.C height, Class.Floating a) => - Int -> General height ZeroInt a -> General height ZeroInt a + (Extent.C horiz, Shape.C height, Class.Floating a) => + Int -> + Full Extent.Big horiz height ZeroInt a -> + Full Extent.Big horiz height ZeroInt a takeColumns k = transpose . takeRows k . transpose dropColumns k = transpose . dropRows k . transpose +{- | +Take a left-top aligned square or as much as possible of it. +The advantange of this function is that it maintains the matrix size relation, +e.g. Square remains Square, Tall remains Tall. +-} +takeEqually :: + (Extent.C vert, Extent.C horiz, Class.Floating a) => + Int -> + Full vert horiz ZeroInt ZeroInt a -> + Full vert horiz ZeroInt ZeroInt a +takeEqually k (Array (MatrixShape.Full order extentA) a) = + let (Shape.ZeroBased heightA, Shape.ZeroBased widthA) = + Extent.dimensions extentA + heightB = min k heightA + widthB = min k widthA + extentB = + Extent.reduceConsistent + (Shape.ZeroBased heightB) (Shape.ZeroBased widthB) extentA + in if' (k<0) (error "take: negative number") $ + Array.unsafeCreate (MatrixShape.Full order extentB) $ \bPtr -> + withForeignPtr a $ \aPtr -> + case order of + RowMajor -> copySubMatrix widthB heightB widthA aPtr widthB bPtr + ColumnMajor -> copySubMatrix heightB widthB heightA aPtr heightB bPtr + +{- | +Drop the same number of top-most rows and left-most columns. +The advantange of this function is that it maintains the matrix size relation, +e.g. Square remains Square, Tall remains Tall. +-} +dropEqually :: + (Extent.C vert, Extent.C horiz, Class.Floating a) => + Int -> + Full vert horiz ZeroInt ZeroInt a -> + Full vert horiz ZeroInt ZeroInt a +dropEqually k (Array (MatrixShape.Full order extentA) a) = + let (Shape.ZeroBased heightA, Shape.ZeroBased widthA) = + Extent.dimensions extentA + heightB = heightA - top; top = min k heightA + widthB = widthA - left; left = min k widthA + extentB = + Extent.reduceConsistent + (Shape.ZeroBased heightB) (Shape.ZeroBased widthB) extentA + in if' (k<0) (error "drop: negative number") $ + Array.unsafeCreate (MatrixShape.Full order extentB) $ \bPtr -> + withForeignPtr a $ \aPtr -> + case order of + RowMajor -> + copySubMatrix widthB heightB + widthA (advancePtr aPtr (top*widthA+left)) widthB bPtr + ColumnMajor -> + copySubMatrix heightB widthB + heightA (advancePtr aPtr (left*heightA+top)) heightB bPtr + + -- alternative: laswp reverseRows :: - (Shape.C width, Class.Floating a) => - General ZeroInt width a -> General ZeroInt width a -reverseRows (Array shape@(MatrixShape.General order height width) a) = + (Extent.C vert, Extent.C horiz, Shape.C width, Class.Floating a) => + Full vert horiz ZeroInt width a -> Full vert horiz ZeroInt width a +reverseRows (Array shape@(MatrixShape.Full order extent) a) = Array.unsafeCreateWithSize shape $ \blockSize bPtr -> evalContT $ do + let (height,width) = Extent.dimensions extent let n = Shape.size height let m = Shape.size width fwdPtr <- Call.bool True @@ -274,65 +450,93 @@ ColumnMajor -> LapackGen.lapmr fwdPtr nPtr mPtr bPtr nPtr kPtr reverseColumns :: - (Shape.C height, Class.Floating a) => - General height ZeroInt a -> General height ZeroInt a + (Extent.C vert, Extent.C horiz, Shape.C height, Class.Floating a) => + Full vert horiz height ZeroInt a -> Full vert horiz height ZeroInt a reverseColumns = transpose . reverseRows . transpose fromRowMajor :: (Shape.C height, Shape.C width, Class.Floating a) => Array (height,width) a -> General height width a -fromRowMajor (Array (height,width) x) = - Array (MatrixShape.General RowMajor height width) x +fromRowMajor = Array.mapShape (uncurry $ MatrixShape.general RowMajor) toRowMajor :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Array (height,width) a -toRowMajor (Array (MatrixShape.General order height width) x) = - let shape = (height, width) - in case order of - RowMajor -> Array shape x - ColumnMajor -> Array.unsafeCreate shape $ \yPtr -> evalContT $ do + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full vert horiz height width a -> Array (height,width) a +toRowMajor = + Array.mapShape + (\shape -> (MatrixShape.fullHeight shape, MatrixShape.fullWidth shape)) . + forceRowMajor + +forceRowMajor :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> + Full vert horiz height width a +forceRowMajor (Array shape@(MatrixShape.Full order extent) x) = + case order of + RowMajor -> Array shape x + ColumnMajor -> + Array.unsafeCreate (MatrixShape.Full RowMajor extent) $ \yPtr -> + withForeignPtr x $ \xPtr -> do + let (height, width) = Extent.dimensions extent let n = Shape.size width let m = Shape.size height - nPtr <- Call.cint n - xPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint m - incyPtr <- Call.cint 1 - liftIO $ sequence_ $ take m $ - zipWith - (\xkPtr ykPtr -> - BlasGen.copy nPtr xkPtr incxPtr ykPtr incyPtr) - (pointerSeq 1 xPtr) - (pointerSeq n yPtr) + copyTransposed n m xPtr n yPtr +forceOrder :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Order -> + Full vert horiz height width a -> + Full vert horiz height width a +forceOrder order = + case order of + RowMajor -> forceRowMajor + ColumnMajor -> transpose . forceRowMajor . transpose + +{- | +@adaptOrder x y@ contains the data of @y@ with the layout of @x@. +-} +adaptOrder :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> + Full vert horiz height width a -> + Full vert horiz height width a +adaptOrder x = forceOrder (MatrixShape.fullOrder $ Array.shape x) + flatten :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Vector ZeroInt a -flatten x = - case toRowMajor x of - Array shape fptr -> Array (zeroInt $ Shape.size shape) fptr + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full vert horiz height width a -> Vector ZeroInt a +flatten = Array.mapShape (zeroInt . Shape.size) . toRowMajor infixl 3 ||| infixl 2 === (|||) :: - (Shape.C height, Eq height, Shape.C widtha, Shape.C widthb, + (Extent.C vert, Shape.C height, Eq height, Shape.C widtha, Shape.C widthb, Class.Floating a) => - General height widtha a -> - General height widthb a -> - General height (widtha:+:widthb) a + Full vert Extent.Big height widtha a -> + Full vert Extent.Big height widthb a -> + Full vert Extent.Big height (widtha:+:widthb) a (|||) - (Array (MatrixShape.General orderA heightA widthA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - if heightA /= heightB + (Array (MatrixShape.Full orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + let (heightA,widthA) = Extent.dimensions extentA + (heightB,widthB) = Extent.dimensions extentB + extent = Extent.widen (widthA:+:widthB) extentA + shape order = MatrixShape.Full order extent + in + if heightA /= heightB then error "(|||): mismatching heights" else case (orderA,orderB) of (RowMajor,RowMajor) -> - Array.unsafeCreate - (MatrixShape.General RowMajor heightA (widthA:+:widthB)) $ + Array.unsafeCreate (shape RowMajor) $ \cPtr -> evalContT $ do let n = Shape.size heightA let ma = Shape.size widthA @@ -355,8 +559,7 @@ (pointerSeq mb bPtr) (pointerSeq m cPtr) (RowMajor,ColumnMajor) -> - Array.unsafeCreate - (MatrixShape.General ColumnMajor heightA (widthA:+:widthB)) $ + Array.unsafeCreate (shape ColumnMajor) $ \cPtr -> evalContT $ do let n = Shape.size heightA let ma = Shape.size widthA @@ -367,8 +570,7 @@ copyTransposed n ma aPtr n cPtr copyBlock (n*mb) bPtr (advancePtr cPtr (n*ma)) (ColumnMajor,RowMajor) -> - Array.unsafeCreate - (MatrixShape.General ColumnMajor heightA (widthA:+:widthB)) $ + Array.unsafeCreate (shape ColumnMajor) $ \cPtr -> evalContT $ do let n = Shape.size heightA let ma = Shape.size widthA @@ -380,8 +582,7 @@ copyBlock volA aPtr cPtr copyTransposed n mb bPtr n (advancePtr cPtr volA) (ColumnMajor,ColumnMajor) -> - Array.unsafeCreate - (MatrixShape.General ColumnMajor heightA (widthA:+:widthB)) $ + Array.unsafeCreate (shape ColumnMajor) $ \cPtr -> evalContT $ do let n = Shape.size heightA let na = n * Shape.size widthA @@ -398,44 +599,62 @@ (cPtr `advancePtr` na) incyPtr (===) :: - (Shape.C width, Eq width, Shape.C heighta, Shape.C heightb, + (Extent.C horiz, Shape.C width, Eq width, Shape.C heighta, Shape.C heightb, Class.Floating a) => - General heighta width a -> - General heightb width a -> - General (heighta:+:heightb) width a + Full Extent.Big horiz heighta width a -> + Full Extent.Big horiz heightb width a -> + Full Extent.Big horiz (heighta:+:heightb) width a (===) a b = transpose (transpose a ||| transpose b) +add, sub :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq height, Eq width, + Class.Floating a) => + Full vert horiz height width a -> + Full vert horiz height width a -> + Full vert horiz height width a +add x y = Vector.add (adaptOrder y x) y +sub x y = Vector.sub (adaptOrder y x) y + + rowSums :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Vector height a + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full vert horiz height width a -> Vector height a rowSums m = - let MatrixShape.General _ _ width = Array.shape m + let width = MatrixShape.fullWidth $ Array.shape m in multiplyVectorUnchecked m (Vector.constant width one) columnSums :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Vector width a + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full vert horiz height width a -> Vector width a columnSums m = - let MatrixShape.General _ height _ = Array.shape m + let height = MatrixShape.fullHeight $ Array.shape m in multiplyVectorUnchecked (transpose m) (Vector.constant height one) -scaleRows :: - (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Vector height a -> General height width a -> General height width a -scaleRows - (Array heightX x) (Array shape@(MatrixShape.General order height width) a) = - Array.unsafeCreate shape $ \bPtr -> do - Call.assert "scaleRows: sizes mismatch" (heightX == height) +scaleRowsComplex :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Real a) => + Vector height a -> + Full vert horiz height width (Complex a) -> + Full vert horiz height width (Complex a) +scaleRowsComplex + (Array heightX x) (Array shape@(MatrixShape.Full order extent) a) = + Array.unsafeCreate shape $ \bComplexPtr -> do + let (height,width) = Extent.dimensions extent + Call.assert "scaleRowsComplex: sizes mismatch" (heightX == height) + let bPtr = castPtr bComplexPtr case order of RowMajor -> evalContT $ do let m = Shape.size height - let n = Shape.size width + let n = Shape.size width * 2 alphaPtr <- Call.alloca nPtr <- Call.cint n xPtr <- ContT $ withForeignPtr x - aPtr <- ContT $ withForeignPtr a + aPtr <- fmap castPtr $ ContT $ withForeignPtr a incaPtr <- Call.cint 1 incbPtr <- Call.cint 1 liftIO $ sequence_ $ take m $ @@ -449,28 +668,148 @@ (pointerSeq n bPtr) ColumnMajor -> evalContT $ do let m = Shape.size width - let n = Shape.size height + let nr = Shape.size height + let n = 2*nr transPtr <- Call.char 'N' + nrPtr <- Call.cint nr nPtr <- Call.cint n klPtr <- Call.cint 0 kuPtr <- Call.cint 0 alphaPtr <- Call.number one - xPtr <- ContT $ withForeignPtr x - ldxPtr <- Call.cint 1 - aPtr <- ContT $ withForeignPtr a + xrPtr <- ContT $ withForeignPtr x + xPtr <- Call.allocaArray n + incxrPtr <- Call.cint 1 + incxPtr <- Call.cint 2 + ldxPtr <- Call.leadingDim 1 + aPtr <- fmap castPtr $ ContT $ withForeignPtr a incaPtr <- Call.cint 1 betaPtr <- Call.number zero incbPtr <- Call.cint 1 - liftIO $ sequence_ $ take m $ - zipWith - (\akPtr bkPtr -> - BlasGen.gbmv transPtr - nPtr nPtr klPtr kuPtr alphaPtr xPtr ldxPtr - akPtr incaPtr betaPtr bkPtr incbPtr) - (pointerSeq n aPtr) - (pointerSeq n bPtr) + liftIO $ do + BlasGen.copy nrPtr xrPtr incxrPtr xPtr incxPtr + BlasGen.copy nrPtr xrPtr incxrPtr (advancePtr xPtr 1) incxPtr + sequence_ $ take m $ + zipWith + (\akPtr bkPtr -> + Private.gbmv transPtr + nPtr nPtr klPtr kuPtr alphaPtr xPtr ldxPtr + akPtr incaPtr betaPtr bkPtr incbPtr) + (pointerSeq n aPtr) + (pointerSeq n bPtr) -scaleColumns :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - Vector width a -> General height width a -> General height width a -scaleColumns x = transpose . scaleRows x . transpose +scaleColumnsComplex :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Real a) => + Vector width a -> + Full vert horiz height width (Complex a) -> + Full vert horiz height width (Complex a) +scaleColumnsComplex x = transpose . scaleRowsComplex x . transpose + + +scaleRowsReal :: + (Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, + Class.Floating a) => + Vector height (RealOf a) -> + Full vert horiz height width a -> + Full vert horiz height width a +scaleRowsReal = + getScaleRowsReal $ + Class.switchFloating + (ScaleRowsReal scaleRows) + (ScaleRowsReal scaleRows) + (ScaleRowsReal scaleRowsComplex) + (ScaleRowsReal scaleRowsComplex) + +newtype ScaleRowsReal f g a = + ScaleRowsReal {getScaleRowsReal :: f (RealOf a) -> g a -> g a} + +scaleColumnsReal :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Vector width (RealOf a) -> + Full vert horiz height width a -> + Full vert horiz height width a +scaleColumnsReal x = transpose . scaleRowsReal x . transpose + + +{- | +> tensorProduct order x y = singleColumn order x <#> singleRow order y +-} +tensorProduct :: + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Order -> Vector height a -> Vector width a -> General height width a +tensorProduct order x y = + case order of + ColumnMajor -> tensorProd 'T' order x y + RowMajor -> transpose $ tensorProd 'T' order y x + +{- | +> outer order x y = tensorProduct order x (Vector.conjugate y) +-} +outer :: + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Order -> Vector height a -> Vector width a -> General height width a +outer order x y = + case order of + ColumnMajor -> tensorProd 'C' ColumnMajor x y + RowMajor -> transpose $ tensorProd 'C' RowMajor y x + +{-# INLINE tensorProd #-} +tensorProd :: + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Char -> Order -> + Vector height a -> Vector width a -> General height width a +tensorProd trans order (Array shX x) (Array shY y) = + Array.unsafeCreate (MatrixShape.general MatrixShape.ColumnMajor shX shY) $ + \cPtr -> do + let m = Shape.size shX + let n = Shape.size shY + let ((transa,transb),(lda,ldb)) = + case order of + ColumnMajor -> (('N',trans),(m,n)) + RowMajor -> ((trans,'N'),(1,1)) + evalContT $ do + transaPtr <- Call.char transa + transbPtr <- Call.char transb + mPtr <- Call.cint m + nPtr <- Call.cint n + kPtr <- Call.cint 1 + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr x + ldaPtr <- Call.leadingDim lda + bPtr <- ContT $ withForeignPtr y + ldbPtr <- Call.leadingDim ldb + betaPtr <- Call.number zero + ldcPtr <- Call.leadingDim m + liftIO $ + BlasGen.gemm + transaPtr transbPtr mPtr nPtr kPtr alphaPtr + aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldcPtr + + +sumRank1 :: + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + (height,width) -> + [(a, (Vector height a, Vector width a))] -> General height width a +sumRank1 (height,width) xys = + Array.unsafeCreateWithSize (MatrixShape.general ColumnMajor height width) $ + \size aPtr -> + evalContT $ do + let m = Shape.size height + let n = Shape.size width + mPtr <- Call.cint m + nPtr <- Call.cint n + alphaPtr <- Call.alloca + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 1 + ldaPtr <- Call.leadingDim m + liftIO $ do + fill zero size aPtr + forM_ xys $ \(alpha, (Array shX x, Array shY y)) -> + withForeignPtr x $ \xPtr -> + withForeignPtr y $ \yPtr -> do + Call.assert "Matrix.sumRank1: non-matching height" (height==shX) + Call.assert "Matrix.sumRank1: non-matching width" (width==shY) + poke alphaPtr alpha + BlasGen.gerc mPtr nPtr + alphaPtr xPtr incxPtr yPtr incyPtr aPtr ldaPtr diff --git a/src/Numeric/LAPACK/Matrix/Banded.hs b/src/Numeric/LAPACK/Matrix/Banded.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Banded.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Numeric.LAPACK.Matrix.Banded ( + module Numeric.LAPACK.Matrix.Banded.Basic, + height, width, + + solve, + determinant, + ) where + +import Numeric.LAPACK.Matrix.Banded.Basic +import Numeric.LAPACK.Matrix.Banded.Linear + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent + +import qualified Data.Array.Comfort.Storable as Array + + +height :: + (Extent.C vert, Extent.C horiz) => + Banded sub super vert horiz height width a -> height +height = MatrixShape.bandedHeight . Array.shape + +width :: + (Extent.C vert, Extent.C horiz) => + Banded sub super vert horiz height width a -> width +width = MatrixShape.bandedWidth . Array.shape diff --git a/src/Numeric/LAPACK/Matrix/Banded/Basic.hs b/src/Numeric/LAPACK/Matrix/Banded/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Banded/Basic.hs @@ -0,0 +1,555 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Numeric.LAPACK.Matrix.Banded.Basic ( + Banded, + General, + Square, + Upper, + Lower, + Diagonal, + fromList, + squareFromList, + lowerFromList, + upperFromList, + mapExtent, + diagonal, + takeDiagonal, + toFull, + toLowerTriangular, + toUpperTriangular, + transpose, + adjoint, + multiplyVector, + multiply, + multiplyFull, + ) where + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Triangular.Private as TriangularPriv +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), transposeFromOrder, swapOnRowMajor, + UnaryProxy, addOffDiagonals) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private + (fill, pointerSeq, pokeCInt, copySubMatrix, copySubTrapezoid) + +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary ((:+:)) +import Type.Data.Num (integralFromProxy) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.Marshal.Array (advancePtr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) + +import qualified Control.Monad.Trans.Maybe as MM +import qualified Control.Monad.Trans.Reader as MR +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (mzero, void) + +import Data.Foldable (forM_) +import Data.Tuple.HT (swap) +import Data.Ord.HT (limit) + + +type Banded sub super vert horiz height width = + Array (MatrixShape.Banded sub super vert horiz height width) + +type General sub super height width = + Array (MatrixShape.BandedGeneral sub super height width) + +type Square sub super size = + Array (MatrixShape.BandedSquare sub super size) + +type Lower sub size = Square sub TypeNum.U0 size +type Upper super size = Square TypeNum.U0 super size + +type Diagonal size = Square TypeNum.U0 TypeNum.U0 size + + +fromList :: + (Unary.Natural sub, Unary.Natural super, + Shape.C height, Shape.C width, Storable a) => + (UnaryProxy sub, UnaryProxy super) -> Order -> height -> width -> [a] -> + General sub super height width a +fromList offDiag order height width = + fromListGen offDiag order (Extent.general height width) + +squareFromList :: + (Unary.Natural sub, Unary.Natural super, Shape.C size, Storable a) => + (UnaryProxy sub, UnaryProxy super) -> Order -> size -> [a] -> + Square sub super size a +squareFromList offDiag order size = + fromListGen offDiag order (Extent.square size) + +lowerFromList :: + (Unary.Natural sub, Shape.C size, Storable a) => + UnaryProxy sub -> Order -> size -> [a] -> Lower sub size a +lowerFromList numOff order size = + fromListGen (numOff,Proxy) order (Extent.square size) + +upperFromList :: + (Unary.Natural super, Shape.C size, Storable a) => + UnaryProxy super -> Order -> size -> [a] -> Upper super size a +upperFromList numOff order size = + fromListGen (Proxy,numOff) order (Extent.square size) + +fromListGen :: + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Storable a) => + (UnaryProxy sub, UnaryProxy super) -> Order -> + Extent.Extent vert horiz height width -> [a] -> + Banded sub super vert horiz height width a +fromListGen offDiag order extent = + Array.fromList (MatrixShape.Banded offDiag order extent) + + +mapExtent :: + (Extent.C vertA, Extent.C horizA) => + (Extent.C vertB, Extent.C horizB) => + Extent.Map vertA horizA vertB horizB height width -> + Banded super sub vertA horizA height width a -> + Banded super sub vertB horizB height width a +mapExtent f = Array.mapShape $ MatrixShape.bandedMapExtent f + +transpose :: + (Extent.C vert, Extent.C horiz) => + Banded sub super vert horiz height width a -> + Banded super sub horiz vert width height a +transpose = Array.mapShape MatrixShape.bandedTranspose + +adjoint :: + (Unary.Natural super, Unary.Natural sub, Extent.C vert, Extent.C horiz, + Shape.C width, Shape.C height, Class.Floating a) => + Banded sub super vert horiz height width a -> + Banded super sub horiz vert width height a +adjoint = Vector.conjugate . transpose + + +diagonal :: (Shape.C sh, Class.Floating a) => Vector sh a -> Diagonal sh a +diagonal (Array sh x) = + Array (MatrixShape.bandedSquare (Proxy,Proxy) ColumnMajor sh) x + +takeDiagonal :: + (Unary.Natural sub, Unary.Natural super, Shape.C sh, Class.Floating a) => + Square sub super sh a -> Vector sh a +takeDiagonal (Array (MatrixShape.Banded (sub,super) order extent) x) = + let size = Extent.squareSize extent + kl = integralFromProxy sub + ku = integralFromProxy super + in if (kl,ku) == (0,0) + then Array size x + else + Array.unsafeCreateWithSize size $ \n yPtr -> evalContT $ do + nPtr <- Call.cint n + xPtr <- ContT $ withForeignPtr x + let k = + case order of + RowMajor -> kl + ColumnMajor -> ku + incxPtr <- Call.cint (kl+ku+1) + incyPtr <- Call.cint 1 + liftIO $ + BlasGen.copy nPtr (advancePtr xPtr k) incxPtr yPtr incyPtr + + +multiplyVector :: + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, + Class.Floating a) => + Banded sub super vert horiz height width a -> + Vector width a -> Vector height a +multiplyVector + (Array (MatrixShape.Banded numOff order extent) a) (Array width x) = + let height = Extent.height extent + in Array.unsafeCreate height $ \yPtr -> do + + Call.assert "Banded.multiplyVector: shapes mismatch" + (Extent.width extent == width) + let (m,n) = MatrixShape.dimensions $ MatrixShape.Full order extent + let (kl,ku) = MatrixShape.numOffDiagonals order numOff + evalContT $ do + transPtr <- Call.char $ transposeFromOrder order + mPtr <- Call.cint m + nPtr <- Call.cint n + klPtr <- Call.cint kl + kuPtr <- Call.cint ku + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim $ kl+1+ku + xPtr <- ContT $ withForeignPtr x + incxPtr <- Call.cint 1 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + liftIO $ + Private.gbmv transPtr mPtr nPtr klPtr kuPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr + + +multiply :: + (Unary.Natural subA, Unary.Natural superA, + Unary.Natural subB, Unary.Natural superB, + (subA :+: subB) ~ subC, + (superA :+: superB) ~ superC, + Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, + Class.Floating a) => + Banded subA superA vert horiz height fuse a -> + Banded subB superB vert horiz fuse width a -> + Banded subC superC vert horiz height width a +multiply + (Array (MatrixShape.Banded numOffA orderA extentA) a) + (Array (MatrixShape.Banded numOffB orderB extentB) b) = + case (addOffDiagonals numOffA numOffB, Extent.fuse extentA extentB) of + (_, Nothing) -> error "Banded.multiply: shapes mismatch" + (((Proof.Nat, Proof.Nat), numOffC), Just extent) -> + Array.unsafeCreate + (MatrixShape.Banded numOffC orderB extent) $ \cPtr -> + let (height,fuse) = Extent.dimensions extentA + width = Extent.width extentB + in case (orderA,orderB) of + (ColumnMajor,ColumnMajor) -> + multiplyColumnMajor ColumnMajor + numOffA numOffB (height,fuse,width) a b cPtr + (RowMajor,ColumnMajor) -> + multiplyColumnMajor RowMajor + numOffA numOffB (height,fuse,width) a b cPtr + (ColumnMajor,RowMajor) -> + multiplyColumnRowMajor + (swap numOffB) (swap numOffA) + (width,fuse,height) b a cPtr + (RowMajor,RowMajor) -> + multiplyColumnMajor ColumnMajor + (swap numOffB) (swap numOffA) + (width,fuse,height) b a cPtr + +multiplyColumnMajor :: + (Unary.Natural subA, Unary.Natural superA, + Unary.Natural subB, Unary.Natural superB, + Shape.C height, Shape.C width, Shape.C fuse, + Class.Floating a) => + Order -> + (UnaryProxy subA, UnaryProxy superA) -> + (UnaryProxy subB, UnaryProxy superB) -> + (height, fuse, width) -> + ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () +multiplyColumnMajor orderA (subA,superA) (subB,superB) + (height,fuse,width) a b cPtr = do + let m = Shape.size height + let k = Shape.size fuse + let n = Shape.size width + let (kla,kua) = (integralFromProxy subA, integralFromProxy superA) + let (klb,kub) = (integralFromProxy subB, integralFromProxy superB) + let ku = kua+kub + let kl = kla+klb + let lda0 = kla+kua + let ldb0 = klb+kub + let ldc0 = lda0+ldb0 + let lda = lda0+1 + let ldc = ldc0+1 + evalContT $ do + transPtr <- Call.char $ transposeFromOrder orderA + mPtr <- Call.alloca + nPtr <- Call.alloca + klPtr <- Call.alloca + kuPtr <- Call.alloca + let ((miPtr,kliPtr),(niPtr,kuiPtr)) = + swapOnRowMajor orderA ((mPtr,klPtr),(nPtr,kuPtr)) + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim lda + bPtr <- ContT $ withForeignPtr b + incxPtr <- Call.cint 1 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + liftIO $ + forM_ (take n [0..]) $ \i -> do + let top = max 0 (i-ku) + let bottom = min m (i+kl+1) + let left = max 0 (i-kub) + let right = min k (i+klb+1) + pokeCInt miPtr $ max 0 $ bottom-top + pokeCInt niPtr $ max 0 $ right-left + let d = top-left; kli = kla-d; kui = kua+d + pokeCInt kuiPtr kui + pokeCInt kliPtr kli + let j0 = i*ldc + let j1 = i*ldc0 + top+ku + let j2 = i*ldc0 + bottom+ku + fill zero (j1-j0) (advancePtr cPtr j0) + let aOffset = + case orderA of + ColumnMajor -> left + RowMajor -> top + Private.gbmv transPtr mPtr nPtr klPtr kuPtr + alphaPtr + (advancePtr aPtr (aOffset*lda)) ldaPtr + (advancePtr bPtr (i*ldb0 + left+kub)) incxPtr + betaPtr + (advancePtr cPtr j1) incyPtr + fill zero (j0+ldc-j2) (advancePtr cPtr j2) + +multiplyColumnRowMajor :: + (Unary.Natural subA, Unary.Natural superA, + Unary.Natural subB, Unary.Natural superB, + Shape.C height, Shape.C width, Shape.C fuse, + Class.Floating a) => + (UnaryProxy subA, UnaryProxy superA) -> + (UnaryProxy subB, UnaryProxy superB) -> + (height, fuse, width) -> + ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () +multiplyColumnRowMajor (subA,superA) (subB,superB) + (height,fuse,width) a b cPtr = do + let m = Shape.size height + let k = Shape.size fuse + let n = Shape.size width + let (kla,kua) = (integralFromProxy subA, integralFromProxy superA) + let (klb,kub) = (integralFromProxy subB, integralFromProxy superB) + let ku = kua+kub + let kl = kla+klb + let lda0 = kla+kua + let ldb0 = klb+kub + let ldc0 = kl+ku + let ldc = ldc0+1 + fill zero (ldc*n) cPtr + evalContT $ do + mPtr <- Call.alloca + nPtr <- Call.alloca + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + bPtr <- ContT $ withForeignPtr b + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 1 + ldc0Ptr <- Call.leadingDim $ ldc0 + if ldb0==0 then 1 else 0 + liftIO $ + forM_ (take k [0..]) $ \i -> do + let top = max 0 (i-kua) + let bottom = min m (i+kla+1) + let left = max 0 (i-klb) + let right = min n (i+kub+1) + pokeCInt mPtr $ max 0 $ bottom-top + pokeCInt nPtr $ max 0 $ right-left + BlasGen.geru mPtr nPtr alphaPtr + (advancePtr aPtr (i*lda0+top+kua)) incxPtr + (advancePtr bPtr (i*ldb0+left+klb)) incyPtr + (advancePtr cPtr (left*ldc0+top+ku)) ldc0Ptr + + +multiplyFull :: + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, + Class.Floating a) => + Banded sub super vert horiz height fuse a -> + Matrix.Full vert horiz fuse width a -> Matrix.Full vert horiz height width a +multiplyFull + (Array (MatrixShape.Banded numOff orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + case Extent.fuse extentA extentB of + Nothing -> error "Banded.multiplyFull: shapes mismatch" + Just extent -> + Array.unsafeCreate (MatrixShape.Full orderB extent) $ \cPtr -> + let (height,fuse) = Extent.dimensions extentA + width = Extent.width extentB + in case orderB of + ColumnMajor -> + multiplyFullColumnMajor + numOff (height,fuse,width) orderA extentA a b cPtr + RowMajor -> + multiplyFullRowMajor + numOff (height,fuse,width) orderA a b cPtr + +multiplyFullColumnMajor :: + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, + Class.Floating a) => + (UnaryProxy sub, UnaryProxy super) -> + (height, fuse, width) -> + Order -> Extent.Extent vert horiz height fuse -> + ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () +multiplyFullColumnMajor numOff (height,fuse,width) orderA extentA a b cPtr = do + let (m,n) = MatrixShape.dimensions $ MatrixShape.Full orderA extentA + let k = Shape.size width + let (kl,ku) = MatrixShape.numOffDiagonals orderA numOff + evalContT $ do + transPtr <- Call.char $ transposeFromOrder orderA + mPtr <- Call.cint m + nPtr <- Call.cint n + klPtr <- Call.cint kl + kuPtr <- Call.cint ku + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim $ kl+1+ku + bPtr <- ContT $ withForeignPtr b + incxPtr <- Call.cint 1 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + liftIO $ + forM_ (take k $ + zip (pointerSeq (Shape.size fuse) bPtr) + (pointerSeq (Shape.size height) cPtr)) $ + \(xPtr,yPtr) -> + Private.gbmv transPtr mPtr nPtr klPtr kuPtr + alphaPtr aPtr ldaPtr xPtr incxPtr + betaPtr yPtr incyPtr + +multiplyFullRowMajor :: + (Unary.Natural sub, Unary.Natural super, + Shape.C height, Shape.C width, Shape.C fuse, + Class.Floating a) => + (UnaryProxy sub, UnaryProxy super) -> + (height, fuse, width) -> + Order -> ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () +multiplyFullRowMajor (sub,super) (height,fuse,width) orderA a b cPtr = do + let m = Shape.size height + let n = Shape.size fuse + let k = Shape.size width + let kl = integralFromProxy sub + let ku = integralFromProxy super + let lda0 = kl+ku + let lda = lda0+1 + evalContT $ do + transPtr <- Call.char 'N' + kPtr <- Call.cint k + dPtr <- Call.alloca + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + bPtr <- ContT $ withForeignPtr b + ldbPtr <- Call.leadingDim k + incxPtr <- Call.cint $ + case orderA of + RowMajor -> 1 + ColumnMajor -> max 1 lda0 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + liftIO $ + forM_ (take m $ zip [0..] $ + zip (pointerSeq lda aPtr) (pointerSeq k cPtr)) $ + \(i,(xPtr,yPtr)) -> do + let firstRow = limit (0,n) (i-kl) + let last1Row = limit (0,n) (i+ku+1) + let biPtr = advancePtr bPtr (firstRow*k) + let xOffset = + case orderA of + RowMajor -> firstRow-i+kl + ColumnMajor -> (firstRow-i)*lda0+ku + let xiPtr = advancePtr xPtr xOffset + pokeCInt dPtr $ last1Row - firstRow + Private.gemv transPtr kPtr dPtr + alphaPtr biPtr ldbPtr xiPtr incxPtr + betaPtr yPtr incyPtr + + +toLowerTriangular :: + (Unary.Natural sub, Shape.C sh, Class.Floating a) => + Lower sub sh a -> Triangular.Lower sh a +toLowerTriangular = + Triangular.transpose . toUpperTriangular . transpose + +toUpperTriangular :: + (Unary.Natural super, Shape.C sh, Class.Floating a) => + Upper super sh a -> Triangular.Upper sh a +toUpperTriangular (Array (MatrixShape.Banded (_sub,super) order extent) a) = + let size = Extent.squareSize extent + in Array.unsafeCreateWithSize + (MatrixShape.Triangular MatrixShape.NonUnit MatrixShape.upper + order size) $ + TriangularPriv.fromBanded + (integralFromProxy super) order (Shape.size size) a + +toFull :: + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Banded sub super vert horiz height width a -> + Matrix.Full vert horiz height width a +toFull (Array (MatrixShape.Banded (sub,super) order extent) a) = + Array.unsafeCreateWithSize (MatrixShape.Full order extent) $ \bSize bPtr -> + withForeignPtr a $ \aPtr -> do + let (height,width) = Extent.dimensions extent + fill zero bSize bPtr + case order of + ColumnMajor -> toFullColumnMajor (sub,super) (height,width) aPtr bPtr + RowMajor -> toFullColumnMajor (super,sub) (width,height) aPtr bPtr + +toFullColumnMajor :: + (Unary.Natural sub, Unary.Natural super, Shape.C height, Shape.C width, + Class.Floating a) => + (UnaryProxy sub, UnaryProxy super) -> (height,width) -> + Ptr a -> Ptr a -> IO () +toFullColumnMajor (sub,super) (height,width) aPtr bPtr = do + let m = Shape.size height + let n = Shape.size width + let kl = integralFromProxy sub + let ku = integralFromProxy super + let lda0 = kl+ku + let lda = lda0+1 + + void $ MM.runMaybeT $ flip MR.runReaderT n $ + if m > lda0 + then do -- diagonal stripe + let col0 = ku + withRightBound col0 $ \col -> + copyUpperTrapezoid (col+kl) col lda0 (advancePtr aPtr ku) m bPtr + let col1 = m-kl + withRightBound col1 $ \col -> + copySubMatrix lda (col-col0) + lda (advancePtr aPtr (col0*lda)) + (m+1) (advancePtr bPtr (col0*m)) + let col2 = m+ku + withRightBound col2 $ \col -> + copySubTrapezoid 'L' lda0 (col-col1) + lda0 (advancePtr aPtr (col1*lda)) + m (advancePtr bPtr (col1*m+m-lda0)) + else do -- full block in the middle + let col0 = max 0 $ m-kl + withRightBound col0 $ \col -> + copyUpperTrapezoid (col+kl) col lda0 (advancePtr aPtr ku) m bPtr + let col1 = ku + withRightBound col1 $ \col -> + copySubMatrix m (col-col0) + lda0 (advancePtr aPtr (col0*lda+(col1-col0))) + m (advancePtr bPtr (col0*m)) + let col2 = m+ku + withRightBound col2 $ \col -> + copySubTrapezoid 'L' m (col-col1) + lda0 (advancePtr aPtr (ku*lda)) + m (advancePtr bPtr (ku*m)) + +withRightBound :: + Int -> (Int -> IO a) -> MR.ReaderT Int (MM.MaybeT IO) a +withRightBound col act = do + n <- MR.ask + if n<=col + then liftIO (act n) >> mzero + else liftIO (act col) + +copyUpperTrapezoid :: + (Class.Floating a) => + Int -> Int -> Int -> Ptr a -> Int -> Ptr a -> IO () +copyUpperTrapezoid m n lda aPtr ldb bPtr = do + let d = m-n + copySubMatrix d n lda aPtr ldb bPtr + copySubTrapezoid 'U' n n + lda (advancePtr aPtr d) + ldb (advancePtr bPtr d) diff --git a/src/Numeric/LAPACK/Matrix/Banded/Linear.hs b/src/Numeric/LAPACK/Matrix/Banded/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Banded/Linear.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Banded.Linear ( + solve, + solveColumnMajor, + determinant, + ) where + +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Split as Split +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Linear.Private (solver, withDeterminantInfo, withInfo) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), transposeFromOrder) +import Numeric.LAPACK.Matrix.Private (Full) +import Numeric.LAPACK.Private (copySubMatrix) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num (integralFromProxy) + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.Marshal.Array (peekArray, advancePtr) +import Foreign.ForeignPtr (withForeignPtr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + + +solve :: + (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Banded.Square sub super sh a -> + Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solve (Array (MatrixShape.Banded numOff order extent) a) = + solver "Banded.solve" (Extent.squareSize extent) $ + \n nPtr nrhsPtr xPtr ldxPtr -> do + let (kl,ku) = MatrixShape.numOffDiagonals order numOff + let k = kl+1+ku + let ldab = kl+k + transPtr <- Call.char $ transposeFromOrder order + klPtr <- Call.cint kl + kuPtr <- Call.cint ku + aPtr <- ContT $ withForeignPtr a + abPtr <- Call.allocaArray (n*ldab) + ldabPtr <- Call.leadingDim ldab + ipivPtr <- Call.allocaArray n + liftIO $ do + copySubMatrix k n k aPtr ldab (advancePtr abPtr kl) + withInfo "gbtrf" $ + LapackGen.gbtrf nPtr nPtr klPtr kuPtr abPtr ldabPtr ipivPtr + withInfo "gbtrs" $ + LapackGen.gbtrs transPtr nPtr klPtr kuPtr nrhsPtr + abPtr ldabPtr ipivPtr xPtr ldxPtr + +solveColumnMajor :: + (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Banded.Square sub super sh a -> + Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solveColumnMajor + (Array (MatrixShape.Banded (sub,super) ColumnMajor extent) a) = + solver "Banded.solve" (Extent.squareSize extent) $ + \n nPtr nrhsPtr xPtr ldxPtr -> do + let kl = integralFromProxy sub + let ku = integralFromProxy super + let k = kl+1+ku + let ldab = kl+k + klPtr <- Call.cint kl + kuPtr <- Call.cint ku + aPtr <- ContT $ withForeignPtr a + abPtr <- Call.allocaArray (n*ldab) + ldabPtr <- Call.leadingDim ldab + ipivPtr <- Call.allocaArray n + liftIO $ do + copySubMatrix k n k aPtr ldab (advancePtr abPtr kl) + withInfo "gbsv" $ + LapackGen.gbsv nPtr klPtr kuPtr nrhsPtr + abPtr ldabPtr ipivPtr xPtr ldxPtr +solveColumnMajor (Array (MatrixShape.Banded _ RowMajor _) _) = + error "Linear.Banded.solveColumnMajor: RowMajor intentionally unimplemented" + +determinant :: + (Unary.Natural sub, Unary.Natural super, Shape.C sh, Class.Floating a) => + Banded.Square sub super sh a -> a +determinant (Array (MatrixShape.Banded numOff order extent) a) = + unsafePerformIO $ do + let n = Shape.size $ Extent.squareSize extent + evalContT $ do + let (kl,ku) = MatrixShape.numOffDiagonals order numOff + let k = kl+1+ku + let ldab = kl+k + nPtr <- Call.cint n + klPtr <- Call.cint kl + kuPtr <- Call.cint ku + aPtr <- ContT $ withForeignPtr a + abPtr <- Call.allocaArray (n*ldab) + ldabPtr <- Call.leadingDim ldab + ipivPtr <- Call.allocaArray n + liftIO $ do + copySubMatrix k n k aPtr ldab (advancePtr abPtr kl) + withDeterminantInfo "gbtrf" + (LapackGen.gbtrf nPtr nPtr klPtr kuPtr abPtr ldabPtr ipivPtr) + (do + det <- Private.product n (advancePtr abPtr (kl+ku)) ldab + ipiv <- peekArray n ipivPtr + return $ if Split.oddPermutation ipiv then -det else det) diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitian.hs b/src/Numeric/LAPACK/Matrix/BandedHermitian.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/BandedHermitian.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.BandedHermitian ( + module Numeric.LAPACK.Matrix.BandedHermitian.Basic, + + eigenvalues, + eigensystem, + ) where + +import qualified Numeric.LAPACK.Matrix.BandedHermitian.Eigen as Eigen +import Numeric.LAPACK.Matrix.BandedHermitian.Basic + +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary + +import qualified Data.Array.Comfort.Shape as Shape + + +eigenvalues :: + (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => + BandedHermitian offDiag sh a -> Vector sh (RealOf a) +eigenvalues = Eigen.values + +{- | +For symmetric eigenvalue problems, @eigensystem@ and @schur@ coincide. +-} +eigensystem :: + (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => + BandedHermitian offDiag sh a -> (Matrix.Square sh a, Vector sh (RealOf a)) +eigensystem = Eigen.decompose diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs b/src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.BandedHermitian.Basic ( + BandedHermitian, + Transposition(..), + fromList, + identity, + diagonal, + takeDiagonal, + toHermitian, + toBanded, + multiplyVector, + multiplyFull, + covariance, + sumRank1, + ) where + +import qualified Numeric.LAPACK.ShapeStatic as ShapeStatic +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Triangular.Private as TriangularPriv +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Hermitian.Private (TakeDiagonal(..)) +import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), flipOrder, uploFromOrder, + UnaryProxy, natFromProxy) +import Numeric.LAPACK.Matrix.Private + (Transposition(NonTransposed, Transposed), transposeOrder) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, zero, one) +import Numeric.LAPACK.Private + (fill, lacgv, copyConjugate, condConjugateToTemp, + pointerSeq, pokeCInt, copySubMatrix) + +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.BLAS.FFI.Complex as BlasComplex +import qualified Numeric.BLAS.FFI.Real as BlasReal +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary ((:+:)) +import Type.Data.Num (integralFromProxy) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.Marshal.Array (advancePtr) +import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable, poke, peek, peekElemOff) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (when) + +import Data.Foldable (for_) +import Data.Tuple.HT (mapPair) + +import Data.Complex (Complex, conjugate) + + +type BandedHermitian offDiag size = + Array (MatrixShape.BandedHermitian offDiag size) + +type Diagonal size = BandedHermitian TypeNum.U0 size + + +fromList :: + (Unary.Natural offDiag, Shape.C size, Storable a) => + UnaryProxy offDiag -> Order -> size -> [a] -> + BandedHermitian offDiag size a +fromList numOff order size = + Array.fromList (MatrixShape.BandedHermitian numOff order size) + +identity :: + (Shape.C sh, Class.Floating a) => sh -> Diagonal sh a +identity sh = + Array.mapShape (MatrixShape.BandedHermitian Proxy ColumnMajor) $ + Vector.constant sh one + +diagonal :: + (Shape.C sh, Class.Floating a) => Vector sh (RealOf a) -> Diagonal sh a +diagonal = + Array.mapShape (MatrixShape.BandedHermitian Proxy ColumnMajor) . + Vector.fromReal + +takeDiagonal :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + BandedHermitian offDiag size a -> Vector size (RealOf a) +takeDiagonal = + runTakeDiagonal $ + Class.switchFloating + (TakeDiagonal $ takeDiagonalAux 1) (TakeDiagonal $ takeDiagonalAux 1) + (TakeDiagonal $ takeDiagonalAux 2) (TakeDiagonal $ takeDiagonalAux 2) + +takeDiagonalAux :: + (Unary.Natural offDiag, Shape.C size, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Int -> BandedHermitian offDiag size a -> Vector size ar +takeDiagonalAux dim (Array (MatrixShape.BandedHermitian numOff order size) a) = + let k = integralFromProxy numOff + in Array.unsafeCreateWithSize size $ \n yPtr -> evalContT $ do + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + let xPtr = + castPtr $ advancePtr aPtr $ + case order of + RowMajor -> 0 + ColumnMajor -> k + incxPtr <- Call.cint (dim * (k+1)) + incyPtr <- Call.cint 1 + liftIO $ BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr + + +toHermitian :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + BandedHermitian offDiag size a -> Hermitian size a +toHermitian (Array (MatrixShape.BandedHermitian numOff order size) a) = + Array.unsafeCreateWithSize (MatrixShape.Hermitian order size) $ + TriangularPriv.fromBanded + (integralFromProxy numOff) order (Shape.size size) a + + +toBanded :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + BandedHermitian offDiag size a -> + Banded.Square offDiag offDiag size a +toBanded (Array (MatrixShape.BandedHermitian numOff order sh) a) = + Array.unsafeCreate + (MatrixShape.Banded (numOff,numOff) order (Extent.square sh)) $ \bPtr -> + withForeignPtr a $ \aPtr -> + case order of + ColumnMajor -> toBandedColumnMajor numOff sh aPtr bPtr + RowMajor -> toBandedRowMajor numOff sh aPtr bPtr + +toBandedColumnMajor :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + UnaryProxy offDiag -> size -> Ptr a -> Ptr a -> IO () +toBandedColumnMajor numOff size aPtr bPtr = do + let n = Shape.size size + let k = integralFromProxy numOff + let lda0 = k + let lda = lda0+1 + let ldb0 = 2*k + let ldb = ldb0+1 + copySubMatrix lda n lda aPtr ldb bPtr + evalContT $ do + incxPtr <- Call.cint lda0 + incyPtr <- Call.cint 1 + inczPtr <- Call.cint 0 + zPtr <- Call.number zero + nPtr <- Call.alloca + liftIO $ for_ (take n [0..]) $ \i -> do + let top = i+1 + let bottom = min n (i+k+1) + let xPtr = advancePtr aPtr ((i+1)*lda0+top+k-1) + let yPtr = advancePtr bPtr (i*ldb0+k) + pokeCInt nPtr (bottom-top) + copyConjugate nPtr xPtr incxPtr (advancePtr yPtr top) incyPtr + pokeCInt nPtr (i+k+1 - bottom) + BlasGen.copy nPtr zPtr inczPtr (advancePtr yPtr bottom) incyPtr + +toBandedRowMajor :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + UnaryProxy offDiag -> size -> Ptr a -> Ptr a -> IO () +toBandedRowMajor numOff size aPtr bPtr = do + let n = Shape.size size + let k = integralFromProxy numOff + let lda0 = k + let lda = lda0+1 + let ldb0 = 2*k + let ldb = ldb0+1 + copySubMatrix lda n lda aPtr ldb (advancePtr bPtr k) + evalContT $ do + incxPtr <- Call.cint lda0 + incyPtr <- Call.cint 1 + inczPtr <- Call.cint 0 + zPtr <- Call.number zero + nPtr <- Call.alloca + liftIO $ for_ (take n [0..]) $ \i -> do + let left = max 0 (i-k) + let xPtr = advancePtr aPtr (left*lda0+i) + let yPtr = advancePtr bPtr (i*ldb0) + pokeCInt nPtr (k-i+left) + BlasGen.copy nPtr zPtr inczPtr (advancePtr yPtr i) incyPtr + pokeCInt nPtr (i-left) + copyConjugate nPtr xPtr incxPtr (advancePtr yPtr (left+k)) incyPtr + + +multiplyVector :: + (Unary.Natural offDiag, Shape.C size, Eq size, Class.Floating a) => + Transposition -> BandedHermitian offDiag size a -> + Vector size a -> Vector size a +multiplyVector transposed + (Array (MatrixShape.BandedHermitian numOff order size) a) (Array sizeX x) = + Array.unsafeCreateWithSize size $ \n yPtr -> do + + Call.assert "BandedHermitian.multiplyVector: shapes mismatch" + (size == sizeX) + let k = integralFromProxy numOff + evalContT $ do + let conj = transposeOrder transposed order == RowMajor + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + kPtr <- Call.cint k + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim $ k+1 + xPtr <- condConjugateToTemp conj n x + incxPtr <- Call.cint 1 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + liftIO $ do + BlasGen.hbmv uploPtr nPtr kPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr + when conj $ lacgv nPtr yPtr incyPtr + + +covariance :: + (Shape.C size, Eq size, Class.Floating a, + Unary.Natural sub, Unary.Natural super) => + Banded.Square sub super size a -> + BandedHermitian (sub :+: super) size a +covariance a = + case mapPair (natFromProxy,natFromProxy) $ + MatrixShape.bandedOffDiagonals $ Array.shape a of + (sub,super) -> + case (Proof.addNat sub super, Proof.addComm sub super) of + (Proof.Nat, Proof.AddComm) -> + fromUpperPart $ Banded.multiply (Banded.adjoint a) a + +fromUpperPart :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + Banded.Square offDiag offDiag size a -> BandedHermitian offDiag size a +fromUpperPart (Array (MatrixShape.Banded (sub,super) order extent) a) = + let sh = Extent.squareSize extent + n = Shape.size sh + kl = integralFromProxy sub + ku = integralFromProxy super + lda = kl+1+ku + ldb = ku+1 + in Array.unsafeCreate (MatrixShape.BandedHermitian super order sh) $ \bPtr -> + withForeignPtr a $ \aPtr -> + case order of + ColumnMajor -> copySubMatrix ldb n lda aPtr ldb bPtr + RowMajor -> copySubMatrix ldb n lda (advancePtr aPtr kl) ldb bPtr + + +multiplyFull :: + (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Transposition -> BandedHermitian offDiag height a -> + Matrix.Full vert horiz height width a -> + Matrix.Full vert horiz height width a +multiplyFull transposed a b = + case MatrixShape.fullOrder $ Array.shape b of + ColumnMajor -> multiplyFullSpecial transposed a b + RowMajor -> multiplyFullGeneric transposed a b + +multiplyFullSpecial :: + (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + Eq height, Shape.C height, Shape.C width, Class.Floating a) => + Transposition -> BandedHermitian offDiag height a -> + Matrix.Full vert horiz height width a -> + Matrix.Full vert horiz height width a +multiplyFullSpecial transposed + (Array (MatrixShape.BandedHermitian numOff orderA sizeA) a) + (Array (MatrixShape.Full orderB extentB) b) = + Array.unsafeCreate (MatrixShape.Full orderB extentB) $ \cPtr -> do + Call.assert "BandedHermitian.multiplyFull: shapes mismatch" + (sizeA == Extent.height extentB) + let (height,width) = Extent.dimensions extentB + case orderB of + ColumnMajor -> + multiplyFullColumnMajor + transposed numOff (height,width) orderA a b cPtr + RowMajor -> + multiplyFullRowMajor + transposed numOff (height,width) orderA a b cPtr + +multiplyFullColumnMajor :: + (Unary.Natural offDiag, Shape.C height, Shape.C width, Class.Floating a) => + Transposition -> UnaryProxy offDiag -> (height, width) -> + Order -> ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () +multiplyFullColumnMajor transposed numOff (height,width) order a b cPtr = do + let n = Shape.size height + let nrhs = Shape.size width + let k = integralFromProxy numOff + evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + kPtr <- Call.cint k + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim $ k+1 + bPtr <- ContT $ withForeignPtr b + incxPtr <- Call.cint 1 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + let pointers = take nrhs $ zip (pointerSeq n bPtr) (pointerSeq n cPtr) + case transposeOrder transposed order of + RowMajor -> do + xPtr <- Call.allocaArray n + liftIO $ for_ pointers $ \(biPtr,yPtr) -> do + copyConjugate nPtr biPtr incxPtr xPtr incxPtr + BlasGen.hbmv uploPtr nPtr kPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr + lacgv nPtr yPtr incyPtr + ColumnMajor -> + liftIO $ for_ pointers $ \(xPtr,yPtr) -> + BlasGen.hbmv uploPtr nPtr kPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr + +multiplyFullRowMajor :: + (Unary.Natural offDiag, Shape.C height, Shape.C width, Class.Floating a) => + Transposition -> UnaryProxy offDiag -> (height, width) -> + Order -> ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () +multiplyFullRowMajor = + error "BandedHermitian.multiplyFullRowMajor: not implemented" + + +multiplyFullGeneric :: + (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Transposition -> BandedHermitian offDiag height a -> + Matrix.Full vert horiz height width a -> + Matrix.Full vert horiz height width a +multiplyFullGeneric transposed a b = + let (lower,upper) = (takeStrictLower a, takeUpper a) + (lowerT,upperT) = + case transposed of + Transposed -> (Banded.transpose upper, Banded.transpose lower) + NonTransposed -> (lower,upper) + in Banded.multiplyFull (Banded.mapExtent Extent.fromSquare lowerT) b + `Vector.add` + Banded.multiplyFull (Banded.mapExtent Extent.fromSquare upperT) b + +takeUpper :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + BandedHermitian offDiag size a -> + Banded.Square TypeNum.U0 offDiag size a +takeUpper = + Array.mapShape + (\(MatrixShape.BandedHermitian numOff order sh) -> + MatrixShape.bandedSquare (Proxy,numOff) order sh) + +takeStrictLower :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + BandedHermitian offDiag size a -> + Banded.Square offDiag TypeNum.U0 size a +takeStrictLower (Array (MatrixShape.BandedHermitian numOff order sh) x) = + Array.unsafeCreateWithSize + (MatrixShape.bandedSquare (numOff,Proxy) (flipOrder order) sh) $ + \size yPtr -> evalContT $ do + let k = integralFromProxy numOff + nPtr <- Call.cint $ Shape.size sh + xPtr <- ContT $ withForeignPtr x + sizePtr <- Call.cint size + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 1 + inczPtr <- Call.cint 0 + ldbPtr <- Call.leadingDim $ k+1 + zPtr <- Call.number zero + liftIO $ do + copyConjugate sizePtr xPtr incxPtr yPtr incyPtr + let offset = case order of ColumnMajor -> k; RowMajor -> 0 + BlasGen.copy nPtr zPtr inczPtr (advancePtr yPtr offset) ldbPtr + + +type StaticVector n = Vector (ShapeStatic.ZeroBased n) + +{- +The list represents ragged rows of a sparse matrix. +-} +sumRank1 :: + (Unary.Natural k, Shape.Indexed sh, Class.Floating a) => + Order -> sh -> + [(RealOf a, (Shape.Index sh, StaticVector (Unary.Succ k) a))] -> + BandedHermitian k sh a +sumRank1 = + getSumRank1 $ + Class.switchFloating + (SumRank1 $ sumRank1Aux Proxy) + (SumRank1 $ sumRank1Aux Proxy) + (SumRank1 $ sumRank1Aux Proxy) + (SumRank1 $ sumRank1Aux Proxy) + +newtype SumRank1 k sh a = SumRank1 {getSumRank1 :: SumRank1_ k sh (RealOf a) a} + +type SumRank1_ k sh ar a = + Order -> sh -> + [(ar, (Shape.Index sh, StaticVector (Unary.Succ k) a))] -> + BandedHermitian k sh a + +sumRank1Aux :: + (Unary.Natural k, Shape.Indexed sh, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + UnaryProxy k -> SumRank1_ k sh ar a +sumRank1Aux numOff order size xs = + Array.unsafeCreateWithSize + (MatrixShape.BandedHermitian numOff order size) $ + \bSize aPtr -> evalContT $ do + let k = integralFromProxy numOff + let n = Shape.size size + let lda = k+1 + uploPtr <- Call.char $ uploFromOrder order + mPtr <- Call.cint lda + alphaPtr <- Call.alloca + incxPtr <- Call.cint 1 + kPtr <- Call.cint k + ldbPtr <- Call.leadingDim k + bSizePtr <- Call.cint bSize + liftIO $ do + fill zero bSize aPtr + for_ xs $ \(alpha, (offset, Array _shX x)) -> + withForeignPtr x $ \xPtr -> do + let i = Shape.offset size offset + Call.assert "BandedHermitian.sumRank1: index too large" (i+k < n) + let bPtr = advancePtr aPtr (lda*i) + hbr order k alpha + uploPtr mPtr kPtr alphaPtr xPtr incxPtr bPtr incxPtr ldbPtr + case order of + RowMajor -> lacgv bSizePtr aPtr incxPtr + ColumnMajor -> return () + + +type HBR_ ar a = + Order -> Int -> ar -> Ptr CChar -> Ptr CInt -> Ptr CInt -> + Ptr a -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> Ptr CInt -> IO () + +newtype HBR a = HBR {getHBR :: HBR_ (RealOf a) a} + +hbr :: Class.Floating a => HBR_ (RealOf a) a +hbr = getHBR $ Class.switchFloating (HBR syr) (HBR syr) (HBR her) (HBR her) + +syr :: (Class.Real a) => HBR_ a a +syr order k alpha uploPtr nPtr kPtr alphaPtr xPtr incxPtr a0Ptr incaPtr ldaPtr = + case order of + ColumnMajor -> do + let aPtr = advancePtr a0Ptr k + poke alphaPtr alpha + BlasReal.syr uploPtr kPtr alphaPtr xPtr incxPtr aPtr ldaPtr + poke alphaPtr . (alpha*) =<< peekElemOff xPtr k + BlasGen.axpy nPtr alphaPtr xPtr incxPtr (advancePtr aPtr (k*k)) incaPtr + RowMajor -> do + let aPtr = a0Ptr + poke alphaPtr . (alpha*) =<< peek xPtr + BlasGen.axpy nPtr alphaPtr xPtr incxPtr aPtr incaPtr + poke alphaPtr alpha + BlasReal.syr uploPtr kPtr alphaPtr + (advancePtr xPtr 1) incxPtr (advancePtr aPtr (k+1)) ldaPtr + +her :: (Class.Real a) => HBR_ a (Complex a) +her order k alpha uploPtr nPtr kPtr alphaPtr xPtr incxPtr a0Ptr incaPtr ldaPtr = + case order of + ColumnMajor -> do + let aPtr = advancePtr a0Ptr k + let alphaRealPtr = castPtr alphaPtr + poke alphaRealPtr alpha + BlasComplex.her uploPtr kPtr alphaRealPtr xPtr incxPtr aPtr ldaPtr + poke alphaPtr . fmap (alpha*) . conjugate =<< peekElemOff xPtr k + BlasGen.axpy nPtr alphaPtr xPtr incxPtr (advancePtr aPtr (k*k)) incaPtr + RowMajor -> do + let aPtr = a0Ptr + let alphaRealPtr = castPtr alphaPtr + poke alphaPtr . fmap (alpha*) . conjugate =<< peek xPtr + BlasGen.axpy nPtr alphaPtr xPtr incxPtr aPtr incaPtr + poke alphaRealPtr alpha + BlasComplex.her uploPtr kPtr alphaRealPtr + (advancePtr xPtr 1) incxPtr (advancePtr aPtr (k+1)) ldaPtr diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs b/src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.BandedHermitian.Eigen ( + values, + decompose, + ) where + +import Numeric.LAPACK.Matrix.BandedHermitian.Basic (BandedHermitian) + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import Numeric.LAPACK.Matrix.Hermitian.Private (TakeDiagonal(..)) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), uploFromOrder) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf) +import Numeric.LAPACK.Private + (copyToTemp, copyCondConjugateToTemp, withInfo, eigenMsg) + +import qualified Numeric.LAPACK.FFI.Complex as LapackComplex +import qualified Numeric.LAPACK.FFI.Real as LapackReal +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num (integralFromProxy) + +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.C.Types (CInt, CChar) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable) + +import Control.Monad.Trans.Cont (evalContT) +import Control.Monad.IO.Class (liftIO) + +import Data.Complex (Complex) + + +values :: + (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => + BandedHermitian offDiag sh a -> Vector sh (RealOf a) +values = + runTakeDiagonal $ + Class.switchFloating + (TakeDiagonal valuesAux) (TakeDiagonal valuesAux) + (TakeDiagonal valuesAux) (TakeDiagonal valuesAux) + +valuesAux :: + (Unary.Natural offDiag, Shape.C sh, + Class.Floating a, RealOf a ~ ar, Storable ar) => + BandedHermitian offDiag sh a -> Vector sh ar +valuesAux (Array (MatrixShape.BandedHermitian numOff order size) a) = + Array.unsafeCreateWithSize size $ \n wPtr -> evalContT $ do + let k = integralFromProxy numOff + let lda = k+1 + jobzPtr <- Call.char 'N' + uploPtr <- Call.char $ uploFromOrder order + kPtr <- Call.cint k + aPtr <- copyToTemp (n*lda) a + ldaPtr <- Call.leadingDim lda + let zPtr = nullPtr + ldzPtr <- Call.leadingDim n + liftIO $ withInfo eigenMsg "hbev" $ + hbev jobzPtr uploPtr n kPtr aPtr ldaPtr wPtr zPtr ldzPtr + + +decompose :: + (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => + BandedHermitian offDiag sh a -> (Matrix.Square sh a, Vector sh (RealOf a)) +decompose = + getDecompose $ + Class.switchFloating + (Decompose decomposeAux) (Decompose decomposeAux) + (Decompose decomposeAux) (Decompose decomposeAux) + +type Decompose_ offDiag sh a = + BandedHermitian offDiag sh a -> (Matrix.Square sh a, Vector sh (RealOf a)) + +newtype Decompose offDiag sh a = + Decompose {getDecompose :: Decompose_ offDiag sh a} + +decomposeAux :: + (Unary.Natural offDiag, Shape.C sh, + Class.Floating a, RealOf a ~ ar, Storable ar) => + Decompose_ offDiag sh a +decomposeAux (Array (MatrixShape.BandedHermitian numOff order size) a) = + Array.unsafeCreateWithSizeAndResult (MatrixShape.square ColumnMajor size) $ + \_ zPtr -> + ArrayIO.unsafeCreateWithSize size $ \n wPtr -> + evalContT $ do + let k = integralFromProxy numOff + let lda = k+1 + jobzPtr <- Call.char 'V' + uploPtr <- Call.char $ uploFromOrder order + kPtr <- Call.cint k + aPtr <- copyCondConjugateToTemp (order==RowMajor) (n*lda) a + ldaPtr <- Call.leadingDim lda + ldzPtr <- Call.leadingDim n + liftIO $ withInfo eigenMsg "hbev" $ + hbev jobzPtr uploPtr n kPtr aPtr ldaPtr wPtr zPtr ldzPtr + + +type HBEV_ ar a = + Ptr CChar -> Ptr CChar -> Int -> Ptr CInt -> Ptr a -> Ptr CInt -> Ptr ar -> + Ptr a -> Ptr CInt -> Ptr CInt -> IO () + +newtype HBEV a = HBEV {getHBEV :: HBEV_ (RealOf a) a} + +hbev :: Class.Floating a => HBEV_ (RealOf a) a +hbev = + getHBEV $ + Class.switchFloating + (HBEV sbevReal) (HBEV sbevReal) (HBEV hbevComplex) (HBEV hbevComplex) + +sbevReal :: Class.Real a => HBEV_ a a +sbevReal jobzPtr uploPtr n kdPtr aPtr ldaPtr wPtr zPtr ldzPtr infoPtr = + evalContT $ do + nPtr <- Call.cint n + workPtr <- Call.allocaArray (max 1 (3*n-2)) + liftIO $ + LapackReal.sbev jobzPtr uploPtr + nPtr kdPtr aPtr ldaPtr wPtr zPtr ldzPtr workPtr infoPtr + +hbevComplex :: Class.Real a => HBEV_ a (Complex a) +hbevComplex jobzPtr uploPtr n kdPtr aPtr ldaPtr wPtr zPtr ldzPtr infoPtr = + evalContT $ do + nPtr <- Call.cint n + workPtr <- Call.allocaArray n + rworkPtr <- Call.allocaArray (max 1 (3*n-2)) + liftIO $ + LapackComplex.hbev jobzPtr uploPtr + nPtr kdPtr aPtr ldaPtr wPtr zPtr ldzPtr workPtr rworkPtr infoPtr diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs @@ -0,0 +1,5 @@ +module Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite ( + module Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear, + ) where + +import Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear ( + solve, + solveDecomposed, + decompose, + determinant, + ) where + +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Linear.Private (solver) +import Numeric.LAPACK.Matrix.BandedHermitian.Basic (BandedHermitian) +import Numeric.LAPACK.Matrix.Hermitian.Private (Determinant(..)) +import Numeric.LAPACK.Matrix.Triangular.Private (copyTriangleToTemp) +import Numeric.LAPACK.Matrix.Shape.Private (uploFromOrder) +import Numeric.LAPACK.Matrix.Private (Full, Conjugation(Conjugated)) +import Numeric.LAPACK.Scalar (RealOf, realPart) +import Numeric.LAPACK.Private (copyBlock, withInfo, rankMsg, definiteMsg) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num (integralFromProxy) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.ForeignPtr (withForeignPtr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + + +solve :: + (Unary.Natural offDiag, Shape.C size, Eq size, + Extent.C vert, Extent.C horiz, Shape.C nrhs, Class.Floating a) => + BandedHermitian offDiag size a -> + Full vert horiz size nrhs a -> Full vert horiz size nrhs a +solve (Array (MatrixShape.BandedHermitian numOff orderA shA) a) = + solver "BandedHermitian.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + uploPtr <- Call.char $ uploFromOrder orderA + let k = integralFromProxy numOff + let lda = k+1 + kPtr <- Call.cint k + aPtr <- copyTriangleToTemp Conjugated orderA (n*lda) a + ldaPtr <- Call.leadingDim lda + liftIO $ + withInfo definiteMsg "pbsv" $ + LapackGen.pbsv uploPtr nPtr kPtr nrhsPtr aPtr ldaPtr xPtr ldxPtr + +{- | +> solve a b == solveDecomposed (decompose a) b +> solve (covariance u) b == solveDecomposed u b +-} +solveDecomposed :: + (Unary.Natural offDiag, Shape.C size, Eq size, + Extent.C vert, Extent.C horiz, Shape.C nrhs, Class.Floating a) => + Banded.Upper offDiag size a -> + Full vert horiz size nrhs a -> Full vert horiz size nrhs a +solveDecomposed (Array (MatrixShape.Banded (_zero,numOff) orderA shA) a) = + solver "BandedHermitian.solveDecomposed" (Extent.squareSize shA) $ + \n nPtr nrhsPtr xPtr ldxPtr -> do + uploPtr <- Call.char $ uploFromOrder orderA + let k = integralFromProxy numOff + let lda = k+1 + kPtr <- Call.cint k + aPtr <- copyTriangleToTemp Conjugated orderA (n*lda) a + ldaPtr <- Call.leadingDim lda + liftIO $ + withInfo rankMsg "pbtrs" $ + LapackGen.pbtrs uploPtr nPtr kPtr nrhsPtr aPtr ldaPtr xPtr ldxPtr + + +{- | +Cholesky decomposition +-} +decompose :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + BandedHermitian offDiag size a -> Banded.Upper offDiag size a +decompose (Array (MatrixShape.BandedHermitian numOff order sh) a) = + Array.unsafeCreateWithSize + (MatrixShape.bandedSquare (Proxy,numOff) order sh) $ \bSize bPtr -> do + evalContT $ do + let k = integralFromProxy numOff + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint $ Shape.size sh + kPtr <- Call.cint k + aPtr <- ContT $ withForeignPtr a + ldbPtr <- Call.leadingDim $ k+1 + liftIO $ do + copyBlock bSize aPtr bPtr + withInfo definiteMsg "pbtrf" $ + LapackGen.pbtrf uploPtr nPtr kPtr bPtr ldbPtr + + +determinant :: + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => + BandedHermitian offDiag size a -> RealOf a +determinant = + getDeterminant $ + Class.switchFloating + (Determinant determinantAux) (Determinant determinantAux) + (Determinant determinantAux) (Determinant determinantAux) + +determinantAux :: + (Unary.Natural offDiag, Shape.C size, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian offDiag size a -> ar +determinantAux = + (^(2::Int)) . product . map realPart . Array.toList . + Banded.takeDiagonal . decompose diff --git a/src/Numeric/LAPACK/Matrix/Basic.hs b/src/Numeric/LAPACK/Matrix/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Basic.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Numeric.LAPACK.Matrix.Basic where + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor)) +import Numeric.LAPACK.Matrix.Private (Full, General) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private (pointerSeq) + +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (poke, peek) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + + +transpose :: + (Extent.C vert, Extent.C horiz) => + Full vert horiz height width a -> Full horiz vert width height a +transpose = Array.mapShape MatrixShape.transpose + + +singleRow :: Order -> Vector width a -> General () width a +singleRow order = Array.mapShape (MatrixShape.general order ()) + +singleColumn :: Order -> Vector height a -> General height () a +singleColumn order = Array.mapShape (flip (MatrixShape.general order) ()) + +flattenRow :: General () width a -> Vector width a +flattenRow = Array.mapShape MatrixShape.fullWidth + +flattenColumn :: General height () a -> Vector height a +flattenColumn = Array.mapShape MatrixShape.fullHeight + + + +scaleRows :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Vector height a -> + Full vert horiz height width a -> + Full vert horiz height width a +scaleRows + (Array heightX x) (Array shape@(MatrixShape.Full order extent) a) = + Array.unsafeCreate shape $ \bPtr -> do + let (height,width) = Extent.dimensions extent + Call.assert "scaleRows: sizes mismatch" (heightX == height) + case order of + RowMajor -> evalContT $ do + let m = Shape.size height + let n = Shape.size width + alphaPtr <- Call.alloca + nPtr <- Call.cint n + xPtr <- ContT $ withForeignPtr x + aPtr <- ContT $ withForeignPtr a + incaPtr <- Call.cint 1 + incbPtr <- Call.cint 1 + liftIO $ sequence_ $ take m $ + zipWith3 + (\xkPtr akPtr bkPtr -> do + poke alphaPtr =<< peek xkPtr + BlasGen.copy nPtr akPtr incaPtr bkPtr incbPtr + BlasGen.scal nPtr alphaPtr bkPtr incbPtr) + (pointerSeq 1 xPtr) + (pointerSeq n aPtr) + (pointerSeq n bPtr) + ColumnMajor -> evalContT $ do + let m = Shape.size width + let n = Shape.size height + transPtr <- Call.char 'N' + nPtr <- Call.cint n + klPtr <- Call.cint 0 + kuPtr <- Call.cint 0 + alphaPtr <- Call.number one + xPtr <- ContT $ withForeignPtr x + ldxPtr <- Call.leadingDim 1 + aPtr <- ContT $ withForeignPtr a + incaPtr <- Call.cint 1 + betaPtr <- Call.number zero + incbPtr <- Call.cint 1 + liftIO $ sequence_ $ take m $ + zipWith + (\akPtr bkPtr -> + Private.gbmv transPtr + nPtr nPtr klPtr kuPtr alphaPtr xPtr ldxPtr + akPtr incaPtr betaPtr bkPtr incbPtr) + (pointerSeq n aPtr) + (pointerSeq n bPtr) + +scaleColumns :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Vector width a -> + Full vert horiz height width a -> + Full vert horiz height width a +scaleColumns x = transpose . scaleRows x . transpose diff --git a/src/Numeric/LAPACK/Matrix/Divide.hs b/src/Numeric/LAPACK/Matrix/Divide.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Divide.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.LAPACK.Matrix.Divide where + +import qualified Numeric.LAPACK.Matrix.Square.Linear + as Square +import qualified Numeric.LAPACK.Matrix.Triangular.Linear + as Triangular +import qualified Numeric.LAPACK.Matrix.Hermitian.Linear + as Hermitian +import qualified Numeric.LAPACK.Matrix.Banded.Linear + as Banded +import qualified Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear + as BandedHermitianPositiveDefinite + +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Shape.Private (HeightOf) +import Numeric.LAPACK.Matrix.Extent.Private (Small) +import Numeric.LAPACK.Matrix.Private (Full) +import Numeric.LAPACK.Vector (Vector) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) + + +class (Shape.C shape) => Solve shape where + solve :: + (Class.Floating a, HeightOf shape ~ height, Eq height, + Extent.C horiz, Extent.C vert, Shape.C nrhs) => + Array shape a -> + Full vert horiz height nrhs a -> Full vert horiz height nrhs a + +class (Solve shape) => Inverse shape where + inverse :: (Class.Floating a) => Array shape a -> Array shape a + +solveVector :: + (Solve shape, HeightOf shape ~ height, Eq height, Class.Floating a) => + Array shape a -> Vector height a -> Vector height a +solveVector m = + Basic.flattenColumn . solve m . Basic.singleColumn MatrixShape.ColumnMajor + + +instance + (vert ~ Small, horiz ~ Small, + Shape.C width, Shape.C height, height ~ width) => + Solve (MatrixShape.Full vert horiz height width) where + solve = Square.solve + +instance + (vert ~ Small, horiz ~ Small, + Shape.C width, Shape.C height, height ~ width) => + Inverse (MatrixShape.Full vert horiz height width) where + inverse = Square.inverse + + +instance (Shape.C shape) => Solve (MatrixShape.Hermitian shape) where + solve = Hermitian.solve + +instance (Shape.C shape) => Inverse (MatrixShape.Hermitian shape) where + inverse = Hermitian.inverse + + +instance + (MatrixShape.Content lo, MatrixShape.Content up, + MatrixShape.TriDiag diag, Shape.C shape) => + Solve (MatrixShape.Triangular lo diag up shape) where + solve = Triangular.solve + +instance + (MatrixShape.DiagUpLo lo up, + MatrixShape.TriDiag diag, Shape.C shape) => + Inverse (MatrixShape.Triangular lo diag up shape) where + inverse = Triangular.inverse + + +instance + (Unary.Natural sub, Unary.Natural super, vert ~ Small, horiz ~ Small, + Shape.C width, Shape.C height, width ~ height) => + Solve (MatrixShape.Banded sub super vert horiz height width) where + solve = Banded.solve + + +{- | +There is no solver for indefinite matrices. +Thus the instance will fail for indefinite but solvable systems. +-} +instance + (Unary.Natural offDiag, Shape.C size) => + Solve (MatrixShape.BandedHermitian offDiag size) where + solve = BandedHermitianPositiveDefinite.solve diff --git a/src/Numeric/LAPACK/Matrix/Extent.hs b/src/Numeric/LAPACK/Matrix/Extent.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Extent.hs @@ -0,0 +1,41 @@ +module Numeric.LAPACK.Matrix.Extent ( + Extent.C(switchTag), + Extent.Extent, + Map, + Small, Big, + Extent.height, + Extent.width, + Extent.squareSize, + Extent.dimensions, + Extent.transpose, + Extent.fuse, + + Extent.square, + + toGeneral, + fromSquare, + fromSquareLiberal, + generalizeTall, + generalizeWide, + ) where + +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Extent.Private (C, Small, Big, Map(Map)) + + +toGeneral :: + (C vert, C horiz) => Map vert horiz Big Big height width +toGeneral = Map Extent.toGeneral + +fromSquare :: (C vert, C horiz) => Map Small Small vert horiz size size +fromSquare = Map Extent.fromSquare + +fromSquareLiberal :: + (C vert, C horiz) => Map Small Small vert horiz height width +fromSquareLiberal = Map Extent.fromSquareLiberal + +generalizeTall :: (C vert, C horiz) => Map vert Small vert horiz height width +generalizeTall = Map Extent.generalizeTall + +generalizeWide :: (C vert, C horiz) => Map Small horiz vert horiz height width +generalizeWide = Map Extent.generalizeWide diff --git a/src/Numeric/LAPACK/Matrix/Extent/Kind.hs b/src/Numeric/LAPACK/Matrix/Extent/Kind.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Extent/Kind.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Extent.Kind where + + +data General height width = + General { + generalHeight :: height, + generalWidth :: width + } deriving (Eq, Show) + +data Tall height width = + Tall { + tallHeight :: height, + tallWidth :: width + } deriving (Eq, Show) + +data Wide height width = + Wide { + wideHeight :: height, + wideWidth :: width + } deriving (Eq, Show) + +data Square height width = + (height ~ width) => + Square { + squareSize :: height + } + +instance (Eq height, Eq width) => Eq (Square height width) where + Square a == Square b = a==b + +instance (Show height, Show width) => Show (Square height width) where + showsPrec p (Square s) = + showParen (p>10) (showString "Square " . showsPrec 11 s) diff --git a/src/Numeric/LAPACK/Matrix/Extent/Private.hs b/src/Numeric/LAPACK/Matrix/Extent/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Extent/Private.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Extent.Private where + +import qualified Numeric.LAPACK.Matrix.Extent.Kind as EK +import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) + +import Control.DeepSeq (NFData, rnf) + +import Data.Maybe.HT (toMaybe) +import Data.Tuple.HT (swap) +import Data.Eq.HT (equating) + + +data Extent vertical horizontal height width = + Extent { + extentDir :: (vertical,horizontal), + extentDim :: Dimensions vertical horizontal height width + } + +instance + (C vertical, C horizontal, NFData height, NFData width) => + NFData (Extent vertical horizontal height width) where + rnf = + getAccessor $ + switchTagPair + (Accessor $ \(Extent o (EK.Square s)) -> rnf (o,s)) + (Accessor $ \(Extent o (EK.Wide h w)) -> rnf (o,(h,w))) + (Accessor $ \(Extent o (EK.Tall h w)) -> rnf (o,(h,w))) + (Accessor $ \(Extent o (EK.General h w)) -> rnf (o,(h,w))) + + +data Big = Big deriving (Eq,Show) +data Small = Small deriving (Eq,Show) + +instance NFData Big where rnf Big = () +instance NFData Small where rnf Small = () + +type General = Extent Big Big +type Tall = Extent Big Small +type Wide = Extent Small Big +type Square sh = Extent Small Small sh sh + + +type family Dimensions vertical horizontal :: * -> * -> * + +type instance Dimensions Big Big = EK.General +type instance Dimensions Big Small = EK.Tall +type instance Dimensions Small Big = EK.Wide +type instance Dimensions Small Small = EK.Square + + +general :: height -> width -> General height width +general h w = Extent (Big,Big) $ EK.General h w + +tall :: height -> width -> Tall height width +tall h w = Extent (Big,Small) $ EK.Tall h w + +wide :: height -> width -> Wide height width +wide h w = Extent (Small,Big) $ EK.Wide h w + +square :: sh -> Square sh +square sh = Extent (Small,Small) $ EK.Square sh + + +newtype Map vertA horizA vertB horizB height width = + Map { + apply :: + Extent vertA horizA height width -> + Extent vertB horizB height width + } + + +class C tag where switchTag :: f Small -> f Big -> f tag +instance C Small where switchTag f _ = f +instance C Big where switchTag _ f = f + + +switchTagPair :: + (C vert, C horiz) => + f Small Small -> f Small Big -> f Big Small -> f Big Big -> f vert horiz +switchTagPair fSquare fWide fTall fGeneral = + getFlip $ + switchTag + (Flip $ switchTag fSquare fWide) + (Flip $ switchTag fTall fGeneral) + + +newtype CaseTallWide height width vert horiz = + CaseTallWide { + getCaseTallWide :: + Extent vert horiz height width -> + Either (Tall height width) (Wide height width) + } + +caseTallWide :: + (C vert, C horiz) => + (height -> width -> Bool) -> + Extent vert horiz height width -> + Either (Tall height width) (Wide height width) +caseTallWide ge = + getCaseTallWide $ + switchTagPair + (CaseTallWide $ \(Extent _ (EK.Square sh)) -> Left $ tall sh sh) + (CaseTallWide Right) + (CaseTallWide Left) + (CaseTallWide $ \(Extent _ (EK.General h w)) -> + if ge h w + then Left $ tall h w + else Right $ wide h w) + + +newtype GenSquare sh vert horiz = + GenSquare {getGenSquare :: sh -> Extent vert horiz sh sh} + +genSquare :: (C vert, C horiz) => sh -> Extent vert horiz sh sh +genSquare = + getGenSquare $ + switchTagPair + (GenSquare square) + (GenSquare (\sh -> wide sh sh)) + (GenSquare (\sh -> tall sh sh)) + (GenSquare (\sh -> general sh sh)) + +newtype GenTall height width vert horiz = + GenTall { + getGenTall :: + Extent vert Small height width -> Extent vert horiz height width + } + +generalizeTall :: (C vert, C horiz) => + Extent vert Small height width -> Extent vert horiz height width +generalizeTall = + getGenTall $ + switchTagPair + (GenTall id) (GenTall $ \(Extent _ (EK.Square s)) -> wide s s) + (GenTall id) (GenTall $ \(Extent _ (EK.Tall h w)) -> general h w) + +newtype GenWide height width vert horiz = + GenWide { + getGenWide :: + Extent Small horiz height width -> Extent vert horiz height width + } + +generalizeWide :: (C vert, C horiz) => + Extent Small horiz height width -> Extent vert horiz height width +generalizeWide = + getGenWide $ + switchTagPair + (GenWide id) + (GenWide id) + (GenWide $ \(Extent _ (EK.Square s)) -> tall s s) + (GenWide $ \(Extent _ (EK.Wide h w)) -> general h w) + + +newtype GenToTall height width vert horiz = + GenToTall { + getGenToTall :: + Extent vert horiz height width -> Extent Big horiz height width + } + +genToTall :: (C vert, C horiz) => + Extent vert horiz height width -> Extent Big horiz height width +genToTall = + getGenToTall $ + switchTagPair + (GenToTall $ \(Extent _ (EK.Square s)) -> tall s s) + (GenToTall $ \(Extent _ (EK.Wide h w)) -> general h w) + (GenToTall id) + (GenToTall id) + + +newtype GenToWide height width vert horiz = + GenToWide { + getGenToWide :: + Extent vert horiz height width -> Extent vert Big height width + } + +genToWide :: (C vert, C horiz) => + Extent vert horiz height width -> Extent vert Big height width +genToWide = + getGenToWide $ + switchTagPair + (GenToWide $ \(Extent _ (EK.Square s)) -> wide s s) + (GenToWide id) + (GenToWide $ \(Extent _ (EK.Tall h w)) -> general h w) + (GenToWide id) + + +squareSize :: Square sh -> sh +squareSize (Extent (Small,Small) (EK.Square sh)) = sh + + +newtype Accessor a height width vert horiz = + Accessor {getAccessor :: Extent vert horiz height width -> a} + +height :: (C vert, C horiz) => Extent vert horiz height width -> height +height = + getAccessor $ + switchTagPair + (Accessor (\(Extent _ (EK.Square s)) -> s)) + (Accessor (EK.wideHeight . extentDim)) + (Accessor (EK.tallHeight . extentDim)) + (Accessor (EK.generalHeight . extentDim)) + +width :: (C vert, C horiz) => Extent vert horiz height width -> width +width = + getAccessor $ + switchTagPair + (Accessor (\(Extent _ (EK.Square s)) -> s)) + (Accessor (EK.wideWidth . extentDim)) + (Accessor (EK.tallWidth . extentDim)) + (Accessor (EK.generalWidth . extentDim)) + + +dimensions :: + (C vert, C horiz) => Extent vert horiz height width -> (height,width) +dimensions x = (height x, width x) + + +toGeneral :: + (C vert, C horiz) => Extent vert horiz height width -> General height width +toGeneral x = general (height x) (width x) + +fromSquare :: (C vert, C horiz) => Square size -> Extent vert horiz size size +fromSquare = genSquare . squareSize + +fromSquareLiberal :: (C vert, C horiz) => + Extent Small Small height width -> Extent vert horiz height width +fromSquareLiberal x@(Extent _ (EK.Square _)) = genSquare $ height x + +squareFromGeneral :: + (C vert, C horiz, Eq size) => + Extent vert horiz size size -> Square size +squareFromGeneral x = + let size = height x + in if size == width x + then square size + else error "Extent.squareFromGeneral: no square shape" + + +newtype Transpose height width vert horiz = + Transpose { + getTranspose :: + Extent vert horiz height width -> + Extent horiz vert width height + } + +transpose :: + (C vert, C horiz) => + Extent vert horiz height width -> + Extent horiz vert width height +transpose = + getTranspose $ + switchTagPair + (Transpose $ \(Extent o (EK.Square s)) -> Extent o (EK.Square s)) + (Transpose $ \(Extent o (EK.Wide h w)) -> Extent (swap o) (EK.Tall w h)) + (Transpose $ \(Extent o (EK.Tall h w)) -> Extent (swap o) (EK.Wide w h)) + (Transpose $ \(Extent o (EK.General h w)) -> Extent o (EK.General w h)) + + +newtype Equal height width vert horiz = + Equal { + getEqual :: + Extent vert horiz height width -> + Extent vert horiz height width -> Bool + } + +instance + (C vert, C horiz, Eq height, Eq width) => + Eq (Extent vert horiz height width) where + (==) = + getEqual $ + switchTagPair + (Equal $ equating extentDim) + (Equal $ equating extentDim) + (Equal $ equating extentDim) + (Equal $ equating extentDim) + + +instance + (C vert, C horiz, Show height, Show width) => + Show (Extent vert horiz height width) where + showsPrec prec = + getAccessor $ + switchTagPair + (Accessor $ showsPrecSquare prec) + (Accessor $ showsPrecAny "Extent.wide" prec) + (Accessor $ showsPrecAny "Extent.tall" prec) + (Accessor $ showsPrecAny "Extent.general" prec) + +showsPrecSquare :: + (Show height) => + Int -> Extent Small Small height width -> ShowS +showsPrecSquare p x = + showParen (p>10) $ + showString "Extent.square " . showsPrec 11 (height x) + +showsPrecAny :: + (C vert, C horiz, Show height, Show width) => + String -> Int -> Extent vert horiz height width -> ShowS +showsPrecAny name p x = + showParen (p>10) $ + showString name . + showString " " . showsPrec 11 (height x) . + showString " " . showsPrec 11 (width x) + + +newtype Widen heightA widthA heightB widthB vert = + Widen { + getWiden :: + Extent vert Big heightA widthA -> + Extent vert Big heightB widthB + } + +widen :: + (C vert) => + widthB -> Extent vert Big height widthA -> Extent vert Big height widthB +widen w = + getWiden $ + switchTag + (Widen (\(Extent o x) -> Extent o (x{EK.wideWidth = w}))) + (Widen (\(Extent o x) -> Extent o (x{EK.generalWidth = w}))) + +reduceWideHeight :: + (C vert) => + heightB -> Extent vert Big heightA width -> Extent vert Big heightB width +reduceWideHeight h = + getWiden $ + switchTag + (Widen (\(Extent o x) -> Extent o (x{EK.wideHeight = h}))) + (Widen (\(Extent o x) -> Extent o (x{EK.generalHeight = h}))) + + +newtype Adapt height width vert horiz = + Adapt { + getAdapt :: + Extent vert horiz height width -> + Extent vert horiz height width + } + +reduceConsistent :: + (C vert, C horiz) => + height -> width -> + Extent vert horiz height width -> Extent vert horiz height width +reduceConsistent h w = + getAdapt $ + switchTagPair + (Adapt $ \(Extent o (EK.Square _)) -> Extent o (EK.Square h)) + (Adapt $ \(Extent o (EK.Wide _ _)) -> Extent o (EK.Wide h w)) + (Adapt $ \(Extent o (EK.Tall _ _)) -> Extent o (EK.Tall h w)) + (Adapt $ \(Extent o (EK.General _ _)) -> Extent o (EK.General h w)) + + +newtype Fuse height fuse width vert horiz = + Fuse { + getFuse :: + Extent vert horiz height fuse -> + Extent vert horiz fuse width -> + Maybe (Extent vert horiz height width) + } + +fuse :: + (C vert, C horiz, Eq fuse) => + Extent vert horiz height fuse -> + Extent vert horiz fuse width -> + Maybe (Extent vert horiz height width) +fuse = + getFuse $ + switchTagPair + (Fuse $ + \(Extent o (EK.Square s0)) (Extent _ (EK.Square s1)) -> + toMaybe (s0==s1) $ Extent o (EK.Square s0)) + (Fuse $ + \(Extent o (EK.Wide h f0)) (Extent _ (EK.Wide f1 w)) -> + toMaybe (f0==f1) $ Extent o (EK.Wide h w)) + (Fuse $ + \(Extent o (EK.Tall h f0)) (Extent _ (EK.Tall f1 w)) -> + toMaybe (f0==f1) $ Extent o (EK.Tall h w)) + (Fuse $ + \(Extent o (EK.General h f0)) (Extent _ (EK.General f1 w)) -> + toMaybe (f0==f1) $ Extent o (EK.General h w)) + + +type family Multiply a b +type instance Multiply Small b = b +type instance Multiply Big b = Big + + +data TagFact a = C a => TagFact + +newtype MultiplyTagLaw b a = + MultiplyTagLaw { + getMultiplyTagLaw :: TagFact a -> TagFact b -> TagFact (Multiply a b) + } + +multiplyTagLaw :: TagFact a -> TagFact b -> TagFact (Multiply a b) +multiplyTagLaw a@TagFact = + ($a) $ getMultiplyTagLaw $ + switchTag + (MultiplyTagLaw $ flip const) + (MultiplyTagLaw const) + +heightFact :: (C vert) => Extent vert horiz height width -> TagFact vert +heightFact _ = TagFact + +widthFact :: (C horiz) => Extent vert horiz height width -> TagFact horiz +widthFact _ = TagFact + + +newtype Unify height fuse width heightC widthC vertB horizB vertA horizA = + Unify { + getUnify :: + Extent vertA horizA height fuse -> + Extent vertB horizB fuse width -> + Extent (Multiply vertA vertB) (Multiply horizA horizB) heightC widthC + } + +unifyLeft :: + (C vertA, C horizA, C vertB, C horizB) => + Extent vertA horizA height fuse -> + Extent vertB horizB fuse width -> + Extent (Multiply vertA vertB) (Multiply horizA horizB) height fuse +unifyLeft = + getUnify $ + switchTagPair + (Unify $ const . fromSquareLiberal) + (Unify $ const . generalizeWide) + (Unify $ const . generalizeTall) + (Unify $ const . toGeneral) + +unifyRight :: + (C vertA, C horizA, C vertB, C horizB) => + Extent vertA horizA height fuse -> + Extent vertB horizB fuse width -> + Extent (Multiply vertA vertB) (Multiply horizA horizB) fuse width +unifyRight = + getUnify $ + switchTagPair + (Unify $ const id) + (Unify $ const genToWide) + (Unify $ const genToTall) + (Unify $ const toGeneral) + + +{- +Square Square -> Square +Square Wide -> Wide +Square Tall -> Tall +Square General -> General +Wide Square -> Wide +Wide Wide -> Wide +Wide Tall -> General +Wide General -> General +Tall Square -> Tall +Tall Wide -> General +Tall Tall -> Tall +Tall General -> General +General Square -> General +General Wide -> General +General Tall -> General +General General -> General + +Small Small Small Small -> Small Small +Small Small Small Big -> Small Big +Small Small Big Small -> Big Small +Small Small Big Big -> Big Big +Small Big Small Small -> Small Big +Small Big Small Big -> Small Big +Small Big Big Small -> Big Big +Small Big Big Big -> Big Big +Big Small Small Small -> Big Small +Big Small Small Big -> Big Big +Big Small Big Small -> Big Small +Big Small Big Big -> Big Big +Big Big Small Small -> Big Big +Big Big Small Big -> Big Big +Big Big Big Small -> Big Big +Big Big Big Big -> Big Big +-} diff --git a/src/Numeric/LAPACK/Matrix/Hermitian.hs b/src/Numeric/LAPACK/Matrix/Hermitian.hs --- a/src/Numeric/LAPACK/Matrix/Hermitian.hs +++ b/src/Numeric/LAPACK/Matrix/Hermitian.hs @@ -1,540 +1,34 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Matrix.Hermitian ( - Hermitian, - fromList, - autoFromList, - identity, - diagonal, - getDiagonal, - - multiplyVector, - square, - multiplySquareLeft, - multiplyGeneralLeft, - multiplySquareRight, - multiplyGeneralRight, - outer, - sumRank1, - sumRank2, + module Numeric.LAPACK.Matrix.Hermitian.Basic, + module Numeric.LAPACK.Matrix.Hermitian.Linear, - toSquare, - covariance, - addTransposed, + eigenvalues, + eigensystem, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Triangular.Private - (forPointers, pack, unpack, unpackToTemp, - diagonalPointers, rowMajorPointers, columnMajorPointers) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), flipOrder, uploFromOrder) -import Numeric.LAPACK.Matrix.Square (Square) -import Numeric.LAPACK.Matrix.Private (General, ZeroInt, zeroInt) +import qualified Numeric.LAPACK.Matrix.Hermitian.Eigen as Eigen +import Numeric.LAPACK.Matrix.Hermitian.Basic +import Numeric.LAPACK.Matrix.Hermitian.Linear + +import Numeric.LAPACK.Matrix.Private (Square) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Private - (RealOf, fill, zero, one, lacgv, fromReal, realPart, copyToTemp) +import Numeric.LAPACK.Scalar (RealOf) -import qualified Numeric.LAPACK.FFI.Complex as LapackComplex -import qualified Numeric.BLAS.FFI.Generic as BlasGen -import qualified Numeric.BLAS.FFI.Complex as BlasComplex -import qualified Numeric.BLAS.FFI.Real as BlasReal -import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class -import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) -import Foreign.C.Types (CInt, CChar) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable, poke, peek) -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Monad (when) - -import qualified Data.NonEmpty as NonEmpty -import Data.Foldable (forM_) -import Data.Complex (Complex) - - -type Hermitian sh = Array (MatrixShape.Hermitian sh) - - -fromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Hermitian sh a -fromList order sh = - Array.fromList (MatrixShape.Hermitian order sh) - -autoFromList :: (Storable a) => Order -> [a] -> Hermitian ZeroInt a -autoFromList order xs = - fromList order - (zeroInt $ MatrixShape.triangleExtent "Hermitian.autoFromList" $ - length xs) - xs - - -identity :: (Shape.C sh, Class.Floating a) => Order -> sh -> Hermitian sh a -identity order sh = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ - \triSize aPtr -> do - fill zero triSize aPtr - mapM_ (flip poke one . snd) $ - diagonalPointers order (Shape.size sh) aPtr aPtr - -diagonal :: - (Shape.C sh, Class.Floating a) => - Order -> Vector sh (RealOf a) -> Hermitian sh a -diagonal order = - runDiagonal $ - Class.switchFloating - (Diagonal $ diagonalAux order) (Diagonal $ diagonalAux order) - (Diagonal $ diagonalAux order) (Diagonal $ diagonalAux order) - -newtype Diagonal sh a = - Diagonal {runDiagonal :: Vector sh (RealOf a) -> Hermitian sh a} - -diagonalAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - Order -> Vector sh ar -> Hermitian sh a -diagonalAux order (Array sh x) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ - \triSize aPtr -> do - fill zero triSize aPtr - withForeignPtr x $ \xPtr -> - forM_ (diagonalPointers order (Shape.size sh) xPtr aPtr) $ - \(srcPtr,dstPtr) -> poke dstPtr . fromReal =<< peek srcPtr - - -getDiagonal :: +eigenvalues :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Vector sh (RealOf a) -getDiagonal = - runGetDiagonal $ - Class.switchFloating - (GetDiagonal $ getDiagonalAux) (GetDiagonal $ getDiagonalAux) - (GetDiagonal $ getDiagonalAux) (GetDiagonal $ getDiagonalAux) - -newtype GetDiagonal sh a = - GetDiagonal {runGetDiagonal :: Hermitian sh a -> Vector sh (RealOf a)} - -getDiagonalAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - Hermitian sh a -> Vector sh ar -getDiagonalAux (Array (MatrixShape.Hermitian order sh) a) = - Array.unsafeCreateWithSize sh $ \n xPtr -> - withForeignPtr a $ \aPtr -> - forM_ (diagonalPointers order n xPtr aPtr) $ - \(dstPtr,srcPtr) -> poke dstPtr . realPart =<< peek srcPtr - - -multiplyVector :: - (Shape.C sh, Eq sh, Class.Floating a) => - Hermitian sh a -> Vector sh a -> Vector sh a -multiplyVector (Array (MatrixShape.Hermitian order shA) a) (Array shX x) = - Array.unsafeCreateWithSize shX $ \n yPtr -> do - Call.assert "Hermitian.multiplyVector: width shapes mismatch" (shA == shX) - evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - alphaPtr <- Call.number one - aPtr <- ContT $ withForeignPtr a - xPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 - betaPtr <- Call.number zero - incyPtr <- Call.cint 1 - liftIO $ - BlasGen.hpmv - uploPtr nPtr alphaPtr aPtr xPtr incxPtr betaPtr yPtr incyPtr - - -square :: - (Shape.C sh, Eq sh, Class.Floating a) => - Hermitian sh a -> Hermitian sh a -square - (Array shape@(MatrixShape.Hermitian order sh) a) = - Array.unsafeCreate shape $ \cpPtr -> do - let n = Shape.size sh - evalContT $ do - sidePtr <- Call.char 'L' - uploPtr <- Call.char 'U' - nPtr <- Call.cint n - let ldPtr = nPtr - bPtr <- unpackToTemp (unpackFull order) n a - cPtr <- Call.allocaArray (n*n) - alphaPtr <- Call.number one - betaPtr <- Call.number zero - liftIO $ do - BlasGen.hemm sidePtr uploPtr - nPtr nPtr alphaPtr bPtr ldPtr - bPtr ldPtr betaPtr cPtr ldPtr - pack order n cPtr cpPtr - - -multiplySquareLeft :: - (Shape.C sh, Eq sh, Class.Floating a) => - Square sh a -> Hermitian sh a -> Square sh a -multiplySquareLeft - (Array shapeB@(MatrixShape.Square orderB shB) b) - (Array (MatrixShape.Hermitian orderA shA) a) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Hermitian.multiplySquareLeft: shapes mismatch" (shA == shB) - let n = Shape.size shB - multiplyAux True orderA n a (flipOrder orderB) n b cPtr - -multiplyGeneralLeft :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Hermitian width a -> General height width a -multiplyGeneralLeft - (Array shapeB@(MatrixShape.General orderB height width) b) - (Array (MatrixShape.Hermitian orderA shA) a) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Hermitian.multiplyGeneralLeft: shapes mismatch" (shA == width) - multiplyAux True - orderA (Shape.size width) a (flipOrder orderB) (Shape.size height) b cPtr - -multiplySquareRight :: - (Shape.C sh, Eq sh, Class.Floating a) => - Hermitian sh a -> Square sh a -> Square sh a -multiplySquareRight - (Array (MatrixShape.Hermitian orderA shA) a) - (Array shapeB@(MatrixShape.Square orderB shB) b) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Hermitian.multiplySquareRight: shapes mismatch" (shA == shB) - let n = Shape.size shB - multiplyAux False orderA n a orderB n b cPtr - -multiplyGeneralRight :: - (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Hermitian height a -> General height width a -> General height width a -multiplyGeneralRight - (Array (MatrixShape.Hermitian orderA shA) a) - (Array shapeB@(MatrixShape.General orderB height width) b) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Hermitian.multiplyGeneralRight: shapes mismatch" (shA == height) - multiplyAux False - orderA (Shape.size height) a orderB (Shape.size width) b cPtr - -multiplyAux :: - Class.Floating a => - Bool -> - Order -> Int -> ForeignPtr a -> - Order -> Int -> ForeignPtr a -> Ptr a -> IO () -multiplyAux extraConjugate orderA m0 a orderB n0 b cPtr = do - let size = m0*m0 - evalContT $ do - let (side,(m,n)) = - case orderB of - ColumnMajor -> ('L',(m0,n0)) - RowMajor -> ('R',(n0,m0)) - sidePtr <- Call.char side - uploPtr <- Call.char $ uploFromOrder orderA - mPtr <- Call.cint m - nPtr <- Call.cint n - alphaPtr <- Call.number one - aPtr <- unpackToTemp (unpack orderA) m0 a - ldaPtr <- Call.cint m0 - incaPtr <- Call.cint 1 - sizePtr <- Call.cint size - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint m - betaPtr <- Call.number zero - ldcPtr <- Call.cint m - liftIO $ do - when ((orderA/=orderB) /= extraConjugate) $ - lacgv sizePtr aPtr incaPtr - BlasGen.hemm sidePtr uploPtr - mPtr nPtr alphaPtr aPtr ldaPtr - bPtr ldbPtr betaPtr cPtr ldcPtr - - -outer :: (Shape.C sh, Class.Floating a) => Vector sh a -> Hermitian sh a -outer = - getMap $ - Class.switchFloating - (Map outerAux) (Map outerAux) - (Map outerAux) (Map outerAux) - -outerAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Vector sh a -> Hermitian sh a -outerAux (Array sh x) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian ColumnMajor sh) $ - \triSize aPtr -> do - let n = Shape.size sh - evalContT $ do - uploPtr <- Call.char $ uploFromOrder ColumnMajor - nPtr <- Call.cint n - alphaPtr <- Call.real one - xPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 - liftIO $ fill zero triSize aPtr - liftIO $ hpr uploPtr nPtr alphaPtr xPtr incxPtr aPtr - - -sumRank1 :: - (Shape.C sh, Eq sh, Class.Floating a) => - NonEmpty.T [] (RealOf a, Vector sh a) -> Hermitian sh a -sumRank1 = - getSumRank1 $ - Class.switchFloating - (SumRank1 sumRank1Aux) (SumRank1 sumRank1Aux) - (SumRank1 sumRank1Aux) (SumRank1 sumRank1Aux) - -type SumRank1_ sh a = NonEmpty.T [] (RealOf a, Vector sh a) -> Hermitian sh a - -newtype SumRank1 sh a = SumRank1 {getSumRank1 :: SumRank1_ sh a} - -sumRank1Aux :: - (Shape.C sh, Eq sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - SumRank1_ sh a -sumRank1Aux xs@(NonEmpty.Cons (_, Array sh _) _) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian ColumnMajor sh) $ - \triSize aPtr -> do - let n = Shape.size sh - evalContT $ do - uploPtr <- Call.char $ uploFromOrder ColumnMajor - nPtr <- Call.cint n - alphaPtr <- Call.alloca - incxPtr <- Call.cint 1 - liftIO $ do - fill zero triSize aPtr - forM_ xs $ \(alpha, Array shX x) -> - withForeignPtr x $ \xPtr -> do - Call.assert - "Hermitian.sumRank1: non-matching vector size" (sh==shX) - poke alphaPtr alpha - hpr uploPtr nPtr alphaPtr xPtr incxPtr aPtr - - -type HPR_ a = - Ptr CChar -> Ptr CInt -> - Ptr (RealOf a) -> Ptr a -> Ptr CInt -> Ptr a -> IO () - -newtype HPR a = HPR {getHPR :: HPR_ a} - -hpr :: Class.Floating a => HPR_ a -hpr = - getHPR $ - Class.switchFloating - (HPR BlasReal.spr) (HPR BlasReal.spr) - (HPR BlasComplex.hpr) (HPR BlasComplex.hpr) - - -sumRank2 :: - (Shape.C sh, Eq sh, Class.Floating a) => - NonEmpty.T [] (a, (Vector sh a, Vector sh a)) -> Hermitian sh a -sumRank2 xys@(NonEmpty.Cons (_, (Array sh _, _)) _) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian ColumnMajor sh) $ - \triSize aPtr -> do - let n = Shape.size sh - evalContT $ do - uploPtr <- Call.char $ uploFromOrder ColumnMajor - nPtr <- Call.cint n - alphaPtr <- Call.alloca - incPtr <- Call.cint 1 - liftIO $ do - fill zero triSize aPtr - forM_ xys $ \(alpha, (Array shX x, Array shY y)) -> - withForeignPtr x $ \xPtr -> - withForeignPtr y $ \yPtr -> do - Call.assert - "Hermitian.sumRank2: non-matching x vector size" (sh==shX) - Call.assert - "Hermitian.sumRank2: non-matching y vector size" (sh==shY) - poke alphaPtr alpha - BlasGen.hpr2 uploPtr nPtr alphaPtr xPtr incPtr yPtr incPtr aPtr - - -{- -It is not strictly necessary to keep the 'order'. -It would be neither more complicated nor less efficient -to change the order via the conversion. --} -toSquare, _toSquare :: - (Shape.C sh, Class.Floating a) => Hermitian sh a -> Square sh a -_toSquare (Array (MatrixShape.Hermitian order sh) a) = - Array.unsafeCreate (MatrixShape.Square order sh) $ \bPtr -> - evalContT $ do - let n = Shape.size sh - aPtr <- ContT $ withForeignPtr a - conjPtr <- conjugateToTemp (MatrixShape.triangleSize n) a - liftIO $ do - unpack (flipOrder order) n conjPtr bPtr -- wrong - unpack order n aPtr bPtr - -toSquare (Array (MatrixShape.Hermitian order sh) a) = - Array.unsafeCreate (MatrixShape.Square order sh) $ \bPtr -> - withForeignPtr a $ \aPtr -> - unpackFull order (Shape.size sh) aPtr bPtr - - -{- | -Make a temporary copy only for complex matrices. --} -conjugateToTemp :: - (Class.Floating a) => Int -> ForeignPtr a -> ContT r IO (Ptr a) -conjugateToTemp n = - runCopyToTemp $ - Class.switchFloating - (CopyToTemp $ ContT . withForeignPtr) - (CopyToTemp $ ContT . withForeignPtr) - (CopyToTemp $ complexConjugateToTemp n) - (CopyToTemp $ complexConjugateToTemp n) - -newtype CopyToTemp r a = - CopyToTemp {runCopyToTemp :: ForeignPtr a -> ContT r IO (Ptr a)} - -complexConjugateToTemp :: - Class.Real a => - Int -> ForeignPtr (Complex a) -> ContT r IO (Ptr (Complex a)) -complexConjugateToTemp n x = do - nPtr <- Call.cint n - xPtr <- copyToTemp n x - incxPtr <- Call.cint 1 - liftIO $ LapackComplex.lacgv nPtr xPtr incxPtr - return xPtr - - -{- | -A^H * A --} -covariance :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Hermitian width a -covariance = - getMap $ - Class.switchFloating - (Map covarianceAux) (Map covarianceAux) - (Map covarianceAux) (Map covarianceAux) - -newtype Map f g a = Map {getMap :: f a -> g a} - -covarianceAux :: - (Shape.C height, Shape.C width, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - General height width a -> Hermitian width a -covarianceAux (Array (MatrixShape.General order height width) a) = - Array.unsafeCreate (MatrixShape.Hermitian order width) $ \bPtr -> do - let n = Shape.size width - let k = Shape.size height - evalContT $ do - nPtr <- Call.cint n - kPtr <- Call.cint k - alphaPtr <- Call.number one - aPtr <- ContT $ withForeignPtr a - betaPtr <- Call.number zero - cPtr <- Call.allocaArray (n*n) - ldcPtr <- Call.cint n - - case order of - ColumnMajor -> do - uploPtr <- Call.char 'U' - transPtr <- Call.char 'C' - ldaPtr <- Call.cint k - liftIO $ do - herk uploPtr transPtr - nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr - pack ColumnMajor n cPtr bPtr - - RowMajor -> do - uploPtr <- Call.char 'L' - transPtr <- Call.char 'N' - ldaPtr <- Call.cint n - liftIO $ do - herk uploPtr transPtr - nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr - pack RowMajor n cPtr bPtr - - -type HERK_ a = - Ptr CChar -> Ptr CChar -> Ptr CInt -> Ptr CInt -> Ptr (RealOf a) -> Ptr a -> - Ptr CInt -> Ptr (RealOf a) -> Ptr a -> Ptr CInt -> IO () - -newtype HERK a = HERK {getHERK :: HERK_ a} - -herk :: Class.Floating a => HERK_ a -herk = - getHERK $ - Class.switchFloating - (HERK BlasReal.syrk) - (HERK BlasReal.syrk) - (HERK BlasComplex.herk) - (HERK BlasComplex.herk) - +eigenvalues = Eigen.values {- | -A^H + A +For symmetric eigenvalue problems, @eigensystem@ and @schur@ coincide. -} -addTransposed, _addTransposed :: - (Shape.C sh, Class.Floating a) => Square sh a -> Hermitian sh a -_addTransposed (Array (MatrixShape.Square order sh) a) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ \bSize bPtr -> do - let n = Shape.size sh - evalContT $ do - alphaPtr <- Call.number one - incxPtr <- Call.cint 1 - aPtr <- ContT $ withForeignPtr a - sizePtr <- Call.cint bSize - conjPtr <- Call.allocaArray bSize - liftIO $ do - pack order n aPtr bPtr - pack (flipOrder order) n aPtr conjPtr -- wrong - lacgv sizePtr conjPtr incxPtr - BlasGen.axpy sizePtr alphaPtr conjPtr incxPtr bPtr incxPtr - -addTransposed (Array (MatrixShape.Square order sh) a) = - Array.unsafeCreate (MatrixShape.Hermitian order sh) $ \bPtr -> do - let n = Shape.size sh - evalContT $ do - alphaPtr <- Call.number one - incxPtr <- Call.cint 1 - incnPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - liftIO $ case order of - RowMajor -> - forPointers (rowMajorPointers n aPtr bPtr) $ - \nPtr (srcPtr,dstPtr) -> do - BlasGen.copy nPtr srcPtr incnPtr dstPtr incxPtr - lacgv nPtr dstPtr incxPtr - BlasGen.axpy nPtr alphaPtr srcPtr incxPtr dstPtr incxPtr - ColumnMajor -> - forPointers (columnMajorPointers n aPtr bPtr) $ - \nPtr ((srcRowPtr,srcColumnPtr),dstPtr) -> do - BlasGen.copy nPtr srcRowPtr incnPtr dstPtr incxPtr - lacgv nPtr dstPtr incxPtr - BlasGen.axpy nPtr alphaPtr srcColumnPtr incxPtr dstPtr incxPtr - - -unpackFull :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () -unpackFull order n packedPtr fullPtr = evalContT $ do - incxPtr <- Call.cint 1 - incyPtr <- Call.cint n - liftIO $ case order of - RowMajor -> - forPointers (rowMajorPointers n fullPtr packedPtr) $ - \nPtr (dstPtr,srcPtr) -> do - BlasGen.copy nPtr srcPtr incxPtr dstPtr incyPtr - lacgv nPtr dstPtr incyPtr - BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr - ColumnMajor -> - forPointers (columnMajorPointers n fullPtr packedPtr) $ - \nPtr ((dstRowPtr,dstColumnPtr),srcPtr) -> do - BlasGen.copy nPtr srcPtr incxPtr dstRowPtr incyPtr - lacgv nPtr dstRowPtr incyPtr - BlasGen.copy nPtr srcPtr incxPtr dstColumnPtr incxPtr - -_pack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () -_pack order n fullPtr packedPtr = - evalContT $ do - incxPtr <- Call.cint 1 - liftIO $ - case order of - ColumnMajor -> - forPointers (columnMajorPointers n fullPtr packedPtr) $ - \nPtr ((_,srcPtr),dstPtr) -> - BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr - RowMajor -> - forPointers (rowMajorPointers n fullPtr packedPtr) $ - \nPtr (srcPtr,dstPtr) -> - BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr +eigensystem :: + (Shape.C sh, Class.Floating a) => + Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) +eigensystem = Eigen.decompose diff --git a/src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs b/src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Hermitian.Basic ( + Hermitian, + Transposition(..), + fromList, + autoFromList, + identity, + diagonal, + takeDiagonal, + + multiplyVector, + square, + multiplyFull, + outer, + sumRank1, sumRank1NonEmpty, + sumRank2, sumRank2NonEmpty, + + toSquare, + covariance, + addAdjoint, + ) where + +import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Hermitian.Private (Diagonal(..), TakeDiagonal(..)) +import Numeric.LAPACK.Matrix.Triangular.Private + (forPointers, pack, unpack, unpackToTemp, + diagonalPointers, diagonalPointerPairs, + rowMajorPointers, columnMajorPointers) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), flipOrder, sideSwapFromOrder, + uploFromOrder) +import Numeric.LAPACK.Matrix.Private + (Full, General, argGeneral, Square, argSquare, ZeroInt, zeroInt, + Transposition(NonTransposed, Transposed), transposeOrder, + Conjugation(Conjugated)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, zero, one, fromReal, realPart) +import Numeric.LAPACK.Private + (fill, lacgv, copyConjugate, conjugateToTemp, condConjugateToTemp) + +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.BLAS.FFI.Complex as BlasComplex +import qualified Numeric.BLAS.FFI.Real as BlasReal +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable, poke, peek) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (when) + +import qualified Data.NonEmpty as NonEmpty +import Data.Foldable (forM_) + + +type Hermitian sh = Array (MatrixShape.Hermitian sh) + + +fromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Hermitian sh a +fromList order sh = + Array.fromList (MatrixShape.Hermitian order sh) + +autoFromList :: (Storable a) => Order -> [a] -> Hermitian ZeroInt a +autoFromList order xs = + fromList order + (zeroInt $ MatrixShape.triangleExtent "Hermitian.autoFromList" $ + length xs) + xs + + +identity :: (Shape.C sh, Class.Floating a) => Order -> sh -> Hermitian sh a +identity order sh = + Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + \triSize aPtr -> do + fill zero triSize aPtr + mapM_ (flip poke one) $ diagonalPointers order (Shape.size sh) aPtr + +diagonal :: + (Shape.C sh, Class.Floating a) => + Order -> Vector sh (RealOf a) -> Hermitian sh a +diagonal order = + runDiagonal $ + Class.switchFloating + (Diagonal $ diagonalAux order) (Diagonal $ diagonalAux order) + (Diagonal $ diagonalAux order) (Diagonal $ diagonalAux order) + +diagonalAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + Order -> Vector sh ar -> Hermitian sh a +diagonalAux order (Array sh x) = + Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + \triSize aPtr -> do + fill zero triSize aPtr + withForeignPtr x $ \xPtr -> + forM_ (diagonalPointerPairs order (Shape.size sh) xPtr aPtr) $ + \(srcPtr,dstPtr) -> poke dstPtr . fromReal =<< peek srcPtr + + +takeDiagonal :: + (Shape.C sh, Class.Floating a) => + Hermitian sh a -> Vector sh (RealOf a) +takeDiagonal = + runTakeDiagonal $ + Class.switchFloating + (TakeDiagonal takeDiagonalAux) (TakeDiagonal takeDiagonalAux) + (TakeDiagonal takeDiagonalAux) (TakeDiagonal takeDiagonalAux) + +takeDiagonalAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + Hermitian sh a -> Vector sh ar +takeDiagonalAux (Array (MatrixShape.Hermitian order sh) a) = + Array.unsafeCreateWithSize sh $ \n xPtr -> + withForeignPtr a $ \aPtr -> + forM_ (diagonalPointerPairs order n xPtr aPtr) $ + \(dstPtr,srcPtr) -> poke dstPtr . realPart =<< peek srcPtr + + +multiplyVector :: + (Shape.C sh, Eq sh, Class.Floating a) => + Transposition -> Hermitian sh a -> Vector sh a -> Vector sh a +multiplyVector transposed + (Array (MatrixShape.Hermitian order shA) a) (Array shX x) = + Array.unsafeCreateWithSize shX $ \n yPtr -> do + Call.assert "Hermitian.multiplyVector: width shapes mismatch" (shA == shX) + evalContT $ do + let conj = transposeOrder transposed order == RowMajor + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + xPtr <- condConjugateToTemp conj n x + incxPtr <- Call.cint 1 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + liftIO $ do + BlasGen.hpmv + uploPtr nPtr alphaPtr aPtr xPtr incxPtr betaPtr yPtr incyPtr + when conj $ lacgv nPtr yPtr incyPtr + + +square :: + (Shape.C sh, Eq sh, Class.Floating a) => + Hermitian sh a -> Hermitian sh a +square (Array shape@(MatrixShape.Hermitian order sh) a) = + Array.unsafeCreate shape $ + Symmetric.square Conjugated order (Shape.size sh) a + + +multiplyFull :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, + Class.Floating a) => + Transposition -> Hermitian height a -> + Full vert horiz height width a -> + Full vert horiz height width a +multiplyFull transposed + (Array (MatrixShape.Hermitian orderA shA) a) + (Array shapeB@(MatrixShape.Full orderB extentB) b) = + Array.unsafeCreate shapeB $ \cPtr -> do + let (height,width) = Extent.dimensions extentB + Call.assert "Hermitian.multiplyFull: shapes mismatch" (shA == height) + let m0 = Shape.size height + let n0 = Shape.size width + let size = m0*m0 + evalContT $ do + let (side,(m,n)) = sideSwapFromOrder orderB (m0,n0) + sidePtr <- Call.char side + uploPtr <- Call.char $ uploFromOrder orderA + mPtr <- Call.cint m + nPtr <- Call.cint n + alphaPtr <- Call.number one + aPtr <- unpackToTemp (unpack orderA) m0 a + ldaPtr <- Call.leadingDim m0 + incaPtr <- Call.cint 1 + sizePtr <- Call.cint size + bPtr <- ContT $ withForeignPtr b + ldbPtr <- Call.leadingDim m + betaPtr <- Call.number zero + ldcPtr <- Call.leadingDim m + liftIO $ do + when (transposeOrder transposed orderA /= orderB) $ + lacgv sizePtr aPtr incaPtr + BlasGen.hemm sidePtr uploPtr + mPtr nPtr alphaPtr aPtr ldaPtr + bPtr ldbPtr betaPtr cPtr ldcPtr + + + +withConjBuffer :: + (Shape.C sh, Class.Floating a) => + Order -> sh -> Int -> Ptr a -> + (Ptr CChar -> Ptr CInt -> Ptr CInt -> IO ()) -> ContT r IO () +withConjBuffer order sh triSize aPtr act = do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint $ Shape.size sh + incxPtr <- Call.cint 1 + sizePtr <- Call.cint triSize + liftIO $ do + fill zero triSize aPtr + act uploPtr nPtr incxPtr + case order of + RowMajor -> lacgv sizePtr aPtr incxPtr + ColumnMajor -> return () + +outer :: + (Shape.C sh, Class.Floating a) => Order -> Vector sh a -> Hermitian sh a +outer order = + getMap $ + Class.switchFloating + (Map $ outerAux order) (Map $ outerAux order) + (Map $ outerAux order) (Map $ outerAux order) + +outerAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Order -> Vector sh a -> Hermitian sh a +outerAux order (Array sh x) = + Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + \triSize aPtr -> + evalContT $ do + alphaPtr <- Call.real one + xPtr <- ContT $ withForeignPtr x + withConjBuffer order sh triSize aPtr $ \uploPtr nPtr incxPtr -> + hpr uploPtr nPtr alphaPtr xPtr incxPtr aPtr + + +sumRank1 :: + (Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(RealOf a, Vector sh a)] -> Hermitian sh a +sumRank1 = + getSumRank1 $ + Class.switchFloating + (SumRank1 sumRank1Aux) (SumRank1 sumRank1Aux) + (SumRank1 sumRank1Aux) (SumRank1 sumRank1Aux) + +type SumRank1_ sh ar a = Order -> sh -> [(ar, Vector sh a)] -> Hermitian sh a + +newtype SumRank1 sh a = SumRank1 {getSumRank1 :: SumRank1_ sh (RealOf a) a} + +sumRank1Aux :: + (Shape.C sh, Eq sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + SumRank1_ sh ar a +sumRank1Aux order sh xs = + Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + \triSize aPtr -> + evalContT $ do + alphaPtr <- Call.alloca + withConjBuffer order sh triSize aPtr $ \uploPtr nPtr incxPtr -> + forM_ xs $ \(alpha, Array shX x) -> + withForeignPtr x $ \xPtr -> do + Call.assert + "Hermitian.sumRank1: non-matching vector size" (sh==shX) + poke alphaPtr alpha + hpr uploPtr nPtr alphaPtr xPtr incxPtr aPtr + + +sumRank1NonEmpty :: + (Shape.C sh, Eq sh, Class.Floating a) => + Order -> NonEmpty.T [] (RealOf a, Vector sh a) -> Hermitian sh a +sumRank1NonEmpty order (NonEmpty.Cons x xs) = + sumRank1 order (Array.shape $ snd x) (x:xs) + + +type HPR_ a = + Ptr CChar -> Ptr CInt -> + Ptr (RealOf a) -> Ptr a -> Ptr CInt -> Ptr a -> IO () + +newtype HPR a = HPR {getHPR :: HPR_ a} + +hpr :: Class.Floating a => HPR_ a +hpr = + getHPR $ + Class.switchFloating + (HPR BlasReal.spr) (HPR BlasReal.spr) + (HPR BlasComplex.hpr) (HPR BlasComplex.hpr) + + +sumRank2 :: + (Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(a, (Vector sh a, Vector sh a))] -> Hermitian sh a +sumRank2 order sh xys = + Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + \triSize aPtr -> + evalContT $ do + alphaPtr <- Call.alloca + withConjBuffer order sh triSize aPtr $ \uploPtr nPtr incPtr -> + forM_ xys $ \(alpha, (Array shX x, Array shY y)) -> + withForeignPtr x $ \xPtr -> + withForeignPtr y $ \yPtr -> do + Call.assert + "Hermitian.sumRank2: non-matching x vector size" (sh==shX) + Call.assert + "Hermitian.sumRank2: non-matching y vector size" (sh==shY) + poke alphaPtr alpha + BlasGen.hpr2 uploPtr nPtr alphaPtr xPtr incPtr yPtr incPtr aPtr + +sumRank2NonEmpty :: + (Shape.C sh, Eq sh, Class.Floating a) => + Order -> NonEmpty.T [] (a, (Vector sh a, Vector sh a)) -> Hermitian sh a +sumRank2NonEmpty order (NonEmpty.Cons xy xys) = + sumRank2 order (Array.shape $ fst $ snd xy) (xy:xys) + + +{- +It is not strictly necessary to keep the 'order'. +It would be neither more complicated nor less efficient +to change the order via the conversion. +-} +toSquare, _toSquare :: + (Shape.C sh, Class.Floating a) => Hermitian sh a -> Square sh a +_toSquare (Array (MatrixShape.Hermitian order sh) a) = + Array.unsafeCreate (MatrixShape.square order sh) $ \bPtr -> + evalContT $ do + let n = Shape.size sh + aPtr <- ContT $ withForeignPtr a + conjPtr <- conjugateToTemp (MatrixShape.triangleSize n) a + liftIO $ do + unpack (flipOrder order) n conjPtr bPtr -- wrong + unpack order n aPtr bPtr + +toSquare (Array (MatrixShape.Hermitian order sh) a) = + Array.unsafeCreate (MatrixShape.square order sh) $ \bPtr -> + withForeignPtr a $ \aPtr -> + Symmetric.unpack Conjugated order (Shape.size sh) aPtr bPtr + + +{- | +A^H * A +-} +covariance :: + (Shape.C height, Shape.C width, Eq width, Class.Floating a) => + General height width a -> Hermitian width a +covariance = + getMap $ + Class.switchFloating + (Map covarianceAux) (Map covarianceAux) + (Map covarianceAux) (Map covarianceAux) + +newtype Map f g a = Map {getMap :: f a -> g a} + +covarianceAux :: + (Shape.C height, Shape.C width, Eq width, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General height width a -> Hermitian width a +covarianceAux = argGeneral $ \order height width a -> + Array.unsafeCreate (MatrixShape.Hermitian order width) $ \bPtr -> do + + let n = Shape.size width + let k = Shape.size height + evalContT $ do + nPtr <- Call.cint n + kPtr <- Call.cint k + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + betaPtr <- Call.number zero + cPtr <- Call.allocaArray (n*n) + ldcPtr <- Call.leadingDim n + + case order of + ColumnMajor -> do + uploPtr <- Call.char 'U' + transPtr <- Call.char 'C' + ldaPtr <- Call.leadingDim k + liftIO $ do + herk uploPtr transPtr + nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr + pack ColumnMajor n cPtr bPtr + + RowMajor -> do + uploPtr <- Call.char 'L' + transPtr <- Call.char 'N' + ldaPtr <- Call.leadingDim n + liftIO $ do + herk uploPtr transPtr + nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr + pack RowMajor n cPtr bPtr + + +type HERK_ a = + Ptr CChar -> Ptr CChar -> Ptr CInt -> Ptr CInt -> Ptr (RealOf a) -> Ptr a -> + Ptr CInt -> Ptr (RealOf a) -> Ptr a -> Ptr CInt -> IO () + +newtype HERK a = HERK {getHERK :: HERK_ a} + +herk :: Class.Floating a => HERK_ a +herk = + getHERK $ + Class.switchFloating + (HERK BlasReal.syrk) + (HERK BlasReal.syrk) + (HERK BlasComplex.herk) + (HERK BlasComplex.herk) + + +{- | +A^H + A +-} +addAdjoint, _addAdjoint :: + (Shape.C sh, Class.Floating a) => Square sh a -> Hermitian sh a +_addAdjoint = + argSquare $ \order sh a -> + Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ \bSize bPtr -> do + let n = Shape.size sh + evalContT $ do + alphaPtr <- Call.number one + incxPtr <- Call.cint 1 + aPtr <- ContT $ withForeignPtr a + sizePtr <- Call.cint bSize + conjPtr <- Call.allocaArray bSize + liftIO $ do + pack order n aPtr bPtr + pack (flipOrder order) n aPtr conjPtr -- wrong + lacgv sizePtr conjPtr incxPtr + BlasGen.axpy sizePtr alphaPtr conjPtr incxPtr bPtr incxPtr + +addAdjoint = + argSquare $ \order sh a -> + Array.unsafeCreate (MatrixShape.Hermitian order sh) $ \bPtr -> do + let n = Shape.size sh + evalContT $ do + alphaPtr <- Call.number one + incxPtr <- Call.cint 1 + incnPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + liftIO $ case order of + RowMajor -> + forPointers (rowMajorPointers n aPtr bPtr) $ + \nPtr (srcPtr,dstPtr) -> do + copyConjugate nPtr srcPtr incnPtr dstPtr incxPtr + BlasGen.axpy nPtr alphaPtr srcPtr incxPtr dstPtr incxPtr + ColumnMajor -> + forPointers (columnMajorPointers n aPtr bPtr) $ + \nPtr ((srcRowPtr,srcColumnPtr),dstPtr) -> do + copyConjugate nPtr srcRowPtr incnPtr dstPtr incxPtr + BlasGen.axpy nPtr alphaPtr srcColumnPtr incxPtr dstPtr incxPtr + + +_pack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () +_pack order n fullPtr packedPtr = + evalContT $ do + incxPtr <- Call.cint 1 + liftIO $ + case order of + ColumnMajor -> + forPointers (columnMajorPointers n fullPtr packedPtr) $ + \nPtr ((_,srcPtr),dstPtr) -> + BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr + RowMajor -> + forPointers (rowMajorPointers n fullPtr packedPtr) $ + \nPtr (srcPtr,dstPtr) -> + BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr diff --git a/src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs b/src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Hermitian.Eigen ( + values, + decompose, + ) where + +import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) +import Numeric.LAPACK.Matrix.Square.Basic (Square) + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import Numeric.LAPACK.Matrix.Hermitian.Private (TakeDiagonal(..)) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), uploFromOrder, triangleSize) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf) +import Numeric.LAPACK.Private + (copyToTemp, copyCondConjugateToTemp, withInfo, eigenMsg) + +import qualified Numeric.LAPACK.FFI.Complex as LapackComplex +import qualified Numeric.LAPACK.FFI.Real as LapackReal +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.C.Types (CInt, CChar) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable) + +import Control.Monad.Trans.Cont (evalContT) +import Control.Monad.IO.Class (liftIO) + +import Data.Complex (Complex) + + +values :: + (Shape.C sh, Class.Floating a) => + Hermitian sh a -> Vector sh (RealOf a) +values = + runTakeDiagonal $ + Class.switchFloating + (TakeDiagonal valuesAux) (TakeDiagonal valuesAux) + (TakeDiagonal valuesAux) (TakeDiagonal valuesAux) + +valuesAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + Hermitian sh a -> Vector sh ar +valuesAux (Array (MatrixShape.Hermitian order size) a) = + Array.unsafeCreateWithSize size $ \n wPtr -> + evalContT $ do + jobzPtr <- Call.char 'N' + uploPtr <- Call.char $ uploFromOrder order + aPtr <- copyToTemp (triangleSize n) a + let zPtr = nullPtr + ldzPtr <- Call.leadingDim n + liftIO $ withInfo eigenMsg "hpev" $ + hpev jobzPtr uploPtr n aPtr wPtr zPtr ldzPtr + + +decompose :: + (Shape.C sh, Class.Floating a) => + Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) +decompose = + getDecompose $ + Class.switchFloating + (Decompose decomposeAux) (Decompose decomposeAux) + (Decompose decomposeAux) (Decompose decomposeAux) + +type Decompose_ sh a = Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) + +newtype Decompose sh a = Decompose {getDecompose :: Decompose_ sh a} + +decomposeAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + Decompose_ sh a +decomposeAux (Array (MatrixShape.Hermitian order size) a) = + Array.unsafeCreateWithSizeAndResult (MatrixShape.square ColumnMajor size) $ + \_ zPtr -> + ArrayIO.unsafeCreateWithSize size $ \n wPtr -> + evalContT $ do + jobzPtr <- Call.char 'V' + uploPtr <- Call.char $ uploFromOrder order + aPtr <- copyCondConjugateToTemp (order==RowMajor) (triangleSize n) a + ldzPtr <- Call.leadingDim n + liftIO $ withInfo eigenMsg "hpev" $ + hpev jobzPtr uploPtr n aPtr wPtr zPtr ldzPtr + + +type HPEV_ ar a = + Ptr CChar -> Ptr CChar -> Int -> Ptr a -> Ptr ar -> + Ptr a -> Ptr CInt -> Ptr CInt -> IO () + +newtype HPEV a = HPEV {getHPEV :: HPEV_ (RealOf a) a} + +hpev :: Class.Floating a => HPEV_ (RealOf a) a +hpev = + getHPEV $ + Class.switchFloating + (HPEV spevReal) (HPEV spevReal) (HPEV hpevComplex) (HPEV hpevComplex) + +spevReal :: Class.Real a => HPEV_ a a +spevReal jobzPtr uploPtr n apPtr wPtr zPtr ldzPtr infoPtr = + evalContT $ do + nPtr <- Call.cint n + workPtr <- Call.allocaArray (3*n) + liftIO $ + LapackReal.spev + jobzPtr uploPtr nPtr apPtr wPtr zPtr ldzPtr workPtr infoPtr + +hpevComplex :: Class.Real a => HPEV_ a (Complex a) +hpevComplex jobzPtr uploPtr n apPtr wPtr zPtr ldzPtr infoPtr = + evalContT $ do + nPtr <- Call.cint n + workPtr <- Call.allocaArray (max 1 (2*n-1)) + rworkPtr <- Call.allocaArray (max 1 (3*n-2)) + liftIO $ + LapackComplex.hpev + jobzPtr uploPtr nPtr apPtr wPtr zPtr ldzPtr workPtr rworkPtr infoPtr diff --git a/src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs b/src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Hermitian.Linear ( + solve, + inverse, + determinant, + ) where + +import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) +import Numeric.LAPACK.Matrix.Private (Full) + +import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Hermitian.Private (Determinant(..)) +import Numeric.LAPACK.Matrix.Private (Conjugation(Conjugated)) +import Numeric.LAPACK.Scalar (RealOf, absoluteSquared) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (peek) + + +solve :: + (Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Hermitian sh a -> + Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solve (Array (MatrixShape.Hermitian orderA shA) a) = + Symmetric.solve "Hermitian.solve" Conjugated orderA shA a + + +inverse :: + (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a +inverse (Array shape@(MatrixShape.Hermitian order sh) a) = + Array.unsafeCreateWithSize shape $ + Symmetric.inverse Conjugated order (Shape.size sh) a + + +determinant :: + (Shape.C sh, Class.Floating a) => Hermitian sh a -> RealOf a +determinant = + getDeterminant $ + Class.switchFloating + (Determinant determinantAux) (Determinant determinantAux) + (Determinant determinantAux) (Determinant determinantAux) + +determinantAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian sh a -> ar +determinantAux (Array (MatrixShape.Hermitian order sh) a) = + unsafePerformIO $ + Symmetric.determinant Conjugated + peekBlockDeterminant order (Shape.size sh) a + +peekBlockDeterminant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Ptr a, Maybe (Ptr a, Ptr a)) -> IO ar +peekBlockDeterminant (a0Ptr,ext) = do + let peekReal = peek . castPtr + a0 <- peekReal a0Ptr + case ext of + Nothing -> return a0 + Just (a1Ptr,bPtr) -> do + a1 <- peekReal a1Ptr + b <- peek bPtr + return (a0*a1 - absoluteSquared b) diff --git a/src/Numeric/LAPACK/Matrix/Hermitian/Private.hs b/src/Numeric/LAPACK/Matrix/Hermitian/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Hermitian/Private.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Hermitian.Private where + +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf) + + +newtype Diagonal f sh a = + Diagonal {runDiagonal :: Vector sh (RealOf a) -> f a} + +newtype TakeDiagonal f sh a = + TakeDiagonal {runTakeDiagonal :: f a -> Vector sh (RealOf a)} + +newtype Determinant f a = Determinant {getDeterminant :: f a -> RealOf a} diff --git a/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs @@ -0,0 +1,5 @@ +module Numeric.LAPACK.Matrix.HermitianPositiveDefinite ( + module Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear, + ) where + +import Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear diff --git a/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear ( + solve, + solveDecomposed, + inverse, + decompose, + determinant, + ) where + +import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) +import Numeric.LAPACK.Matrix.Triangular.Basic (Upper, takeDiagonal) +import Numeric.LAPACK.Matrix.Private (Full) + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Hermitian.Private (Determinant(..)) +import Numeric.LAPACK.Matrix.Triangular.Private (copyTriangleToTemp) +import Numeric.LAPACK.Matrix.Shape.Private + (NonUnit(NonUnit), uploFromOrder, triangleSize) +import Numeric.LAPACK.Matrix.Private (Conjugation(Conjugated)) +import Numeric.LAPACK.Linear.Private (solver) +import Numeric.LAPACK.Scalar (RealOf, realPart) +import Numeric.LAPACK.Private (copyBlock, withInfo, rankMsg, definiteMsg) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.ForeignPtr (withForeignPtr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + + +solve :: + (Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Hermitian sh a -> + Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solve (Array (MatrixShape.Hermitian orderA shA) a) = + solver "Hermitian.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + uploPtr <- Call.char $ uploFromOrder orderA + apPtr <- copyTriangleToTemp Conjugated orderA (triangleSize n) a + liftIO $ + withInfo definiteMsg "ppsv" $ + LapackGen.ppsv uploPtr nPtr nrhsPtr apPtr xPtr ldxPtr + +{- | +> solve a b == solveDecomposed (decompose a) b +> solve (covariance u) b == solveDecomposed u b +-} +solveDecomposed :: + (Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Upper sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solveDecomposed (Array (MatrixShape.Triangular NonUnit _uplo orderA shA) a) = + solver "Hermitian.solveDecomposed" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + uploPtr <- Call.char $ uploFromOrder orderA + apPtr <- copyTriangleToTemp Conjugated orderA (triangleSize n) a + liftIO $ + withInfo rankMsg "pptrs" $ + LapackGen.pptrs uploPtr nPtr nrhsPtr apPtr xPtr ldxPtr + + +inverse :: + (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a +inverse + (Array shape@(MatrixShape.Hermitian order sh) a) = + Array.unsafeCreateWithSize shape $ \triSize bPtr -> do + evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint $ Shape.size sh + aPtr <- ContT $ withForeignPtr a + liftIO $ do + copyBlock triSize aPtr bPtr + withInfo definiteMsg "pptrf" $ LapackGen.pptrf uploPtr nPtr bPtr + withInfo rankMsg "pptri" $ LapackGen.pptri uploPtr nPtr bPtr + +{- | +Cholesky decomposition +-} +decompose :: + (Shape.C sh, Class.Floating a) => Hermitian sh a -> Upper sh a +decompose + (Array (MatrixShape.Hermitian order sh) a) = + Array.unsafeCreateWithSize + (MatrixShape.Triangular NonUnit MatrixShape.upper order sh) $ + \triSize bPtr -> do + evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint $ Shape.size sh + aPtr <- ContT $ withForeignPtr a + liftIO $ do + copyBlock triSize aPtr bPtr + withInfo definiteMsg "pptrf" $ LapackGen.pptrf uploPtr nPtr bPtr + + +determinant :: + (Shape.C sh, Class.Floating a) => Hermitian sh a -> RealOf a +determinant = + getDeterminant $ + Class.switchFloating + (Determinant determinantAux) (Determinant determinantAux) + (Determinant determinantAux) (Determinant determinantAux) + +determinantAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian sh a -> ar +determinantAux = + (^(2::Int)) . product . map realPart . Array.toList . takeDiagonal . decompose diff --git a/src/Numeric/LAPACK/Matrix/Multiply.hs b/src/Numeric/LAPACK/Matrix/Multiply.hs --- a/src/Numeric/LAPACK/Matrix/Multiply.hs +++ b/src/Numeric/LAPACK/Matrix/Multiply.hs @@ -1,24 +1,37 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} module Numeric.LAPACK.Matrix.Multiply where import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Triangular as Triangular -import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian -import qualified Numeric.LAPACK.Matrix.Square as Square -import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix.BandedHermitian.Basic as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular +import qualified Numeric.LAPACK.Matrix.Hermitian.Basic as Hermitian import qualified Numeric.LAPACK.Private as Private import Numeric.LAPACK.Matrix.Shape.Private - (HeightOf, WidthOf, Order(ColumnMajor), transposeFromOrder) -import Numeric.LAPACK.Matrix.Triangular (Triangular) -import Numeric.LAPACK.Matrix.Private (General) + (HeightOf, WidthOf, Empty, Filled, Unit, NonUnit, + Order(RowMajor,ColumnMajor), flipOrder, transposeFromOrder) +import Numeric.LAPACK.Matrix.Extent.Private (Small) +import Numeric.LAPACK.Matrix.Triangular.Basic (Triangular) +import Numeric.LAPACK.Matrix.Basic (transpose) +import Numeric.LAPACK.Matrix.Private + (Square, Full, mapExtent, + Transposition(NonTransposed, Transposed)) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Private (zero, one) +import Numeric.LAPACK.Scalar (zero, one) -import qualified Numeric.BLAS.FFI.Generic as BlasGen import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary ((:+:)) + import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Internal (Array(Array)) @@ -29,24 +42,23 @@ import Control.Monad.IO.Class (liftIO) -transpose :: General height width a -> General width height a -transpose = Array.mapShape MatrixShape.transpose - multiplyVector :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Vector width a -> Vector height a + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, + Class.Floating a) => + Full vert horiz height width a -> Vector width a -> Vector height a multiplyVector a x = - let MatrixShape.General _order _height width = Array.shape a + let width = MatrixShape.fullWidth $ Array.shape a in if width == Array.shape x then multiplyVectorUnchecked a x else error "multiplyVector: width shapes mismatch" multiplyVectorUnchecked :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Vector width a -> Vector height a + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> Vector width a -> Vector height a multiplyVectorUnchecked - (Array shape@(MatrixShape.General order height _width) a) (Array _ x) = - Array.unsafeCreate height $ \yPtr -> do + (Array shape@(MatrixShape.Full order extent) a) (Array _ x) = + Array.unsafeCreate (Extent.height extent) $ \yPtr -> do let (m,n) = MatrixShape.dimensions shape let lda = m evalContT $ do @@ -55,274 +67,552 @@ nPtr <- Call.cint n alphaPtr <- Call.number one aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.cint lda + ldaPtr <- Call.leadingDim lda xPtr <- ContT $ withForeignPtr x incxPtr <- Call.cint 1 betaPtr <- Call.number zero incyPtr <- Call.cint 1 liftIO $ - BlasGen.gemv + Private.gemv transPtr mPtr nPtr alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr -multiply :: - (Shape.C height, +{- | +Multiply two matrices with the same dimension constraints. +E.g. you can multiply 'General' and 'General' matrices, +or 'Square' and 'Square' matrices. +It may seem to be overly strict in this respect, +but that design supports type inference the best. +You can lift the restrictions by generalizing operands +with 'Square.toFull', 'Matrix.fromFull', +'Matrix.generalizeTall' or 'Matrix.generalizeWide'. +-} +multiply, multiplyColumnMajor :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => - General height fuse a -> General fuse width a -> General height width a + Full vert horiz height fuse a -> + Full vert horiz fuse width a -> + Full vert horiz height width a +-- preserve order of the right factor multiply - (Array (MatrixShape.General orderA height fuseA) a) - (Array (MatrixShape.General orderB fuseB width) b) = - Array.unsafeCreate (MatrixShape.General ColumnMajor height width) $ - \cPtr -> do - Call.assert "multiply: fuse shapes mismatch" (fuseA == fuseB) - let m = Shape.size height - let n = Shape.size width - let k = Shape.size fuseA - Private.multiplyMatrix orderA orderB m k n a b cPtr + (Array (MatrixShape.Full orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + case Extent.fuse extentA extentB of + Nothing -> error "multiply: fuse shapes mismatch" + Just extent -> + Array.unsafeCreate (MatrixShape.Full orderB extent) $ \cPtr -> do + let (height,fuse) = Extent.dimensions extentA + let width = Extent.width extentB + let m = Shape.size height + let n = Shape.size width + let k = Shape.size fuse + case orderB of + RowMajor -> + Private.multiplyMatrix (flipOrder orderB) (flipOrder orderA) + n k m b a cPtr + ColumnMajor -> Private.multiplyMatrix orderA orderB m k n a b cPtr +-- always return ColumnMajor +multiplyColumnMajor + (Array (MatrixShape.Full orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + case Extent.fuse extentA extentB of + Nothing -> error "multiply: fuse shapes mismatch" + Just extent -> + Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ \cPtr -> do + + let (height,fuse) = Extent.dimensions extentA + let width = Extent.width extentB + let m = Shape.size height + let n = Shape.size width + let k = Shape.size fuse + Private.multiplyMatrix orderA orderB m k n a b cPtr + + infixl 7 <#, <#> infixr 7 #> -class MultiplyRight shape where +class (Shape.C shape) => MultiplyRight shape where (#>) :: (Class.Floating a) => - Array shape a -> Array (WidthOf shape) a -> Array (HeightOf shape) a + Array shape a -> Vector (WidthOf shape) a -> Vector (HeightOf shape) a -class MultiplyLeft shape where +class (Shape.C shape) => MultiplyLeft shape where (<#) :: (Class.Floating a) => - Array (HeightOf shape) a -> Array shape a -> Array (WidthOf shape) a - -class Multiply shapeA shapeB where - type Multiplied shapeA shapeB - (<#>) :: - (Class.Floating a) => - Array shapeA a -> Array shapeB a -> Array (Multiplied shapeA shapeB) a + Vector (HeightOf shape) a -> Array shape a -> Vector (WidthOf shape) a instance - (Eq width, Shape.C width, Shape.C height) => - MultiplyRight (MatrixShape.General height width) where + (Extent.C vert, Extent.C horiz, Eq width, Shape.C width, Shape.C height) => + MultiplyRight (MatrixShape.Full vert horiz height width) where (#>) = multiplyVector instance - (Eq height, Shape.C width, Shape.C height) => - MultiplyLeft (MatrixShape.General height width) where + (Extent.C vert, Extent.C horiz, Eq height, Shape.C width, Shape.C height) => + MultiplyLeft (MatrixShape.Full vert horiz height width) where v <# m = multiplyVector (transpose m) v instance (Eq shape, Shape.C shape) => - MultiplyRight (MatrixShape.Square shape) where - m #> v = multiplyVector (Square.toGeneral m) v + MultiplyRight (MatrixShape.Hermitian shape) where + (#>) = Hermitian.multiplyVector NonTransposed instance (Eq shape, Shape.C shape) => - MultiplyLeft (MatrixShape.Square shape) where - v <# m = multiplyVector (transpose $ Square.toGeneral m) v + MultiplyLeft (MatrixShape.Hermitian shape) where + (<#) = flip $ Hermitian.multiplyVector Transposed instance - (Eq shape, Shape.C shape) => - MultiplyRight (MatrixShape.Hermitian shape) where - m #> v = Hermitian.multiplyVector m v + (MatrixShape.Content lo, MatrixShape.Content up, + MatrixShape.TriDiag diag, Eq shape, Shape.C shape) => + MultiplyRight (MatrixShape.Triangular lo diag up shape) where + m #> v = Triangular.multiplyVector m v instance - (Eq shape, Shape.C shape) => - MultiplyLeft (MatrixShape.Hermitian shape) where - v <# m = Hermitian.multiplyVector (Vector.conjugate m) v + (MatrixShape.Content lo, MatrixShape.Content up, + MatrixShape.TriDiag diag, Eq shape, Shape.C shape) => + MultiplyLeft (MatrixShape.Triangular lo diag up shape) where + v <# m = Triangular.multiplyVector (Triangular.transpose m) v instance - (MatrixShape.Uplo uplo, Eq shape, Shape.C shape) => - MultiplyRight (MatrixShape.Triangular uplo shape) where - m #> v = Triangular.multiplyVectorRight m v + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, Eq width, Shape.C width, Shape.C height) => + MultiplyRight (MatrixShape.Banded sub super vert horiz height width) where + m #> v = Banded.multiplyVector m v instance - (MatrixShape.Uplo uplo, Eq shape, Shape.C shape) => - MultiplyLeft (MatrixShape.Triangular uplo shape) where - v <# m = Triangular.multiplyVectorLeft m v + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, Eq height, Shape.C width, Shape.C height) => + MultiplyLeft (MatrixShape.Banded sub super vert horiz height width) where + v <# m = Banded.multiplyVector (Banded.transpose m) v instance + (Unary.Natural offDiag, Shape.C size, Eq size) => + MultiplyRight (MatrixShape.BandedHermitian offDiag size) where + (#>) = BandedHermitian.multiplyVector NonTransposed + +instance + (Unary.Natural offDiag, Shape.C size, Eq size) => + MultiplyLeft (MatrixShape.BandedHermitian offDiag size) where + (<#) = flip $ BandedHermitian.multiplyVector Transposed + + +{- | +This class allows to multiply two matrices of arbitrary special features +and returns the most special matrix type possible. +At the first glance, this is handy. +At the second glance, this has some problems. +First of all, we may refine the types in future +and then multiplication may return a different, more special type than before. +Second, if you write code with polymorphic matrix types, +then '<#>' may leave you with constraints like +@ExtentPriv.Multiply vert vert ~ vert@. +That constraint is always fulfilled but the compiler cannot infer that. +Because of these problems +you may instead consider using specialised 'multiply' functions +from the various modules for production use. +Btw. 'MultiplyLeft' and 'MultiplyRight' are much less problematic, +because the input and output are always dense vectors. +-} +class (Shape.C shapeA, Shape.C shapeB) => Multiply shapeA shapeB where + type Multiplied shapeA shapeB + (<#>) :: + (Class.Floating a) => + Array shapeA a -> Array shapeB a -> Array (Multiplied shapeA shapeB) a + +instance (Shape.C heightA, Shape.C widthA, Shape.C widthB, - widthA ~ heightB, Eq heightB) => + widthA ~ heightB, Eq heightB, + Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB) => Multiply - (MatrixShape.General heightA widthA) - (MatrixShape.General heightB widthB) where + (MatrixShape.Full vertA horizA heightA widthA) + (MatrixShape.Full vertB horizB heightB widthB) where type Multiplied - (MatrixShape.General heightA widthA) - (MatrixShape.General heightB widthB) = - MatrixShape.General heightA widthB - (<#>) = multiply + (MatrixShape.Full vertA horizA heightA widthA) + (MatrixShape.Full vertB horizB heightB widthB) = + MatrixShape.Full + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + heightA widthB + a <#> b = + case unifyFactors (fullExtent a) (fullExtent b) of + ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> + multiply + (mapExtent unifyLeft a) + (mapExtent unifyRight b) +fullExtent :: + Full vert horiz height width a -> + Extent.Extent vert horiz height width +fullExtent = MatrixShape.fullExtent . Array.shape + +unifyFactors :: + (Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB) => + (ExtentPriv.Multiply vertA vertB ~ vertC) => + (ExtentPriv.Multiply horizA horizB ~ horizC) => + Extent.Extent vertA horizA height fuse -> + Extent.Extent vertB horizB fuse width -> + ((ExtentPriv.TagFact vertC, ExtentPriv.TagFact horizC), + (Extent.Map vertA horizA vertC horizC height fuse, + Extent.Map vertB horizB vertC horizC fuse width)) +unifyFactors a b = + ((ExtentPriv.multiplyTagLaw + (ExtentPriv.heightFact a) (ExtentPriv.heightFact b), + ExtentPriv.multiplyTagLaw + (ExtentPriv.widthFact a) (ExtentPriv.widthFact b)), + (ExtentPriv.Map $ flip ExtentPriv.unifyLeft b, + ExtentPriv.Map $ ExtentPriv.unifyRight a)) + + instance - (Shape.C shapeA, Shape.C widthB, shapeA ~ heightB, Eq heightB) => + (Extent.C vert, Extent.C horiz, + Shape.C size, size ~ width, Eq width, Shape.C height) => Multiply - (MatrixShape.Square shapeA) - (MatrixShape.General heightB widthB) where + (MatrixShape.Full vert horiz height width) + (MatrixShape.Hermitian size) + where type Multiplied - (MatrixShape.Square shapeA) - (MatrixShape.General heightB widthB) = - MatrixShape.General heightB widthB - a <#> b = multiply (Square.toGeneral a) b + (MatrixShape.Full vert horiz height width) + (MatrixShape.Hermitian size) = + MatrixShape.Full vert horiz height width + a <#> b = transpose $ Hermitian.multiplyFull Transposed b (transpose a) instance - (Shape.C heightA, Shape.C widthA, widthA ~ shapeB, Eq shapeB) => + (Extent.C vert, Extent.C horiz, + Shape.C size, size ~ height, Eq height, Shape.C width) => Multiply - (MatrixShape.General heightA widthA) - (MatrixShape.Square shapeB) where + (MatrixShape.Hermitian size) + (MatrixShape.Full vert horiz height width) + where type Multiplied - (MatrixShape.General heightA widthA) - (MatrixShape.Square shapeB) = - MatrixShape.General heightA widthA - a <#> b = multiply a (Square.toGeneral b) + (MatrixShape.Hermitian size) + (MatrixShape.Full vert horiz height width) = + MatrixShape.Full vert horiz height width + (<#>) = Hermitian.multiplyFull NonTransposed instance (Shape.C shapeA, shapeA ~ shapeB, Eq shapeB) => - Multiply (MatrixShape.Square shapeA) (MatrixShape.Square shapeB) where - type Multiplied (MatrixShape.Square shapeA) (MatrixShape.Square shapeB) = + Multiply (MatrixShape.Hermitian shapeA) (MatrixShape.Hermitian shapeB) + where + type Multiplied + (MatrixShape.Hermitian shapeA) (MatrixShape.Hermitian shapeB) = MatrixShape.Square shapeA - (<#>) = Square.multiply + a <#> b = Hermitian.multiplyFull NonTransposed a (Hermitian.toSquare b) instance - (Shape.C shapeA, shapeA ~ width, Eq width, Shape.C height) => + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Extent.C vert, Extent.C horiz, + Shape.C size, size ~ width, Eq width, Shape.C height) => Multiply - (MatrixShape.General height width) - (MatrixShape.Hermitian shapeA) + (MatrixShape.Full vert horiz height width) + (MatrixShape.Triangular lo diag up size) where type Multiplied - (MatrixShape.General height width) (MatrixShape.Hermitian shapeA) = - MatrixShape.General height width - (<#>) = Hermitian.multiplyGeneralLeft + (MatrixShape.Full vert horiz height width) + (MatrixShape.Triangular lo diag up size) = + MatrixShape.Full vert horiz height width + a <#> b = + transpose $ Triangular.multiplyFull (Triangular.transpose b) (transpose a) instance - (Shape.C shapeA, shapeA ~ shapeB, Eq shapeB) => - Multiply (MatrixShape.Square shapeB) (MatrixShape.Hermitian shapeA) - where + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Extent.C vert, Extent.C horiz, + Shape.C size, size ~ height, Eq height, Shape.C width) => + Multiply + (MatrixShape.Triangular lo diag up size) + (MatrixShape.Full vert horiz height width) + where type Multiplied - (MatrixShape.Square shapeB) (MatrixShape.Hermitian shapeA) = - MatrixShape.Square shapeA - (<#>) = Hermitian.multiplySquareLeft + (MatrixShape.Triangular lo diag up size) + (MatrixShape.Full vert horiz height width) = + MatrixShape.Full vert horiz height width + (<#>) = Triangular.multiplyFull instance - (Shape.C shapeA, shapeA ~ height, Eq height, Shape.C width) => + (Shape.C sizeA, sizeA ~ sizeB, Eq sizeB, + MultiplyTriangular loA upA loB upB, + MatrixShape.TriDiag diagA, MatrixShape.TriDiag diagB) => Multiply - (MatrixShape.Hermitian shapeA) - (MatrixShape.General height width) - where + (MatrixShape.Triangular loA diagA upA sizeA) + (MatrixShape.Triangular loB diagB upB sizeB) where type Multiplied - (MatrixShape.Hermitian shapeA) (MatrixShape.General height width) = - MatrixShape.General height width - (<#>) = Hermitian.multiplyGeneralRight + (MatrixShape.Triangular loA diagA upA sizeA) + (MatrixShape.Triangular loB diagB upB sizeB) = + -- requires UndecidableInstances + MultipliedTriangular loA diagA upA loB diagB upB sizeB + (<#>) = multiplyTriangular +class + (MatrixShape.Content loA, MatrixShape.Content upA, + MatrixShape.Content loB, MatrixShape.Content upB) => + MultiplyTriangular loA upA loB upB where + multiplyTriangular :: + (Class.Floating a, Shape.C size, Eq size, + MatrixShape.TriDiag diagA, MatrixShape.TriDiag diagB) => + Triangular loA diagA upA size a -> + Triangular loB diagB upB size a -> + Array (MultipliedTriangular loA diagA upA loB diagB upB size) a + + +type MultipliedTriangular loA diagA upA loB diagB upB size = + ComposedTriangular + (MultipliedPart loA loB) + (MultipliedDiag diagA diagB) + (MultipliedPart upA upB) + size + +type family MultipliedPart a b :: * +type instance MultipliedPart Empty b = b +type instance MultipliedPart Filled b = Filled + +type family MultipliedDiag a b :: * +type instance MultipliedDiag Unit b = b +type instance MultipliedDiag NonUnit b = NonUnit + +type family ComposedTriangular lo diag up size :: * +type instance ComposedTriangular Empty diag up size = + MatrixShape.Triangular Empty diag up size +type instance ComposedTriangular Filled diag Empty size = + MatrixShape.LowerTriangular diag size +type instance ComposedTriangular Filled diag Filled size = + MatrixShape.Square size + + +instance MultiplyTriangular Empty Empty Empty Empty where + multiplyTriangular = multiplyTriangularConform + +instance MultiplyTriangular Empty Empty Filled Filled where + multiplyTriangular a = Triangular.multiplyFull a . Triangular.toSquare + +instance MultiplyTriangular Empty Filled Filled Filled where + multiplyTriangular a = Triangular.multiplyFull a . Triangular.toSquare + +instance MultiplyTriangular Filled Empty Filled Filled where + multiplyTriangular a = Triangular.multiplyFull a . Triangular.toSquare + +instance MultiplyTriangular Empty Filled Empty Filled where + multiplyTriangular = multiplyTriangularConform + +instance MultiplyTriangular Filled Empty Filled Empty where + multiplyTriangular = multiplyTriangularConform + +instance MultiplyTriangular Filled Empty Empty Filled where + multiplyTriangular a = Triangular.multiplyFull a . Triangular.toSquare + +instance MultiplyTriangular Empty Filled Filled Empty where + multiplyTriangular a = Triangular.multiplyFull a . Triangular.toSquare + +instance MultiplyTriangular Filled Filled Empty Empty where + multiplyTriangular = multiplyTriangularToSquare + +instance MultiplyTriangular Filled Filled Empty Filled where + multiplyTriangular = multiplyTriangularToSquare + +instance MultiplyTriangular Filled Filled Filled Empty where + multiplyTriangular = multiplyTriangularToSquare + +instance MultiplyTriangular Filled Filled Filled Filled where + multiplyTriangular = multiplyTriangularToSquare + +multiplyTriangularToSquare :: + (MatrixShape.Content loA, MatrixShape.Content upA, MatrixShape.TriDiag diagA, + MatrixShape.Content loB, MatrixShape.Content upB, MatrixShape.TriDiag diagB, + Shape.C size, Eq size, Class.Floating a) => + Triangular loA diagA upA size a -> + Triangular loB diagB upB size a -> + Square size a +multiplyTriangularToSquare a b = + transpose $ Triangular.multiplyFull (Triangular.transpose b) $ + transpose $ Triangular.toSquare a + + +newtype MultiplyTriangularConform lo up size a diagB diagA = + MultiplyTriangularConform { + getMultiplyTriangularConform :: + Triangular lo diagA up size a -> + Triangular lo diagB up size a -> + Triangular lo (MultipliedDiag diagA diagB) up size a + } + +multiplyTriangularConform :: + (Shape.C size, Eq size, Class.Floating a, + MatrixShape.DiagUpLo lo up, + MatrixShape.TriDiag diagA, MatrixShape.TriDiag diagB) => + (MultipliedDiag diagA diagB ~ diagC) => + Triangular lo diagA up size a -> + Triangular lo diagB up size a -> + Triangular lo diagC up size a +multiplyTriangularConform = + getMultiplyTriangularConform $ + MatrixShape.switchTriDiag + (MultiplyTriangularConform $ \a b -> + Triangular.multiply (Triangular.relaxUnitDiagonal a) b) + (MultiplyTriangularConform $ \a b -> + Triangular.multiply a (Triangular.strictNonUnitDiagonal b)) + + instance - (Shape.C shapeA, shapeA ~ shapeB, Eq shapeB) => - Multiply (MatrixShape.Hermitian shapeA) (MatrixShape.Square shapeB) - where + (Unary.Natural sub, Unary.Natural super, + Extent.C vertA, Extent.C horizA, + Extent.C vertB, Extent.C horizB, + Shape.C heightA, Shape.C widthA, Shape.C widthB, + widthA ~ heightB, Eq heightB) => + Multiply + (MatrixShape.Full vertA horizA heightA widthA) + (MatrixShape.Banded sub super vertB horizB heightB widthB) + where type Multiplied - (MatrixShape.Hermitian shapeA) (MatrixShape.Square shapeB) = - MatrixShape.Square shapeA - (<#>) = Hermitian.multiplySquareRight + (MatrixShape.Full vertA horizA heightA widthA) + (MatrixShape.Banded sub super vertB horizB heightB widthB) = + MatrixShape.Full + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + heightA widthB + a <#> b = + case unifyFactors (fullExtent a) (bandedExtent b) of + ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> + transpose $ + Banded.multiplyFull + (Banded.transpose $ Banded.mapExtent unifyRight b) + (transpose $ mapExtent unifyLeft a) instance - (Shape.C shapeA, shapeA ~ shapeB, Eq shapeB) => - Multiply (MatrixShape.Hermitian shapeA) (MatrixShape.Hermitian shapeB) - where + (Unary.Natural sub, Unary.Natural super, + Extent.C vertA, Extent.C horizA, + Extent.C vertB, Extent.C horizB, + Shape.C heightA, Shape.C widthA, Shape.C widthB, + widthA ~ heightB, Eq heightB) => + Multiply + (MatrixShape.Banded sub super vertA horizA heightA widthA) + (MatrixShape.Full vertB horizB heightB widthB) + where type Multiplied - (MatrixShape.Hermitian shapeA) (MatrixShape.Hermitian shapeB) = - MatrixShape.Square shapeA - a <#> b = Hermitian.multiplySquareRight a (Hermitian.toSquare b) + (MatrixShape.Banded sub super vertA horizA heightA widthA) + (MatrixShape.Full vertB horizB heightB widthB) = + MatrixShape.Full + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + heightA widthB + a <#> b = + case unifyFactors (bandedExtent a) (fullExtent b) of + ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> + Banded.multiplyFull + (Banded.mapExtent unifyLeft a) + (mapExtent unifyRight b) +instance + (Unary.Natural subA, Unary.Natural superA, + Unary.Natural subB, Unary.Natural superB, + Extent.C vertA, Extent.C horizA, + Extent.C vertB, Extent.C horizB, + Shape.C heightA, Shape.C widthA, Shape.C widthB, + widthA ~ heightB, Eq heightB) => + Multiply + (MatrixShape.Banded subA superA vertA horizA heightA widthA) + (MatrixShape.Banded subB superB vertB horizB heightB widthB) where + type Multiplied + (MatrixShape.Banded subA superA vertA horizA heightA widthA) + (MatrixShape.Banded subB superB vertB horizB heightB widthB) = + MatrixShape.Banded + (subA :+: subB) (superA :+: superB) + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + heightA widthB + a <#> b = + case unifyFactors (bandedExtent a) (bandedExtent b) of + ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> + Banded.multiply + (Banded.mapExtent unifyLeft a) + (Banded.mapExtent unifyRight b) +bandedExtent :: + Banded.Banded sup super vert horiz height width a -> + Extent.Extent vert horiz height width +bandedExtent = MatrixShape.bandedExtent . Array.shape instance - (MatrixShape.Uplo uplo, - Shape.C shapeA, shapeA ~ width, Eq width, Shape.C height) => + (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + Shape.C size, size ~ width, Eq width, Shape.C height, Eq height) => Multiply - (MatrixShape.General height width) - (MatrixShape.Triangular uplo shapeA) + (MatrixShape.Full vert horiz height width) + (MatrixShape.BandedHermitian offDiag size) where type Multiplied - (MatrixShape.General height width) - (MatrixShape.Triangular uplo shapeA) = - MatrixShape.General height width - (<#>) = Triangular.multiplyGeneralLeft + (MatrixShape.Full vert horiz height width) + (MatrixShape.BandedHermitian offDiag size) = + MatrixShape.Full vert horiz height width + a <#> b = transpose $ BandedHermitian.multiplyFull Transposed b (transpose a) instance - (MatrixShape.Uplo uplo, Shape.C shapeA, shapeA ~ shapeB, Eq shapeB) => - Multiply (MatrixShape.Square shapeB) (MatrixShape.Triangular uplo shapeA) - where + (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + Shape.C size, size ~ height, Eq height, Shape.C width, Eq width) => + Multiply + (MatrixShape.BandedHermitian offDiag size) + (MatrixShape.Full vert horiz height width) + where type Multiplied - (MatrixShape.Square shapeB) (MatrixShape.Triangular uplo shapeA) = - MatrixShape.Square shapeA - (<#>) = Triangular.multiplySquareLeft + (MatrixShape.BandedHermitian offDiag size) + (MatrixShape.Full vert horiz height width) = + MatrixShape.Full vert horiz height width + (<#>) = BandedHermitian.multiplyFull NonTransposed instance - (MatrixShape.Uplo uplo, - Shape.C shapeA, shapeA ~ height, Eq height, Shape.C width) => + (Unary.Natural offDiag, Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, + Shape.C size, size ~ width, Eq width, Shape.C height, Eq height) => Multiply - (MatrixShape.Triangular uplo shapeA) - (MatrixShape.General height width) + (MatrixShape.Banded sub super vert horiz height width) + (MatrixShape.BandedHermitian offDiag size) where type Multiplied - (MatrixShape.Triangular uplo shapeA) - (MatrixShape.General height width) = - MatrixShape.General height width - (<#>) = Triangular.multiplyGeneralRight + (MatrixShape.Banded sub super vert horiz height width) + (MatrixShape.BandedHermitian offDiag size) = + MatrixShape.Banded + (sub:+:offDiag) (super:+:offDiag) vert horiz height width + a <#> b = + Banded.multiply + a (Banded.mapExtent Extent.fromSquare (BandedHermitian.toBanded b)) instance - (MatrixShape.Uplo uplo, Shape.C shapeA, shapeA ~ shapeB, Eq shapeB) => - Multiply (MatrixShape.Triangular uplo shapeA) (MatrixShape.Square shapeB) - where + (Unary.Natural offDiag, Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, + Shape.C size, size ~ height, Eq height, Shape.C width, Eq width) => + Multiply + (MatrixShape.BandedHermitian offDiag size) + (MatrixShape.Banded sub super vert horiz height width) + where type Multiplied - (MatrixShape.Triangular uplo shapeA) (MatrixShape.Square shapeB) = - MatrixShape.Square shapeA - (<#>) = Triangular.multiplySquareRight + (MatrixShape.BandedHermitian offDiag size) + (MatrixShape.Banded sub super vert horiz height width) = + MatrixShape.Banded + (offDiag:+:sub) (offDiag:+:super) vert horiz height width + a <#> b = + Banded.multiply + (Banded.mapExtent Extent.fromSquare (BandedHermitian.toBanded a)) b instance - (Shape.C shapeA, shapeA ~ shapeB, Eq shapeB, - MultiplyTriangular uploA uploB) => + (Unary.Natural offDiagA, Unary.Natural offDiagB, + Shape.C sizeA, sizeA ~ sizeB, Shape.C sizeB, Eq sizeB) => Multiply - (MatrixShape.Triangular uploA shapeA) - (MatrixShape.Triangular uploB shapeB) where + (MatrixShape.BandedHermitian offDiagA sizeA) + (MatrixShape.BandedHermitian offDiagB sizeB) + where type Multiplied - (MatrixShape.Triangular uploA shapeA) - (MatrixShape.Triangular uploB shapeB) = - MultipliedTriangular uploA uploB shapeB - (<#>) = multiplyTriangular - -class MultiplyTriangular uploA uploB where - type MultipliedTriangular uploA uploB :: * -> * - multiplyTriangular :: - (Class.Floating a, Shape.C shape, Eq shape) => - Triangular uploA shape a -> - Triangular uploB shape a -> - Array (MultipliedTriangular uploA uploB shape) a - -instance MultiplyTriangular MatrixShape.Lower MatrixShape.Lower where - type MultipliedTriangular MatrixShape.Lower MatrixShape.Lower = - MatrixShape.Triangular MatrixShape.Lower - multiplyTriangular = Triangular.multiply - -instance MultiplyTriangular MatrixShape.Upper MatrixShape.Upper where - type MultipliedTriangular MatrixShape.Upper MatrixShape.Upper = - MatrixShape.Triangular MatrixShape.Upper - multiplyTriangular = Triangular.multiply - -instance MultiplyTriangular MatrixShape.Lower MatrixShape.Upper where - type MultipliedTriangular MatrixShape.Lower MatrixShape.Upper = - MatrixShape.Square - multiplyTriangular a b = - Square.multiply (Triangular.toSquare a) (Triangular.toSquare b) - -instance MultiplyTriangular MatrixShape.Upper MatrixShape.Lower where - type MultipliedTriangular MatrixShape.Upper MatrixShape.Lower = - MatrixShape.Square - multiplyTriangular a b = - Square.multiply (Triangular.toSquare a) (Triangular.toSquare b) + (MatrixShape.BandedHermitian offDiagA sizeA) + (MatrixShape.BandedHermitian offDiagB sizeB) = + MatrixShape.Banded + (offDiagA:+:offDiagB) (offDiagA:+:offDiagB) + Small Small sizeA sizeB + a <#> b = + Banded.multiply (BandedHermitian.toBanded a) (BandedHermitian.toBanded b) diff --git a/src/Numeric/LAPACK/Matrix/Private.hs b/src/Numeric/LAPACK/Matrix/Private.hs --- a/src/Numeric/LAPACK/Matrix/Private.hs +++ b/src/Numeric/LAPACK/Matrix/Private.hs @@ -1,15 +1,90 @@ module Numeric.LAPACK.Matrix.Private where import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Data.Array.Comfort.Storable (Array) +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import Numeric.LAPACK.Matrix.Shape.Private (Order, flipOrder) +import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) +import Foreign.ForeignPtr (ForeignPtr) + +type Full vert horiz height width = + Array (MatrixShape.Full vert horiz height width) + type General height width = Array (MatrixShape.General height width) +type Tall height width = Array (MatrixShape.Tall height width) +type Wide height width = Array (MatrixShape.Wide height width) +type Square sh = Array (MatrixShape.Square sh) +argGeneral :: + (MatrixShape.Order -> height -> width -> ForeignPtr a -> b) -> + (General height width a -> b) +argGeneral f (Array (MatrixShape.Full order extent) a) = + f order (Extent.height extent) (Extent.width extent) a + +argSquare :: + (MatrixShape.Order -> sh -> ForeignPtr a -> b) -> (Square sh a -> b) +argSquare f (Array (MatrixShape.Full order extent) a) = + f order (Extent.squareSize extent) a + + type ZeroInt = Shape.ZeroBased Int zeroInt :: Int -> ZeroInt zeroInt = Shape.ZeroBased + + +mapExtent :: + (Extent.C vertA, Extent.C horizA) => + (Extent.C vertB, Extent.C horizB) => + Extent.Map vertA horizA vertB horizB height width -> + Full vertA horizA height width a -> Full vertB horizB height width a +mapExtent f = Array.mapShape $ MatrixShape.fullMapExtent f + +fromFull :: + (Extent.C vert, Extent.C horiz) => + Full vert horiz height width a -> General height width a +fromFull = mapExtent Extent.toGeneral + +generalizeTall :: + (Extent.C vert, Extent.C horiz) => + Full vert Extent.Small height width a -> Full vert horiz height width a +generalizeTall = mapExtent Extent.generalizeTall + +generalizeWide :: + (Extent.C vert, Extent.C horiz) => + Full Extent.Small horiz height width a -> Full vert horiz height width a +generalizeWide = mapExtent Extent.generalizeWide + + +height :: + (Extent.C vert, Extent.C horiz) => + Full vert horiz height width a -> height +height = MatrixShape.fullHeight . Array.shape + +width :: + (Extent.C vert, Extent.C horiz) => + Full vert horiz height width a -> width +width = MatrixShape.fullWidth . Array.shape + + +data Transposition = NonTransposed | Transposed + deriving (Eq, Show, Enum, Bounded) + +transposeOrder :: Transposition -> Order -> Order +transposeOrder NonTransposed = id +transposeOrder Transposed = flipOrder + +data Conjugation = NonConjugated | Conjugated + deriving (Eq, Show, Enum, Bounded) + +data Inversion = NonInverted | Inverted + deriving (Eq, Show, Enum, Bounded) + +flipInversion :: Inversion -> Inversion +flipInversion NonInverted = Inverted +flipInversion Inverted = NonInverted diff --git a/src/Numeric/LAPACK/Matrix/Shape.hs b/src/Numeric/LAPACK/Matrix/Shape.hs --- a/src/Numeric/LAPACK/Matrix/Shape.hs +++ b/src/Numeric/LAPACK/Matrix/Shape.hs @@ -1,5 +1,102 @@ module Numeric.LAPACK.Matrix.Shape ( General, + Tall, + Wide, + Square, + Full(..), fullHeight, fullWidth, + Order(..), flipOrder, + general, + square, + wide, + tall, + + Split, + SplitGeneral, + Triangle(..), + Reflector(..), + splitGeneral, + splitFromFull, + + Hermitian(..), + hermitian, + + Triangular(..), + Identity, + Diagonal, + LowerTriangular, + UpperTriangular, + Symmetric, + diagonal, + lowerTriangular, + upperTriangular, + symmetric, + autoDiag, + autoUplo, + DiagUpLo, + Unit(Unit), + NonUnit(NonUnit), + + Banded(..), + BandedGeneral, + BandedSquare, + BandedLowerTriangular, + BandedUpperTriangular, + BandedDiagonal, + BandedIndex(..), + bandedGeneral, + bandedSquare, + bandedFromFull, + UnaryProxy, + addOffDiagonals, + TriDiag, + switchTriDiag, + Content, + + BandedHermitian(..), + bandedHermitian, ) where +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import Numeric.LAPACK.Matrix.Shape.Private + + +type SplitGeneral lower height width = + Split lower Extent.Big Extent.Big height width + +splitGeneral :: + lower -> Order -> height -> width -> SplitGeneral lower height width +splitGeneral lowerPart order height width = + Split lowerPart order $ Extent.general height width + +splitFromFull :: + lower -> + Full vert horiz height width -> + Split lower vert horiz height width +splitFromFull lowerPart (Full order extent) = Split lowerPart order extent + + +diagonal :: Order -> size -> Triangular Empty NonUnit Empty size +diagonal = Triangular NonUnit autoUplo + +lowerTriangular :: Order -> size -> LowerTriangular NonUnit size +lowerTriangular = Triangular NonUnit autoUplo + +upperTriangular :: Order -> size -> UpperTriangular NonUnit size +upperTriangular = Triangular NonUnit autoUplo + +symmetric :: Order -> size -> Symmetric size +symmetric = Triangular NonUnit autoUplo + +hermitian :: Order -> size -> Hermitian size +hermitian = Hermitian + + +bandedFromFull :: + (UnaryProxy sub, UnaryProxy super) -> + Full vert horiz height width -> + Banded sub super vert horiz height width +bandedFromFull offDiag (Full order extent) = Banded offDiag order extent + + +bandedHermitian :: UnaryProxy off -> Order -> size -> BandedHermitian off size +bandedHermitian = BandedHermitian diff --git a/src/Numeric/LAPACK/Matrix/Shape/Private.hs b/src/Numeric/LAPACK/Matrix/Shape/Private.hs --- a/src/Numeric/LAPACK/Matrix/Shape/Private.hs +++ b/src/Numeric/LAPACK/Matrix/Shape/Private.hs @@ -1,327 +1,1011 @@ {-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Matrix.Shape.Private where - -import qualified Data.Array.Comfort.Shape as Shape - -import Control.Applicative (Const(Const, getConst)) - -import Data.Functor.Identity (Identity(Identity), runIdentity) -import Data.List (tails) -import Data.Tuple.HT (swap) - - -data Order = RowMajor | ColumnMajor - deriving (Eq, Show) - -flipOrder :: Order -> Order -flipOrder RowMajor = ColumnMajor -flipOrder ColumnMajor = RowMajor - -transposeFromOrder :: Order -> Char -transposeFromOrder RowMajor = 'T' -transposeFromOrder ColumnMajor = 'N' - - -type family HeightOf shape -type family WidthOf shape - - -data General height width = - General { - generalOrder :: Order, - generalHeight :: height, - generalWidth :: width - } deriving (Eq, Show) - -type instance HeightOf (General height width) = height -type instance WidthOf (General height width) = width - -instance (Shape.C height, Shape.C width) => Shape.C (General height width) where - type Index (General height width) = (Shape.Index height, Shape.Index width) - indices (General _ height width) = Shape.indices (height,width) - - offset (General RowMajor height width) = - Shape.offset (height,width) - offset (General ColumnMajor height width) = - Shape.offset (width,height) . swap - uncheckedOffset (General RowMajor height width) = - Shape.uncheckedOffset (height,width) - uncheckedOffset (General ColumnMajor height width) = - Shape.uncheckedOffset (width,height) . swap - - sizeOffset (General RowMajor height width) = - Shape.sizeOffset (height,width) - sizeOffset (General ColumnMajor height width) = - Shape.sizeOffset (width,height) . swap - uncheckedSizeOffset (General RowMajor height width) = - Shape.uncheckedSizeOffset (height,width) - uncheckedSizeOffset (General ColumnMajor height width) = - Shape.uncheckedSizeOffset (width,height) . swap - - inBounds (General _ height width) = Shape.inBounds (height,width) - size (General _ height width) = Shape.size (height,width) - uncheckedSize (General _ height width) = Shape.uncheckedSize (height,width) - - -transpose :: General height width -> General width height -transpose (General order height width) = General (flipOrder order) width height - -dimensions :: - (Shape.C height, Shape.C width) => General height width -> (Int, Int) -dimensions (General order height width) = - case order of - RowMajor -> (Shape.size width, Shape.size height) - ColumnMajor -> (Shape.size height, Shape.size width) - - -data Square size = - Square { - squareOrder :: Order, - squareSize :: size - } deriving (Eq, Show) - -type instance HeightOf (Square size) = size -type instance WidthOf (Square size) = size - -generalFromSquare :: Square size -> General size size -generalFromSquare (Square order sh) = General order sh sh - -transposeSquare :: Square sh -> Square sh -transposeSquare (Square order size) = Square (flipOrder order) size - -instance (Shape.C size) => Shape.C (Square size) where - type Index (Square size) = (Shape.Index size, Shape.Index size) - indices (Square _ size) = Shape.indices (size,size) - - offset (Square RowMajor size) = - Shape.offset (size,size) - offset (Square ColumnMajor size) = - Shape.offset (size,size) . swap - uncheckedOffset (Square RowMajor size) = - Shape.uncheckedOffset (size,size) - uncheckedOffset (Square ColumnMajor size) = - Shape.uncheckedOffset (size,size) . swap - - sizeOffset (Square RowMajor size) = - Shape.sizeOffset (size,size) - sizeOffset (Square ColumnMajor size) = - Shape.sizeOffset (size,size) . swap - uncheckedSizeOffset (Square RowMajor size) = - Shape.uncheckedSizeOffset (size,size) - uncheckedSizeOffset (Square ColumnMajor size) = - Shape.uncheckedSizeOffset (size,size) . swap - - inBounds (Square _ size) = Shape.inBounds (size,size) - size (Square _ size) = Shape.size (size,size) - uncheckedSize (Square _ size) = Shape.uncheckedSize (size,size) - - -data Householder height width = - Householder { - householderOrder :: Order, - householderHeight :: height, - householderWidth :: width - } deriving (Eq, Show) - -type instance HeightOf (Householder height width) = height -type instance WidthOf (Householder height width) = width - -data Reflector = Reflector deriving (Eq) -data Triangle = Triangle deriving (Eq) - -householderPart :: - (Shape.C height, Shape.C width) => - Householder height width -> - (Shape.Index height, Shape.Index width) -> Either Reflector Triangle -householderPart (Householder _ height width) (r,c) = - if Shape.offset height r > Shape.offset width c - then Left Reflector - else Right Triangle - -instance - (Shape.C height, Shape.C width) => - Shape.C (Householder height width) where - - type Index (Householder height width) = - (Either Reflector Triangle, - (Shape.Index height, Shape.Index width)) - - indices sh@(Householder _ height width) = - map (\ix -> (householderPart sh ix, ix)) $ - Shape.indices (height,width) - - offset sh@(Householder order height width) (part,ix) = - if part == householderPart sh ix - then - case order of - RowMajor -> Shape.offset (height,width) ix - ColumnMajor -> Shape.offset (width,height) (swap ix) - else error "Shape.Householder.offset: wrong matrix part" - uncheckedOffset (Householder RowMajor height width) = - Shape.uncheckedOffset (height,width) . snd - uncheckedOffset (Householder ColumnMajor height width) = - Shape.uncheckedOffset (width,height) . swap . snd - - sizeOffset sh@(Householder order height width) (part,ix) = - if part == householderPart sh ix - then - case order of - RowMajor -> Shape.sizeOffset (height,width) ix - ColumnMajor -> Shape.sizeOffset (width,height) (swap ix) - else error "Shape.Householder.sizeOffset: wrong matrix part" - uncheckedSizeOffset (Householder RowMajor height width) = - Shape.uncheckedSizeOffset (height,width) . snd - uncheckedSizeOffset (Householder ColumnMajor height width) = - Shape.uncheckedSizeOffset (width,height) . swap . snd - - size (Householder _ height width) = Shape.size (height,width) - uncheckedSize (Householder _ height width) = - Shape.uncheckedSize (height,width) - inBounds sh@(Householder _ height width) (part,ix) = - Shape.inBounds (height,width) ix - && - part == householderPart sh ix - - -{- | -Store the upper triangular half of a real symmetric or complex Hermitian matrix. --} -data Hermitian size = - Hermitian { - hermitianOrder :: Order, - hermitianSize :: size - } deriving (Eq, Show) - -type instance HeightOf (Hermitian size) = size -type instance WidthOf (Hermitian size) = size - -uploFromOrder :: Order -> Char -uploFromOrder RowMajor = 'L' -uploFromOrder ColumnMajor = 'U' - -instance (Shape.C size) => Shape.C (Hermitian size) where - type Index (Hermitian size) = (Shape.Index size, Shape.Index size) - - indices (Hermitian _ size) = - let ixs = Shape.indices size - in concat $ zipWith (\r cs -> map ((,) r) cs) ixs $ tails ixs - - uncheckedOffset sh ix = - snd $ Shape.uncheckedSizeOffset sh ix - - sizeOffset sh ix = - if Shape.inBounds sh ix - then Shape.uncheckedSizeOffset sh ix - else error "Shape.Hermitian.sizeOffset: wrong matrix part" - - uncheckedSizeOffset (Hermitian RowMajor size) (rs,cs) = - let (s,r) = Shape.uncheckedSizeOffset size rs - c = Shape.uncheckedOffset size cs - in (s, triangleSize s - triangleSize (s-r) + c-r) - uncheckedSizeOffset (Hermitian ColumnMajor size) (rs,cs) = - let (s,r) = Shape.uncheckedSizeOffset size rs - c = Shape.uncheckedOffset size cs - in (s, triangleSize c + r) - - size (Hermitian _ size) = triangleSize $ Shape.size size - uncheckedSize (Hermitian _ size) = triangleSize $ Shape.uncheckedSize size - inBounds (Hermitian _ size) ix@(r,c) = - Shape.inBounds (size,size) ix - && - Shape.offset size r <= Shape.offset size c - - -data Triangular uplo size = - Triangular { - triangularUplo :: uplo, - triangularOrder :: Order, - triangularSize :: size - } deriving (Eq, Show) - -type instance HeightOf (Triangular uplo size) = size -type instance WidthOf (Triangular uplo size) = size - -data Lower = Lower deriving (Eq, Show) -data Upper = Upper deriving (Eq, Show) - -type LowerTriangular = Triangular Lower -type UpperTriangular = Triangular Upper - -triangularTransposeUp :: LowerTriangular sh -> UpperTriangular sh -triangularTransposeUp (Triangular Lower order size) = - Triangular Upper (flipOrder order) size - -triangularTransposeDown :: UpperTriangular sh -> LowerTriangular sh -triangularTransposeDown (Triangular Upper order size) = - Triangular Lower (flipOrder order) size - - -class Uplo uplo where switchUplo :: f Lower -> f Upper -> f uplo -instance Uplo Lower where switchUplo f _ = f -instance Uplo Upper where switchUplo _ f = f - -autoUplo :: Uplo uplo => uplo -autoUplo = runIdentity $ switchUplo (Identity Lower) (Identity Upper) - -uploOrder :: Uplo uplo => uplo -> Order -> Order -uploOrder uplo order = caseUplo uplo (flipOrder order) order - -getUploConst :: uplo -> Const a uplo -> a -getUploConst _ = getConst - -caseUplo :: Uplo uplo => uplo -> a -> a -> a -caseUplo uplo lo up = - getUploConst uplo $ switchUplo (Const lo) (Const up) - -instance (Uplo uplo, Shape.C size) => Shape.C (Triangular uplo size) where - type Index (Triangular uplo size) = (Shape.Index size, Shape.Index size) - - indices (Triangular uplo _ size) = - let ixs = Shape.indices size - rcs = concat $ zipWith (\r cs -> map ((,) r) cs) ixs $ tails ixs - in caseUplo uplo (map swap rcs) rcs - - uncheckedOffset sh ix = - snd $ Shape.uncheckedSizeOffset sh ix - - sizeOffset sh ix = - if Shape.inBounds sh ix - then Shape.uncheckedSizeOffset sh ix - else error "Shape.Triangular.sizeOffset: wrong matrix part" - - uncheckedSizeOffset (Triangular uplo RowMajor size) (rs,cs) = - let (s,r) = Shape.uncheckedSizeOffset size rs - c = Shape.uncheckedOffset size cs - in (s, - caseUplo uplo - (triangleSize r + c) - (triangleSize s - triangleSize (s-r) + c-r)) - uncheckedSizeOffset (Triangular uplo ColumnMajor size) (rs,cs) = - let (s,r) = Shape.uncheckedSizeOffset size rs - c = Shape.uncheckedOffset size cs - in (s, - caseUplo uplo - (triangleSize s - triangleSize (s-c) + r-c) - (triangleSize c + r)) - - size (Triangular _ _ size) = triangleSize $ Shape.size size - uncheckedSize (Triangular _ _ size) = triangleSize $ Shape.uncheckedSize size - inBounds (Triangular uplo _ size) ix@(r,c) = - Shape.inBounds (size,size) ix - && - caseUplo uplo - (Shape.offset size r >= Shape.offset size c) - (Shape.offset size r <= Shape.offset size c) - -triangleSize :: Int -> Int -triangleSize n = div (n*(n+1)) 2 - -triangleRoot :: Floating a => a -> a -triangleRoot size = (sqrt (8*size+1)-1)/2 - -triangleExtent :: String -> Int -> Int -triangleExtent name size = - let n = round (triangleRoot (fromIntegral size :: Double)) - in if size == triangleSize n - then n - else error (name ++ ": no triangular number of elements") +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Numeric.LAPACK.Matrix.Shape.Private where + +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Extent.Private (Extent) +import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) + +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary (unary, (:+:)) +import Type.Data.Num (integralFromProxy) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Array.Comfort.Shape as Shape + +import Control.DeepSeq (NFData, rnf) +import Control.Applicative (Const(Const, getConst)) + +import qualified Data.NonEmpty as NonEmpty +import Data.Functor.Identity (Identity(Identity), runIdentity) +import Data.List (tails) +import Data.Tuple.HT (mapPair, swap, double) +import Data.Bool.HT (if') + + +data Order = RowMajor | ColumnMajor + deriving (Eq, Show) + +instance NFData Order where + rnf RowMajor = () + rnf ColumnMajor = () + +flipOrder :: Order -> Order +flipOrder RowMajor = ColumnMajor +flipOrder ColumnMajor = RowMajor + +transposeFromOrder :: Order -> Char +transposeFromOrder RowMajor = 'T' +transposeFromOrder ColumnMajor = 'N' + +swapOnRowMajor :: Order -> (a,a) -> (a,a) +swapOnRowMajor order = + case order of + RowMajor -> swap + ColumnMajor -> id + +sideSwapFromOrder :: Order -> (a,a) -> (Char, (a,a)) +sideSwapFromOrder order (m0,n0) = + let ((side,m), (_,n)) = swapOnRowMajor order (('L', m0), ('R', n0)) + in (side,(m,n)) + + +type family HeightOf shape +type family WidthOf shape + + +data Full vert horiz height width = + Full { + fullOrder :: Order, + fullExtent :: Extent vert horiz height width + } deriving (Eq, Show) + +type instance HeightOf (Full vert horiz height width) = height +type instance WidthOf (Full vert horiz height width) = width + +instance + (Extent.C vert, Extent.C horiz, NFData height, NFData width) => + NFData (Full vert horiz height width) where + rnf (Full order extent) = rnf (order, extent) + +instance + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Shape.C (Full vert horiz height width) where + + size (Full _ extent) = Shape.size (Extent.dimensions extent) + uncheckedSize (Full _ extent) = + Shape.uncheckedSize (Extent.dimensions extent) + +instance + (Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => + Shape.Indexed (Full vert horiz height width) where + + type Index (Full vert horiz height width) = + (Shape.Index height, Shape.Index width) + indices (Full order extent) = fullIndices order extent + + offset (Full RowMajor extent) = + Shape.offset (Extent.dimensions extent) + offset (Full ColumnMajor extent) = + Shape.offset (swap $ Extent.dimensions extent) . swap + uncheckedOffset (Full RowMajor extent) = + Shape.uncheckedOffset (Extent.dimensions extent) + uncheckedOffset (Full ColumnMajor extent) = + Shape.uncheckedOffset (swap $ Extent.dimensions extent) . swap + + sizeOffset (Full RowMajor extent) = + Shape.sizeOffset (Extent.dimensions extent) + sizeOffset (Full ColumnMajor extent) = + Shape.sizeOffset (swap $ Extent.dimensions extent) . swap + uncheckedSizeOffset (Full RowMajor extent) = + Shape.uncheckedSizeOffset (Extent.dimensions extent) + uncheckedSizeOffset (Full ColumnMajor extent) = + Shape.uncheckedSizeOffset (swap $ Extent.dimensions extent) . swap + + inBounds (Full _ extent) = Shape.inBounds (Extent.dimensions extent) + +instance + (Extent.C vert, Extent.C horiz, + Shape.InvIndexed height, Shape.InvIndexed width) => + Shape.InvIndexed (Full vert horiz height width) where + + indexFromOffset (Full order extent) = fullIndexFromOffset order extent + + +transpose :: + (Extent.C vert, Extent.C horiz) => + Full vert horiz height width -> Full horiz vert width height +transpose (Full order extent) = Full (flipOrder order) (Extent.transpose extent) + +dimensions :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Full vert horiz height width -> (Int, Int) +dimensions (Full order extent) = + swapOnRowMajor order + (Shape.size $ Extent.height extent, + Shape.size $ Extent.width extent) + +fullHeight :: + (Extent.C vert, Extent.C horiz) => Full vert horiz height width -> height +fullHeight = Extent.height . fullExtent + +fullWidth :: + (Extent.C vert, Extent.C horiz) => Full vert horiz height width -> width +fullWidth = Extent.width . fullExtent + + +fullIndices :: + (Extent.C vert, Extent.C horiz, Shape.Indexed a, Shape.Indexed b) => + Order -> Extent vert horiz a b -> [(Shape.Index a, Shape.Index b)] +fullIndices order extent = + case order of + RowMajor -> Shape.indices $ Extent.dimensions extent + ColumnMajor -> map swap $ Shape.indices $ swap $ Extent.dimensions extent + +fullIndexFromOffset :: + (Extent.C vert, Extent.C horiz, Shape.InvIndexed a, Shape.InvIndexed b) => + Order -> Extent vert horiz a b -> Int -> + (Shape.Index a, Shape.Index b) +fullIndexFromOffset order extent = + case order of + RowMajor -> + Shape.indexFromOffset (Extent.dimensions extent) + ColumnMajor -> + swap . Shape.indexFromOffset (swap $ Extent.dimensions extent) + + +type General height width = Full Extent.Big Extent.Big height width +type Tall height width = Full Extent.Big Extent.Small height width +type Wide height width = Full Extent.Small Extent.Big height width +type Square size = Full Extent.Small Extent.Small size size + + +fullMapExtent :: + Extent.Map vertA horizA vertB horizB height width -> + Full vertA horizA height width -> + Full vertB horizB height width +fullMapExtent f (Full order extent) = Full order $ Extent.apply f extent + +general :: Order -> height -> width -> General height width +general order height width = Full order $ Extent.general height width + +tall :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> Tall height width +tall order height width = + if Shape.size height >= Shape.size width + then Full order $ Extent.tall height width + else error "MatrixShape.tall: height smaller than width" + +wide :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> Wide height width +wide order height width = + if Shape.size height <= Shape.size width + then Full order $ Extent.wide height width + else error "MatrixShape.wide: width smaller than height" + +square :: Order -> sh -> Square sh +square order sh = Full order $ Extent.square sh + + +caseTallWide :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Full vert horiz height width -> + Either (Tall height width) (Wide height width) +caseTallWide (Full order extent) = + either (Left . Full order) (Right . Full order) $ + Extent.caseTallWide (\h w -> Shape.size h >= Shape.size w) extent + + +data Split lower vert horiz height width = + Split { + splitLower :: lower, + splitOrder :: Order, + splitExtent :: Extent vert horiz height width + } deriving (Eq, Show) + +splitHeight :: + (Extent.C vert, Extent.C horiz) => + Split lower vert horiz height width -> height +splitHeight = Extent.height . splitExtent + +splitWidth :: + (Extent.C vert, Extent.C horiz) => + Split lower vert horiz height width -> width +splitWidth = Extent.width . splitExtent + +splitMapExtent :: + Extent.Map vertA horizA vertB horizB height width -> + Split lower vertA horizA height width -> + Split lower vertB horizB height width +splitMapExtent f (Split lowerPart order extent) = + Split lowerPart order $ Extent.apply f extent + + +caseTallWideSplit :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Split lower vert horiz height width -> + Either + (Split lower Extent.Big Extent.Small height width) + (Split lower Extent.Small Extent.Big height width) +caseTallWideSplit (Split lowerPart order extent) = + either (Left . Split lowerPart order) (Right . Split lowerPart order) $ + Extent.caseTallWide (\h w -> Shape.size h >= Shape.size w) extent + + +type instance HeightOf (Split lower vert horiz height width) = height +type instance WidthOf (Split lower vert horiz height width) = width + +data Reflector = Reflector deriving (Eq, Show) +data Triangle = Triangle deriving (Eq, Show) + +instance NFData Reflector where rnf Reflector = () +instance NFData Triangle where rnf Triangle = () + +splitPart :: + (Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width) => + Split lower vert horiz height width -> + (Shape.Index height, Shape.Index width) -> Either lower Triangle +splitPart (Split lowerPart _ extent) (r,c) = + if Shape.offset (Extent.height extent) r > + Shape.offset (Extent.width extent) c + then Left lowerPart + else Right Triangle + +instance + (NFData lower, Extent.C vert, Extent.C horiz, NFData height, NFData width) => + NFData (Split lower vert horiz height width) where + rnf (Split lowerPart order extent) = rnf (lowerPart, order, extent) + +instance + (Eq lower, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Shape.C (Split lower vert horiz height width) where + + size (Split _ _ extent) = Shape.size (Extent.dimensions extent) + uncheckedSize (Split _ _ extent) = + Shape.uncheckedSize (Extent.dimensions extent) + +instance + (Eq lower, Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => + Shape.Indexed (Split lower vert horiz height width) where + + type Index (Split lower vert horiz height width) = + (Either lower Triangle, + (Shape.Index height, Shape.Index width)) + + indices sh@(Split _ order extent) = + map (\ix -> (splitPart sh ix, ix)) $ fullIndices order extent + + offset sh@(Split _ order extent) (part,ix) = + if part == splitPart sh ix + then + case order of + RowMajor -> Shape.offset (Extent.dimensions extent) ix + ColumnMajor -> + Shape.offset (swap $ Extent.dimensions extent) (swap ix) + else error "Shape.Split.offset: wrong matrix part" + uncheckedOffset (Split _ RowMajor extent) = + Shape.uncheckedOffset (Extent.dimensions extent) . snd + uncheckedOffset (Split _ ColumnMajor extent) = + Shape.uncheckedOffset (swap $ Extent.dimensions extent) . swap . snd + + sizeOffset sh@(Split _ order extent) (part,ix) = + if part == splitPart sh ix + then + case order of + RowMajor -> Shape.sizeOffset (Extent.dimensions extent) ix + ColumnMajor -> + Shape.sizeOffset (swap $ Extent.dimensions extent) (swap ix) + else error "Shape.Split.sizeOffset: wrong matrix part" + uncheckedSizeOffset (Split _ RowMajor extent) = + Shape.uncheckedSizeOffset (Extent.dimensions extent) . snd + uncheckedSizeOffset (Split _ ColumnMajor extent) = + Shape.uncheckedSizeOffset (swap $ Extent.dimensions extent) . swap . snd + + inBounds sh@(Split _ _ extent) (part,ix) = + Shape.inBounds (Extent.dimensions extent) ix + && + part == splitPart sh ix + +instance + (Eq lower, Extent.C vert, Extent.C horiz, + Shape.InvIndexed height, Shape.InvIndexed width) => + Shape.InvIndexed (Split lower vert horiz height width) where + + indexFromOffset sh@(Split _ order extent) k = + let ix = fullIndexFromOffset order extent k + in (splitPart sh ix, ix) + + +{- | +Store the upper triangular half of a real symmetric or complex Hermitian matrix. +-} +data Hermitian size = + Hermitian { + hermitianOrder :: Order, + hermitianSize :: size + } deriving (Eq, Show) + +type instance HeightOf (Hermitian size) = size +type instance WidthOf (Hermitian size) = size + +uploFromOrder :: Order -> Char +uploFromOrder RowMajor = 'L' +uploFromOrder ColumnMajor = 'U' + +instance (NFData size) => NFData (Hermitian size) where + rnf (Hermitian order size) = rnf (order, size) + +instance (Shape.C size) => Shape.C (Hermitian size) where + size (Hermitian _ size) = triangleSize $ Shape.size size + uncheckedSize (Hermitian _ size) = triangleSize $ Shape.uncheckedSize size + +instance (Shape.Indexed size) => Shape.Indexed (Hermitian size) where + type Index (Hermitian size) = (Shape.Index size, Shape.Index size) + + indices (Hermitian order size) = triangleIndices order size + + uncheckedOffset sh ix = + snd $ Shape.uncheckedSizeOffset sh ix + + sizeOffset sh ix = + if Shape.inBounds sh ix + then Shape.uncheckedSizeOffset sh ix + else error "Shape.Hermitian.sizeOffset: wrong matrix part" + + uncheckedSizeOffset (Hermitian order size) (rs,cs) = + let (n,r) = Shape.uncheckedSizeOffset size rs + c = Shape.uncheckedOffset size cs + in (triangleSize n, + case order of + RowMajor -> triangleOffset n (r,c) + ColumnMajor -> triangleSize c + r) + + inBounds (Hermitian _ size) ix@(r,c) = + Shape.inBounds (size,size) ix + && + Shape.offset size r <= Shape.offset size c + +instance (Shape.InvIndexed size) => Shape.InvIndexed (Hermitian size) where + indexFromOffset (Hermitian order size) k = + triangleIndexFromOffset order size k + + + +data Triangular lo diag up size = + Triangular { + triangularDiag :: diag, + triangularUplo :: (lo,up), + triangularOrder :: Order, + triangularSize :: size + } deriving (Eq, Show) + +type instance HeightOf (Triangular lo diag up size) = size +type instance WidthOf (Triangular lo diag up size) = size + + +data Unit = Unit deriving (Eq, Show) +data NonUnit = NonUnit deriving (Eq, Show) + +class TriDiag diag where switchTriDiag :: f Unit -> f NonUnit -> f diag +instance TriDiag Unit where switchTriDiag f _ = f +instance TriDiag NonUnit where switchTriDiag _ f = f + +autoDiag :: TriDiag diag => diag +autoDiag = runIdentity $ switchTriDiag (Identity Unit) (Identity NonUnit) + +caseTriDiag :: TriDiag diag => diag -> a -> a -> a +caseTriDiag diag unit nonUnit = + getConstAs diag $ switchTriDiag (Const unit) (Const nonUnit) + +charFromTriDiag :: TriDiag diag => diag -> Char +charFromTriDiag diag = caseTriDiag diag 'U' 'N' + + +relaxUnitDiagonal :: + (TriDiag diag) => Triangular lo Unit up sh -> Triangular lo diag up sh +relaxUnitDiagonal shape = shape{triangularDiag = autoDiag} + +strictNonUnitDiagonal :: + (TriDiag diag) => Triangular lo diag up sh -> Triangular lo NonUnit up sh +strictNonUnitDiagonal shape = shape{triangularDiag = NonUnit} + + +data Empty = Empty deriving (Eq, Show) +data Filled = Filled deriving (Eq, Show) + +lower :: (Filled,Empty) +lower = (Filled,Empty) + +upper :: (Empty,Filled) +upper = (Empty,Filled) + +type Identity = Triangular Empty Unit Empty +type Diagonal = Triangular Empty NonUnit Empty +type LowerTriangular diag = Triangular Filled diag Empty +type UpperTriangular diag = Triangular Empty diag Filled +type FlexSymmetric diag = Triangular Filled diag Filled +type Symmetric = FlexSymmetric NonUnit + +triangularTranspose :: + (Content lo, Content up) => + Triangular lo diag up sh -> Triangular up diag lo sh +triangularTranspose (Triangular diag uplo order size) = + Triangular diag + (swap uplo) + (caseDiagUpLoSym uplo flipOrder flipOrder flipOrder id order) + size + + +class Content c where switchContent :: f Empty -> f Filled -> f c +instance Content Empty where switchContent f _ = f +instance Content Filled where switchContent _ f = f + + +type UpLo lo up = (UpLoC lo up, UpLoC up lo) + +class (DiagUpLoC lo up, UpLoSymC lo up) => UpLoC lo up where + switchUpLo :: f Empty Filled -> f Filled Empty -> f lo up + +instance UpLoC Empty Filled where switchUpLo f _ = f +instance UpLoC Filled Empty where switchUpLo _ f = f + + +type DiagUpLo lo up = (DiagUpLoC lo up, DiagUpLoC up lo) + +class (Content lo, Content up) => DiagUpLoC lo up where + switchDiagUpLo :: + f Empty Empty -> f Empty Filled -> f Filled Empty -> f lo up + +instance DiagUpLoC Empty Empty where switchDiagUpLo f _ _ = f +instance DiagUpLoC Empty Filled where switchDiagUpLo _ f _ = f +instance DiagUpLoC Filled Empty where switchDiagUpLo _ _ f = f + + +type UpLoSym lo up = (UpLoSymC lo up, UpLoSymC up lo) + +class (Content lo, Content up) => UpLoSymC lo up where + switchUpLoSym :: + f Empty Filled -> f Filled Empty -> f Filled Filled -> f lo up + +instance UpLoSymC Empty Filled where switchUpLoSym f _ _ = f +instance UpLoSymC Filled Empty where switchUpLoSym _ f _ = f +instance UpLoSymC Filled Filled where switchUpLoSym _ _ f = f + + +switchDiagUpLoSym :: + (Content lo, Content up) => + f Empty Empty -> f Empty Filled -> f Filled Empty -> f Filled Filled -> + f lo up +switchDiagUpLoSym fDiag fUpper fLower fSymm = + getFlip $ + switchContent + (Flip $ switchContent fDiag fUpper) + (Flip $ switchContent fLower fSymm) + +autoContent :: Content c => c +autoContent = runIdentity $ switchContent (Identity Empty) (Identity Filled) + +autoUplo :: (Content lo, Content up) => (lo,up) +autoUplo = (autoContent,autoContent) + +uploOrder :: (Content lo, Content up) => (lo,up) -> Order -> Order +uploOrder (_loc,upc) = caseContent upc flipOrder id + +getConstAs :: c -> Const a c -> a +getConstAs _ = getConst + +caseContent :: Content c => c -> a -> a -> a +caseContent c lo up = + getConstAs c $ switchContent (Const lo) (Const up) + +caseLoUp :: UpLo lo up => (lo,up) -> a -> a -> a +caseLoUp (_loc,upc) = caseContent upc + +caseDiagUpLoSym :: (Content lo, Content up) => (lo,up) -> a -> a -> a -> a -> a +caseDiagUpLoSym (loc,upc) diag up lo symm = + caseContent loc + (caseContent upc diag up) + (caseContent upc lo symm) + + +newtype Const2 a lo up = Const2 {getConst2 :: a} + +getContentConst2 :: (lo,up) -> Const2 a lo up -> a +getContentConst2 _ = getConst2 + +caseUpLoSym :: (UpLoSym lo up) => (lo,up) -> a -> a -> a -> a +caseUpLoSym c lo up sym = + getContentConst2 c $ switchUpLoSym (Const2 lo) (Const2 up) (Const2 sym) + + +instance + (Content lo, TriDiag diag, Content up, NFData size) => + NFData (Triangular lo diag up size) where + rnf (Triangular diag (loc,upc) order size) = + rnf + (flip getFlip diag $ + switchTriDiag (Flip $ \Unit -> ()) (Flip $ \NonUnit -> ()), + let rnfContent c = + flip getFlip c $ + switchContent + (Flip $ \Empty -> ()) + (Flip $ \Filled -> ()) + in (rnfContent loc, rnfContent upc), + order, size) + +instance + (Content lo, TriDiag diag, Content up, Shape.C size) => + Shape.C (Triangular lo diag up size) where + + size (Triangular _diag uplo _ size) = + let n = Shape.size size + in caseDiagUpLoSym uplo n + (triangleSize n) + (triangleSize n) + (triangleSize n) + uncheckedSize (Triangular _diag uplo _ size) = + let n = Shape.uncheckedSize size + in caseDiagUpLoSym uplo n + (triangleSize n) + (triangleSize n) + (triangleSize n) + +instance + (Content lo, TriDiag diag, Content up, Shape.Indexed size) => + Shape.Indexed (Triangular lo diag up size) where + type Index (Triangular lo diag up size) = + (Shape.Index size, Shape.Index size) + + indices (Triangular _diag uplo order size) = + caseDiagUpLoSym uplo + (map double $ Shape.indices size) + (triangleIndices order size) + (map swap $ triangleIndices (flipOrder order) size) + (triangleIndices order size) + + uncheckedOffset sh ix = + snd $ Shape.uncheckedSizeOffset sh ix + + sizeOffset sh ix = + if Shape.inBounds sh ix + then Shape.uncheckedSizeOffset sh ix + else error "Shape.Triangular.sizeOffset: wrong matrix part" + + uncheckedSizeOffset (Triangular _diag uplo order size) (rs,cs) = + let (n,r) = Shape.uncheckedSizeOffset size rs + c = Shape.uncheckedOffset size cs + triSize = triangleSize n + in case order of + RowMajor -> + caseDiagUpLoSym uplo (n,c) + (triSize, triangleOffset n (r,c)) + (triSize, triangleSize r + c) + (triSize, triangleOffset n (r,c)) + ColumnMajor -> + caseDiagUpLoSym uplo (n,c) + (triSize, triangleSize c + r) + (triSize, triangleOffset n (c,r)) + (triSize, triangleSize c + r) + + inBounds (Triangular _diag uplo _ size) ix@(r,c) = + Shape.inBounds (size,size) ix + && + caseDiagUpLoSym uplo + (Shape.offset size r == Shape.offset size c) + (Shape.offset size r <= Shape.offset size c) + (Shape.offset size r >= Shape.offset size c) + (Shape.offset size r <= Shape.offset size c) + +instance + (Content lo, TriDiag diag, Content up, Shape.InvIndexed size) => + Shape.InvIndexed (Triangular lo diag up size) where + + indexFromOffset (Triangular _diag uplo order size) k = + caseDiagUpLoSym uplo + (double $ Shape.indexFromOffset size k) + (triangleIndexFromOffset order size k) + (swap $ triangleIndexFromOffset (flipOrder order) size k) + (triangleIndexFromOffset order size k) + + +triangleSize :: Int -> Int +triangleSize n = div (n*(n+1)) 2 + +triangleOffset :: Int -> (Int,Int) -> Int +triangleOffset s (r,c) = + triangleSize s - triangleSize (s-r) + c-r + +triangleRoot :: Floating a => a -> a +triangleRoot size = (sqrt (8*size+1)-1)/2 + +triangleRootDouble :: Int -> Double +triangleRootDouble = triangleRoot . fromIntegral + +triangleExtent :: String -> Int -> Int +triangleExtent name size = + let n = round $ triangleRootDouble size + in if size == triangleSize n + then n + else error (name ++ ": no triangular number of elements") + +triangleIndices :: + (Shape.Indexed sh) => Order -> sh -> [(Shape.Index sh, Shape.Index sh)] +triangleIndices RowMajor size = + let ixs = Shape.indices size + in concat $ zipWith (\r cs -> map ((,) r) cs) ixs $ tails ixs +triangleIndices ColumnMajor size = + let ixs = Shape.indices size + in concat $ + zipWith (\rs c -> map (flip (,) c) rs) + (NonEmpty.tail $ NonEmpty.inits ixs) ixs + +triangleIndexFromOffset :: + (Shape.InvIndexed sh) => + Order -> sh -> Int -> (Shape.Index sh, Shape.Index sh) +triangleIndexFromOffset order size k = + mapPair (Shape.indexFromOffset size, Shape.indexFromOffset size) $ + case order of + RowMajor -> + let n = Shape.size size + triSize = triangleSize n + rr = ceiling (triangleRootDouble (triSize-k)) + r = n - rr + in (r, k+r - (triSize - triangleSize rr)) + ColumnMajor -> + let c = floor (triangleRootDouble k) + in (k - triangleSize c, c) + + +type UnaryProxy a = Proxy (Unary.Un a) + +data Banded sub super vert horiz height width = + Banded { + bandedOffDiagonals :: (UnaryProxy sub, UnaryProxy super), + bandedOrder :: Order, + bandedExtent :: Extent vert horiz height width + } deriving (Eq, Show) + +type BandedGeneral sub super = Banded sub super Extent.Big Extent.Big +type BandedSquare sub super size = + Banded sub super Extent.Small Extent.Small size size + +type BandedLowerTriangular sub size = BandedSquare sub TypeNum.U0 size +type BandedUpperTriangular super size = BandedSquare TypeNum.U0 super size + +type BandedDiagonal size = BandedSquare TypeNum.U0 TypeNum.U0 size + + +bandedHeight :: + (Extent.C vert, Extent.C horiz) => + Banded sub super vert horiz height width -> height +bandedHeight = Extent.height . bandedExtent + +bandedWidth :: + (Extent.C vert, Extent.C horiz) => + Banded sub super vert horiz height width -> width +bandedWidth = Extent.width . bandedExtent + +bandedMapExtent :: + Extent.Map vertA horizA vertB horizB height width -> + Banded sub super vertA horizA height width -> + Banded sub super vertB horizB height width +bandedMapExtent f (Banded numDiag order extent) = + Banded numDiag order $ Extent.apply f extent + +type instance HeightOf (Banded sub super vert horiz height width) = height +type instance WidthOf (Banded sub super vert horiz height width) = width + +bandedBreadth :: + (Unary.Natural sub, Unary.Natural super) => + (UnaryProxy sub, UnaryProxy super) -> Int +bandedBreadth (sub,super) = + integralFromProxy sub + 1 + integralFromProxy super + +numOffDiagonals :: + (Unary.Natural sub, Unary.Natural super) => + Order -> (UnaryProxy sub, UnaryProxy super) -> (Int,Int) +numOffDiagonals order (sub,super) = + swapOnRowMajor order (integralFromProxy sub, integralFromProxy super) + +natFromProxy :: (Unary.Natural n) => UnaryProxy n -> Proof.Nat n +natFromProxy Proxy = Proof.Nat + +addOffDiagonals :: + (Unary.Natural subA, Unary.Natural superA, + Unary.Natural subB, Unary.Natural superB, + (subA :+: subB) ~ subC, + (superA :+: superB) ~ superC) => + (UnaryProxy subA, UnaryProxy superA) -> + (UnaryProxy subB, UnaryProxy superB) -> + ((Proof.Nat subC, Proof.Nat superC), + (UnaryProxy subC, UnaryProxy superC)) +addOffDiagonals (subA,superA) (subB,superB) = + ((Proof.addNat (natFromProxy subA) (natFromProxy subB), + Proof.addNat (natFromProxy superA) (natFromProxy superB)), + (Proxy,Proxy)) + +bandedTranspose :: + (Extent.C vert, Extent.C horiz) => + Banded sub super vert horiz height width -> + Banded super sub horiz vert width height +bandedTranspose (Banded (sub,super) order extent) = + Banded (super,sub) (flipOrder order) (Extent.transpose extent) + + +bandedGeneral :: + (UnaryProxy sub, UnaryProxy super) -> Order -> height -> width -> + Banded sub super Extent.Big Extent.Big height width +bandedGeneral offDiag order height width = + Banded offDiag order (Extent.general height width) + +bandedSquare :: + (UnaryProxy sub, UnaryProxy super) -> Order -> size -> + Banded sub super Extent.Small Extent.Small size size +bandedSquare offDiag order = Banded offDiag order . Extent.square + + +data BandedIndex row column = + InsideBox row column + | VertOutsideBox Int column + | HorizOutsideBox row Int + deriving (Eq, Show) + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, NFData height, NFData width) => + NFData (Banded sub super vert horiz height width) where + rnf (Banded (Proxy,Proxy) order extent) = rnf (order, extent) + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Shape.C (Banded sub super vert horiz height width) where + + size (Banded offDiag order extent) = + bandedBreadth offDiag * + case order of + RowMajor -> Shape.size (Extent.height extent) + ColumnMajor -> Shape.size (Extent.width extent) + uncheckedSize (Banded offDiag order extent) = + bandedBreadth offDiag * + case order of + RowMajor -> Shape.uncheckedSize (Extent.height extent) + ColumnMajor -> Shape.uncheckedSize (Extent.width extent) + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => + Shape.Indexed (Banded sub super vert horiz height width) where + + type Index (Banded sub super vert horiz height width) = + BandedIndex (Shape.Index height) (Shape.Index width) + indices (Banded (sub,super) order extent) = + let (height,width) = Extent.dimensions extent + in case order of + RowMajor -> + map (\(r,c) -> either (HorizOutsideBox r) (InsideBox r) c) $ + bandedIndicesRowMajor (sub,super) (height,width) + ColumnMajor -> + map (\(c,r) -> + either (flip VertOutsideBox c) (flip InsideBox c) r) $ + bandedIndicesRowMajor (super,sub) (width,height) + + offset shape ix = + if Shape.inBounds shape ix + then Shape.uncheckedOffset shape ix + else error "Banded.offset: index outside band" + + uncheckedOffset (Banded (sub,super) order extent) ix = + let (height,width) = Extent.dimensions extent + kl = integralFromProxy sub + ku = integralFromProxy super + in bandedOffset (kl,ku) order (height,width) ix + + inBounds (Banded (sub,super) order extent) ix = + let (height,width) = Extent.dimensions extent + kl = integralFromProxy sub + ku = integralFromProxy super + insideBand r c = Shape.inBounds (Shape.Range (-kl) ku) (c-r) + in case (order,ix) of + (_, InsideBox r c) -> + Shape.inBounds (height,width) (r,c) + && + insideBand (Shape.offset height r) (Shape.offset width c) + (RowMajor, HorizOutsideBox r c) -> + Shape.inBounds height r + && + insideBand (Shape.offset height r) (outsideOffset width c) + (ColumnMajor, VertOutsideBox r c) -> + Shape.inBounds width c + && + insideBand (outsideOffset height r) (Shape.offset width c) + _ -> False + +instance + (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + Shape.InvIndexed height, Shape.InvIndexed width) => + Shape.InvIndexed (Banded sub super vert horiz height width) where + + indexFromOffset (Banded (sub,super) order extent) j = + bandedIndexFromOffset + Shape.indexFromOffset Shape.indexFromOffset + (integralFromProxy sub, integralFromProxy super) order + (Extent.dimensions extent) j + + uncheckedIndexFromOffset (Banded (sub,super) order extent) j = + bandedIndexFromOffset + Shape.uncheckedIndexFromOffset Shape.uncheckedIndexFromOffset + (integralFromProxy sub, integralFromProxy super) order + (Extent.dimensions extent) j + +outsideOffset :: Shape.C sh => sh -> Int -> Int +outsideOffset size k = if k<0 then k else Shape.size size + k + +bandedOffset :: + (Shape.Indexed height, Shape.Indexed width) => + (Int, Int) -> Order -> (height, width) -> + BandedIndex (Shape.Index height) (Shape.Index width) -> Int +bandedOffset (kl,ku) order (height,width) ix = + let k = kl+ku + in case ix of + InsideBox r c -> + let i = Shape.uncheckedOffset height r + j = Shape.uncheckedOffset width c + in case order of + RowMajor -> k*i + kl+j + ColumnMajor -> k*j + ku+i + VertOutsideBox r c -> + let i = outsideOffset height r + j = Shape.uncheckedOffset width c + in k*j + ku+i + HorizOutsideBox r c -> + let i = Shape.uncheckedOffset height r + j = outsideOffset width c + in k*i + kl+j + +bandedIndicesRowMajor :: + (Unary.Natural sub, Unary.Natural super, + Shape.Indexed height, Shape.Indexed width) => + (UnaryProxy sub, UnaryProxy super) -> + (height, width) -> + [(Shape.Index height, Either Int (Shape.Index width))] +bandedIndicesRowMajor (sub,super) (height,width) = + let kl = integralFromProxy sub + ku = integralFromProxy super + in concat $ + zipWith (\r -> map ((,) r)) (Shape.indices height) $ + map (take (kl+1+ku)) $ tails $ + (map Left $ take kl $ iterate (1+) (-kl)) ++ + (map Right $ Shape.indices width) ++ + (map Left $ iterate (1+) 0) + +bandedIndexFromOffset :: + (Shape.C height, Shape.C width) => + (height -> Int -> row) -> + (width -> Int -> column) -> + (Int,Int) -> Order -> (height,width) -> Int -> BandedIndex row column +bandedIndexFromOffset + rowFromOffset columnFromOffset (kl,ku) order (height,width) j = + case order of + RowMajor -> + let n = Shape.size width + (rb,cb) = divMod j (kl+1+ku) + r = rowFromOffset height rb + ci = rb+cb-kl + in if' (ci<0) (HorizOutsideBox r ci) $ + if' (ci>=n) (HorizOutsideBox r (ci-n)) $ + InsideBox r (columnFromOffset width ci) + ColumnMajor -> + let m = Shape.size height + (cb,rb) = divMod j (kl+1+ku) + c = columnFromOffset width cb + ri = rb+cb-ku + in if' (ri<0) (VertOutsideBox ri c) $ + if' (ri>=m) (VertOutsideBox (ri-m) c) $ + InsideBox (rowFromOffset height ri) c + + +data BandedHermitian off size = + BandedHermitian { + bandedHermitianOffDiagonals :: UnaryProxy off, + bandedHermitianOrder :: Order, + bandedHermitianSize :: size + } deriving (Eq, Show) + +type instance HeightOf (BandedHermitian off size) = size +type instance WidthOf (BandedHermitian off size) = size + +instance (Unary.Natural off, NFData size) => + NFData (BandedHermitian off size) where + rnf (BandedHermitian Proxy order size) = rnf (order, size) + +instance (Unary.Natural off, Shape.C size) => + Shape.C (BandedHermitian off size) where + size (BandedHermitian offDiag _order size) = + (1 + integralFromProxy offDiag) * Shape.size size + uncheckedSize (BandedHermitian offDiag _order size) = + (1 + integralFromProxy offDiag) * Shape.uncheckedSize size + +instance (Unary.Natural off, Shape.Indexed size) => + Shape.Indexed (BandedHermitian off size) where + type Index (BandedHermitian off size) = + BandedIndex (Shape.Index size) (Shape.Index size) + indices (BandedHermitian offDiag order size) = + case order of + RowMajor -> + map (\(r,c) -> either (HorizOutsideBox r) (InsideBox r) c) $ + bandedIndicesRowMajor (unary TypeNum.u0, offDiag) (size,size) + ColumnMajor -> + map (\(c,r) -> + either (flip VertOutsideBox c) (flip InsideBox c) r) $ + bandedIndicesRowMajor (offDiag, unary TypeNum.u0) (size,size) + + offset shape ix = + if Shape.inBounds shape ix + then Shape.uncheckedOffset shape ix + else error "BandedHermitian.offset: index outside band" + + uncheckedOffset (BandedHermitian offDiag order size) ix = + let k = integralFromProxy offDiag + in bandedOffset (0,k) order (size,size) ix + + inBounds (BandedHermitian offDiag order size) ix = + let ku = integralFromProxy offDiag + insideBand r c = Shape.inBounds (Shape.Range 0 ku) (c-r) + in case (order,ix) of + (_, InsideBox r c) -> + Shape.inBounds (size,size) (r,c) + && + insideBand (Shape.offset size r) (Shape.offset size c) + (RowMajor, HorizOutsideBox r c) -> + Shape.inBounds size r + && + insideBand (Shape.offset size r) (outsideOffset size c) + (ColumnMajor, VertOutsideBox r c) -> + Shape.inBounds size c + && + insideBand (outsideOffset size r) (Shape.offset size c) + _ -> False + +instance (Unary.Natural off, Shape.InvIndexed size) => + Shape.InvIndexed (BandedHermitian off size) where + + indexFromOffset (BandedHermitian offDiag order size) j = + bandedHermitianIndexFromOffset + Shape.indexFromOffset Shape.indexFromOffset + (integralFromProxy offDiag) order size j + + uncheckedIndexFromOffset (BandedHermitian offDiag order size) j = + bandedHermitianIndexFromOffset + Shape.uncheckedIndexFromOffset Shape.uncheckedIndexFromOffset + (integralFromProxy offDiag) order size j + +bandedHermitianIndexFromOffset :: + (Shape.C sh) => + (sh -> Int -> row) -> + (sh -> Int -> column) -> + Int -> Order -> sh -> Int -> BandedIndex row column +bandedHermitianIndexFromOffset rowFromOffset columnFromOffset k order size j = + case order of + RowMajor -> + let n = Shape.size size + (rb,cb) = divMod j (k+1) + r = rowFromOffset size rb + ci = rb+cb + in if ci + let (cb,rb) = divMod j (k+1) + c = columnFromOffset size cb + ri = rb+cb-k + in if ri>=0 + then InsideBox (rowFromOffset size ri) c + else VertOutsideBox ri c diff --git a/src/Numeric/LAPACK/Matrix/Square.hs b/src/Numeric/LAPACK/Matrix/Square.hs --- a/src/Numeric/LAPACK/Matrix/Square.hs +++ b/src/Numeric/LAPACK/Matrix/Square.hs @@ -1,202 +1,51 @@ module Numeric.LAPACK.Matrix.Square ( - Square, - size, - toGeneral, - fromGeneral, - fromScalar, - toScalar, - fromList, - autoFromList, - - transpose, - adjoint, - - identity, - identityFrom, - diagonal, - getDiagonal, - trace, + module Numeric.LAPACK.Matrix.Square.Basic, + module Numeric.LAPACK.Matrix.Square.Linear, - multiply, - square, - power, + eigenvalues, + Eigen.schur, + eigensystem, + ComplexOf, ) where +import qualified Numeric.LAPACK.Matrix.Square.Eigen as Eigen +import Numeric.LAPACK.Matrix.Square.Basic +import Numeric.LAPACK.Matrix.Square.Linear -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Vector as Vector -import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor)) -import Numeric.LAPACK.Matrix.Private (General, ZeroInt, zeroInt) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Private (zero, one) +import Numeric.LAPACK.Scalar (ComplexOf) -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.BLAS.FFI.Generic as BlasGen -import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class -import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Storable (Storable, peek, poke) -import System.IO.Unsafe (unsafePerformIO) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) - -import Data.Function.HT (powerAssociative) - - -type Square sh = Array (MatrixShape.Square sh) - -size :: Square sh a -> sh -size = MatrixShape.squareSize . Array.shape - -toGeneral :: Square sh a -> General sh sh a -toGeneral (Array sh a) = Array (MatrixShape.generalFromSquare sh) a - -fromGeneral :: (Eq sh) => General sh sh a -> Square sh a -fromGeneral (Array (MatrixShape.General order height width) a) = - if height==width - then Array (MatrixShape.Square order height) a - else error "Square.fromGeneral: no square shape" - - -fromScalar :: (Storable a) => a -> Square () a -fromScalar a = - Array.unsafeCreate (MatrixShape.Square RowMajor ()) $ flip poke a - -toScalar :: (Storable a) => Square () a -> a -toScalar (Array (MatrixShape.Square _ ()) a) = - unsafePerformIO $ withForeignPtr a peek - -fromList :: (Shape.C sh, Storable a) => sh -> [a] -> Square sh a -fromList sh = - Array.fromList (MatrixShape.Square RowMajor sh) - -autoFromList :: (Storable a) => [a] -> Square ZeroInt a -autoFromList xs = - let n = length xs - m = round $ sqrt (fromIntegral n :: Double) - in if n == m*m - then fromList (zeroInt m) xs - else error "Square.autoFromList: no quadratic number of elements" - - -transpose :: Square sh a -> Square sh a -transpose = Array.mapShape MatrixShape.transposeSquare +eigenvalues :: + (Shape.C sh, Class.Floating a) => + Square sh a -> Vector sh (ComplexOf a) +eigenvalues = Eigen.values {- | -conjugate transpose --} -adjoint :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a -adjoint = transpose . Vector.conjugate - - -identity :: (Shape.C sh, Class.Floating a) => sh -> Square sh a -identity = identityOrder ColumnMajor - -identityFrom :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a -identityFrom (Array (MatrixShape.Square order sh) _) = identityOrder order sh - -identityOrder, _identityOrder :: - (Shape.C sh, Class.Floating a) => Order -> sh -> Square sh a -identityOrder order sh = - Array.unsafeCreate (MatrixShape.Square order sh) $ \aPtr -> - evalContT $ do - uploPtr <- Call.char 'A' - nPtr <- Call.cint $ Shape.size sh - alphaPtr <- Call.number zero - betaPtr <- Call.number one - liftIO $ LapackGen.laset uploPtr nPtr nPtr alphaPtr betaPtr aPtr nPtr - -_identityOrder order sh = - Array.unsafeCreateWithSize (MatrixShape.Square order sh) $ \blockSize yPtr -> - evalContT $ do - nPtr <- Call.alloca - xPtr <- Call.number zero - incxPtr <- Call.cint 0 - incyPtr <- Call.cint 1 - liftIO $ do - poke nPtr $ fromIntegral blockSize - BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr - let n = fromIntegral $ Shape.size sh - poke nPtr n - poke xPtr one - poke incyPtr (n+1) - BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr - -diagonal :: (Shape.C sh, Class.Floating a) => Vector sh a -> Square sh a -diagonal (Array sh x) = - Array.unsafeCreateWithSize (MatrixShape.Square ColumnMajor sh) $ - \blockSize yPtr -> - evalContT $ do - nPtr <- Call.alloca - xPtr <- ContT $ withForeignPtr x - zPtr <- Call.number zero - incxPtr <- Call.cint 1 - incyPtr <- Call.cint 1 - inczPtr <- Call.cint 0 - liftIO $ do - poke nPtr $ fromIntegral blockSize - BlasGen.copy nPtr zPtr inczPtr yPtr incyPtr - let n = fromIntegral $ Shape.size sh - poke nPtr n - poke incyPtr (n+1) - BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr - -getDiagonal :: (Shape.C sh, Class.Floating a) => Square sh a -> Vector sh a -getDiagonal (Array (MatrixShape.Square _ sh) x) = - Array.unsafeCreateWithSize sh $ \n yPtr -> evalContT $ do - nPtr <- Call.cint n - xPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint (n+1) - incyPtr <- Call.cint 1 - liftIO $ BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr - -trace :: (Shape.C sh, Class.Floating a) => Square sh a -> a -trace (Array (MatrixShape.Square _ sh) x) = unsafePerformIO $ do - let n = Shape.size sh - withForeignPtr x $ \xPtr -> Private.sum n xPtr (n+1) - - -multiply :: - (Shape.C sh, Eq sh, Class.Floating a) => - Square sh a -> Square sh a -> Square sh a -multiply - (Array (MatrixShape.Square orderA shA) a) - (Array (MatrixShape.Square orderB shB) b) = - Array.unsafeCreate (MatrixShape.Square ColumnMajor shA) $ \cPtr -> do - Call.assert "Square.multiply: shapes mismatch" (shA == shB) - let n = Shape.size shA - Private.multiplyMatrix orderA orderB n n n a b cPtr +@(vr,d,vl) = eigensystem a@ -square :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a -square a = multiplyCommutativeUnchecked a a +Counterintuitively, @vr@ contains the right eigenvectors +and @vl@ contains the left eigenvectors as columns. +The idea is to provide a decomposition of @a@. +If @a@ is diagonalizable, then @vr@ and @vl@ are almost inverse to each other. +More precisely, @adjoint vl \<#\> vr@ is a diagonal matrix. +This is because all eigenvectors are normalized to Euclidean norm 1. +With the following scaling, the decomposition becomes perfect: -power :: - (Shape.C sh, Class.Floating a) => - Integer -> Square sh a -> Square sh a -power n a = - powerAssociative multiplyCommutativeUnchecked (identityFrom a) a n +> let scal = Array.map recip $ takeDiagonal $ adjoint vl <#> vr +> a == vr <#> diagonal d <#> diagonal scal <#> adjoint vl -{- -orderA and orderB must be equal but this is not checked. +If @a@ is non-diagonalizable then some columns of @vr@ and @vl@ are left zero +and the above property does not hold. -} -multiplyCommutativeUnchecked :: +eigensystem :: (Shape.C sh, Class.Floating a) => - Square sh a -> Square sh a -> Square sh a -multiplyCommutativeUnchecked - (Array shape@(MatrixShape.Square order sh) a) - (Array (MatrixShape.Square _order _sh) b) = - Array.unsafeCreate shape $ \cPtr -> - let n = Shape.size sh - (at,bt) = - case order of - ColumnMajor -> (a,b) - RowMajor -> (b,a) - in Private.multiplyMatrix ColumnMajor ColumnMajor n n n at bt cPtr + Square sh a -> + (Square sh (ComplexOf a), + Vector sh (ComplexOf a), + Square sh (ComplexOf a)) +eigensystem = Eigen.decompose diff --git a/src/Numeric/LAPACK/Matrix/Square/Basic.hs b/src/Numeric/LAPACK/Matrix/Square/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Square/Basic.hs @@ -0,0 +1,214 @@ +module Numeric.LAPACK.Matrix.Square.Basic ( + Square, + size, + toFull, + toGeneral, + fromGeneral, + fromScalar, + toScalar, + fromList, + autoFromList, + + transpose, + adjoint, + + identity, + identityFrom, + identityFromWidth, + identityFromHeight, + diagonal, + takeDiagonal, + trace, + + multiply, + square, + power, + ) where + + +import qualified Numeric.LAPACK.Matrix.Multiply as Mult +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor, ColumnMajor), swapOnRowMajor) +import Numeric.LAPACK.Matrix.Private + (Full, mapExtent, + General, argGeneral, Square, argSquare, ZeroInt, zeroInt) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private (pokeCInt) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (Storable, peek, poke) + +import System.IO.Unsafe (unsafePerformIO) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + +import Data.Function.HT (powerAssociative) + + +size :: Square sh a -> sh +size = MatrixShape.fullHeight . Array.shape + +toGeneral :: Square sh a -> General sh sh a +toGeneral = toFull + +toFull :: + (Extent.C vert, Extent.C horiz) => Square sh a -> Full vert horiz sh sh a +toFull = mapExtent Extent.fromSquare + +fromGeneral :: (Eq sh) => General sh sh a -> Square sh a +fromGeneral = mapExtent (ExtentPriv.Map ExtentPriv.squareFromGeneral) + + +fromScalar :: (Storable a) => a -> Square () a +fromScalar a = + Array.unsafeCreate (MatrixShape.square RowMajor ()) $ flip poke a + +toScalar :: (Storable a) => Square () a -> a +toScalar = argSquare $ \_ () a -> + unsafePerformIO $ withForeignPtr a peek + +fromList :: (Shape.C sh, Storable a) => sh -> [a] -> Square sh a +fromList sh = + Array.fromList (MatrixShape.square RowMajor sh) + +autoFromList :: (Storable a) => [a] -> Square ZeroInt a +autoFromList xs = + let n = length xs + m = round $ sqrt (fromIntegral n :: Double) + in if n == m*m + then fromList (zeroInt m) xs + else error "Square.autoFromList: no quadratic number of elements" + + +transpose :: Square sh a -> Square sh a +transpose = Array.mapShape MatrixShape.transpose + +{- | +conjugate transpose +-} +adjoint :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a +adjoint = transpose . Vector.conjugate + + +identity :: (Shape.C sh, Class.Floating a) => sh -> Square sh a +identity = identityOrder ColumnMajor + +identityFrom :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a +identityFrom = argSquare $ \order sh _ -> identityOrder order sh + +identityFromWidth :: + (Shape.C height, Shape.C width, Class.Floating a) => + General height width a -> Square width a +identityFromWidth = + argGeneral $ \order _ width _ -> identityOrder order width + +identityFromHeight :: + (Shape.C height, Shape.C width, Class.Floating a) => + General height width a -> Square height a +identityFromHeight = + argGeneral $ \order height _ _ -> identityOrder order height + +identityOrder, _identityOrder :: + (Shape.C sh, Class.Floating a) => Order -> sh -> Square sh a +identityOrder order sh = + Array.unsafeCreate (MatrixShape.square order sh) $ \aPtr -> + evalContT $ do + uploPtr <- Call.char 'A' + nPtr <- Call.cint $ Shape.size sh + alphaPtr <- Call.number zero + betaPtr <- Call.number one + liftIO $ LapackGen.laset uploPtr nPtr nPtr alphaPtr betaPtr aPtr nPtr + +_identityOrder order sh = + Array.unsafeCreateWithSize (MatrixShape.square order sh) $ \blockSize yPtr -> + evalContT $ do + nPtr <- Call.alloca + xPtr <- Call.number zero + incxPtr <- Call.cint 0 + incyPtr <- Call.cint 1 + liftIO $ do + pokeCInt nPtr blockSize + BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr + let n = fromIntegral $ Shape.size sh + poke nPtr n + poke xPtr one + poke incyPtr (n+1) + BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr + +diagonal :: (Shape.C sh, Class.Floating a) => Vector sh a -> Square sh a +diagonal (Array sh x) = + Array.unsafeCreateWithSize (MatrixShape.square ColumnMajor sh) $ + \blockSize yPtr -> + evalContT $ do + nPtr <- Call.alloca + xPtr <- ContT $ withForeignPtr x + zPtr <- Call.number zero + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 1 + inczPtr <- Call.cint 0 + liftIO $ do + pokeCInt nPtr blockSize + BlasGen.copy nPtr zPtr inczPtr yPtr incyPtr + let n = fromIntegral $ Shape.size sh + poke nPtr n + poke incyPtr (n+1) + BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr + +takeDiagonal :: (Shape.C sh, Class.Floating a) => Square sh a -> Vector sh a +takeDiagonal = argSquare $ \_ sh x -> + Array.unsafeCreateWithSize sh $ \n yPtr -> evalContT $ do + nPtr <- Call.cint n + xPtr <- ContT $ withForeignPtr x + incxPtr <- Call.cint (n+1) + incyPtr <- Call.cint 1 + liftIO $ BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr + +trace :: (Shape.C sh, Class.Floating a) => Square sh a -> a +trace = argSquare $ \_ sh x -> unsafePerformIO $ do + let n = Shape.size sh + withForeignPtr x $ \xPtr -> Private.sum n xPtr (n+1) + + +multiply :: + (Shape.C sh, Eq sh, Class.Floating a) => + Square sh a -> Square sh a -> Square sh a +multiply = Mult.multiply + +square :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a +square a = multiplyCommutativeUnchecked a a + +power :: + (Shape.C sh, Class.Floating a) => + Integer -> Square sh a -> Square sh a +power n a = + powerAssociative multiplyCommutativeUnchecked (identityFrom a) a n + +{- +orderA and orderB must be equal but this is not checked. +-} +multiplyCommutativeUnchecked :: + (Shape.C sh, Class.Floating a) => + Square sh a -> Square sh a -> Square sh a +multiplyCommutativeUnchecked + (Array shape@(MatrixShape.Full order extent) a) + (Array _ b) = + Array.unsafeCreate shape $ \cPtr -> + let n = Shape.size $ Extent.height extent + (at,bt) = swapOnRowMajor order (a,b) + in Private.multiplyMatrix ColumnMajor ColumnMajor n n n at bt cPtr diff --git a/src/Numeric/LAPACK/Matrix/Square/Eigen.hs b/src/Numeric/LAPACK/Matrix/Square/Eigen.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Square/Eigen.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Square.Eigen ( + values, + schur, + decompose, + ComplexOf, + ) where + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), swapOnRowMajor) +import Numeric.LAPACK.Matrix.Private (Square, argSquare) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (ComplexOf, RealOf, zero) +import Numeric.LAPACK.Private + (copyConjugate, copyToTemp, copyToColumnMajor, + withAutoWorkspaceInfo) + +import qualified Numeric.LAPACK.FFI.Complex as LapackComplex +import qualified Numeric.LAPACK.FFI.Real as LapackReal +import qualified Numeric.BLAS.FFI.Real as BlasReal +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) + +import Foreign.Marshal.Array (advancePtr, peekArray) +import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, nullPtr, nullFunPtr, castPtr) +import Foreign.Storable (Storable) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + +import Data.Complex (Complex) + + +values :: + (Shape.C sh, Class.Floating a) => + Square sh a -> Vector sh (ComplexOf a) +values = + getValues $ + Class.switchFloating + (Values valuesAux) (Values valuesAux) + (Values valuesAux) (Values valuesAux) + +type Values_ sh a = Square sh a -> Vector sh (ComplexOf a) + +newtype Values sh a = Values {getValues :: Values_ sh a} + +valuesAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + Values_ sh a +valuesAux = argSquare $ \_order size a -> + Array.unsafeCreateWithSize size $ \n wPtr -> do + let lda = n + evalContT $ do + jobvsPtr <- Call.char 'N' + sortPtr <- Call.char 'N' + aPtr <- copyToTemp (n*n) a + ldaPtr <- Call.leadingDim lda + sdimPtr <- Call.alloca + let vsPtr = nullPtr + ldvsPtr <- Call.leadingDim n + let bworkPtr = nullPtr + liftIO $ + withAutoWorkspaceInfo eigenMsg "gees" $ \workPtr lworkPtr infoPtr -> + gees + jobvsPtr sortPtr n aPtr ldaPtr sdimPtr + wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr + + +{- | +If @(q,r) = schur a@, then @a = q \<#\> r \<#\> adjoint q@, +where @q@ is unitary (orthogonal) +and @r@ is a right-upper triangular matrix for complex @a@ +and a 1x1-or-2x2-block upper triangular matrix for real @a@. +With @takeDiagonal r@ you get all eigenvalues of @a@ if @a@ is complex +and the real parts of the eigenvalues if @a@ is real. +Complex conjugated eigenvalues of a real matrix @a@ +are encoded as 2x2 blocks along the diagonal. +-} +schur :: + (Shape.C sh, Class.Floating a) => + Square sh a -> (Square sh a, Square sh a) +schur = + getSchur $ + Class.switchFloating + (Schur schurAux) (Schur schurAux) + (Schur schurAux) (Schur schurAux) + +type Schur_ sh a = Square sh a -> (Square sh a, Square sh a) + +newtype Schur sh a = Schur {getSchur :: Schur_ sh a} + +schurAux :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + Schur_ sh a +schurAux = argSquare $ \order size a -> + let sh = MatrixShape.square ColumnMajor size + in Array.unsafeCreateWithSizeAndResult sh $ \_ vsPtr -> + ArrayIO.unsafeCreate sh $ \sPtr -> do + + let n = Shape.size size + let lda = n + evalContT $ do + jobvsPtr <- Call.char 'V' + sortPtr <- Call.char 'N' + aPtr <- ContT $ withForeignPtr a + liftIO $ copyToColumnMajor order n n aPtr sPtr + ldaPtr <- Call.leadingDim lda + sdimPtr <- Call.alloca + wPtr <- Call.allocaArray n + ldvsPtr <- Call.leadingDim n + let bworkPtr = nullPtr + liftIO $ + withAutoWorkspaceInfo eigenMsg "gees" $ \workPtr lworkPtr infoPtr -> + gees + jobvsPtr sortPtr n sPtr ldaPtr sdimPtr + wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr + + + +type GEES_ ar a = + Ptr CChar -> Ptr CChar -> Int -> Ptr a -> Ptr CInt -> + Ptr CInt -> Ptr (Complex ar) -> Ptr a -> Ptr CInt -> + Ptr a -> Ptr CInt -> Ptr Bool -> Ptr CInt -> IO () + +newtype GEES a = GEES {getGEES :: GEES_ (RealOf a) a} + +gees :: Class.Floating a => GEES_ (RealOf a) a +gees = + getGEES $ + Class.switchFloating + (GEES geesReal) (GEES geesReal) (GEES geesComplex) (GEES geesComplex) + +geesReal :: Class.Real a => GEES_ a a +geesReal + jobvsPtr sortPtr n aPtr ldaPtr sdimPtr + wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr = + evalContT $ do + let selectPtr = nullFunPtr + nPtr <- Call.cint n + wrPtr <- Call.allocaArray n + wiPtr <- Call.allocaArray n + liftIO $ + LapackReal.gees + jobvsPtr sortPtr selectPtr nPtr aPtr ldaPtr sdimPtr + wrPtr wiPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr + liftIO $ zipComplex n wrPtr wiPtr wPtr + +geesComplex :: Class.Real a => GEES_ a (Complex a) +geesComplex + jobvsPtr sortPtr n aPtr ldaPtr sdimPtr + wPtr vsPtr ldvsPtr workPtr lworkPtr bworkPtr infoPtr = + evalContT $ do + let selectPtr = nullFunPtr + nPtr <- Call.cint n + rworkPtr <- Call.allocaArray n + liftIO $ + LapackComplex.gees + jobvsPtr sortPtr selectPtr nPtr aPtr ldaPtr sdimPtr + wPtr vsPtr ldvsPtr workPtr lworkPtr rworkPtr bworkPtr infoPtr + + + +decompose :: + (Shape.C sh, Class.Floating a) => + Square sh a -> + (Square sh (ComplexOf a), + Vector sh (ComplexOf a), + Square sh (ComplexOf a)) +decompose = + getDecompose $ + Class.switchFloating + (Decompose decomposeReal) + (Decompose decomposeReal) + (Decompose decomposeComplex) + (Decompose decomposeComplex) + +newtype Decompose sh a = + Decompose { + getDecompose :: + Square sh a -> + (Square sh (ComplexOf a), + Vector sh (ComplexOf a), + Square sh (ComplexOf a)) + } + +decomposeReal :: + (Shape.C sh, Class.Real a) => + Square sh a -> + (Square sh (Complex a), Vector sh (Complex a), Square sh (Complex a)) +decomposeReal = argSquare $ \order size a -> + (\(w, (vlc,vrc)) -> (vlc, w, vrc)) $ + Array.unsafeCreateWithSizeAndResult size $ \n wPtr -> + evalContT $ do + jobvlPtr <- Call.char 'V' + jobvrPtr <- Call.char 'V' + nPtr <- Call.cint n + aPtr <- copyToTemp (n*n) a + ldaPtr <- Call.leadingDim n + wrPtr <- Call.allocaArray n + wiPtr <- Call.allocaArray n + vlPtr <- Call.allocaArray (n*n) + ldvlPtr <- Call.leadingDim n + vrPtr <- Call.allocaArray (n*n) + ldvrPtr <- Call.leadingDim n + liftIO $ withAutoWorkspaceInfo eigenMsg "geev" $ + LapackReal.geev + jobvlPtr jobvrPtr nPtr aPtr ldaPtr + wrPtr wiPtr vlPtr ldvlPtr vrPtr ldvrPtr + liftIO $ zipComplex n wrPtr wiPtr wPtr + liftIO $ createArrayPair order (MatrixShape.square ColumnMajor size) $ + \vlcPtr vrcPtr -> do + eigenvectorsToComplex n wiPtr vlPtr vlcPtr + eigenvectorsToComplex n wiPtr vrPtr vrcPtr + +eigenvectorsToComplex :: + (Eq a, Class.Real a) => + Int -> Ptr a -> Ptr a -> Ptr (Complex a) -> IO () +eigenvectorsToComplex n wiPtr vPtr vcPtr = evalContT $ do + nPtr <- Call.cint n + zeroPtr <- Call.real zero + inc0Ptr <- Call.cint 0 + inc1Ptr <- Call.cint 1 + inc2Ptr <- Call.cint 2 + liftIO $ do + let go _ _ [] = return () + go xPtr yPtr (False:wi) = do + let yrPtr = castPtr yPtr + let yiPtr = advancePtr yrPtr 1 + BlasReal.copy nPtr xPtr inc1Ptr yrPtr inc2Ptr + BlasReal.copy nPtr zeroPtr inc0Ptr yiPtr inc2Ptr + go (advancePtr xPtr n) (advancePtr yPtr n) wi + go xPtr yPtr (True:True:wi) = do + let xrPtr = xPtr + let xiPtr = advancePtr xPtr n + let yrPtr = castPtr yPtr + let yiPtr = advancePtr yrPtr 1 + let y1Ptr = advancePtr yPtr n + BlasReal.copy nPtr xrPtr inc1Ptr yrPtr inc2Ptr + BlasReal.copy nPtr xiPtr inc1Ptr yiPtr inc2Ptr + copyConjugate nPtr yPtr inc1Ptr y1Ptr inc1Ptr + go (advancePtr xPtr (2*n)) (advancePtr yPtr (2*n)) wi + go _xPtr _yPtr wi = + error $ "eigenvectorToComplex: invalid non-real pattern " ++ show wi + go vPtr vcPtr . map (zero/=) =<< peekArray n wiPtr + +decomposeComplex :: + (Shape.C sh, Class.Real a) => + Square sh (Complex a) -> + (Square sh (Complex a), Vector sh (Complex a), Square sh (Complex a)) +decomposeComplex = argSquare $ \order size a -> + (\(w, (vlc,vrc)) -> (vlc, w, vrc)) $ + Array.unsafeCreateWithSizeAndResult size $ \n wPtr -> + evalContT $ do + jobvlPtr <- Call.char 'V' + jobvrPtr <- Call.char 'V' + nPtr <- Call.cint n + aPtr <- copyToTemp (n*n) a + ldaPtr <- Call.leadingDim n + ldvlPtr <- Call.leadingDim n + ldvrPtr <- Call.leadingDim n + rworkPtr <- Call.allocaArray (2*n) + + liftIO $ createArrayPair order (MatrixShape.square ColumnMajor size) $ + \vlPtr vrPtr -> + + withAutoWorkspaceInfo eigenMsg "geev" $ \workPtr lworkPtr infoPtr -> + LapackComplex.geev + jobvlPtr jobvrPtr nPtr aPtr ldaPtr + wPtr vlPtr ldvlPtr vrPtr ldvrPtr + workPtr lworkPtr rworkPtr infoPtr + + +zipComplex :: + (Class.Real a) => Int -> Ptr a -> Ptr a -> Ptr (Complex a) -> IO () +zipComplex n vr vi vc = + evalContT $ do + nPtr <- Call.cint n + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 2 + let yPtr = castPtr vc + liftIO $ BlasReal.copy nPtr vr incxPtr yPtr incyPtr + liftIO $ BlasReal.copy nPtr vi incxPtr (advancePtr yPtr 1) incyPtr + +createArrayPair :: + (Shape.C sh, Storable a) => + Order -> sh -> (Ptr a -> Ptr a -> IO ()) -> + IO (Array sh a, Array sh a) +createArrayPair order sh act = + fmap (swapOnRowMajor order) $ + ArrayIO.unsafeCreateWithSizeAndResult sh $ \_ vrcPtr -> + ArrayIO.unsafeCreate sh $ \vlcPtr -> act vlcPtr vrcPtr + + +eigenMsg :: String +eigenMsg = "only eigenvalues starting with the %d-th one converged" diff --git a/src/Numeric/LAPACK/Matrix/Square/Linear.hs b/src/Numeric/LAPACK/Matrix/Square/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Square/Linear.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Square.Linear ( + solve, + inverse, + determinant, + ) where + +import Numeric.LAPACK.Matrix.Private (Full, Square, argSquare) + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Split as Split +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Linear.Private + (solver, withDeterminantInfo, withInfo, diagonalMsg) +import Numeric.LAPACK.Matrix.Shape.Private (transposeFromOrder) +import Numeric.LAPACK.Private + (withAutoWorkspaceInfo, copyBlock, copyToTemp, copyToColumnMajor) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.Marshal.Array (peekArray) +import Foreign.ForeignPtr (withForeignPtr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (when) + + +solve, _solve :: + (Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Square sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solve = + argSquare $ \orderA shA a -> + solver "Square.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + transPtr <- Call.char $ transposeFromOrder orderA + aPtr <- copyToTemp (n*n) a + ldaPtr <- Call.leadingDim n + ipivPtr <- Call.allocaArray n + liftIO $ do + withInfo "getrf" $ + LapackGen.getrf nPtr nPtr aPtr ldaPtr ipivPtr + withInfo "getrs" $ + LapackGen.getrs transPtr nPtr nrhsPtr + aPtr ldaPtr ipivPtr xPtr ldxPtr + +_solve = + argSquare $ \orderA shA a -> + solver "Square.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + aPtr <- ContT $ withForeignPtr a + atmpPtr <- Call.allocaArray (n*n) + ldaPtr <- Call.leadingDim n + ipivPtr <- Call.allocaArray n + liftIO $ do + copyToColumnMajor orderA n n aPtr atmpPtr + withInfo "gesv" $ + LapackGen.gesv nPtr nrhsPtr atmpPtr ldaPtr ipivPtr xPtr ldxPtr + + +inverse :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a +inverse (Array shape@(MatrixShape.Full _order extent) a) = + Array.unsafeCreateWithSize shape $ \blockSize bPtr -> do + let n = Shape.size $ Extent.squareSize extent + evalContT $ do + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + ldbPtr <- Call.leadingDim n + ipivPtr <- Call.allocaArray n + liftIO $ when (n>0) $ do + copyBlock blockSize aPtr bPtr + withInfo "getrf" $ LapackGen.getrf nPtr nPtr bPtr ldbPtr ipivPtr + withAutoWorkspaceInfo diagonalMsg "getri" $ + LapackGen.getri nPtr bPtr ldbPtr ipivPtr + + +determinant :: (Shape.C sh, Class.Floating a) => Square sh a -> a +determinant = argSquare $ \_order sh a -> unsafePerformIO $ do + let n = Shape.size sh + evalContT $ do + nPtr <- Call.cint n + aPtr <- copyToTemp (n*n) a + ldaPtr <- Call.leadingDim n + ipivPtr <- Call.allocaArray n + liftIO $ withDeterminantInfo "getrf" + (LapackGen.getrf nPtr nPtr aPtr ldaPtr ipivPtr) + (do + det <- Private.product n aPtr (n+1) + ipiv <- peekArray n ipivPtr + return $ if Split.oddPermutation ipiv then -det else det) diff --git a/src/Numeric/LAPACK/Matrix/Symmetric/Private.hs b/src/Numeric/LAPACK/Matrix/Symmetric/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Symmetric/Private.hs @@ -0,0 +1,158 @@ +module Numeric.LAPACK.Matrix.Symmetric.Private where + +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Triangular.Private + (diagonalPointerPairs, columnMajorPointers, rowMajorPointers, + forPointers, pack, unpackToTemp, copyTriangleToTemp) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), uploFromOrder, triangleSize) +import Numeric.LAPACK.Matrix.Private + (Full, Conjugation(NonConjugated, Conjugated)) +import Numeric.LAPACK.Linear.Private (solver, withDeterminantInfo, withInfo) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private (copyBlock, copyToTemp, copyCondConjugate) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Shape as Shape + +import Foreign.Marshal.Array (advancePtr) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable, peek) + +import qualified System.IO.Lazy as LazyIO + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Applicative ((<$>)) + + +unpack :: Class.Floating a => + Conjugation -> Order -> Int -> Ptr a -> Ptr a -> IO () +unpack conj order n packedPtr fullPtr = evalContT $ do + incxPtr <- Call.cint 1 + incyPtr <- Call.cint n + liftIO $ case order of + RowMajor -> + forPointers (rowMajorPointers n fullPtr packedPtr) $ + \nPtr (dstPtr,srcPtr) -> do + copyCondConjugate (conj==Conjugated) + nPtr srcPtr incxPtr dstPtr incyPtr + BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr + ColumnMajor -> + forPointers (columnMajorPointers n fullPtr packedPtr) $ + \nPtr ((dstRowPtr,dstColumnPtr),srcPtr) -> do + copyCondConjugate (conj==Conjugated) + nPtr srcPtr incxPtr dstRowPtr incyPtr + BlasGen.copy nPtr srcPtr incxPtr dstColumnPtr incxPtr + + +square :: + (Class.Floating a) => + Conjugation -> Order -> Int -> ForeignPtr a -> Ptr a -> IO () +square conj order n a bpPtr = + evalContT $ do + sidePtr <- Call.char 'L' + uploPtr <- Call.char 'U' + nPtr <- Call.cint n + ldPtr <- Call.leadingDim n + aPtr <- unpackToTemp (unpack conj order) n a + bPtr <- Call.allocaArray (n*n) + alphaPtr <- Call.number one + betaPtr <- Call.number zero + liftIO $ do + (if conj==Conjugated then BlasGen.hemm else BlasGen.symm) + sidePtr uploPtr + nPtr nPtr alphaPtr aPtr ldPtr + aPtr ldPtr betaPtr bPtr ldPtr + pack order n bPtr bpPtr + + +solve :: + (Extent.C vert, Extent.C horiz, + Shape.C width, Shape.C height, Eq height, Class.Floating a) => + String -> Conjugation -> Order -> height -> ForeignPtr a -> + Full vert horiz height width a -> + Full vert horiz height width a +solve name conj order sh a = + solver name sh $ \n nPtr nrhsPtr xPtr ldxPtr -> do + uploPtr <- Call.char $ uploFromOrder order + apPtr <- copyTriangleToTemp conj order (triangleSize n) a + ipivPtr <- Call.allocaArray n + liftIO $ + let (lapackName,slv) = + case conj of + Conjugated -> ("hpsv", LapackGen.hpsv) + NonConjugated -> ("spsv", LapackGen.spsv) + in withInfo lapackName $ + slv uploPtr nPtr nrhsPtr apPtr ipivPtr xPtr ldxPtr + + +inverse :: + Class.Floating a => + Conjugation -> Order -> Int -> ForeignPtr a -> Int -> Ptr a -> IO () +inverse conj order n a triSize bPtr = evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + ipivPtr <- Call.allocaArray n + workPtr <- Call.allocaArray n + liftIO $ do + copyBlock triSize aPtr bPtr + case conj of + Conjugated -> do + withInfo "hptrf" $ LapackGen.hptrf uploPtr nPtr bPtr ipivPtr + withInfo "hptri" $ LapackGen.hptri uploPtr nPtr bPtr ipivPtr workPtr + NonConjugated -> do + withInfo "sptrf" $ LapackGen.sptrf uploPtr nPtr bPtr ipivPtr + withInfo "sptri" $ LapackGen.sptri uploPtr nPtr bPtr ipivPtr workPtr + + +blockDiagonalPointers :: + (Storable a) => + Order -> [(Ptr CInt, Ptr a)] -> LazyIO.T [(Ptr a, Maybe (Ptr a, Ptr a))] +blockDiagonalPointers order = + let go ((ipiv0Ptr,a0Ptr):ptrs0) = do + ipiv <- LazyIO.interleave $ peek ipiv0Ptr + (ext,ptrTuples) <- + if ipiv >= 0 + then (,) Nothing <$> go ptrs0 + else + case ptrs0 of + [] -> error "Symmetric.determinant: incomplete 2x2 block" + (_ipiv1Ptr,a1Ptr):ptrs1 -> + let bPtr = + case order of + ColumnMajor -> advancePtr a1Ptr (-1) + RowMajor -> advancePtr a0Ptr 1 + in (,) (Just (a1Ptr,bPtr)) <$> go ptrs1 + return $ (a0Ptr,ext) : ptrTuples + go [] = return [] + in go + +determinant :: + (Class.Floating a, Class.Floating ar) => + Conjugation -> ((Ptr a, Maybe (Ptr a, Ptr a)) -> IO ar) -> + Order -> Int -> ForeignPtr a -> IO ar +determinant conj peekBlockDeterminant order n a = evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + aPtr <- copyToTemp (triangleSize n) a + ipivPtr <- Call.allocaArray n + let (name,trf) = + case conj of + Conjugated -> ("hptrf", LapackGen.hptrf) + NonConjugated -> ("sptrf", LapackGen.sptrf) + liftIO $ withDeterminantInfo name + (trf uploPtr nPtr aPtr ipivPtr) + (((return $!) =<<) $ + LazyIO.run + (fmap product $ + mapM (LazyIO.interleave . peekBlockDeterminant) =<< + blockDiagonalPointers order + (diagonalPointerPairs order n ipivPtr aPtr))) diff --git a/src/Numeric/LAPACK/Matrix/Triangular.hs b/src/Numeric/LAPACK/Matrix/Triangular.hs --- a/src/Numeric/LAPACK/Matrix/Triangular.hs +++ b/src/Numeric/LAPACK/Matrix/Triangular.hs @@ -1,315 +1,58 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Numeric.LAPACK.Matrix.Triangular ( - Triangular, MatrixShape.Uplo(..), - Upper, Lower, - fromList, autoFromList, - lowerFromList, autoLowerFromList, - upperFromList, autoUpperFromList, - identity, - diagonal, - getDiagonal, - transposeUp, transposeDown, - adjointUp, adjointDown, - - toSquare, + module Numeric.LAPACK.Matrix.Triangular.Basic, + module Numeric.LAPACK.Matrix.Triangular.Linear, + size, - multiplyVectorLeft, - multiplyVectorRight, - square, - multiply, - multiplySquareLeft, - multiplyGeneralLeft, - multiplySquareRight, - multiplyGeneralRight, + eigenvalues, + eigensystem, ) where +import qualified Numeric.LAPACK.Matrix.Triangular.Eigen as Eigen +import Numeric.LAPACK.Matrix.Triangular.Basic +import Numeric.LAPACK.Matrix.Triangular.Linear + import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Triangular.Private - (diagonalPointers, pack, unpack, unpackZero, unpackToTemp) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), - flipOrder, transposeFromOrder, uploFromOrder, uploOrder) -import Numeric.LAPACK.Matrix.Square (Square) -import Numeric.LAPACK.Matrix.Private (General, ZeroInt, zeroInt) +import Numeric.LAPACK.Matrix.Shape.Private (NonUnit) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Private (fill, zero, one, copyBlock) -import qualified Numeric.BLAS.FFI.Generic as BlasGen -import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class -import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable, poke, peek) -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) - -import Data.Foldable (forM_) - - -type Triangular uplo sh = Array (MatrixShape.Triangular uplo sh) - -type Lower sh = Array (MatrixShape.LowerTriangular sh) -type Upper sh = Array (MatrixShape.UpperTriangular sh) - -transposeUp :: Lower sh a -> Upper sh a -transposeUp (Array sh a) = - Array (MatrixShape.triangularTransposeUp sh) a - -transposeDown :: Upper sh a -> Lower sh a -transposeDown (Array sh a) = - Array (MatrixShape.triangularTransposeDown sh) a - -adjointUp :: (Shape.C sh, Class.Floating a) => Lower sh a -> Upper sh a -adjointUp = Vector.conjugate . transposeUp - -adjointDown :: (Shape.C sh, Class.Floating a) => Upper sh a -> Lower sh a -adjointDown = Vector.conjugate . transposeDown - - -fromList :: - (MatrixShape.Uplo uplo, Shape.C sh, Storable a) => - Order -> sh -> [a] -> Triangular uplo sh a -fromList order sh = - Array.fromList (MatrixShape.Triangular MatrixShape.autoUplo order sh) - -lowerFromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Lower sh a -lowerFromList = fromList - -upperFromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Upper sh a -upperFromList = fromList - - -autoFromList :: - (MatrixShape.Uplo uplo, Storable a) => - Order -> [a] -> Triangular uplo ZeroInt a -autoFromList order xs = - fromList order - (zeroInt $ MatrixShape.triangleExtent "Triangular.autoFromList" $ - length xs) - xs - -autoLowerFromList :: (Storable a) => Order -> [a] -> Lower ZeroInt a -autoLowerFromList = autoFromList - -autoUpperFromList :: (Storable a) => Order -> [a] -> Upper ZeroInt a -autoUpperFromList = autoFromList - - -toSquare :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Triangular uplo sh a -> Square sh a -toSquare (Array (MatrixShape.Triangular uplo order sh) a) = - Array.unsafeCreate (MatrixShape.Square order sh) $ \bPtr -> - withForeignPtr a $ \aPtr -> - unpackZero (uploOrder uplo order) (Shape.size sh) aPtr bPtr - - -identity :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Order -> sh -> Triangular uplo sh a -identity order sh = - let (realOrder, uplo) = autoUploOrder order - in Array.unsafeCreate (MatrixShape.Triangular uplo order sh) $ \aPtr -> do - let n = Shape.size sh - fill zero (MatrixShape.triangleSize n) aPtr - forM_ (diagonalPointers realOrder n aPtr aPtr) $ flip poke one . snd - -diagonal :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Order -> Vector sh a -> Triangular uplo sh a -diagonal order (Array sh x) = - let (realOrder, uplo) = autoUploOrder order - in Array.unsafeCreate (MatrixShape.Triangular uplo order sh) $ \aPtr -> do - let n = Shape.size sh - fill zero (MatrixShape.triangleSize n) aPtr - withForeignPtr x $ \xPtr -> - forM_ (diagonalPointers realOrder n xPtr aPtr) $ - \(srcPtr,dstPtr) -> poke dstPtr =<< peek srcPtr - -getDiagonal :: - (MatrixShape.Uplo uplo, Shape.C sh, Class.Floating a) => - Triangular uplo sh a -> Vector sh a -getDiagonal (Array (MatrixShape.Triangular uplo order sh) a) = - Array.unsafeCreate sh $ \xPtr -> do - withForeignPtr a $ \aPtr -> - mapM_ - (\(dstPtr,srcPtr) -> poke dstPtr =<< peek srcPtr) - (diagonalPointers (uploOrder uplo order) (Shape.size sh) xPtr aPtr) - - -multiplyVectorLeft, multiplyVectorRight :: - (MatrixShape.Uplo uplo, Shape.C sh, Eq sh, Class.Floating a) => - Triangular uplo sh a -> Vector sh a -> Vector sh a -multiplyVectorLeft = multiplyVector True -multiplyVectorRight = multiplyVector False - -multiplyVector :: - (MatrixShape.Uplo uplo, Shape.C sh, Eq sh, Class.Floating a) => - Bool -> Triangular uplo sh a -> Vector sh a -> Vector sh a -multiplyVector transp - (Array (MatrixShape.Triangular uplo order shA) a) (Array shX x) = - Array.unsafeCreate shX $ \yPtr -> do - Call.assert "Triangular.multiplyVector: width shapes mismatch" (shA == shX) - let n = Shape.size shA - evalContT $ do - uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo order - transPtr <- - Call.char $ transposeFromOrder $ - (if transp then flipOrder else id) order - diagPtr <- Call.char 'N' - nPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - xPtr <- ContT $ withForeignPtr x - incyPtr <- Call.cint 1 - liftIO $ do - copyBlock n xPtr yPtr - BlasGen.tpmv uploPtr transPtr diagPtr nPtr aPtr yPtr incyPtr +size :: Triangular lo diag up sh a -> sh +size = MatrixShape.triangularSize . Array.shape -square :: - (MatrixShape.Uplo uplo, Shape.C sh, Eq sh, Class.Floating a) => - Triangular uplo sh a -> Triangular uplo sh a -square - (Array shape@(MatrixShape.Triangular uplo order sh) a) = - Array.unsafeCreate shape $ \bpPtr -> do - let n = Shape.size sh - evalContT $ do - sidePtr <- Call.char 'L' - let realOrder = uploOrder uplo order - uploPtr <- Call.char $ uploFromOrder realOrder - transPtr <- Call.char 'N' - diagPtr <- Call.char 'N' - nPtr <- Call.cint n - let ldPtr = nPtr - aPtr <- unpackToTemp (unpack realOrder) n a - bPtr <- unpackToTemp (unpackZero realOrder) n a - alphaPtr <- Call.number one - liftIO $ do - BlasGen.trmm sidePtr uploPtr transPtr diagPtr - nPtr nPtr alphaPtr aPtr ldPtr bPtr ldPtr - pack realOrder n bPtr bpPtr - -multiply :: - (MatrixShape.Uplo uplo, Shape.C sh, Eq sh, Class.Floating a) => - Triangular uplo sh a -> Triangular uplo sh a -> Triangular uplo sh a -multiply - (Array (MatrixShape.Triangular uploA orderA shA) a) - (Array shapeB@(MatrixShape.Triangular uploB orderB shB) b) = - Array.unsafeCreate shapeB $ \cpPtr -> do - Call.assert "Triangular.multiply: width shapes mismatch" (shA == shB) - let n = Shape.size shA - evalContT $ do - let (side,trans) = - case orderB of - ColumnMajor -> ('L', orderA) - RowMajor -> ('R', flipOrder orderA) - sidePtr <- Call.char side - let realOrderA = uploOrder uploA orderA - let realOrderB = uploOrder uploB orderB - uploPtr <- Call.char $ uploFromOrder realOrderA - transPtr <- Call.char $ transposeFromOrder trans - diagPtr <- Call.char 'N' - nPtr <- Call.cint n - let ldPtr = nPtr - aPtr <- unpackToTemp (unpack realOrderA) n a - bPtr <- unpackToTemp (unpackZero realOrderB) n b - alphaPtr <- Call.number one - liftIO $ do - BlasGen.trmm sidePtr uploPtr transPtr diagPtr - nPtr nPtr alphaPtr aPtr ldPtr bPtr ldPtr - pack realOrderB n bPtr cpPtr +eigenvalues :: + (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> Vector sh a +eigenvalues = Eigen.values -multiplySquareLeft :: - (MatrixShape.Uplo uplo, Shape.C sh, Eq sh, Class.Floating a) => - Square sh a -> Triangular uplo sh a -> Square sh a -multiplySquareLeft - (Array shapeB@(MatrixShape.Square orderB shB) b) - (Array (MatrixShape.Triangular uploA orderA shA) a) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Triangular.multiplySquareLeft: shapes mismatch" (shA == shB) - let n = Shape.size shB - MatrixShape.caseUplo uploA - (multiplyAux MatrixShape.Upper) - (multiplyAux MatrixShape.Lower) - (flipOrder orderA) n a (flipOrder orderB) n b cPtr - -multiplyGeneralLeft :: - (MatrixShape.Uplo uplo, - Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Triangular uplo width a -> General height width a -multiplyGeneralLeft - (Array shapeB@(MatrixShape.General orderB height width) b) - (Array (MatrixShape.Triangular uploA orderA shA) a) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Triangular.multiplyGeneralLeft: shapes mismatch" (shA == width) - MatrixShape.caseUplo uploA - (multiplyAux MatrixShape.Upper) - (multiplyAux MatrixShape.Lower) - (flipOrder orderA) (Shape.size width) a - (flipOrder orderB) (Shape.size height) b cPtr - -multiplySquareRight :: - (MatrixShape.Uplo uplo, Shape.C sh, Eq sh, Class.Floating a) => - Triangular uplo sh a -> Square sh a -> Square sh a -multiplySquareRight - (Array (MatrixShape.Triangular uploA orderA shA) a) - (Array shapeB@(MatrixShape.Square orderB shB) b) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Triangular.multiplySquareRight: shapes mismatch" (shA == shB) - let n = Shape.size shB - multiplyAux uploA orderA n a orderB n b cPtr - -multiplyGeneralRight :: - (MatrixShape.Uplo uplo, - Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Triangular uplo height a -> General height width a -> General height width a -multiplyGeneralRight - (Array (MatrixShape.Triangular uploA orderA shA) a) - (Array shapeB@(MatrixShape.General orderB height width) b) = - Array.unsafeCreate shapeB $ \cPtr -> do - Call.assert "Triangular.multiplyGeneralRight: shapes mismatch" - (shA == height) - multiplyAux - uploA orderA (Shape.size height) a orderB (Shape.size width) b cPtr +{- | +@(vr,d,vlAdj) = eigensystem a@ -multiplyAux :: - (MatrixShape.Uplo uplo, Class.Floating a) => - uplo -> - Order -> Int -> ForeignPtr a -> - Order -> Int -> ForeignPtr a -> Ptr a -> IO () -multiplyAux uploA orderA m0 a orderB n0 b cPtr = - evalContT $ do - let (side,trans,(m,n)) = - case orderB of - ColumnMajor -> ('L', orderA, (m0,n0)) - RowMajor -> ('R', flipOrder orderA, (n0,m0)) - sidePtr <- Call.char side - let realOrderA = uploOrder uploA orderA - uploPtr <- Call.char $ uploFromOrder realOrderA - transPtr <- Call.char $ transposeFromOrder trans - diagPtr <- Call.char 'N' - mPtr <- Call.cint m - nPtr <- Call.cint n - alphaPtr <- Call.number one - aPtr <- unpackToTemp (unpack realOrderA) m0 a - ldaPtr <- Call.cint m0 - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint m - liftIO $ do - copyBlock (m0*n0) bPtr cPtr - BlasGen.trmm sidePtr uploPtr transPtr diagPtr - mPtr nPtr alphaPtr aPtr ldaPtr cPtr ldbPtr +Counterintuitively, @vr@ contains the right eigenvectors as columns +and @vlAdj@ contains the left conjugated eigenvectors as rows. +The idea is to provide a decomposition of @a@. +If @a@ is diagonalizable, then @vr@ and @vlAdj@ +are almost inverse to each other. +More precisely, @vlAdj \<#\> vr@ is a diagonal matrix. +This is because the eigenvectors are not normalized. +With the following scaling, the decomposition becomes perfect: +> let scal = Array.map recip $ takeDiagonal $ vlAdj <#> vr +> a == vr <#> diagonal d <#> diagonal scal <#> vlAdj -autoUploOrder :: MatrixShape.Uplo uplo => Order -> (Order, uplo) -autoUploOrder order = - case MatrixShape.autoUplo of - uplo -> (uploOrder uplo order, uplo) +If @a@ is non-diagonalizable +then some columns of @vr@ and corresponding rows of @vlAdj@ are left zero +and the above property does not hold. +-} +eigensystem :: + (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => + Triangular lo NonUnit up sh a -> + (Triangular lo NonUnit up sh a, Vector sh a, Triangular lo NonUnit up sh a) +eigensystem = Eigen.decompose diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Basic.hs b/src/Numeric/LAPACK/Matrix/Triangular/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Triangular/Basic.hs @@ -0,0 +1,548 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +module Numeric.LAPACK.Matrix.Triangular.Basic ( + Triangular, MatrixShape.UpLo, + Upper, UnitUpper, + Lower, UnitLower, + Symmetric, Diagonal, + fromList, autoFromList, + lowerFromList, autoLowerFromList, + upperFromList, autoUpperFromList, + symmetricFromList, autoSymmetricFromList, + diagonalFromList, autoDiagonalFromList, + relaxUnitDiagonal, strictNonUnitDiagonal, + asDiagonal, asLower, asUpper, asSymmetric, + forceUnitDiagonal, forceNonUnitDiagonal, + identity, + diagonal, + takeDiagonal, + transpose, + adjoint, + + toSquare, + takeUpper, + takeLower, + + Tri.PowerDiag, + multiplyVector, + square, squareGeneric, + multiply, + multiplyFull, + ) where + +import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric +import qualified Numeric.LAPACK.Matrix.Triangular.Private as Tri +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Triangular.Private + (Triangular, FlexDiagonal, diagonalPointers, diagonalPointerPairs, + pack, packRect, unpack, unpackZero, unpackToTemp) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor,ColumnMajor), + flipOrder, transposeFromOrder, uploFromOrder, uploOrder, + Unit(Unit), NonUnit(NonUnit), charFromTriDiag) +import Numeric.LAPACK.Matrix.Private + (Full, Square, ZeroInt, zeroInt, Conjugation(NonConjugated)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private (fill, copyBlock) + +import qualified Numeric.LAPACK.FFI.Complex as LapackComplex +import qualified Numeric.BLAS.FFI.Real as BlasReal +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.C.Types (CChar, CInt) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable, poke, peek) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + +import Data.Foldable (forM_) + + +type Lower sh = FlexLower NonUnit sh +type Upper sh = FlexUpper NonUnit sh +type Symmetric sh = Array (MatrixShape.Symmetric sh) +type Diagonal sh = FlexDiagonal NonUnit sh + +type FlexLower diag sh = Array (MatrixShape.LowerTriangular diag sh) +type FlexUpper diag sh = Array (MatrixShape.UpperTriangular diag sh) +type FlexSymmetric diag sh = Array (MatrixShape.FlexSymmetric diag sh) + +type UnitLower sh = Array (MatrixShape.LowerTriangular Unit sh) +type UnitUpper sh = Array (MatrixShape.UpperTriangular Unit sh) + +transpose :: + (MatrixShape.Content lo, MatrixShape.Content up, + MatrixShape.TriDiag diag) => + Triangular lo diag up sh a -> Triangular up diag lo sh a +transpose (Array sh a) = + Array (MatrixShape.triangularTranspose sh) a + +adjoint :: + (MatrixShape.Content lo, MatrixShape.Content up, + MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> Triangular up diag lo sh a +adjoint = Vector.conjugate . transpose + + +fromList :: + (MatrixShape.Content lo, MatrixShape.Content up, Shape.C sh, Storable a) => + Order -> sh -> [a] -> Triangular lo NonUnit up sh a +fromList order sh = + Array.fromList (MatrixShape.Triangular NonUnit MatrixShape.autoUplo order sh) + +lowerFromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Lower sh a +lowerFromList = fromList + +upperFromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Upper sh a +upperFromList = fromList + +symmetricFromList :: + (Shape.C sh, Storable a) => Order -> sh -> [a] -> Symmetric sh a +symmetricFromList = fromList + +diagonalFromList :: + (Shape.C sh, Storable a) => Order -> sh -> [a] -> Diagonal sh a +diagonalFromList = fromList + + +autoFromList :: + (MatrixShape.Content lo, MatrixShape.Content up, Storable a) => + Order -> [a] -> Triangular lo NonUnit up ZeroInt a +autoFromList order xs = + let n = length xs + triSize = MatrixShape.triangleExtent "Triangular.autoFromList" n + uplo = MatrixShape.autoUplo + size = MatrixShape.caseDiagUpLoSym uplo n triSize triSize triSize + in Array.fromList + (MatrixShape.Triangular + MatrixShape.autoDiag uplo order (zeroInt size)) + xs + +autoLowerFromList :: (Storable a) => Order -> [a] -> Lower ZeroInt a +autoLowerFromList = autoFromList + +autoUpperFromList :: (Storable a) => Order -> [a] -> Upper ZeroInt a +autoUpperFromList = autoFromList + +autoSymmetricFromList :: (Storable a) => Order -> [a] -> Symmetric ZeroInt a +autoSymmetricFromList = autoFromList + +autoDiagonalFromList :: (Storable a) => Order -> [a] -> Diagonal ZeroInt a +autoDiagonalFromList = autoFromList + + +asDiagonal :: FlexDiagonal diag sh a -> FlexDiagonal diag sh a +asDiagonal = id + +asLower :: FlexLower diag sh a -> FlexLower diag sh a +asLower = id + +asUpper :: FlexUpper diag sh a -> FlexUpper diag sh a +asUpper = id + +asSymmetric :: FlexSymmetric diag sh a -> FlexSymmetric diag sh a +asSymmetric = id + +forceUnitDiagonal :: Triangular lo Unit up sh a -> Triangular lo Unit up sh a +forceUnitDiagonal = id + +forceNonUnitDiagonal :: + Triangular lo NonUnit up sh a -> Triangular lo NonUnit up sh a +forceNonUnitDiagonal = id + + +toSquare :: + (MatrixShape.Content lo, MatrixShape.Content up, + Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> Square sh a +toSquare (Array (MatrixShape.Triangular _diag uplo order sh) a) = + Array.unsafeCreateWithSize (MatrixShape.square order sh) $ \size bPtr -> + let n = Shape.size sh + in withForeignPtr a $ \aPtr -> + MatrixShape.caseDiagUpLoSym uplo + (do + fill zero size bPtr + evalContT $ do + nPtr <- Call.cint n + incxPtr <- Call.cint 1 + incyPtr <- Call.cint (n+1) + liftIO $ BlasGen.copy nPtr aPtr incxPtr bPtr incyPtr) + (unpackZero order n aPtr bPtr) + (unpackZero (flipOrder order) n aPtr bPtr) + (Symmetric.unpack NonConjugated order n aPtr bPtr) + +takeLower :: + (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => + Full Extent.Small horiz height width a -> Lower height a +takeLower = + Tri.takeLower (MatrixShape.NonUnit, const $ const $ const $ return ()) + +takeUpper :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Full vert Extent.Small height width a -> Upper width a +takeUpper (Array (MatrixShape.Full order extent) a) = + let (height,width) = Extent.dimensions extent + m = Shape.size height + n = Shape.size width + k = case order of RowMajor -> n; ColumnMajor -> m + in Array.unsafeCreate + (MatrixShape.Triangular MatrixShape.NonUnit + MatrixShape.upper order width) $ \bPtr -> + withForeignPtr a $ \aPtr -> packRect order n k aPtr bPtr + + +identity :: + (MatrixShape.Content lo, MatrixShape.Content up, + Shape.C sh, Class.Floating a) => + Order -> sh -> Triangular lo Unit up sh a +identity order sh = + let (realOrder, uplo) = autoUploOrder order + in Array.unsafeCreateWithSize (MatrixShape.Triangular Unit uplo order sh) $ + \size aPtr -> do + let n = Shape.size sh + let fillTriangle = do + fill zero size aPtr + mapM_ (flip poke one) (diagonalPointers realOrder n aPtr) + MatrixShape.caseDiagUpLoSym uplo + (fill one n aPtr) + fillTriangle + fillTriangle + fillTriangle + +diagonal, diagonalAux :: + (MatrixShape.Content lo, MatrixShape.Content up, + Shape.C sh, Class.Floating a) => + Order -> Vector sh a -> Triangular lo NonUnit up sh a +diagonal order x@(Array sh xPtr) = + let uplo = MatrixShape.autoUplo + in MatrixShape.caseDiagUpLoSym uplo + (Array (MatrixShape.Triangular NonUnit uplo order sh) xPtr) + (diagonalAux order x) + (diagonalAux order x) + (diagonalAux order x) + +diagonalAux order (Array sh x) = + let (realOrder, uplo) = autoUploOrder order + in Array.unsafeCreateWithSize + (MatrixShape.Triangular NonUnit uplo order sh) $ + \size aPtr -> do + let n = Shape.size sh + fill zero size aPtr + withForeignPtr x $ \xPtr -> + forM_ (diagonalPointerPairs realOrder n xPtr aPtr) $ + \(srcPtr,dstPtr) -> poke dstPtr =<< peek srcPtr + + +takeDiagonal, takeDiagonalAux :: + (MatrixShape.Content lo, MatrixShape.Content up, + Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> Vector sh a +takeDiagonal a@(Array (MatrixShape.Triangular _diag uplo _order sh) aPtr) = + MatrixShape.caseDiagUpLoSym uplo + (Array sh aPtr) + (takeDiagonalAux a) + (takeDiagonalAux a) + (takeDiagonalAux a) + +takeDiagonalAux (Array (MatrixShape.Triangular _diag uplo order sh) a) = + Array.unsafeCreate sh $ \xPtr -> + withForeignPtr a $ \aPtr -> + mapM_ + (\(dstPtr,srcPtr) -> poke dstPtr =<< peek srcPtr) + (diagonalPointerPairs (uploOrder uplo order) (Shape.size sh) xPtr aPtr) + +relaxUnitDiagonal :: + (MatrixShape.TriDiag diag) => + Triangular lo Unit up sh a -> Triangular lo diag up sh a +relaxUnitDiagonal = Array.mapShape MatrixShape.relaxUnitDiagonal + +strictNonUnitDiagonal :: + (MatrixShape.TriDiag diag) => + Triangular lo diag up sh a -> Triangular lo NonUnit up sh a +strictNonUnitDiagonal = Array.mapShape MatrixShape.strictNonUnitDiagonal + + +multiplyVector :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + Triangular lo diag up sh a -> Vector sh a -> Vector sh a +multiplyVector = + Tri.getMultiplyRight $ + MatrixShape.switchDiagUpLoSym + (Tri.MultiplyRight $ + Tri.multiplyDiagonal + "multiplyVector.diagonal: sizes mismatch" + Array.shape + (Vector.mul . takeDiagonal)) + (Tri.MultiplyRight multiplyVectorTriangular) + (Tri.MultiplyRight multiplyVectorTriangular) + (Tri.MultiplyRight multiplyVectorTriangular) + +multiplyVectorTriangular :: + (MatrixShape.UpLoSym lo up, MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + Triangular lo diag up sh a -> Vector sh a -> Vector sh a +multiplyVectorTriangular + (Array (MatrixShape.Triangular diag uplo order shA) a) (Array shX x) = + Array.unsafeCreate shX $ \yPtr -> do + Call.assert "Triangular.multiplyVector: width shapes mismatch" (shA == shX) + let n = Shape.size shA + evalContT $ do + uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo order + transPtr <- Call.char $ transposeFromOrder order + diagPtr <- Call.char $ charFromTriDiag diag + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + xPtr <- ContT $ withForeignPtr x + alphaPtr <- Call.number one + betaPtr <- Call.number zero + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 1 + let runTPMV = do + copyBlock n xPtr yPtr + BlasGen.tpmv uploPtr transPtr diagPtr nPtr aPtr yPtr incyPtr + liftIO $ + MatrixShape.caseUpLoSym uplo + runTPMV + runTPMV + (spmv uploPtr nPtr alphaPtr aPtr xPtr incxPtr betaPtr yPtr incyPtr) + + +newtype SPMV a = + SPMV { + getSPMV :: + Ptr CChar -> Ptr CInt -> Ptr a -> Ptr a -> + Ptr a -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () + } + +spmv :: Class.Floating a => + Ptr CChar -> Ptr CInt -> Ptr a -> Ptr a -> + Ptr a -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () +spmv = + getSPMV $ + Class.switchFloating + (SPMV BlasReal.spmv) (SPMV BlasReal.spmv) + (SPMV LapackComplex.spmv) (SPMV LapackComplex.spmv) + + +square :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + Triangular lo diag up sh a -> Triangular lo diag up sh a +square = + Tri.getMap $ + MatrixShape.switchDiagUpLo + (Tri.Map squareDiagonal) + (Tri.Map squareTriangular) + (Tri.Map squareTriangular) + + +{- | +Include symmetric matrices. +However, symmetric matrices do not preserve unit diagonals. +-} +squareGeneric :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + Triangular lo diag up sh a -> + Triangular lo (Tri.PowerDiag lo up diag) up sh a +squareGeneric = + Tri.getPower $ + MatrixShape.switchDiagUpLoSym + (Tri.Power squareDiagonal) + (Tri.Power squareTriangular) + (Tri.Power squareTriangular) + (Tri.Power $ squareSymmetric . strictNonUnitDiagonal) + + +squareDiagonal :: + (MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + FlexDiagonal diag sh a -> FlexDiagonal diag sh a +squareDiagonal = + getMapDiag $ + MatrixShape.switchTriDiag (MapDiag id) (MapDiag $ \a -> Vector.mul a a) + +newtype MapDiag lo up sh a diag = + MapDiag { + getMapDiag :: + Triangular lo diag up sh a -> + Triangular lo diag up sh a + } + +squareTriangular :: + (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + Triangular lo diag up sh a -> Triangular lo diag up sh a +squareTriangular + (Array shape@(MatrixShape.Triangular diag uplo order sh) a) = + Array.unsafeCreate shape $ \bpPtr -> do + let n = Shape.size sh + evalContT $ do + sidePtr <- Call.char 'L' + let realOrder = uploOrder uplo order + uploPtr <- Call.char $ uploFromOrder realOrder + transPtr <- Call.char 'N' + diagPtr <- Call.char $ charFromTriDiag diag + nPtr <- Call.cint n + ldPtr <- Call.leadingDim n + aPtr <- unpackToTemp (unpack realOrder) n a + bPtr <- unpackToTemp (unpackZero realOrder) n a + alphaPtr <- Call.number one + liftIO $ do + BlasGen.trmm sidePtr uploPtr transPtr diagPtr + nPtr nPtr alphaPtr aPtr ldPtr bPtr ldPtr + pack realOrder n bPtr bpPtr + +squareSymmetric :: + (Shape.C sh, Eq sh, Class.Floating a) => + Symmetric sh a -> Symmetric sh a +squareSymmetric (Array shape@(MatrixShape.Triangular _diag _uplo order sh) a) = + Array.unsafeCreate shape $ + Symmetric.square NonConjugated order (Shape.size sh) a + + +multiply :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + Triangular lo diag up sh a -> Triangular lo diag up sh a -> + Triangular lo diag up sh a +multiply = + getMultiply $ + MatrixShape.switchDiagUpLo + (Multiply $ + Tri.multiplyDiagonal + "multiply.diagonal: sizes mismatch" + (MatrixShape.triangularSize . Array.shape) + (\a b -> + Array.mapShape + (MatrixShape.Triangular + MatrixShape.autoDiag MatrixShape.autoUplo + (MatrixShape.triangularOrder $ Array.shape b)) $ + Vector.mul (takeDiagonal a) (takeDiagonal b))) + (Multiply multiplyTriangular) + (Multiply multiplyTriangular) + +newtype Multiply diag sh a lo up = + Multiply { + getMultiply :: + Triangular lo diag up sh a -> + Triangular lo diag up sh a -> Triangular lo diag up sh a + } + +multiplyTriangular :: + (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Eq sh, Class.Floating a) => + Triangular lo diag up sh a -> + Triangular lo diag up sh a -> Triangular lo diag up sh a +multiplyTriangular + (Array (MatrixShape.Triangular diag uploA orderA shA) a) + (Array shapeB@(MatrixShape.Triangular _diag uploB orderB shB) b) = + Array.unsafeCreate shapeB $ \cpPtr -> do + Call.assert "Triangular.multiply: width shapes mismatch" (shA == shB) + let n = Shape.size shA + evalContT $ do + let (side,trans) = + case orderB of + ColumnMajor -> ('L', orderA) + RowMajor -> ('R', flipOrder orderA) + sidePtr <- Call.char side + let realOrderA = uploOrder uploA orderA + let realOrderB = uploOrder uploB orderB + uploPtr <- Call.char $ uploFromOrder realOrderA + transPtr <- Call.char $ transposeFromOrder trans + diagPtr <- Call.char $ charFromTriDiag diag + nPtr <- Call.cint n + ldPtr <- Call.leadingDim n + aPtr <- unpackToTemp (unpack realOrderA) n a + bPtr <- unpackToTemp (unpackZero realOrderB) n b + alphaPtr <- Call.number one + liftIO $ do + BlasGen.trmm sidePtr uploPtr transPtr diagPtr + nPtr nPtr alphaPtr aPtr ldPtr bPtr ldPtr + pack realOrderB n bPtr cpPtr + + +multiplyFull :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, + Class.Floating a) => + Triangular lo diag up height a -> + Full vert horiz height width a -> + Full vert horiz height width a +multiplyFull = + Tri.getMultiplyRight $ + MatrixShape.switchDiagUpLoSym + (Tri.MultiplyRight $ + Tri.multiplyDiagonal + "multiplyFull.diagonal: sizes mismatch" + (MatrixShape.fullHeight . Array.shape) + (Basic.scaleRows . takeDiagonal)) + (Tri.MultiplyRight multiplyFullTriangular) + (Tri.MultiplyRight multiplyFullTriangular) + (Tri.MultiplyRight multiplyFullTriangular) + +multiplyFullTriangular :: + (MatrixShape.UpLoSym lo up, MatrixShape.TriDiag diag, + Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, + Class.Floating a) => + Triangular lo diag up height a -> + Full vert horiz height width a -> + Full vert horiz height width a +multiplyFullTriangular + (Array (MatrixShape.Triangular diag uploA orderA shA) a) + (Array shapeB@(MatrixShape.Full orderB extentB) b) = + Array.unsafeCreateWithSize shapeB $ \size cPtr -> do + let (height,width) = Extent.dimensions extentB + Call.assert "Triangular.multiplyFull: shapes mismatch" (shA == height) + let m0 = Shape.size height + let n0 = Shape.size width + evalContT $ do + let (side,trans,(m,n)) = + case orderB of + ColumnMajor -> ('L', orderA, (m0,n0)) + RowMajor -> ('R', flipOrder orderA, (n0,m0)) + sidePtr <- Call.char side + let realOrderA = uploOrder uploA orderA + uploPtr <- Call.char $ uploFromOrder realOrderA + transPtr <- Call.char $ transposeFromOrder trans + diagPtr <- Call.char $ charFromTriDiag diag + mPtr <- Call.cint m + nPtr <- Call.cint n + alphaPtr <- Call.number one + aPtr <- unpackToTemp (unpack realOrderA) m0 a + ldaPtr <- Call.leadingDim m0 + betaPtr <- Call.number zero + bPtr <- ContT $ withForeignPtr b + ldbPtr <- Call.leadingDim m + let runTRMM = do + copyBlock size bPtr cPtr + BlasGen.trmm sidePtr uploPtr transPtr diagPtr + mPtr nPtr alphaPtr aPtr ldaPtr cPtr ldbPtr + liftIO $ + MatrixShape.caseUpLoSym uploA + runTRMM + runTRMM + (BlasGen.symm sidePtr uploPtr + mPtr nPtr alphaPtr aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldbPtr) + + +autoUploOrder :: + (MatrixShape.Content lo, MatrixShape.Content up) => Order -> (Order, (lo,up)) +autoUploOrder order = + case MatrixShape.autoUplo of + uplo -> (uploOrder uplo order, uplo) diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs b/src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +module Numeric.LAPACK.Matrix.Triangular.Eigen ( + values, + decompose, + ) where + +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import Numeric.LAPACK.Matrix.Triangular.Private + (unpackZero, pack, unpackToTemp, fillTriangle, + forPointers, rowMajorPointers) +import Numeric.LAPACK.Matrix.Triangular.Basic (Triangular) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(ColumnMajor,RowMajor), caseLoUp, uploOrder, + NonUnit(NonUnit), triangleSize) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (zero) +import Numeric.LAPACK.Private (lacgv, withInfo, errorCodeMsg) + +import qualified Numeric.LAPACK.FFI.Complex as LapackComplex +import qualified Numeric.LAPACK.FFI.Real as LapackReal +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.C.Types (CInt, CChar) +import Foreign.Ptr (Ptr, nullPtr) + +import Control.Monad.Trans.Cont (evalContT) +import Control.Monad.IO.Class (liftIO) + +import Data.Complex (Complex) +import Data.Tuple.HT (swap) + + +values :: + (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> Vector sh a +values = Triangular.takeDiagonal + + +decompose :: + (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => + Triangular lo NonUnit up sh a -> + (Triangular lo NonUnit up sh a, Vector sh a, Triangular lo NonUnit up sh a) +decompose a = + let (vr,vl) = + flip getDecompose a $ + MatrixShape.switchDiagUpLo + (Decompose $ + (\eye -> (eye, Triangular.transpose eye)) . + Triangular.relaxUnitDiagonal . + Triangular.identity ColumnMajor . + MatrixShape.triangularSize . Array.shape) + (Decompose decomposeTriangular) + (Decompose decomposeTriangular) + in (vr, values a, vl) + +newtype Decompose sh a lo up = + Decompose { + getDecompose :: + Triangular lo NonUnit up sh a -> + (Triangular lo NonUnit up sh a, Triangular lo NonUnit up sh a) + } + +decomposeTriangular :: + (MatrixShape.UpLo lo up, Shape.C sh, Class.Floating a) => + Triangular lo NonUnit up sh a -> + (Triangular lo NonUnit up sh a, Triangular lo NonUnit up sh a) +decomposeTriangular (Array (MatrixShape.Triangular _diag uplo order sh) a) = + let triShape ord = + MatrixShape.Triangular NonUnit uplo (uploOrder uplo ord) sh + n = Shape.size sh + n2 = n*n + triSize = triangleSize n + + in caseLoUp uplo id swap $ + Array.unsafeCreateWithSizeAndResult (triShape RowMajor) $ \_ vlpPtr -> + ArrayIO.unsafeCreate (triShape ColumnMajor) $ \vrpPtr -> + + evalContT $ do + sidePtr <- Call.char 'B' + howManyPtr <- Call.char 'A' + let selectPtr = nullPtr + let unpk = + case uploOrder uplo order of + ColumnMajor -> unpackZero ColumnMajor + RowMajor -> unpackZeroRowMajor + aPtr <- unpackToTemp unpk n a + ldaPtr <- Call.leadingDim n + vlPtr <- Call.allocaArray n2 + vrPtr <- Call.allocaArray n2 + mmPtr <- Call.cint n + mPtr <- Call.alloca + liftIO $ withInfo errorCodeMsg "trevc" $ + trevc sidePtr howManyPtr selectPtr n + aPtr ldaPtr vlPtr ldaPtr vrPtr ldaPtr mmPtr mPtr + sizePtr <- Call.cint triSize + incPtr <- Call.cint 1 + liftIO $ do + pack ColumnMajor n vrPtr vrpPtr + pack RowMajor n vlPtr vlpPtr + lacgv sizePtr vlpPtr incPtr + + +unpackZeroRowMajor :: Class.Floating a => Int -> Ptr a -> Ptr a -> IO () +unpackZeroRowMajor n packedPtr fullPtr = do + fillTriangle zero RowMajor n fullPtr + unpackRowMajor n packedPtr fullPtr + +unpackRowMajor :: Class.Floating a => Int -> Ptr a -> Ptr a -> IO () +unpackRowMajor n packedPtr fullPtr = evalContT $ do + incxPtr <- Call.cint 1 + incyPtr <- Call.cint n + liftIO $ + forPointers (rowMajorPointers n fullPtr packedPtr) $ + \nPtr (dstPtr,srcPtr) -> + BlasGen.copy nPtr srcPtr incxPtr dstPtr incyPtr + + +type TREVC_ a = + Ptr CChar -> Ptr CChar -> Ptr Bool -> + Int -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> + Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () + +newtype TREVC a = TREVC {getTREVC :: TREVC_ a} + +trevc :: Class.Floating a => TREVC_ a +trevc = + getTREVC $ + Class.switchFloating + (TREVC trevcReal) (TREVC trevcReal) + (TREVC trevcComplex) (TREVC trevcComplex) + +trevcReal :: Class.Real a => TREVC_ a +trevcReal sidePtr howmnyPtr selectPtr n + tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr infoPtr = + evalContT $ do + nPtr <- Call.cint n + workPtr <- Call.allocaArray (3*n) + liftIO $ + LapackReal.trevc sidePtr howmnyPtr selectPtr nPtr + tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr workPtr infoPtr + +trevcComplex :: Class.Real a => TREVC_ (Complex a) +trevcComplex sidePtr howmnyPtr selectPtr n + tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr infoPtr = + evalContT $ do + nPtr <- Call.cint n + workPtr <- Call.allocaArray (2*n) + rworkPtr <- Call.allocaArray n + liftIO $ + LapackComplex.trevc sidePtr howmnyPtr selectPtr nPtr + tPtr ldtPtr vlPtr ldvlPtr vrPtr ldvrPtr mmPtr mPtr + workPtr rworkPtr infoPtr diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Linear.hs b/src/Numeric/LAPACK/Matrix/Triangular/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Triangular/Linear.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +module Numeric.LAPACK.Matrix.Triangular.Linear ( + solve, + inverse, + inverseGeneric, + determinant, + ) where + +import qualified Numeric.LAPACK.Matrix.Banded.Linear as BandedLin +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric +import qualified Numeric.LAPACK.Matrix.Triangular.Private as Tri +import Numeric.LAPACK.Linear.Private (solver, withInfo) +import Numeric.LAPACK.Matrix.Triangular.Basic + (Triangular, Symmetric, PowerDiag, takeDiagonal, strictNonUnitDiagonal) +import Numeric.LAPACK.Matrix.Private (Full) + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Shape.Private + (transposeFromOrder, uploFromOrder, uploOrder, + charFromTriDiag, triangleSize) +import Numeric.LAPACK.Matrix.Private (Conjugation(NonConjugated)) +import Numeric.LAPACK.Private (copyBlock, copyToTemp) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + + +solve :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Triangular lo diag up sh a -> + Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solve = + Tri.getMultiplyRight $ + MatrixShape.switchDiagUpLoSym + (Tri.MultiplyRight $ + Tri.multiplyDiagonal + "solve.diagonal: sizes mismatch" + (MatrixShape.fullHeight . Array.shape) + (BandedLin.solve . Banded.diagonal . takeDiagonal)) + (Tri.MultiplyRight solveTriangular) + (Tri.MultiplyRight solveTriangular) + (Tri.MultiplyRight $ solveSymmetric . strictNonUnitDiagonal) + +solveTriangular :: + (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Triangular lo diag up sh a -> + Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solveTriangular (Array (MatrixShape.Triangular diag uplo orderA shA) a) = + solver "Triangular.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo orderA + transPtr <- Call.char $ transposeFromOrder orderA + diagPtr <- Call.char $ charFromTriDiag diag + apPtr <- copyToTemp (triangleSize n) a + liftIO $ + withInfo "tptrs" $ + LapackGen.tptrs uploPtr transPtr diagPtr + nPtr nrhsPtr apPtr xPtr ldxPtr + +solveSymmetric :: + (Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Symmetric sh a -> + Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a +solveSymmetric (Array (MatrixShape.Triangular _diag _uplo orderA shA) a) = + Symmetric.solve "Symmetric.solve" NonConjugated orderA shA a + + +inverse :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> Triangular lo diag up sh a +inverse = + Tri.getMap $ + MatrixShape.switchDiagUpLo + (Tri.Map inverseDiagonal) + (Tri.Map inverseTriangular) + (Tri.Map inverseTriangular) + +inverseGeneric :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> + Triangular lo (PowerDiag lo up diag) up sh a +inverseGeneric = + Tri.getPower $ + MatrixShape.switchDiagUpLoSym + (Tri.Power inverseDiagonal) + (Tri.Power inverseTriangular) + (Tri.Power inverseTriangular) + (Tri.Power $ inverseSymmetric . strictNonUnitDiagonal) + +inverseDiagonal :: + (MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => + Tri.FlexDiagonal diag sh a -> Tri.FlexDiagonal diag sh a +inverseDiagonal = Tri.caseTriDiagArray id (Array.map recip) + +inverseTriangular :: + (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> Triangular lo diag up sh a +inverseTriangular (Array shape@(MatrixShape.Triangular diag uplo order sh) a) = + Array.unsafeCreateWithSize shape $ \triSize bPtr -> + evalContT $ do + uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo order + diagPtr <- Call.char $ charFromTriDiag diag + nPtr <- Call.cint $ Shape.size sh + aPtr <- ContT $ withForeignPtr a + liftIO $ do + copyBlock triSize aPtr bPtr + withInfo "tptri" $ LapackGen.tptri uploPtr diagPtr nPtr bPtr + +inverseSymmetric :: + (Shape.C sh, Class.Floating a) => Symmetric sh a -> Symmetric sh a +inverseSymmetric (Array shape@(MatrixShape.Triangular _diag _uplo order sh) a) = + Array.unsafeCreateWithSize shape $ + Symmetric.inverse NonConjugated order (Shape.size sh) a + + +determinant :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> a +determinant = + Tri.getMultiplyRight $ + MatrixShape.switchDiagUpLoSym + (Tri.MultiplyRight determinantTriangular) + (Tri.MultiplyRight determinantTriangular) + (Tri.MultiplyRight determinantTriangular) + (Tri.MultiplyRight $ determinantSymmetric . strictNonUnitDiagonal) + +determinantTriangular :: + (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => + Triangular lo diag up sh a -> a +determinantTriangular = product . Array.toList . takeDiagonal + +determinantSymmetric :: + (Shape.C sh, Class.Floating a) => Symmetric sh a -> a +determinantSymmetric (Array (MatrixShape.Triangular _diag _uplo order sh) a) = + unsafePerformIO $ + Symmetric.determinant NonConjugated + peekBlockDeterminant order (Shape.size sh) a + +peekBlockDeterminant :: + (Class.Floating a) => (Ptr a, Maybe (Ptr a, Ptr a)) -> IO a +peekBlockDeterminant (a0Ptr,ext) = do + a0 <- peek a0Ptr + case ext of + Nothing -> return a0 + Just (a1Ptr,bPtr) -> do + a1 <- peek a1Ptr + b <- peek bPtr + return (a0*a1 - b*b) diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Private.hs b/src/Numeric/LAPACK/Matrix/Triangular/Private.hs --- a/src/Numeric/LAPACK/Matrix/Triangular/Private.hs +++ b/src/Numeric/LAPACK/Matrix/Triangular/Private.hs @@ -1,19 +1,31 @@ +{-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Matrix.Triangular.Private where +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), flipOrder, uploFromOrder, triangleSize) -import Numeric.LAPACK.Private (pointerSeq, copyToTemp, lacgv, fill, zero) + (Order(RowMajor,ColumnMajor), flipOrder, uploFromOrder, + Empty, Filled, NonUnit) +import Numeric.LAPACK.Matrix.Private (Full, Conjugation(Conjugated)) +import Numeric.LAPACK.Scalar (zero) +import Numeric.LAPACK.Private + (pointerSeq, copyBlock, copyCondConjugateToTemp, + pokeCInt, fill, withInfo, errorCodeMsg) import qualified Numeric.LAPACK.FFI.Generic as LapackGen import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (advancePtr) import Foreign.C.Types (CInt) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable, poke) +import Foreign.Storable (Storable) import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) @@ -21,16 +33,20 @@ import Data.Foldable (forM_) -diagonalPointers :: - (Storable a, Storable ar) => - Order -> Int -> Ptr ar -> Ptr a -> [(Ptr ar, Ptr a)] -diagonalPointers order n xPtr aPtr = - take n $ zip (pointerSeq 1 xPtr) $ scanl advancePtr aPtr $ +diagonalPointers :: (Storable a) => Order -> Int -> Ptr a -> [Ptr a] +diagonalPointers order n aPtr = + take n $ scanl advancePtr aPtr $ case order of RowMajor -> iterate pred n ColumnMajor -> iterate succ 2 +diagonalPointerPairs :: + (Storable a, Storable b) => + Order -> Int -> Ptr a -> Ptr b -> [(Ptr a, Ptr b)] +diagonalPointerPairs order n aPtr bPtr = + zip (pointerSeq 1 aPtr) $ diagonalPointers order n bPtr + columnMajorPointers :: (Storable a) => Int -> Ptr a -> Ptr a -> [(Int, ((Ptr a, Ptr a), Ptr a))] columnMajorPointers n fullPtr packedPtr = @@ -52,23 +68,15 @@ forPointers xs act = alloca $ \nPtr -> forM_ xs $ \(d,ptrs) -> do - poke nPtr $ fromIntegral d + pokeCInt nPtr d act nPtr ptrs copyTriangleToTemp :: Class.Floating a => - Order -> Int -> ForeignPtr a -> ContT r IO (Ptr a) -copyTriangleToTemp order n a = do - let aSize = triangleSize n - apPtr <- copyToTemp aSize a - liftIO $ evalContT $ do - aSizePtr <- Call.cint aSize - incPtr <- Call.cint 1 - case order of - RowMajor -> liftIO $ lacgv aSizePtr apPtr incPtr - ColumnMajor -> return () - return apPtr + Conjugation -> Order -> Int -> ForeignPtr a -> ContT r IO (Ptr a) +copyTriangleToTemp conj order = + copyCondConjugateToTemp (order==RowMajor && conj==Conjugated) unpackToTemp :: @@ -87,16 +95,21 @@ evalContT $ do uploPtr <- Call.char $ uploFromOrder order nPtr <- Call.cint n - ldaPtr <- Call.cint n - liftIO $ withInfo $ LapackGen.tpttr uploPtr nPtr packedPtr fullPtr ldaPtr + ldaPtr <- Call.leadingDim n + liftIO $ withInfo errorCodeMsg "tpttr" $ + LapackGen.tpttr uploPtr nPtr packedPtr fullPtr ldaPtr pack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () -pack order n fullPtr packedPtr = +pack order n = packRect order n n + +packRect :: Class.Floating a => Order -> Int -> Int -> Ptr a -> Ptr a -> IO () +packRect order n ld fullPtr packedPtr = evalContT $ do uploPtr <- Call.char $ uploFromOrder order nPtr <- Call.cint n - ldaPtr <- Call.cint n - liftIO $ withInfo $ LapackGen.trttp uploPtr nPtr fullPtr ldaPtr packedPtr + ldaPtr <- Call.leadingDim ld + liftIO $ withInfo errorCodeMsg "trttp" $ + LapackGen.trttp uploPtr nPtr fullPtr ldaPtr packedPtr unpackZero, _unpackZero :: @@ -117,5 +130,88 @@ liftIO $ LapackGen.laset uploPtr nPtr nPtr zPtr zPtr aPtr nPtr -withInfo :: (Ptr CInt -> IO ()) -> IO () -withInfo = alloca +type Triangular lo diag up sh = Array (MatrixShape.Triangular lo diag up sh) + +type FlexDiagonal diag sh = + Triangular MatrixShape.Empty diag MatrixShape.Empty sh + +newtype MultiplyRight diag sh a b lo up = + MultiplyRight {getMultiplyRight :: Triangular lo diag up sh a -> b} + +newtype Map diag sh a lo up = + Map {getMap :: Triangular lo diag up sh a -> Triangular lo diag up sh a} + +newtype Power diag sh a lo up = + Power { + getPower :: + Triangular lo diag up sh a -> + Triangular lo (PowerDiag lo up diag) up sh a + } + +type family PowerDiag lo up diag +type instance PowerDiag Empty up diag = diag +type instance PowerDiag Filled Empty diag = diag +type instance PowerDiag Filled Filled diag = NonUnit + +caseTriDiagArray :: + (MatrixShape.TriDiag diag) => + (Triangular lo diag up sh a -> b) -> + (Triangular lo diag up sh a -> b) -> + (Triangular lo diag up sh a -> b) +caseTriDiagArray fu fn a = + MatrixShape.caseTriDiag + (MatrixShape.triangularDiag $ Array.shape a) + (fu a) (fn a) + +multiplyDiagonal :: + (Eq sh, MatrixShape.TriDiag diag) => + String -> + (b -> sh) -> + (Triangular lo diag up sh a -> b -> b) -> + (Triangular lo diag up sh a -> b -> b) +multiplyDiagonal msg shape = + caseTriDiagArray + (\a b -> + if MatrixShape.triangularSize (Array.shape a) == shape b + then b + else error ("Triangular." ++ msg)) + + +fromBanded :: + (Class.Floating a) => + Int -> Order -> Int -> ForeignPtr a -> Int -> Ptr a -> IO () +fromBanded k order n a bSize bPtr = + withForeignPtr a $ \aPtr -> do + fill zero bSize bPtr + let lda = k+1 + let pointers = + zip [0..] $ zip (pointerSeq lda aPtr) $ + diagonalPointers order n bPtr + case order of + ColumnMajor -> + forM_ pointers $ \(i,(xPtr,yPtr)) -> + let j = min i k + in copyBlock (j+1) (advancePtr xPtr (k-j)) (advancePtr yPtr (-j)) + RowMajor -> + forM_ pointers $ \(i,(xPtr,yPtr)) -> + copyBlock (min lda (n-i)) xPtr yPtr + + +type FlexLower diag sh = Array (MatrixShape.LowerTriangular diag sh) + +takeLower :: + (MatrixShape.TriDiag diag, + Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => + (diag, Order -> Int -> Ptr a -> IO ()) -> + Full Extent.Small horiz height width a -> FlexLower diag height a +takeLower (diag, fillDiag) (Array (MatrixShape.Full order extent) a) = + let (height,width) = Extent.dimensions extent + m = Shape.size height + n = Shape.size width + k = case order of RowMajor -> n; ColumnMajor -> m + in Array.unsafeCreate + (MatrixShape.Triangular diag MatrixShape.lower order height) $ \lPtr -> + withForeignPtr a $ \aPtr -> do + let dstOrder = flipOrder order + packRect dstOrder m k aPtr lPtr + fillDiag dstOrder m lPtr diff --git a/src/Numeric/LAPACK/Orthogonal.hs b/src/Numeric/LAPACK/Orthogonal.hs --- a/src/Numeric/LAPACK/Orthogonal.hs +++ b/src/Numeric/LAPACK/Orthogonal.hs @@ -2,34 +2,34 @@ module Numeric.LAPACK.Orthogonal ( leastSquares, minimumNorm, - leastSquaresMinimumNorm, + leastSquaresMinimumNormRCond, pseudoInverseRCond, - Householder, - householder, - householderDecompose, - householderDeterminant, determinant, - householderExtractQ, - householderExtractR, - orthogonalComplement, + determinantAbsolute, + complement, + + householder, ) where -import qualified Numeric.LAPACK.Matrix.Square as Square -import Numeric.LAPACK.Matrix - (General, ZeroInt, zeroInt, transpose, identity, dropColumns) -import Numeric.LAPACK.Matrix.Square (Square) +import qualified Numeric.LAPACK.Orthogonal.Private as HH +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Extent.Kind as EK +import Numeric.LAPACK.Matrix.Square.Basic (Square) +import Numeric.LAPACK.Matrix.Private (Full, Tall, ZeroInt, zeroInt) +import Numeric.LAPACK.Matrix (transpose, dropColumns) + import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor, ColumnMajor), transposeFromOrder) -import Numeric.LAPACK.Vector (Vector) +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor,ColumnMajor)) +import Numeric.LAPACK.Scalar (RealOf, zero, absolute) import Numeric.LAPACK.Private - (RealOf, zero, fill, - copySubMatrix, copyBlock, copyToTemp, - copyToColumnMajor, copyToSubColumnMajor, - withAutoWorkspaceInfo, allocArray, allocHigherArray) + (lacgv, peekCInt, + copySubMatrix, copyToTemp, copyToColumnMajor, copyToSubColumnMajor, + withAutoWorkspaceInfo, rankMsg, errorCodeMsg, createHigherArray) import qualified Numeric.LAPACK.FFI.Generic as LapackGen import qualified Numeric.LAPACK.FFI.Complex as LapackComplex @@ -43,15 +43,13 @@ import System.IO.Unsafe (unsafePerformIO) -import Foreign.Marshal.Array (advancePtr) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Array (pokeArray) +import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) import Data.Complex (Complex) import Data.Tuple.HT (mapSnd) @@ -64,34 +62,39 @@ Precondition: @a@ must have full rank and @height a >= width a@. -} leastSquares :: - (Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - General height width a -> General height nrhs a -> General width nrhs a + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + Full horiz Extent.Small height width a -> + Full vert horiz height nrhs a -> + Full vert horiz width nrhs a leastSquares - (Array shapeA@(MatrixShape.General orderA heightA widthA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - Array.unsafeCreate (MatrixShape.General ColumnMajor widthA widthB) $ - \xPtr -> do - Call.assert "leastSquares: height shapes mismatch" (heightA == heightB) - Call.assert "leastSquares: height of 'a' must be at least the width" - (Shape.size heightA >= Shape.size widthA) + (Array shapeA@(MatrixShape.Full orderA extentA) a) + (Array shapeB@(MatrixShape.Full orderB extentB) b) = + + case Extent.fuse (Extent.generalizeWide $ Extent.transpose extentA) extentB of + Nothing -> error "leastSquares: height shapes mismatch" + Just extent -> + Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ \xPtr -> do + + let widthA = Extent.width extentA + let (height,widthB) = Extent.dimensions extentB let (m,n) = MatrixShape.dimensions shapeA let lda = m let nrhs = Shape.size widthB - let ldb = Shape.size heightB + let ldb = Shape.size height let ldx = Shape.size widthA evalContT $ do - transPtr <- Call.char $ transposeFromOrder orderA mPtr <- Call.cint m nPtr <- Call.cint n nrhsPtr <- Call.cint nrhs - aPtr <- copyToTemp (Shape.size shapeA) a - ldaPtr <- Call.cint lda + (transPtr,aPtr) <- transposeA orderA (m*n) a + ldaPtr <- Call.leadingDim lda bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint ldb - let bSize = Shape.size (heightB,widthB) + ldbPtr <- Call.leadingDim ldb + let bSize = Shape.size shapeB btmpPtr <- Call.allocaArray bSize liftIO $ copyToColumnMajor orderB ldb nrhs bPtr btmpPtr - liftIO $ withAutoWorkspaceInfo "gels" $ + liftIO $ withAutoWorkspaceInfo rankMsg "gels" $ LapackGen.gels transPtr mPtr nPtr nrhsPtr aPtr ldaPtr btmpPtr ldbPtr liftIO $ copySubMatrix ldx nrhs ldb btmpPtr ldx xPtr @@ -104,74 +107,126 @@ Precondition: @a@ must have full rank and @height a <= width a@. -} minimumNorm :: - (Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - General height width a -> General height nrhs a -> General width nrhs a + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + Full Extent.Small vert height width a -> + Full vert horiz height nrhs a -> + Full vert horiz width nrhs a minimumNorm - (Array shapeA@(MatrixShape.General orderA heightA widthA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - Array.unsafeCreate (MatrixShape.General ColumnMajor widthA widthB) $ - \xPtr -> do - Call.assert "minimumNorm: height shapes mismatch" (heightA == heightB) - Call.assert "minimumNorm: width of 'a' must be at least the height" - (Shape.size widthA >= Shape.size heightA) + (Array shapeA@(MatrixShape.Full orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + + case Extent.fuse (Extent.generalizeTall $ Extent.transpose extentA) extentB of + Nothing -> error "minimumNorm: height shapes mismatch" + Just extent -> + Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ \xPtr -> do + + let widthA = Extent.width extentA + let (height,widthB) = Extent.dimensions extentB let (m,n) = MatrixShape.dimensions shapeA let lda = m let nrhs = Shape.size widthB - let ldb = Shape.size heightB + let ldb = Shape.size height let ldx = Shape.size widthA evalContT $ do - transPtr <- Call.char $ transposeFromOrder orderA mPtr <- Call.cint m nPtr <- Call.cint n nrhsPtr <- Call.cint nrhs - aPtr <- copyToTemp (Shape.size shapeA) a - ldaPtr <- Call.cint lda + (transPtr,aPtr) <- transposeA orderA (m*n) a + ldaPtr <- Call.leadingDim lda bPtr <- ContT $ withForeignPtr b - ldxPtr <- Call.cint ldx + ldxPtr <- Call.leadingDim ldx liftIO $ copyToSubColumnMajor orderB ldb nrhs bPtr ldx xPtr - liftIO $ withAutoWorkspaceInfo "gels" $ + liftIO $ withAutoWorkspaceInfo rankMsg "gels" $ LapackGen.gels transPtr mPtr nPtr nrhsPtr aPtr ldaPtr xPtr ldxPtr + +transposeA :: + Class.Floating a => + Order -> Int -> ForeignPtr a -> ContT r IO (Ptr CChar, Ptr a) +transposeA order size a = do + aPtr <- copyToTemp size a + trans <- + case order of + RowMajor -> do + sizePtr <- Call.cint size + incPtr <- Call.cint 1 + liftIO $ lacgv sizePtr aPtr incPtr + return $ HH.invChar a + ColumnMajor -> return 'N' + transPtr <- Call.char trans + return (transPtr, aPtr) + + {- | -If @x = leastSquaresMinimumNorm a b@ +If @x = leastSquaresMinimumNormRCond rcond a b@ then @x@ is the vector with minimum @Vector.norm2 x@ that minimizes @Vector.norm2 (multiply a x `sub` b)@. Matrix @a@ can have any rank but you must specify the reciprocal condition of the rank-truncated matrix. -} -leastSquaresMinimumNorm :: - (Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => +leastSquaresMinimumNormRCond :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => RealOf a -> - General height width a -> General height nrhs a -> - (Int, General width nrhs a) -leastSquaresMinimumNorm rcond - (Array (MatrixShape.General orderA heightA widthA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - unsafePerformIO $ do - Call.assert "leastSquaresMinimumNorm: height shapes mismatch" - (heightA == heightB) - let shapeX = MatrixShape.General ColumnMajor widthA widthB - let m = Shape.size heightA - let n = Shape.size widthA - let nrhs = Shape.size widthB + Full horiz vert height width a -> + Full vert horiz height nrhs a -> + (Int, Full vert horiz width nrhs a) +leastSquaresMinimumNormRCond rcond + (Array (MatrixShape.Full orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + case Extent.fuse (Extent.transpose extentA) extentB of + Nothing -> error "leastSquaresMinimumNormRCond: height shapes mismatch" + Just extent -> + let widthA = Extent.width extentA + (height,widthB) = Extent.dimensions extentB + shapeX = MatrixShape.Full ColumnMajor extent + m = Shape.size height + n = Shape.size widthA + nrhs = Shape.size widthB + in if m == 0 + then (0, Vector.constant shapeX zero) + else + if nrhs == 0 + then + (fst $ unsafePerformIO $ + case Vector.constant height zero of + Array _ b1 -> + leastSquaresMinimumNormIO rcond + (MatrixShape.general ColumnMajor widthA ()) + orderA a orderB b1 m n 1, + Vector.constant shapeX zero) + else + unsafePerformIO $ + leastSquaresMinimumNormIO rcond shapeX + orderA a orderB b m n nrhs + +leastSquaresMinimumNormIO :: + (Shape.C sh, Class.Floating a) => + RealOf a -> sh -> + Order -> ForeignPtr a -> + Order -> ForeignPtr a -> + Int -> Int -> Int -> IO (Int, Array sh a) +leastSquaresMinimumNormIO rcond shapeX orderA a orderB b m n nrhs = + createHigherArray shapeX m n nrhs $ \(tmpPtr,ldtmp) -> do + let aSize = m*n let lda = m evalContT $ do aPtr <- ContT $ withForeignPtr a atmpPtr <- Call.allocaArray aSize liftIO $ copyToColumnMajor orderA m n aPtr atmpPtr - ldaPtr <- Call.cint lda - (x,(tmpPtr,ldtmp)) <- allocHigherArray shapeX m n nrhs - ldtmpPtr <- Call.cint ldtmp + ldaPtr <- Call.leadingDim lda + ldtmpPtr <- Call.leadingDim ldtmp bPtr <- ContT $ withForeignPtr b liftIO $ copyToSubColumnMajor orderB m nrhs bPtr ldtmp tmpPtr jpvtPtr <- Call.allocaArray n + liftIO $ pokeArray jpvtPtr (replicate n 0) rankPtr <- Call.alloca gelsy m n nrhs atmpPtr ldaPtr tmpPtr ldtmpPtr jpvtPtr rcond rankPtr - rank <- liftIO $ fromIntegral <$> peek rankPtr - return (rank, x) + liftIO $ peekCInt rankPtr type GELSY_ r ar a = @@ -195,7 +250,7 @@ nPtr <- Call.cint n nrhsPtr <- Call.cint nrhs rcondPtr <- Call.real rcond - liftIO $ withAutoWorkspaceInfo "gelsy" $ + liftIO $ withAutoWorkspaceInfo errorCodeMsg "gelsy" $ LapackReal.gelsy mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr jpvtPtr rcondPtr rankPtr @@ -206,167 +261,85 @@ nrhsPtr <- Call.cint nrhs rcondPtr <- Call.real rcond rworkPtr <- Call.allocaArray (2*n) - liftIO $ withAutoWorkspaceInfo "gelsy" $ \workPtr lworkPtr infoPtr -> + liftIO $ + withAutoWorkspaceInfo errorCodeMsg "gelsy" $ \workPtr lworkPtr infoPtr -> LapackComplex.gelsy mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr jpvtPtr rcondPtr rankPtr workPtr lworkPtr rworkPtr infoPtr pseudoInverseRCond :: - (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - RealOf a -> General height width a -> (Int, General width height a) + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + RealOf a -> + Full vert horiz height width a -> + (Int, Full horiz vert width height a) pseudoInverseRCond rcond a = - let (MatrixShape.General _ height width) = Array.shape a - in if Shape.size height < Shape.size width - then leastSquaresMinimumNorm rcond a $ identity height - else mapSnd transpose $ - leastSquaresMinimumNorm rcond (transpose a) $ - identity width + case Matrix.caseTallWide a of + Left _ -> + mapSnd transpose $ + leastSquaresMinimumNormRCond rcond (transpose a) $ + Square.toFull $ Square.identity $ + MatrixShape.fullWidth $ Array.shape a + Right _ -> + leastSquaresMinimumNormRCond rcond a $ + Square.toFull $ Square.identity $ + MatrixShape.fullHeight $ Array.shape a -type Householder height width = Array (MatrixShape.Householder height width) - {- @(q,r) = householder a@ means that @q@ is unitary and @r@ is upper triangular and @a = multiply q r@. -} householder :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> - (Square height a, General height width a) + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> + (Square height a, Full vert horiz height width a) householder a = - let hh = householderDecompose a - in (householderExtractQ hh, householderExtractR $ snd hh) + let hh = HH.fromMatrix a + in (HH.extractQ hh, HH.extractR hh) -householderDecompose :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> (Vector width a, Householder height width a) -householderDecompose (Array shape@(MatrixShape.General order height width) a) = - unsafePerformIO $ do - let (m,n) = MatrixShape.dimensions shape - let lda = m - let mn = min m n - evalContT $ do - mPtr <- Call.cint m - nPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.cint lda - (qr,qrPtr) <- allocArray $ MatrixShape.Householder order height width - liftIO $ copyBlock (m*n) aPtr qrPtr - (tau,tauPtr) <- allocArray width - liftIO $ fill zero (n-mn) (advancePtr tauPtr mn) - liftIO $ - case order of - RowMajor -> - withAutoWorkspaceInfo "gelqf" $ - LapackGen.gelqf mPtr nPtr qrPtr ldaPtr tauPtr - ColumnMajor -> - withAutoWorkspaceInfo "geqrf" $ - LapackGen.geqrf mPtr nPtr qrPtr ldaPtr tauPtr - return (tau, qr) - -householderDeterminant :: - (Shape.C height, Shape.C width, Class.Floating a) => - Householder height width a -> a -householderDeterminant - (Array (MatrixShape.Householder order height width) a) = - let m = Shape.size height - n = Shape.size width - k = case order of RowMajor -> n; ColumnMajor -> m - in unsafePerformIO $ - withForeignPtr a $ \aPtr -> - Private.product (min m n) aPtr (k+1) - +determinant :: (Shape.C sh, Class.Floating a) => Square sh a -> a +determinant = HH.determinant . HH.fromMatrix {-| -Generalized determinant - works also for non-square matrices. -In contrast to the square root of the Gramian determinant -it has the proper sign. +Gramian determinant - +works also for non-square matrices, but is sensitive to transposition. + +> determinantAbsolute a = sqrt (Herm.determinant (Herm.covariance a)) -} -determinant :: - (Shape.C height, Shape.C width, Eq a, Class.Floating a) => - General height width a -> a -determinant a = - let (tau,hh) = householderDecompose a - in foldl (\x _ -> negate x) - (householderDeterminant hh) - (takeWhile (/=zero) $ Array.toList tau) +determinantAbsolute :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> RealOf a +determinantAbsolute = + absolute . + either (HH.determinantR . HH.fromMatrix) (const zero) . + Matrix.caseTallWide -householderExtractQ :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - (Vector width a, Householder height width a) -> Square height a -householderExtractQ - (Array widthTau tau, - Array (MatrixShape.Householder order height width) qr) = - - Array.unsafeCreate (MatrixShape.Square order height) $ \qPtr -> do - - Call.assert "householderExtractQ: width shapes mismatch" (widthTau == width) - - let m = Shape.size height - let k = min m $ Shape.size width - let lda = m - evalContT $ do - mPtr <- Call.cint m - kPtr <- Call.cint k - qrPtr <- ContT $ withForeignPtr qr - ldaPtr <- Call.cint lda - tauPtr <- ContT $ withForeignPtr tau - liftIO $ - case order of - RowMajor -> do - copySubMatrix k m k qrPtr lda qPtr - withAutoWorkspaceInfo "unglq" $ - LapackGen.unglq mPtr mPtr kPtr qPtr ldaPtr tauPtr - ColumnMajor -> do - copyBlock (m*k) qrPtr qPtr - withAutoWorkspaceInfo "ungqr" $ - LapackGen.ungqr mPtr mPtr kPtr qPtr ldaPtr tauPtr - -householderExtractR :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - Householder height width a -> General height width a -householderExtractR - (Array (MatrixShape.Householder order height width) qr) = - - Array.unsafeCreate (MatrixShape.General order height width) $ - \rPtr -> do - - let (uplo, (m,n)) = - case order of - RowMajor -> ('L', (Shape.size width, Shape.size height)) - ColumnMajor -> ('U', (Shape.size height, Shape.size width)) - fill zero (m*n) rPtr - evalContT $ do - uploPtr <- Call.char uplo - mPtr <- Call.cint m - nPtr <- Call.cint n - qrPtr <- ContT $ withForeignPtr qr - ldqrPtr <- Call.cint m - ldrPtr <- Call.cint m - liftIO $ LapackGen.lacpy uploPtr mPtr nPtr qrPtr ldqrPtr rPtr ldrPtr - {- | For an m-by-n-matrix @a@ with m>=n this function computes an m-by-(m-n)-matrix @b@ -such that @Matrix.multiply (transpose b) a@ is a zero matrix. +such that @Matrix.multiply (adjoint b) a@ is a zero matrix. The function does not try to compensate a rank deficiency of @a@. That is, @a|||b@ has full rank if and only if @a@ has full rank. For full-rank matrices you might also call this @kernel@ or @nullspace@. -} -orthogonalComplement :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> General height ZeroInt a -orthogonalComplement a = - dropColumns (Shape.size $ MatrixShape.generalWidth $ Array.shape a) $ - Array.mapShape zeroIntWidth $ - Square.toGeneral $ householderExtractQ $ householderDecompose a +complement :: + (Shape.C height, Shape.C width, Class.Floating a) => + Tall height width a -> Tall height ZeroInt a +complement a = + dropColumns (Shape.size $ MatrixShape.fullWidth $ Array.shape a) $ + Array.mapShape zeroIntWidth $ Square.toFull $ + HH.extractQ $ HH.fromMatrix $ Matrix.fromFull a zeroIntWidth :: (Shape.C width) => - MatrixShape.General height width -> MatrixShape.General height ZeroInt -zeroIntWidth (MatrixShape.General order height width) = - MatrixShape.General order height (zeroInt $ Shape.size width) + MatrixShape.Tall height width -> MatrixShape.Tall height ZeroInt +zeroIntWidth (MatrixShape.Full order (Extent.Extent o (EK.Tall height width))) = + MatrixShape.Full order + (Extent.Extent o (EK.Tall height (zeroInt $ Shape.size width))) diff --git a/src/Numeric/LAPACK/Orthogonal/Householder.hs b/src/Numeric/LAPACK/Orthogonal/Householder.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Orthogonal/Householder.hs @@ -0,0 +1,30 @@ +module Numeric.LAPACK.Orthogonal.Householder ( + Householder, + General, + Tall, + Wide, + Square, + mapExtent, + fromMatrix, + determinant, + determinantAbsolute, + leastSquares, + minimumNorm, + + Matrix.Transposition(..), + Matrix.Conjugation(..), + Matrix.Inversion(..), + extractQ, + extractR, + multiplyQ, + + tallExtractQ, + tallExtractR, + tallMultiplyQ, + tallMultiplyQAdjoint, + tallMultiplyR, + tallSolveR, + ) where + +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import Numeric.LAPACK.Orthogonal.Private diff --git a/src/Numeric/LAPACK/Orthogonal/Private.hs b/src/Numeric/LAPACK/Orthogonal/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Orthogonal/Private.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Orthogonal.Private where + +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Split as Split +import Numeric.LAPACK.Matrix.Triangular.Basic (Upper) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor, ColumnMajor), sideSwapFromOrder) +import Numeric.LAPACK.Matrix.Extent.Private (Extent) +import Numeric.LAPACK.Matrix.Private + (Full, ZeroInt, zeroInt, + Transposition(NonTransposed, Transposed), + Conjugation(NonConjugated, Conjugated), + Inversion(NonInverted, Inverted), flipInversion) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Format (Format(format)) +import Numeric.LAPACK.Scalar (RealOf, zero, isZero, absolute, conjugate) +import Numeric.LAPACK.Private + (fill, copySubMatrix, copyBlock, conjugateToTemp, + withAutoWorkspaceInfo, errorCodeMsg) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import Foreign.Marshal.Array (advancePtr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (when) +import Control.Applicative (Const(Const,getConst), liftA3) + +import qualified Data.List as List + + +data Householder vert horiz height width a = + Householder { + tau_ :: Vector ZeroInt a, + split_ :: + Array + (MatrixShape.Split MatrixShape.Reflector vert horiz height width) a + } deriving (Show) + +type General = Householder Extent.Big Extent.Big +type Tall = Householder Extent.Big Extent.Small +type Wide = Householder Extent.Small Extent.Big +type Square sh = Householder Extent.Small Extent.Small sh sh + + +extent_ :: + Householder vert horiz height width a -> + Extent vert horiz height width +extent_ = MatrixShape.splitExtent . Array.shape . split_ + +mapExtent :: + (Extent.C vertA, Extent.C horizA) => + (Extent.C vertB, Extent.C horizB) => + Extent.Map vertA horizA vertB horizB height width -> + Householder vertA horizA height width a -> + Householder vertB horizB height width a +mapExtent f (Householder tau split) = + Householder tau $ Array.mapShape (MatrixShape.splitMapExtent f) split + +caseTallWide :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => + Householder vert horiz height width a -> + Either (Tall height width a) (Wide height width a) +caseTallWide (Householder tau (Array shape a)) = + either + (Left . Householder tau . flip Array a) + (Right . Householder tau . flip Array a) $ + MatrixShape.caseTallWideSplit shape + + +instance + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Format (Householder vert horiz height width a) where + format fmt (Householder tau m) = format fmt (tau, m) + +fromMatrix :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full vert horiz height width a -> + Householder vert horiz height width a +fromMatrix (Array shape@(MatrixShape.Full order extent) a) = + let (m,n) = MatrixShape.dimensions shape + in uncurry Householder $ + Array.unsafeCreateWithSizeAndResult (zeroInt $ min m n) $ \_ tauPtr -> + ArrayIO.unsafeCreate + (MatrixShape.Split MatrixShape.Reflector order extent) $ \qrPtr -> + + evalContT $ do + mPtr <- Call.cint m + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim m + liftIO $ do + copyBlock (m*n) aPtr qrPtr + case order of + RowMajor -> + withAutoWorkspaceInfo errorCodeMsg "gelqf" $ + LapackGen.gelqf mPtr nPtr qrPtr ldaPtr tauPtr + ColumnMajor -> + withAutoWorkspaceInfo errorCodeMsg "geqrf" $ + LapackGen.geqrf mPtr nPtr qrPtr ldaPtr tauPtr + +determinantR :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Householder vert Extent.Small height width a -> a +determinantR = Split.determinantR . split_ + +{- +For complex numbers LAPACK uses not exactly reflections, +i.e. the determinants of the primitive transformations are not necessarily -1. + +It holds: det(I-tau*v*v^H) = 1-tau*v^H*v + because of https://en.wikipedia.org/wiki/Sylvester's_determinant_theorem + simple proof from: https://en.wikipedia.org/wiki/Matrix_determinant_lemma + I 0 . I+u*vt u . I 0 = I+u*vt u . I 0 = I u + vt 1 0 1 -vt 1 vt+vt*u*vt vt*u+1 -vt 1 0 vt*u+1 + +We already know: + v^H*v is real and greater or equal to 1, because v[i] = 1, + and determinant has absolute value 1. + +Let k = v^H*v. +For which real k lies 1-tau*k on the unit circle? + + (1-taur*k)^2 + (taui*k)^2 = 1 + 1-2*taur*k+(taur^2+taui^2)*k^2 = 1 + (taur^2 + taui^2)*k^2 - 2*taur*k = 0 (k/=0) + (taur^2 + taui^2)*k - 2*taur = 0 + k = 2*taur / (taur^2 + taui^2) + + 1-tau*k + = (taur^2 + taui^2 - tau*2*taur) / (taur^2 + taui^2) + = (taur^2 + taui^2 - 2*(taur+i*taui)*taur) / (taur^2 + taui^2) + = (-taur^2 + taui^2 - 2*(i*taui)*taur) / (taur^2 + taui^2) + = -(taur + i*taui)^2 / (taur^2 + taui^2) +-} +determinant :: + (Shape.C sh, Class.Floating a) => + Square sh a -> a +determinant (Householder tau split) = + List.foldl' (*) (Split.determinantR split) $ + (case MatrixShape.splitOrder $ Array.shape split of + RowMajor -> map conjugate + ColumnMajor -> id) $ + map (negate.(^(2::Int)).signum) $ + filter (not . isZero) $ Array.toList tau + +determinantAbsolute :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Householder vert horiz height width a -> RealOf a +determinantAbsolute = + absolute . either determinantR (const zero) . caseTallWide + + +leastSquares :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, + Class.Floating a) => + Householder horiz Extent.Small height width a -> + Full vert horiz height nrhs a -> + Full vert horiz width nrhs a +leastSquares qr = + tallSolveR NonTransposed NonConjugated qr . tallMultiplyQAdjoint qr + +{- | +@ +HH.minimumNorm (HH.fromMatrix a) b +== +Ortho.minimumNorm (adjoint a) b +@ +-} +minimumNorm :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, + Class.Floating a) => + Householder vert Extent.Small width height a -> + Full vert horiz height nrhs a -> + Full vert horiz width nrhs a +minimumNorm qr = tallMultiplyQ qr . tallSolveR Transposed Conjugated qr + +-- cf. Matrix.takeRows +takeRows :: + (Extent.C vert, Extent.C horiz, + Eq fuse, Shape.C fuse, Shape.C height, Shape.C width, Class.Floating a) => + Extent Extent.Small horiz height fuse -> + Full vert horiz fuse width a -> + Full vert horiz height width a +takeRows extentA (Array (MatrixShape.Full order extentB) b) = + case Extent.fuse (ExtentPriv.generalizeWide extentA) extentB of + Nothing -> error "Householder.takeRows: heights mismatch" + Just extentC -> + Array.unsafeCreateWithSize (MatrixShape.Full order extentC) $ + \blockSize cPtr -> + withForeignPtr b $ \bPtr -> + case order of + RowMajor -> copyBlock blockSize bPtr cPtr + ColumnMajor -> + let n = Shape.size $ Extent.width extentB + mb = Shape.size $ Extent.height extentB + mc = Shape.size $ Extent.height extentC + in copySubMatrix mc n mb bPtr mc cPtr + +addRows :: + (Extent.C vert, Extent.C horiz, + Eq fuse, Shape.C fuse, Shape.C height, Shape.C width, Class.Floating a) => + Extent vert Extent.Small height fuse -> + Full vert horiz fuse width a -> + Full vert horiz height width a +addRows extentA (Array shapeB@(MatrixShape.Full order extentB) b) = + case Extent.fuse (ExtentPriv.generalizeTall extentA) extentB of + Nothing -> error "Householder.addRows: heights mismatch" + Just extentC -> + Array.unsafeCreateWithSize (MatrixShape.Full order extentC) $ + \cSize cPtr -> + withForeignPtr b $ \bPtr -> + case order of + RowMajor -> do + let bSize = Shape.size shapeB + copyBlock bSize bPtr cPtr + fill zero (cSize - bSize) (advancePtr cPtr bSize) + ColumnMajor -> do + let n = Shape.size $ Extent.width extentB + mb = Shape.size $ Extent.height extentB + mc = Shape.size $ Extent.height extentC + copySubMatrix mb n mb bPtr mc cPtr + evalContT $ do + uploPtr <- Call.char 'A' + mPtr <- Call.cint (mc-mb) + nPtr <- Call.cint n + ldcPtr <- Call.leadingDim mc + zPtr <- Call.number zero + liftIO $ + LapackGen.laset uploPtr mPtr nPtr zPtr zPtr + (advancePtr cPtr mb) ldcPtr + + +extractQ :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Householder vert horiz height width a -> Matrix.Square height a +extractQ + (Householder tau (Array (MatrixShape.Split _ order extent) qr)) = + extractQAux tau (Extent.width extent) order + (Extent.square $ Extent.height extent) qr + +tallExtractQ :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Householder vert Extent.Small height width a -> + Full vert Extent.Small height width a +tallExtractQ + (Householder tau (Array (MatrixShape.Split _ order extent) qr)) = + extractQAux tau (Extent.width extent) order extent qr + + +extractQAux :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C widthQR, + Class.Floating a) => + Vector ZeroInt a -> widthQR -> + Order -> Extent vert horiz height width -> ForeignPtr a -> + Full vert horiz height width a +extractQAux (Array widthTau tau) widthQR order extent qr = + Array.unsafeCreate (MatrixShape.Full order extent) $ \qPtr -> do + + let (height,width) = Extent.dimensions extent + let m = Shape.size height + let n = Shape.size width + let k = Shape.size widthTau + evalContT $ do + mPtr <- Call.cint m + nPtr <- Call.cint n + kPtr <- Call.cint k + qrPtr <- ContT $ withForeignPtr qr + tauPtr <- ContT $ withForeignPtr tau + case order of + RowMajor -> do + ldaPtr <- Call.leadingDim n + liftIO $ do + copySubMatrix k m (Shape.size widthQR) qrPtr n qPtr + withAutoWorkspaceInfo errorCodeMsg "unglq" $ + LapackGen.unglq nPtr mPtr kPtr qPtr ldaPtr tauPtr + ColumnMajor -> do + ldaPtr <- Call.leadingDim m + liftIO $ do + copyBlock (m*k) qrPtr qPtr + withAutoWorkspaceInfo errorCodeMsg "ungqr" $ + LapackGen.ungqr mPtr nPtr kPtr qPtr ldaPtr tauPtr + + +tallMultiplyQ :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, + Class.Floating a) => + Householder vert Extent.Small height fuse a -> + Full vert horiz fuse width a -> + Full vert horiz height width a +tallMultiplyQ qr = multiplyQ NonInverted qr . addRows (extent_ qr) + +tallMultiplyQAdjoint :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => + Householder horiz Extent.Small fuse height a -> + Full vert horiz fuse width a -> + Full vert horiz height width a +tallMultiplyQAdjoint qr = + takeRows (Extent.transpose $ extent_ qr) . multiplyQ Inverted qr + + +multiplyQ :: + (Extent.C vertA, Extent.C horizA, Shape.C widthA, + Extent.C vertB, Extent.C horizB, Shape.C widthB, + Shape.C height, Eq height, Class.Floating a) => + Inversion -> + Householder vertA horizA height widthA a -> + Full vertB horizB height widthB a -> + Full vertB horizB height widthB a +multiplyQ inverted + (Householder + (Array widthTau tau) + (Array shapeA@(MatrixShape.Split _ orderA extentA) qr)) + (Array shapeB@(MatrixShape.Full orderB extentB) b) = + + Array.unsafeCreateWithSize shapeB $ \cSize cPtr -> do + + let (heightA,widthA) = Extent.dimensions extentA + let (height,width) = Extent.dimensions extentB + Call.assert "Householder.multiplyQ: height shapes mismatch" + (heightA == height) + + let (side,(m,n)) = + sideSwapFromOrder orderB (Shape.size height, Shape.size width) + + evalContT $ do + sidePtr <- Call.char side + mPtr <- Call.cint m + nPtr <- Call.cint n + let k = Shape.size widthTau + kPtr <- Call.cint k + (transPtr,qrPtr,tauPtr) <- + if orderA==orderB + then + liftA3 (,,) + (Call.char $ transposeFromInversion qr inverted) + (ContT $ withForeignPtr qr) + (ContT $ withForeignPtr tau) + else + liftA3 (,,) + (Call.char $ + transposeFromInversion qr $ flipInversion inverted) + (conjugateToTemp (Shape.size shapeA) qr) + (conjugateToTemp k tau) + bPtr <- ContT $ withForeignPtr b + ldcPtr <- Call.leadingDim m + liftIO $ copyBlock cSize bPtr cPtr + case orderA of + ColumnMajor -> do + ldaPtr <- Call.leadingDim $ Shape.size heightA + liftIO $ withAutoWorkspaceInfo errorCodeMsg "unmqr" $ + LapackGen.unmqr sidePtr transPtr + mPtr nPtr kPtr qrPtr ldaPtr tauPtr cPtr ldcPtr + RowMajor -> do + ldaPtr <- Call.leadingDim $ Shape.size widthA + -- work-around for https://github.com/Reference-LAPACK/lapack/issues/260 + liftIO $ when (k>0) $ + withAutoWorkspaceInfo errorCodeMsg "unmlq" $ + LapackGen.unmlq sidePtr transPtr + mPtr nPtr kPtr qrPtr ldaPtr tauPtr cPtr ldcPtr + +transposeFromInversion :: (Class.Floating a) => f a -> Inversion -> Char +transposeFromInversion qr Inverted = invChar qr +transposeFromInversion _ NonInverted = 'N' + +invChar :: (Class.Floating a) => f a -> Char +invChar f = getConst $ asFuncTypeOf f inverseChar + +asFuncTypeOf :: f a -> g a -> g a +asFuncTypeOf = const id + +inverseChar :: (Class.Floating a) => Const Char a +inverseChar = + Class.switchFloating (Const 'T') (Const 'T') (Const 'C') (Const 'C') + + +extractR :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Householder vert horiz height width a -> + Full vert horiz height width a +extractR = Split.extractTriangle (Right MatrixShape.Triangle) . split_ + +tallExtractR :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Householder vert Extent.Small height width a -> Upper width a +tallExtractR = Split.tallExtractR . split_ + +tallMultiplyR :: + (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + Shape.C heightA, Shape.C widthB, Class.Floating a) => + Transposition -> + Householder vertA Extent.Small heightA height a -> + Full vert horiz height widthB a -> + Full vert horiz height widthB a +tallMultiplyR transposed = Split.tallMultiplyR transposed . split_ + +tallSolveR :: + (Extent.C vertA, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => + Transposition -> Conjugation -> + Householder vertA Extent.Small height width a -> + Full vert horiz width nrhs a -> Full vert horiz width nrhs a +tallSolveR transposed conjugated = + Split.tallSolveR transposed conjugated . split_ diff --git a/src/Numeric/LAPACK/Permutation.hs b/src/Numeric/LAPACK/Permutation.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Permutation.hs @@ -0,0 +1,15 @@ +module Numeric.LAPACK.Permutation ( + Permutation, + Matrix.Inversion(..), + fromPivots, + toPivots, + toMatrix, + determinant, + numberFromSign, + transpose, + multiply, + apply, + ) where + +import Numeric.LAPACK.Permutation.Private +import qualified Numeric.LAPACK.Matrix.Private as Matrix diff --git a/src/Numeric/LAPACK/Permutation/Private.hs b/src/Numeric/LAPACK/Permutation/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Permutation/Private.hs @@ -0,0 +1,193 @@ +module Numeric.LAPACK.Permutation.Private where + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Split as Split +import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor)) +import Numeric.LAPACK.Matrix.Private + (Full, Square, ZeroInt, Inversion(NonInverted, Inverted)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Format (Format(format)) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private (fill, pointerSeq, copyBlock, copyToTemp) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import qualified Text.PrettyPrint.Boxes as TextBox + +import qualified Foreign.Marshal.Array.Guarded as ForeignArray +import Foreign.Marshal.Array (advancePtr, copyArray) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable, poke, peek, pokeElemOff, peekElemOff) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (forM_) +import Control.Applicative ((<$>)) + +import Data.Bool.HT (if') + + +newtype Permutation sh = Permutation (Vector sh CInt) + deriving (Show) + +instance (Shape.C sh) => Format (Permutation sh) where + format _fmt (Permutation perm) = + let n = Shape.size $ Array.shape perm + in TextBox.vcat TextBox.top $ + map (TextBox.hsep 1 TextBox.right . map TextBox.char) $ + map (\k -> (replicate (k-1) '.' ++ '1' : replicate (n-k) '.')) $ + map fromIntegral $ Array.toList perm + + +{- +We could use laswp if it would be available for CInt elements. +-} +{- | +The pivot array must be at most as long as @Shape.size sh@. +-} +fromPivots :: (Shape.C sh) => + Inversion -> sh -> Vector ZeroInt CInt -> Permutation sh +fromPivots inverted sh (Array (Shape.ZeroBased numIPiv) ipiv) = + Permutation $ + if' (numIPiv > Shape.size sh) + (error "Permutation.fromPivots: too many pivots") $ + Array.unsafeCreateWithSize sh $ \n permPtr -> + withForeignPtr ipiv $ \ipivPtr -> do + sequence_ $ take n $ zipWith poke (pointerSeq 1 permPtr) (iterate (1+) 1) + let is = + case inverted of + Inverted -> tail $ iterate (subtract 1) numIPiv + NonInverted -> iterate (1+) 0 + forM_ (take numIPiv is) $ \i -> + swapElem permPtr i =<< peek1 ipivPtr i + +swapElem :: (Storable a) => Ptr a -> Int -> Int -> IO () +swapElem ptr i j = swap (advancePtr ptr i) (advancePtr ptr j) + +swap :: (Storable a) => Ptr a -> Ptr a -> IO () +swap ptr0 ptr1 = do + a <- peek ptr0 + poke ptr0 =<< peek ptr1 + poke ptr1 a + + +toPivots :: (Shape.C sh) => Inversion -> Permutation sh -> Vector sh CInt +toPivots inverted (Permutation (Array sh perm)) = + Array.unsafeCreateWithSize sh $ \n invPtr -> + withForeignPtr perm $ \perm0Ptr -> + ForeignArray.alloca n $ \permPtr -> do + case inverted of + Inverted -> do + copyArray permPtr perm0Ptr n + transposeIO n permPtr invPtr + NonInverted -> do + copyArray invPtr perm0Ptr n + transposeIO n perm0Ptr permPtr + forM_ (take n $ iterate (1+) 0) $ \i -> do + j <- peek1 invPtr i + k <- peek1 permPtr i + poke1 permPtr j k + poke1 invPtr k j + + +data Sign = Negative | Positive + deriving (Eq, Show) + +{- +We could also count the cycles of even number. This might be a little faster. +-} +determinant :: (Shape.C sh) => Permutation sh -> Sign +determinant = + (\oddp -> if oddp then Negative else Positive) . + Split.oddPermutation . Array.toList . toPivots NonInverted + +numberFromSign :: (Class.Floating a) => Sign -> a +numberFromSign s = + case s of + Negative -> -1 + Positive -> 1 + + +transpose :: (Shape.C sh) => Permutation sh -> Permutation sh +transpose (Permutation (Array shape perm)) = + Permutation $ + Array.unsafeCreateWithSize shape $ \n dstPtr -> + withForeignPtr perm $ \srcPtr -> + transposeIO n srcPtr dstPtr + +transposeIO :: Int -> Ptr CInt -> Ptr CInt -> IO () +transposeIO n srcPtr dstPtr = + forM_ (take n $ iterate (1+) 0) $ \i -> do + j <- peek1 srcPtr i + poke1 dstPtr j i + + +multiply :: (Shape.C sh, Eq sh) => + Permutation sh -> Permutation sh -> Permutation sh +multiply (Permutation (Array shape permA)) (Permutation (Array shapeB permB)) = + if shape /= shapeB + then error "Permutation.multiply: sizes mismatch" + else + Permutation $ + Array.unsafeCreateWithSize shape $ \n cPtr -> + withForeignPtr permA $ \aPtr -> + withForeignPtr permB $ \bPtr -> + forM_ (take n $ iterate (1+) 0) $ \i -> + poke1 cPtr i =<< peek1 bPtr =<< peek1 aPtr i + + +toMatrix :: (Shape.C sh, Class.Floating a) => Permutation sh -> Square sh a +toMatrix (Permutation (Array shape perm)) = + Array.unsafeCreate (MatrixShape.square RowMajor shape) $ \aPtr -> + withForeignPtr perm $ \permPtr -> do + let n = Shape.size shape + fill zero (n*n) aPtr + forM_ (take n $ zip (iterate (1+) 0) (pointerSeq n aPtr)) $ + \(k,rowPtr) -> do + i <- peek1 permPtr k + pokeElemOff rowPtr i one + + +peek1 :: Ptr CInt -> Int -> IO Int +peek1 ptr i = subtract 1 . fromIntegral <$> peekElemOff ptr i + +poke1 :: Ptr CInt -> Int -> Int -> IO () +poke1 ptr i j = pokeElemOff ptr i (fromIntegral (j+1)) + + +apply :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Bool -> Permutation height -> + Full vert horiz height width a -> + Full vert horiz height width a +apply inverted + (Permutation (Array shapeP perm)) + (Array shape@(MatrixShape.Full order extent) a) = + + Array.unsafeCreateWithSize shape $ \blockSize bPtr -> do + + let (height,width) = Extent.dimensions extent + Call.assert "Permutation.apply: heights mismatch" (height == shapeP) + let m = Shape.size height + let n = Shape.size width + evalContT $ do + fwdPtr <- Call.bool $ not inverted + mPtr <- Call.cint m + nPtr <- Call.cint n + kPtr <- copyToTemp n perm + aPtr <- ContT $ withForeignPtr a + liftIO $ do + copyBlock blockSize aPtr bPtr + case order of + RowMajor -> LapackGen.lapmt fwdPtr nPtr mPtr bPtr mPtr kPtr + ColumnMajor -> LapackGen.lapmr fwdPtr mPtr nPtr bPtr nPtr kPtr diff --git a/src/Numeric/LAPACK/Private.hs b/src/Numeric/LAPACK/Private.hs --- a/src/Numeric/LAPACK/Private.hs +++ b/src/Numeric/LAPACK/Private.hs @@ -3,6 +3,7 @@ import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor), transposeFromOrder) +import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) import qualified Numeric.LAPACK.FFI.Generic as LapackGen import qualified Numeric.LAPACK.FFI.Complex as LapackComplex @@ -10,56 +11,35 @@ import qualified Numeric.BLAS.FFI.Generic as BlasGen import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class +import Numeric.LAPACK.Scalar (zero, one, isZero) -import Foreign.Marshal.Array (advancePtr) +import qualified Foreign.Marshal.Utils as Marshal +import qualified Foreign.C.String as CStr +import Foreign.Marshal.Array (copyArray, advancePtr) import Foreign.Marshal.Alloc (alloca) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray) +import Foreign.C.Types (CChar, CInt) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr) import Foreign.Storable (Storable, poke, peek) import Text.Printf (printf) -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.Trans.Cont (ContT(ContT), evalContT, runContT) import Control.Monad.IO.Class (liftIO) -import Control.Monad (foldM) +import Control.Monad (when, foldM) import Control.Applicative ((<$>)) -import Data.Functor.Identity (Identity(Identity, runIdentity)) - +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Internal (Array(Array)) +import Data.Array.Comfort.Storable (Array) import qualified Data.Complex as Complex -import Data.Complex (Complex((:+))) +import Data.Complex (Complex) +import Data.Tuple.HT (swap) import Prelude hiding (sum) -type family RealOf x - -type instance RealOf Float = Float -type instance RealOf Double = Double -type instance RealOf (Complex a) = a - - -type ComplexOf x = Complex (RealOf x) - - -zero, one, minusOne :: Class.Floating a => a -zero = - runIdentity $ - Class.switchFloating (Identity 0) (Identity 0) (Identity 0) (Identity 0) -one = - runIdentity $ - Class.switchFloating (Identity 1) (Identity 1) (Identity 1) (Identity 1) -minusOne = - runIdentity $ - Class.switchFloating - (Identity (-1)) (Identity (-1)) (Identity (-1)) (Identity (-1)) - - - fill :: (Class.Floating a) => a -> Int -> Ptr a -> IO () fill a n dstPtr = evalContT $ do nPtr <- Call.cint n @@ -76,27 +56,93 @@ incyPtr <- Call.cint 1 liftIO $ BlasGen.copy nPtr srcPtr incxPtr dstPtr incyPtr -copyToTemp :: (Class.Floating a) => Int -> ForeignPtr a -> ContT r IO (Ptr a) +copyToTemp :: (Storable a) => Int -> ForeignPtr a -> ContT r IO (Ptr a) copyToTemp n fptr = do ptr <- ContT $ withForeignPtr fptr tmpPtr <- Call.allocaArray n - liftIO $ copyBlock n ptr tmpPtr + liftIO $ copyArray tmpPtr ptr n return tmpPtr {- | +Make a temporary copy only for complex matrices. +-} +conjugateToTemp :: + (Class.Floating a) => Int -> ForeignPtr a -> ContT r IO (Ptr a) +conjugateToTemp n = + runCopyToTemp $ + Class.switchFloating + (CopyToTemp $ ContT . withForeignPtr) + (CopyToTemp $ ContT . withForeignPtr) + (CopyToTemp $ complexConjugateToTemp n) + (CopyToTemp $ complexConjugateToTemp n) + +newtype CopyToTemp r a = + CopyToTemp {runCopyToTemp :: ForeignPtr a -> ContT r IO (Ptr a)} + +complexConjugateToTemp :: + Class.Real a => + Int -> ForeignPtr (Complex a) -> ContT r IO (Ptr (Complex a)) +complexConjugateToTemp n x = do + nPtr <- Call.cint n + xPtr <- copyToTemp n x + incxPtr <- Call.cint 1 + liftIO $ LapackComplex.lacgv nPtr xPtr incxPtr + return xPtr + + +copyConjugate :: + (Class.Floating a) => + Ptr CInt -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> IO () +copyConjugate nPtr xPtr incxPtr yPtr incyPtr = do + BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr + lacgv nPtr yPtr incyPtr + +copyCondConjugate :: + (Class.Floating a) => + Bool -> Ptr CInt -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> IO () +copyCondConjugate conj nPtr xPtr incxPtr yPtr incyPtr = do + BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr + when conj $ lacgv nPtr yPtr incyPtr + +condConjugateToTemp :: + (Class.Floating a) => + Bool -> Int -> ForeignPtr a -> ContT r IO (Ptr a) +condConjugateToTemp conj n x = + if conj then conjugateToTemp n x else ContT $ withForeignPtr x + +copyCondConjugateToTemp :: + (Class.Floating a) => + Bool -> Int -> ForeignPtr a -> ContT r IO (Ptr a) +copyCondConjugateToTemp conj n a = do + bPtr <- Call.allocaArray n + liftIO $ evalContT $ do + aPtr <- ContT $ withForeignPtr a + sizePtr <- Call.cint n + incPtr <- Call.cint 1 + liftIO $ copyCondConjugate conj sizePtr aPtr incPtr bPtr incPtr + return bPtr + + + +{- | In ColumnMajor: Copy a m-by-n-matrix with lda>=m and ldb>=m. -} copySubMatrix :: (Class.Floating a) => Int -> Int -> Int -> Ptr a -> Int -> Ptr a -> IO () -copySubMatrix m n lda aPtr ldb bPtr = evalContT $ do - uploPtr <- Call.char 'A' +copySubMatrix = copySubTrapezoid 'A' + +copySubTrapezoid :: + (Class.Floating a) => + Char -> Int -> Int -> Int -> Ptr a -> Int -> Ptr a -> IO () +copySubTrapezoid side m n lda aPtr ldb bPtr = evalContT $ do + uploPtr <- Call.char side mPtr <- Call.cint m nPtr <- Call.cint n - ldaPtr <- Call.cint lda - ldbPtr <- Call.cint ldb + ldaPtr <- Call.leadingDim lda + ldbPtr <- Call.leadingDim ldb liftIO $ LapackGen.lacpy uploPtr mPtr nPtr aPtr ldaPtr bPtr ldbPtr copyTransposed :: @@ -140,26 +186,19 @@ pointerSeq k ptr = iterate (flip advancePtr k) ptr -allocArray :: (Shape.C sh, Storable a) => sh -> ContT r IO (Array sh a, Ptr a) -allocArray sh = do - fptr <- liftIO $ mallocForeignPtrArray $ Shape.size sh - ptr <- ContT $ withForeignPtr fptr - return (Array sh fptr, ptr) - - -allocHigherArray :: +createHigherArray :: (Shape.C sh, Class.Floating a) => - sh -> Int -> Int -> Int -> ContT r IO (Array sh a, (Ptr a, Int)) -allocHigherArray shapeX m n nrhs = do - (x,xPtr) <- allocArray shapeX + sh -> Int -> Int -> Int -> + ((Ptr a, Int) -> IO rank) -> IO (rank, Array sh a) +createHigherArray shapeX m n nrhs act = + fmap swap $ ArrayIO.unsafeCreateWithSizeAndResult shapeX $ \ _ xPtr -> if m>n - then do - tmpPtr <- Call.allocaArray (m*nrhs) - ContT $ \act -> do - r <- act (x,(tmpPtr,m)) + then + runContT (Call.allocaArray (m*nrhs)) $ \tmpPtr -> do + r <- act (tmpPtr,m) copySubMatrix n nrhs m tmpPtr n xPtr return r - else return (x,(xPtr,n)) + else act (xPtr,n) @@ -193,17 +232,17 @@ onePtr <- Call.number one zeroincPtr <- Call.cint 0 aPtr <- Call.allocaArray n - ldaPtr <- Call.cint 1 + ldaPtr <- Call.leadingDim 1 incxPtr <- Call.cint incx betaPtr <- Call.number zero yPtr <- Call.alloca incyPtr <- Call.cint 1 - liftIO $ BlasGen.copy nPtr onePtr zeroincPtr aPtr incyPtr - liftIO $ - BlasGen.gemv + liftIO $ do + BlasGen.copy nPtr onePtr zeroincPtr aPtr incyPtr + gemv transPtr mPtr nPtr alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr - liftIO $ peek yPtr + peek yPtr product :: Class.Floating a => Int -> Ptr a -> Int -> IO a @@ -224,6 +263,51 @@ (LACGV LapackComplex.lacgv) +{- +Work around an inconsistency of BLAS. +In case of a zero-column matrix +BLAS's gemv and gbmv do not initialize the target vector. +In contrast, these work-arounds do. +-} +{-# INLINE gemv #-} +gemv :: + (Class.Floating a) => + Ptr CChar -> Ptr CInt -> Ptr CInt -> + Ptr a -> Ptr a -> Ptr CInt -> + Ptr a -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () +gemv transPtr mPtr nPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr = do + initializeMV transPtr mPtr nPtr betaPtr yPtr incyPtr + BlasGen.gemv transPtr mPtr nPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr + +{-# INLINE gbmv #-} +gbmv :: + (Class.Floating a) => + Ptr CChar -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> + Ptr a -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> + Ptr a -> Ptr a -> Ptr CInt -> IO () +gbmv transPtr mPtr nPtr klPtr kuPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr = do + initializeMV transPtr mPtr nPtr betaPtr yPtr incyPtr + BlasGen.gbmv transPtr mPtr nPtr klPtr kuPtr + alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr + +initializeMV :: + Class.Floating a => + Ptr CChar -> Ptr CInt -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () +initializeMV transPtr mPtr nPtr betaPtr yPtr incyPtr = do + trans <- peek transPtr + let (mtPtr,ntPtr) = + if trans == CStr.castCharToCChar 'N' + then (mPtr,nPtr) else (nPtr,mPtr) + n <- peek ntPtr + beta <- peek betaPtr + when (n == 0 && isZero beta) $ + Marshal.with 0 $ \incbPtr -> + BlasGen.copy mtPtr betaPtr incbPtr yPtr incyPtr + + multiplyMatrix :: (Class.Floating a) => Order -> Order -> Int -> Int -> Int -> @@ -240,11 +324,11 @@ kPtr <- Call.cint k alphaPtr <- Call.number one aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.cint lda + ldaPtr <- Call.leadingDim lda bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint ldb + ldbPtr <- Call.leadingDim ldb betaPtr <- Call.number zero - ldcPtr <- Call.cint ldc + ldcPtr <- Call.leadingDim ldc liftIO $ BlasGen.gemm transaPtr transbPtr mPtr nPtr kPtr alphaPtr aPtr ldaPtr @@ -254,16 +338,11 @@ withAutoWorkspaceInfo :: (Class.Floating a) => - String -> (Ptr a -> Ptr CInt -> Ptr CInt -> IO ()) -> IO () -withAutoWorkspaceInfo name computation = evalContT $ do - infoPtr <- Call.alloca - liftIO $ withAutoWorkspace $ \workPtr lworkPtr -> + String -> String -> (Ptr a -> Ptr CInt -> Ptr CInt -> IO ()) -> IO () +withAutoWorkspaceInfo msg name computation = + withInfo msg name $ \infoPtr -> + withAutoWorkspace $ \workPtr lworkPtr -> computation workPtr lworkPtr infoPtr - info <- liftIO $ fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ printf "%s: deficient rank %d" name info withAutoWorkspace :: (Class.Floating a) => @@ -272,42 +351,48 @@ lworkPtr <- Call.cint (-1) lwork <- liftIO $ alloca $ \workPtr -> do computation workPtr lworkPtr - ceilingSize <$> peek workPtr + max 1 . ceilingSize <$> peek workPtr workPtr <- Call.allocaArray lwork - liftIO $ poke lworkPtr $ fromIntegral lwork + liftIO $ pokeCInt lworkPtr lwork liftIO $ computation workPtr lworkPtr +withInfo :: String -> String -> (Ptr CInt -> IO ()) -> IO () +withInfo msg name computation = alloca $ \infoPtr -> do + computation infoPtr + info <- peekCInt infoPtr + case compare info (0::Int) of + EQ -> return () + LT -> error $ printf argMsg name (-info) + GT -> error $ name ++ ": " ++ printf msg info -newtype FromReal a = FromReal {getFromReal :: RealOf a -> a} +argMsg :: String +argMsg = "%s: illegal value in %d-th argument" -fromReal :: (Class.Floating a) => RealOf a -> a -fromReal = - getFromReal $ - Class.switchFloating - (FromReal id) - (FromReal id) - (FromReal (:+0)) - (FromReal (:+0)) +errorCodeMsg :: String +errorCodeMsg = "unknown error code %d" -newtype RealPart a = RealPart {getRealPart :: a -> RealOf a} +rankMsg :: String +rankMsg = "deficient rank %d" -realPart :: (Class.Floating a) => a -> RealOf a -realPart = - getRealPart $ - Class.switchFloating - (RealPart id) - (RealPart id) - (RealPart Complex.realPart) - (RealPart Complex.realPart) +definiteMsg :: String +definiteMsg = "minor of order %d not positive definite" +eigenMsg :: String +eigenMsg = "%d off-diagonal elements not converging" -newtype FuncArg b a = FuncArg {runFuncArg :: a -> b} +pokeCInt :: Ptr CInt -> Int -> IO () +pokeCInt ptr = poke ptr . fromIntegral + +peekCInt :: Ptr CInt -> IO Int +peekCInt ptr = fromIntegral <$> peek ptr + + ceilingSize :: (Class.Floating a) => a -> Int ceilingSize = - runFuncArg $ + getFlip $ Class.switchFloating - (FuncArg ceiling) - (FuncArg ceiling) - (FuncArg $ ceiling . Complex.realPart) - (FuncArg $ ceiling . Complex.realPart) + (Flip ceiling) + (Flip ceiling) + (Flip $ ceiling . Complex.realPart) + (Flip $ ceiling . Complex.realPart) diff --git a/src/Numeric/LAPACK/Scalar.hs b/src/Numeric/LAPACK/Scalar.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Scalar.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Scalar ( + RealOf, + ComplexOf, + zero, + one, + minusOne, + isZero, + selectReal, + selectFloating, + + fromReal, + absolute, + absoluteSquared, + norm1, + realPart, + conjugate, + ) where + +import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) + +import qualified Numeric.Netlib.Class as Class + +import Data.Functor.Identity (Identity(Identity, runIdentity)) + +import qualified Data.Complex as Complex +import Data.Complex (Complex((:+))) +import Data.Monoid (Endo(Endo,appEndo)) + + +type family RealOf x + +type instance RealOf Float = Float +type instance RealOf Double = Double +type instance RealOf (Complex a) = a + + +type ComplexOf x = Complex (RealOf x) + + +-- move to netlib-carray:Utility or netlib-ffi:Class +zero, one, minusOne :: Class.Floating a => a +zero = selectFloating 0 0 0 0 +one = selectFloating 1 1 1 1 +minusOne = selectFloating (-1) (-1) (-1) (-1) + +selectReal :: (Class.Real a) => Float -> Double -> a +selectReal rf rd = + runIdentity $ Class.switchReal (Identity rf) (Identity rd) + +selectFloating :: + (Class.Floating a) => + Float -> Double -> Complex Float -> Complex Double -> a +selectFloating rf rd cf cd = + runIdentity $ + Class.switchFloating + (Identity rf) (Identity rd) (Identity cf) (Identity cd) + + +isZero :: Class.Floating a => a -> Bool +isZero = + getFlip $ + Class.switchFloating + (Flip (0==)) (Flip (0==)) + (Flip (0==)) (Flip (0==)) + + +newtype FromReal a = FromReal {getFromReal :: RealOf a -> a} + +fromReal :: (Class.Floating a) => RealOf a -> a +fromReal = + getFromReal $ + Class.switchFloating + (FromReal id) + (FromReal id) + (FromReal (:+0)) + (FromReal (:+0)) + +newtype ToReal a = ToReal {getToReal :: a -> RealOf a} + +realPart :: (Class.Floating a) => a -> RealOf a +realPart = + getToReal $ + Class.switchFloating + (ToReal id) + (ToReal id) + (ToReal Complex.realPart) + (ToReal Complex.realPart) + +absolute :: (Class.Floating a) => a -> RealOf a +absolute = + getToReal $ + Class.switchFloating + (ToReal abs) + (ToReal abs) + (ToReal Complex.magnitude) + (ToReal Complex.magnitude) + + +norm1 :: (Class.Floating a) => a -> RealOf a +norm1 = + getToReal $ + Class.switchFloating + (ToReal abs) + (ToReal abs) + (ToReal norm1Complex) + (ToReal norm1Complex) + +norm1Complex :: (Class.Real a) => Complex a -> a +norm1Complex (r:+i) = abs r + abs i + + +absoluteSquared :: (Class.Floating a) => a -> RealOf a +absoluteSquared = + getToReal $ + Class.switchFloating + (ToReal absoluteSquaredReal) + (ToReal absoluteSquaredReal) + (ToReal absoluteSquaredComplex) + (ToReal absoluteSquaredComplex) + +absoluteSquaredReal :: (Class.Real a) => a -> a +absoluteSquaredReal a = a*a + +absoluteSquaredComplex :: (Class.Real a) => Complex a -> a +absoluteSquaredComplex (r:+i) = r*r+i*i + + +conjugate :: (Class.Floating a) => a -> a +conjugate = + appEndo $ + Class.switchFloating + (Endo id) (Endo id) (Endo Complex.conjugate) (Endo Complex.conjugate) diff --git a/src/Numeric/LAPACK/ShapeStatic.hs b/src/Numeric/LAPACK/ShapeStatic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/ShapeStatic.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.ShapeStatic where + +import Numeric.LAPACK.Matrix.Shape.Private (UnaryProxy) + +import qualified Data.FixedLength as FL + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) + +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num (integralFromProxy) +import Type.Base.Proxy (Proxy(Proxy)) + +import Foreign.Storable (Storable) + +import Text.Printf (printf) + + +{- | +'ZeroBased' denotes a range starting at zero and has a certain length. +-} +newtype ZeroBased n = ZeroBased {zeroBasedSize :: UnaryProxy n} + deriving (Eq, Show) + +instance (Unary.Natural n) => Shape.C (ZeroBased n) where + size = Shape.uncheckedSize + uncheckedSize (ZeroBased len) = integralFromProxy len + +instance (Unary.Natural n) => Shape.Indexed (ZeroBased n) where + type Index (ZeroBased n) = FL.Index n + indices _len = FL.toList FL.indices + offset = Shape.uncheckedOffset + uncheckedOffset _len = fromIntegral . FL.numFromIndex + inBounds _len _ix = True + +instance (Unary.Natural n) => Shape.InvIndexed (ZeroBased n) where + -- could be implemented using new fixed-length-0.2.1:FL.indexFromNum + indexFromOffset len k = + case (0<=k, drop k $ Shape.indices len) of + (True, i:_) -> i + _ -> -- cf. comfort-array:Shape.errorIndexFromOffset + error $ + printf "indexFromOffset (ShapeStatic.ZeroBased): index %d out of range" k + + +vector :: (Unary.Natural n, Storable a) => FL.T n a -> Array (ZeroBased n) a +vector = Array.fromList (ZeroBased Proxy) . FL.toList diff --git a/src/Numeric/LAPACK/Singular.hs b/src/Numeric/LAPACK/Singular.hs --- a/src/Numeric/LAPACK/Singular.hs +++ b/src/Numeric/LAPACK/Singular.hs @@ -1,9 +1,11 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Singular ( values, + valuesTall, + valuesWide, decompose, - decomposeNarrow, - decomposeSquat, + decomposeTall, + decomposeWide, determinantAbsolute, leastSquaresMinimumNormRCond, pseudoInverseRCond, @@ -11,15 +13,22 @@ ) where import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Square (Square) -import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor,ColumnMajor)) -import Numeric.LAPACK.Matrix.Private (General, ZeroInt, zeroInt) +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Matrix.Hermitian.Private + (TakeDiagonal(..), Determinant(..)) +import Numeric.LAPACK.Matrix.Extent.Private (Extent) +import Numeric.LAPACK.Matrix.Square.Basic (Square) +import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), swapOnRowMajor) +import Numeric.LAPACK.Matrix (scaleRowsReal) +import Numeric.LAPACK.Matrix.Private (Full, General, ZeroInt, zeroInt) import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, zero) import Numeric.LAPACK.Private - (RealOf, withAutoWorkspace, fromReal, allocArray, allocHigherArray, + (withAutoWorkspace, peekCInt, createHigherArray, copyToTemp, copyToColumnMajor, copyToSubColumnMajor) import qualified Numeric.LAPACK.FFI.Complex as LapackComplex @@ -27,49 +36,68 @@ import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class +import qualified Data.Array.Comfort.Storable.Internal.Monadic as ArrayIO import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Internal (Array(Array)) import System.IO.Unsafe (unsafePerformIO) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Marshal.Alloc (alloca) +import qualified Foreign.Marshal.Array.Guarded as ForeignArray +import qualified Foreign.Marshal.Utils as Marshal import Foreign.C.Types (CInt, CChar) -import Foreign.ForeignPtr (withForeignPtr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (Storable, peek) +import Foreign.Storable (Storable) import Control.Monad.Trans.Cont (evalContT) import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) -import Text.Printf (printf) - import Data.Complex (Complex) +import Data.Tuple.HT (mapSnd) +import Data.Bool.HT (if') values :: (Shape.C height, Shape.C width, Class.Floating a) => General height width a -> Vector ZeroInt (RealOf a) values = - getValues $ - Class.switchFloating - (Values valuesAux) (Values valuesAux) - (Values valuesAux) (Values valuesAux) + valuesGen $ \extent -> + zeroInt $ + min + (Shape.size $ Extent.height extent) + (Shape.size $ Extent.width extent) -type Values_ height width a = - General height width a -> Vector ZeroInt (RealOf a) +valuesTall :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Full vert Extent.Small height width a -> Vector width (RealOf a) +valuesTall = valuesGen Extent.width -newtype Values height width a = Values {getValues :: Values_ height width a} +valuesWide :: + (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => + Full Extent.Small horiz height width a -> Vector height (RealOf a) +valuesWide = valuesTall . Matrix.transpose +valuesGen :: + (Extent.C vert, Extent.C horiz, Shape.C width, Shape.C height, + Shape.C shape, Class.Floating a) => + (Extent vert horiz height width -> shape) -> + Full vert horiz height width a -> Vector shape (RealOf a) +valuesGen resultShape = + runTakeDiagonal $ + Class.switchFloating + (TakeDiagonal $ valuesAux resultShape) + (TakeDiagonal $ valuesAux resultShape) + (TakeDiagonal $ valuesAux resultShape) + (TakeDiagonal $ valuesAux resultShape) + valuesAux :: - (Shape.C height, Shape.C width, - Class.Floating a, RealOf a ~ ar, Storable ar) => - Values_ height width a -valuesAux (Array shape@(MatrixShape.General _order height width) a) = - Array.unsafeCreateWithSize - (zeroInt $ min (Shape.size height) (Shape.size width)) $ \mn sPtr -> do + (Extent.C vert, Extent.C horiz, Shape.C width, Shape.C height, + Shape.C shape, Class.Floating a, RealOf a ~ ar, Storable ar) => + (Extent vert horiz height width -> shape) -> + Full vert horiz height width a -> Vector shape ar +valuesAux resultShape (Array shape@(MatrixShape.Full _order extent) a) = + Array.unsafeCreateWithSize (resultShape extent) $ \mn sPtr -> do let (m,n) = MatrixShape.dimensions shape let lda = m evalContT $ do @@ -78,11 +106,11 @@ mPtr <- Call.cint m nPtr <- Call.cint n aPtr <- copyToTemp (m*n) a - ldaPtr <- Call.cint lda + ldaPtr <- Call.leadingDim lda let uPtr = nullPtr let vtPtr = nullPtr - lduPtr <- Call.cint m - ldvtPtr <- Call.cint n + lduPtr <- Call.leadingDim m + ldvtPtr <- Call.leadingDim n liftIO $ withInfo "gesvd" $ \infoPtr -> gesvd jobuPtr jobvtPtr mPtr nPtr @@ -93,23 +121,21 @@ (Shape.C height, Shape.C width, Class.Floating a) => General height width a -> RealOf a determinantAbsolute = - getDeterminantAbsolute $ + getDeterminant $ Class.switchFloating - (DeterminantAbsolute determinantAbsoluteAux) - (DeterminantAbsolute determinantAbsoluteAux) - (DeterminantAbsolute determinantAbsoluteAux) - (DeterminantAbsolute determinantAbsoluteAux) - -newtype DeterminantAbsolute f a = - DeterminantAbsolute { - getDeterminantAbsolute :: f a -> RealOf a - } + (Determinant determinantAbsoluteAux) + (Determinant determinantAbsoluteAux) + (Determinant determinantAbsoluteAux) + (Determinant determinantAbsoluteAux) determinantAbsoluteAux :: (Shape.C height, Shape.C width, - Class.Floating a, RealOf a ~ ar, Class.Floating ar) => + Class.Floating a, RealOf a ~ ar, Class.Real ar) => General height width a -> ar -determinantAbsoluteAux = Vector.product . values +determinantAbsoluteAux = + either (Vector.product . valuesTall) (const zero) + . + Matrix.caseTallWide decompose :: @@ -125,56 +151,61 @@ (Decompose decomposeAux) newtype Decompose m f v g a = - Decompose { - getDecompose :: m a -> (f a, v (RealOf a), g a) - } + Decompose {getDecompose :: m a -> (f a, v (RealOf a), g a)} decomposeAux :: (Shape.C height, Shape.C width, Class.Floating a, RealOf a ~ ar, Storable ar) => General height width a -> (Square height a, Vector ZeroInt ar, Square width a) -decomposeAux (Array (MatrixShape.General order height width) a) = - unsafePerformIO $ evalContT $ do - (u,uPtr0) <- allocArray (MatrixShape.Square order height) - (vt,vtPtr0) <- allocArray (MatrixShape.Square order width) - let ((m,n),(uPtr,vtPtr)) = - case order of - RowMajor -> - ((Shape.size width, Shape.size height), (vtPtr0,uPtr0)) - ColumnMajor -> - ((Shape.size height, Shape.size width), (uPtr0,vtPtr0)) - let mn = min m n +decomposeAux arr@(Array shape@(MatrixShape.Full order extent) a) = + + let (height,width) = Extent.dimensions extent + (m,n) = MatrixShape.dimensions shape + mn = min m n + + in (if' (mn==0) + (Square.identityFromHeight arr, + Vector.autoFromList [], + Square.identityFromWidth arr)) $ + (\(u,(s,vt)) -> (u,s,vt)) $ + Array.unsafeCreateWithSizeAndResult (MatrixShape.square order height) $ + \ _ uPtr0 -> + ArrayIO.unsafeCreateWithSizeAndResult (zeroInt mn) $ \ _ sPtr -> + ArrayIO.unsafeCreate (MatrixShape.square order width) $ \vtPtr0 -> + + evalContT $ do + let (uPtr,vtPtr) = swapOnRowMajor order (uPtr0,vtPtr0) let lda = m jobuPtr <- Call.char 'A' jobvtPtr <- Call.char 'A' mPtr <- Call.cint m nPtr <- Call.cint n aPtr <- copyToTemp (m*n) a - ldaPtr <- Call.cint lda - (s,sPtr) <- allocArray (zeroInt mn) - lduPtr <- Call.cint m - ldvtPtr <- Call.cint n + ldaPtr <- Call.leadingDim lda + lduPtr <- Call.leadingDim m + ldvtPtr <- Call.leadingDim n liftIO $ withInfo "gesvd" $ \infoPtr -> gesvd jobuPtr jobvtPtr mPtr nPtr aPtr ldaPtr sPtr uPtr lduPtr vtPtr ldvtPtr mn infoPtr - return (u, s, vt) -decomposeSquat :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> - (Square height a, Vector height (RealOf a), General height width a) -decomposeSquat a = - let (u,s,vt) = decomposeNarrow $ Matrix.transpose a +decomposeWide :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Full Extent.Small vert height width a -> + (Square height a, Vector height (RealOf a), + Full Extent.Small vert height width a) +decomposeWide a = + let (u,s,vt) = decomposeTall $ Matrix.transpose a in (Square.transpose vt, s, Matrix.transpose u) -decomposeNarrow :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> - (General height width a, Vector width (RealOf a), Square width a) -decomposeNarrow = +decomposeTall :: + (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => + Full horiz Extent.Small height width a -> + (Full horiz Extent.Small height width a, + Vector width (RealOf a), Square width a) +decomposeTall = getDecompose $ Class.switchFloating (Decompose decomposeThin) @@ -183,23 +214,22 @@ (Decompose decomposeThin) decomposeThin :: - (Shape.C height, Shape.C width, + (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a, RealOf a ~ ar, Storable ar) => - General height width a -> - (General height width a, Vector width ar, Square width a) -decomposeThin (Array (MatrixShape.General order height width) a) = - unsafePerformIO $ do - Call.assert "Singular.decomposeThin: matrix is wider than high" - (Shape.size height >= Shape.size width) - evalContT $ do - (u,uPtr0) <- allocArray (MatrixShape.General order height width) - (vt,vtPtr0) <- allocArray (MatrixShape.Square order width) - let ((m,n),(uPtr,vtPtr)) = - case order of - RowMajor -> - ((Shape.size width, Shape.size height), (vtPtr0,uPtr0)) - ColumnMajor -> - ((Shape.size height, Shape.size width), (uPtr0,vtPtr0)) + Full horiz Extent.Small height width a -> + (Full horiz Extent.Small height width a, Vector width ar, Square width a) +decomposeThin (Array (MatrixShape.Full order extent) a) = + let (height,width) = Extent.dimensions extent + in (\(u,(s,vt)) -> (u,s,vt)) $ + Array.unsafeCreateWithSizeAndResult (MatrixShape.Full order extent) $ + \ _ uPtr0 -> + ArrayIO.unsafeCreateWithSizeAndResult width $ \ _ sPtr -> + ArrayIO.unsafeCreate (MatrixShape.square order width) $ \vtPtr0 -> + + evalContT $ do + let ((m,uPtr),(n,vtPtr)) = + swapOnRowMajor order + ((Shape.size height, uPtr0), (Shape.size width, vtPtr0)) let mn = min m n let lda = m jobuPtr <- Call.char 'S' @@ -207,15 +237,13 @@ mPtr <- Call.cint m nPtr <- Call.cint n aPtr <- copyToTemp (m*n) a - ldaPtr <- Call.cint lda - (s,sPtr) <- allocArray width - lduPtr <- Call.cint m - ldvtPtr <- Call.cint mn + ldaPtr <- Call.leadingDim lda + lduPtr <- Call.leadingDim m + ldvtPtr <- Call.leadingDim mn liftIO $ withInfo "gesvd" $ \infoPtr -> gesvd jobuPtr jobvtPtr mPtr nPtr aPtr ldaPtr sPtr uPtr lduPtr vtPtr ldvtPtr mn infoPtr - return (u, s, vt) type GESVD_ ar a = @@ -245,7 +273,7 @@ gesvdComplex :: (Class.Real a) => GESVD_ a (Complex a) gesvdComplex jobuPtr jobvtPtr mPtr nPtr aPtr ldaPtr sPtr uPtr lduPtr vtPtr ldvtPtr mn infoPtr = - allocaArray (5*mn) $ \rworkPtr -> + ForeignArray.alloca (5*mn) $ \rworkPtr -> withAutoWorkspace $ \workPtr lworkPtr -> LapackComplex.gesvd jobuPtr jobvtPtr mPtr nPtr aPtr ldaPtr sPtr uPtr lduPtr vtPtr ldvtPtr @@ -253,38 +281,50 @@ leastSquaresMinimumNormRCond :: - (Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - RealOf a -> General height width a -> General height nrhs a -> - (Int, General width nrhs a) -leastSquaresMinimumNormRCond = - getLeastSquaresMinimumNormRCond $ - Class.switchFloating - (LeastSquaresMinimumNormRCond leastSquaresMinimumNormRCondAux) - (LeastSquaresMinimumNormRCond leastSquaresMinimumNormRCondAux) - (LeastSquaresMinimumNormRCond leastSquaresMinimumNormRCondAux) - (LeastSquaresMinimumNormRCond leastSquaresMinimumNormRCondAux) + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + RealOf a -> + Full horiz vert height width a -> + Full vert horiz height nrhs a -> + (Int, Full vert horiz width nrhs a) +leastSquaresMinimumNormRCond rcond + (Array (MatrixShape.Full orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + case Extent.fuse (Extent.transpose extentA) extentB of + Nothing -> error "leastSquaresMinimumNorm: height shapes mismatch" + Just extent -> + let widthA = Extent.width extentA + (height,widthB) = Extent.dimensions extentB + shapeX = MatrixShape.Full ColumnMajor extent + m = Shape.size height + n = Shape.size widthA + nrhs = Shape.size widthB + in if m == 0 + then (0, Vector.constant shapeX zero) + else + if nrhs == 0 + then + (fst $ unsafePerformIO $ + case Vector.constant height zero of + Array _ b1 -> + leastSquaresMinimumNormIO rcond + (MatrixShape.general ColumnMajor widthA ()) + orderA a orderB b1 m n 1, + Vector.constant shapeX zero) + else + unsafePerformIO $ + leastSquaresMinimumNormIO rcond shapeX + orderA a orderB b m n nrhs -newtype LeastSquaresMinimumNormRCond f g h a = - LeastSquaresMinimumNormRCond { - getLeastSquaresMinimumNormRCond :: - RealOf a -> f a -> g a -> (Int, h a) - } +leastSquaresMinimumNormIO :: + (Shape.C sh, Class.Floating a) => + RealOf a -> sh -> + Order -> ForeignPtr a -> + Order -> ForeignPtr a -> + Int -> Int -> Int -> IO (Int, Array sh a) +leastSquaresMinimumNormIO rcond shapeX orderA a orderB b m n nrhs = + createHigherArray shapeX m n nrhs $ \(tmpPtr,ldtmp) -> do -leastSquaresMinimumNormRCondAux :: - (Shape.C height, Eq height, Shape.C width, Shape.C nrhs, - Class.Floating a, RealOf a ~ ar, Class.Floating ar) => - ar -> General height width a -> General height nrhs a -> - (Int, General width nrhs a) -leastSquaresMinimumNormRCondAux rcond - (Array (MatrixShape.General orderA heightA widthA) a) - (Array (MatrixShape.General orderB heightB widthB) b) = - unsafePerformIO $ do - Call.assert "leastSquaresMinimumNorm: height shapes mismatch" - (heightA == heightB) - let shapeX = MatrixShape.General ColumnMajor widthA widthB - let m = Shape.size heightA - let n = Shape.size widthA - let nrhs = Shape.size widthB let mn = min m n let aSize = m*n let lda = m @@ -295,28 +335,24 @@ aPtr <- Call.allocaArray aSize liftIO $ withForeignPtr a $ \asrcPtr -> copyToColumnMajor orderA m n asrcPtr aPtr - ldaPtr <- Call.cint lda - (x,(tmpPtr,ldtmp)) <- allocHigherArray shapeX m n nrhs - ldtmpPtr <- Call.cint ldtmp + ldaPtr <- Call.leadingDim lda + ldtmpPtr <- Call.leadingDim ldtmp liftIO $ withForeignPtr b $ \bPtr -> copyToSubColumnMajor orderB m nrhs bPtr ldtmp tmpPtr - sPtr <- Call.allocaArray mn - rcondPtr <- Call.number rcond rankPtr <- Call.alloca liftIO $ withInfo "gelss" $ \infoPtr -> - gelss mPtr nPtr nrhsPtr aPtr ldaPtr tmpPtr ldtmpPtr sPtr rcondPtr + gelss mPtr nPtr nrhsPtr aPtr ldaPtr tmpPtr ldtmpPtr rcond rankPtr mn infoPtr - rank <- liftIO $ fromIntegral <$> peek rankPtr - return (rank, x) + liftIO $ peekCInt rankPtr type GELSS_ ar a = Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> - Ptr ar -> Ptr ar -> Ptr CInt -> Int -> Ptr CInt -> IO () + ar -> Ptr CInt -> Int -> Ptr CInt -> IO () newtype GELSS a = GELSS {getGELSS :: GELSS_ (RealOf a) a} @@ -330,17 +366,21 @@ (GELSS gelssComplex) gelssReal :: (Class.Real a) => GELSS_ a a -gelssReal mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr sPtr rcondPtr - rankPtr _mn infoPtr = +gelssReal mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr rcond + rankPtr mn infoPtr = + Marshal.with rcond $ \rcondPtr -> + ForeignArray.alloca mn $ \sPtr -> withAutoWorkspace $ \workPtr lworkPtr -> LapackReal.gelss mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr sPtr rcondPtr rankPtr workPtr lworkPtr infoPtr gelssComplex :: (Class.Real a) => GELSS_ a (Complex a) -gelssComplex mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr sPtr rcondPtr +gelssComplex mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr rcond rankPtr mn infoPtr = - allocaArray (5*mn) $ \rworkPtr -> + Marshal.with rcond $ \rcondPtr -> + ForeignArray.alloca mn $ \sPtr -> + ForeignArray.alloca (5*mn) $ \rworkPtr -> withAutoWorkspace $ \workPtr lworkPtr -> LapackComplex.gelss mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr sPtr rcondPtr @@ -348,8 +388,11 @@ pseudoInverseRCond :: - (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - RealOf a -> General height width a -> (Int, General width height a) + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + RealOf a -> + Full vert horiz height width a -> + (Int, Full horiz vert width height a) pseudoInverseRCond = getPseudoInverseRCond $ Class.switchFloating @@ -364,43 +407,70 @@ } pseudoInverseRCondAux :: - (Shape.C height, Eq height, Shape.C width, Eq width, + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - RealOf a -> General height width a -> (Int, General width height a) -pseudoInverseRCondAux rcond a = - let (MatrixShape.General _ height width) = Array.shape a - in if Shape.size height < Shape.size width - then - let (u,s,vt) = decomposeSquat a - (rank,recipS) = recipSigma rcond s - in (rank, - Matrix.multiply (Matrix.adjoint vt) $ - Matrix.scaleRows recipS $ - Square.toGeneral $ Square.adjoint u) - else - let (u,s,vt) = decomposeNarrow a - (rank,recipS) = recipSigma rcond s - in (rank, - Matrix.multiply (Square.toGeneral $ Square.adjoint vt) $ - Matrix.scaleRows recipS $ Matrix.adjoint u) + ar -> + Full vert horiz height width a -> + (Int, Full horiz vert width height a) +pseudoInverseRCondAux rcond = + getPseudoInverseExtent $ + Extent.switchTagPair + (PseudoInverseExtent $ pseudoInverseRCondWide rcond) + (PseudoInverseExtent $ pseudoInverseRCondWide rcond) + (PseudoInverseExtent $ pseudoInverseRCondTall rcond) + (PseudoInverseExtent $ + either + (mapSnd Matrix.fromFull . pseudoInverseRCondTall rcond) + (mapSnd Matrix.fromFull . pseudoInverseRCondWide rcond) + . + Matrix.caseTallWide) +newtype PseudoInverseExtent height width a vert horiz = + PseudoInverseExtent { + getPseudoInverseExtent :: + Full vert horiz height width a -> + (Int, Full horiz vert width height a) + } + +pseudoInverseRCondWide :: + (Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + RealOf a -> + Full Extent.Small horiz height width a -> + (Int, Full horiz Extent.Small width height a) +pseudoInverseRCondWide rcond a = + let (u,s,vt) = decomposeWide a + (rank,recipS) = recipSigma rcond s + in (rank, + Matrix.multiply (Matrix.adjoint vt) $ + scaleRowsReal recipS $ Square.toFull $ Square.adjoint u) + +pseudoInverseRCondTall :: + (Extent.C vert, Shape.C height, Eq height, Shape.C width, Eq width, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + RealOf a -> + Full vert Extent.Small height width a -> + (Int, Full Extent.Small vert width height a) +pseudoInverseRCondTall rcond a = + let (u,s,vt) = decomposeTall a + (rank,recipS) = recipSigma rcond s + in (rank, + Matrix.multiply (Square.toFull $ Square.adjoint vt) $ + scaleRowsReal recipS $ Matrix.adjoint u) + + recipSigma :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ar -> Array sh ar -> (Int, Array sh a) + (Shape.C sh, Class.Real a) => a -> Array sh a -> (Int, Array sh a) recipSigma rcond sigmas = case Array.toList sigmas of - [] -> (0, Array.map fromReal sigmas) + [] -> (0, sigmas) + 0:_ -> (0, sigmas) xs@(x:_) -> let smin = x * rcond in (length (takeWhile (>=smin) xs), - Array.map (\s -> if s>=smin then fromReal (recip s) else 0) sigmas) + Array.map (\s -> if s>=smin then recip s else 0) sigmas) withInfo :: String -> (Ptr CInt -> IO ()) -> IO () -withInfo name computation = alloca $ \infoPtr -> do - computation infoPtr - info <- fromIntegral <$> peek infoPtr - case compare info (0::Int) of - EQ -> return () - LT -> error $ printf "%s: illegal value in %d-th argument" name (-info) - GT -> error $ printf "%s: %d superdiagonals did not converge" name info +withInfo = Private.withInfo "%d superdiagonals did not converge" diff --git a/src/Numeric/LAPACK/Split.hs b/src/Numeric/LAPACK/Split.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Split.hs @@ -0,0 +1,244 @@ +module Numeric.LAPACK.Split where + +import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Triangular.Private as TriPriv +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Tri +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Private as Private +import Numeric.LAPACK.Matrix.Triangular.Private (diagonalPointers) +import Numeric.LAPACK.Matrix.Triangular.Basic (UnitLower, Upper) +import Numeric.LAPACK.Matrix.Shape.Private + (Order(RowMajor, ColumnMajor), transposeFromOrder, + swapOnRowMajor, sideSwapFromOrder, + Triangle, uploFromOrder, flipOrder) +import Numeric.LAPACK.Matrix.Private + (Full, Transposition, transposeOrder, + Conjugation(NonConjugated, Conjugated)) +import Numeric.LAPACK.Linear.Private (solver, withInfo) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private (copyBlock, conjugateToTemp) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Internal as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Internal (Array(Array)) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (poke) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + + +type Split lower vert horiz height width = + Array (MatrixShape.Split lower vert horiz height width) + + +determinantR :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Split lower vert Extent.Small height width a -> a +determinantR (Array (MatrixShape.Split _ order extent) a) = + let (height,width) = Extent.dimensions extent + m = Shape.size height + n = Shape.size width + k = case order of RowMajor -> n; ColumnMajor -> m + in unsafePerformIO $ + withForeignPtr a $ \aPtr -> + Private.product (min m n) aPtr (k+1) + +oddPermutation :: [CInt] -> Bool +oddPermutation = not . null . dropEven . filter id . zipWith (/=) [1..] + +dropEven :: [a] -> [a] +dropEven (_:_:xs) = dropEven xs +dropEven xs = xs + + +extractTriangle :: + (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Either lower Triangle -> + Split lower vert horiz height width a -> + Full vert horiz height width a +extractTriangle part (Array (MatrixShape.Split _ order extent) qr) = + + Array.unsafeCreate (MatrixShape.Full order extent) $ \rPtr -> do + + let (height,width) = Extent.dimensions extent + let ((loup,m), (uplo,n)) = + swapOnRowMajor order + (('L', Shape.size height), ('U', Shape.size width)) + evalContT $ do + loupPtr <- Call.char loup + uploPtr <- Call.char uplo + mPtr <- Call.cint m + nPtr <- Call.cint n + qrPtr <- ContT $ withForeignPtr qr + ldqrPtr <- Call.leadingDim m + ldrPtr <- Call.leadingDim m + zeroPtr <- Call.number zero + onePtr <- Call.number one + liftIO $ + case part of + Left _ -> do + LapackGen.lacpy loupPtr mPtr nPtr qrPtr ldqrPtr rPtr ldrPtr + LapackGen.laset uploPtr mPtr nPtr zeroPtr onePtr rPtr ldrPtr + Right _ -> do + LapackGen.laset loupPtr mPtr nPtr zeroPtr zeroPtr rPtr ldrPtr + LapackGen.lacpy uploPtr mPtr nPtr qrPtr ldqrPtr rPtr ldrPtr + + +wideExtractL :: + (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => + Split lower Extent.Small horiz height width a -> UnitLower height a +wideExtractL = + TriPriv.takeLower + (MatrixShape.Unit, + \order m lPtr -> mapM_ (flip poke one) $ diagonalPointers order m lPtr) + . + toFull + +tallExtractR :: + (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => + Split lower vert Extent.Small height width a -> Upper width a +tallExtractR = Tri.takeUpper . toFull + +toFull :: + Split lower vert horiz height width a -> + Full vert horiz height width a +toFull = + Array.mapShape + (\(MatrixShape.Split _ order extent) -> MatrixShape.Full order extent) + + +wideMultiplyL :: + (Extent.C horizA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + Shape.C widthA, Shape.C widthB, Class.Floating a) => + Transposition -> + Split Triangle Extent.Small horizA height widthA a -> + Full vert horiz height widthB a -> + Full vert horiz height widthB a +wideMultiplyL transposed a b = + if MatrixShape.splitHeight (Array.shape a) == Matrix.height b + then multiplyTriangular ('L','U') 'U' transposed a b + else error "wideMultiplyL: height shapes mismatch" + +tallMultiplyR :: + (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + Shape.C heightA, Shape.C widthB, Class.Floating a) => + Transposition -> + Split lower vertA Extent.Small heightA height a -> + Full vert horiz height widthB a -> + Full vert horiz height widthB a +tallMultiplyR transposed a b = + if MatrixShape.splitWidth (Array.shape a) == Matrix.height b + then multiplyTriangular ('U','L') 'N' transposed a b + else error "wideMultiplyR: height shapes mismatch" + +multiplyTriangular :: + (Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB, + Shape.C heightA, Shape.C widthA, Shape.C heightB, Shape.C widthB, + Class.Floating a) => + (Char,Char) -> Char -> Transposition -> + Split lower vertA horizA heightA widthA a -> + Full vertB horizB heightB widthB a -> + Full vertB horizB heightB widthB a +multiplyTriangular (normalPart,transposedPart) diag transposed + (Array (MatrixShape.Split _ orderA extentA) a) + (Array (MatrixShape.Full orderB extentB) b) = + + Array.unsafeCreate (MatrixShape.Full orderB extentB) $ \cPtr -> do + + let (heightA,widthA) = Extent.dimensions extentA + let (heightB,widthB) = Extent.dimensions extentB + let transOrderB = transposeOrder transposed orderB + let ((uplo, transa), lda) = + case orderA of + RowMajor -> + ((transposedPart, flipOrder transOrderB), Shape.size widthA) + ColumnMajor -> + ((normalPart, transOrderB), Shape.size heightA) + let (side,(m,n)) = + sideSwapFromOrder orderB (Shape.size heightB, Shape.size widthB) + evalContT $ do + sidePtr <- Call.char side + uploPtr <- Call.char uplo + transaPtr <- Call.char $ transposeFromOrder transa + diagPtr <- Call.char diag + mPtr <- Call.cint m + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim lda + bPtr <- ContT $ withForeignPtr b + ldcPtr <- Call.leadingDim m + alphaPtr <- Call.number one + liftIO $ do + copyBlock (m*n) bPtr cPtr + BlasGen.trmm sidePtr uploPtr transaPtr diagPtr + mPtr nPtr alphaPtr aPtr ldaPtr cPtr ldcPtr + + +wideSolveL :: + (Extent.C horizA, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + Transposition -> Conjugation -> + Split Triangle Extent.Small horizA height width a -> + Full vert horiz height nrhs a -> Full vert horiz height nrhs a +wideSolveL transposed conjugated + (Array (MatrixShape.Split _ orderA extentA) a) = + let heightA = Extent.height extentA + in solver "Split.wideSolveL" heightA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + + uploPtr <- Call.char $ uploFromOrder $ flipOrder orderA + diagPtr <- Call.char 'U' + let m = Shape.size heightA + solveTriangular transposed conjugated orderA m n a + uploPtr diagPtr nPtr nrhsPtr xPtr ldxPtr + +tallSolveR :: + (Extent.C vertA, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => + Transposition -> Conjugation -> + Split lower vertA Extent.Small height width a -> + Full vert horiz width nrhs a -> Full vert horiz width nrhs a +tallSolveR transposed conjugated + (Array (MatrixShape.Split _ orderA extentA) a) = + let (heightA,widthA) = Extent.dimensions extentA + in solver "Split.tallSolveR" widthA $ \n nPtr nrhsPtr xPtr ldxPtr -> do + + uploPtr <- Call.char $ uploFromOrder orderA + diagPtr <- Call.char 'N' + let m = Shape.size heightA + solveTriangular transposed conjugated orderA m n a + uploPtr diagPtr nPtr nrhsPtr xPtr ldxPtr + +solveTriangular :: + Class.Floating a => + Transposition -> Conjugation -> + Order -> Int -> Int -> ForeignPtr a -> + Ptr CChar -> Ptr CChar -> Ptr CInt -> Ptr CInt -> + Ptr a -> Ptr CInt -> ContT r IO () +solveTriangular transposed conjugated orderA m n a + uploPtr diagPtr nPtr nrhsPtr xPtr ldxPtr = do + let (trans, getA) = + case (transposeOrder transposed orderA, conjugated) of + (RowMajor, NonConjugated) -> ('T', ContT $ withForeignPtr a) + (RowMajor, Conjugated) -> ('C', ContT $ withForeignPtr a) + (ColumnMajor, NonConjugated) -> ('N', ContT $ withForeignPtr a) + (ColumnMajor, Conjugated) -> ('N', conjugateToTemp (m*n) a) + transPtr <- Call.char trans + aPtr <- getA + ldaPtr <- Call.leadingDim $ case orderA of ColumnMajor -> m; RowMajor -> n + liftIO $ + withInfo "trtrs" $ + LapackGen.trtrs uploPtr transPtr diagPtr + nPtr nrhsPtr aPtr ldaPtr xPtr ldxPtr diff --git a/src/Numeric/LAPACK/Vector.hs b/src/Numeric/LAPACK/Vector.hs --- a/src/Numeric/LAPACK/Vector.hs +++ b/src/Numeric/LAPACK/Vector.hs @@ -1,29 +1,49 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Numeric.LAPACK.Vector ( Vector, + RealOf, + ComplexOf, + toList, fromList, autoFromList, + append, take, drop, + takeLeft, takeRight, constant, - dot, + unit, + dot, inner, sum, absSum, norm1, norm2, + normInf, + normInf1, argAbsMaximum, argAbs1Maximum, product, - scale, - add, sub , + scale, scaleReal, + add, sub, mac, mul, - outer, + conjugate, + fromReal, + toComplex, + realPart, + complexFromReal, + complexToRealPart, + complexToImaginaryPart, + zipComplex, + unzipComplex, + random, RandomDistribution(..), ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Scalar as Scalar import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Private (RealOf, zero, one, minusOne, fill) +import Numeric.LAPACK.Matrix.Private (ZeroInt) +import Numeric.LAPACK.Scalar (ComplexOf, RealOf, zero, one, minusOne, absolute) +import Numeric.LAPACK.Private (fill, copyConjugate) import qualified Numeric.LAPACK.FFI.Generic as LapackGen import qualified Numeric.LAPACK.FFI.Complex as LapackComplex @@ -33,8 +53,9 @@ import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class +import Foreign.Marshal.Array (copyArray, advancePtr) import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable, peek, peekElemOff, pokeElemOff) import Foreign.C.Types (CInt) @@ -42,22 +63,27 @@ import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) -import Control.Applicative (Const(Const,getConst), (<$>)) +import Control.Applicative (Const(Const,getConst), liftA3, (<$>)) import qualified Data.Array.Comfort.Storable.Internal as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Internal (Array(Array)) +import Data.Array.Comfort.Shape ((:+:)((:+:))) import Data.Complex (Complex) +import Data.Tuple.HT (mapFst, uncurry3) import Data.Word (Word64) import Data.Bits (shiftR, (.&.)) -import Prelude hiding (sum, product) +import Prelude hiding (sum, product, take, drop) type Vector = Array +toList :: (Shape.C sh, Storable a) => Vector sh a -> [a] +toList = Array.toList + fromList :: (Shape.C sh, Storable a) => sh -> [a] -> Vector sh a fromList = Array.fromList @@ -68,9 +94,63 @@ constant :: (Shape.C sh, Class.Floating a) => sh -> a -> Vector sh a constant sh a = Array.unsafeCreateWithSize sh $ fill a +unit :: + (Shape.Indexed sh, Class.Floating a) => + sh -> Shape.Index sh -> Vector sh a +unit sh ix = Array.unsafeCreateWithSize sh $ \n xPtr -> do + fill zero n xPtr + pokeElemOff xPtr (Shape.offset sh ix) one + +append :: + (Shape.C shx, Shape.C shy, Storable a) => + Vector shx a -> Vector shy a -> Vector (shx:+:shy) a +append (Array shX x) (Array shY y) = + Array.unsafeCreate (shX:+:shY) $ \zPtr -> + evalContT $ do + xPtr <- ContT $ withForeignPtr x + yPtr <- ContT $ withForeignPtr y + let sizeX = Shape.size shX + let sizeY = Shape.size shY + liftIO $ do + copyArray zPtr xPtr sizeX + copyArray (advancePtr zPtr sizeX) yPtr sizeY + +take, drop :: (Storable a) => Int -> Vector ZeroInt a -> Vector ZeroInt a +take n = takeLeft . split n +drop n = takeRight . split n + +split :: (Storable a) => Int -> Vector ZeroInt a -> Vector (ZeroInt:+:ZeroInt) a +split n = + Array.mapShape + (\(Shape.ZeroBased m) -> + if n<0 + then error "Vector.split: negative number of elements" + else + let k = min n m + in Shape.ZeroBased k :+: Shape.ZeroBased (m-k)) + +takeLeft :: + (Shape.C sh0, Shape.C sh1, Storable a) => + Vector (sh0:+:sh1) a -> Vector sh0 a +takeLeft (Array (sh0 :+: _sh1) x) = + Array.unsafeCreateWithSize sh0 $ \k yPtr -> + withForeignPtr x $ \xPtr -> copyArray yPtr xPtr k + +takeRight :: + (Shape.C sh0, Shape.C sh1, Storable a) => + Vector (sh0:+:sh1) a -> Vector sh1 a +takeRight (Array (sh0:+:sh1) x) = + Array.unsafeCreateWithSize sh1 $ \k yPtr -> + withForeignPtr x $ \xPtr -> + copyArray yPtr (advancePtr xPtr (Shape.size sh0)) k + + newtype Dot sh a = Dot {runDot :: Vector sh a -> Vector sh a -> a} +{- | +> dot x y = Matrix.toScalar (singleRow x <#> singleColumn y) +-} dot :: (Shape.C sh, Eq sh, Class.Floating a) => Vector sh a -> Vector sh a -> a @@ -79,18 +159,30 @@ Class.switchFloating (Dot dotReal) (Dot dotReal) - (Dot dotComplex) - (Dot dotComplex) + (Dot $ dotComplex 'T') + (Dot $ dotComplex 'T') +{- | +> inner x y = dot (conjugate x) y +-} +inner :: + (Shape.C sh, Eq sh, Class.Floating a) => + Vector sh a -> Vector sh a -> a +inner = + runDot $ + Class.switchFloating + (Dot dotReal) + (Dot dotReal) + (Dot $ dotComplex 'C') + (Dot $ dotComplex 'C') + dotReal :: (Shape.C sh, Eq sh, Class.Real a) => Vector sh a -> Vector sh a -> a -dotReal (Array shX x) (Array shY y) = unsafePerformIO $ do +dotReal arrX@(Array shX _x) (Array shY y) = unsafePerformIO $ do Call.assert "dot: shapes mismatch" (shX == shY) evalContT $ do - nPtr <- Call.cint $ Shape.size shX - sxPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 + (nPtr, sxPtr, incxPtr) <- vectorArgs arrX syPtr <- ContT $ withForeignPtr y incyPtr <- Call.cint 1 liftIO $ BlasReal.dot nPtr sxPtr incxPtr syPtr incyPtr @@ -101,23 +193,24 @@ -} dotComplex :: (Shape.C sh, Eq sh, Class.Real a) => - Vector sh (Complex a) -> Vector sh (Complex a) -> Complex a -dotComplex (Array shX x) (Array shY y) = unsafePerformIO $ do + Char -> Vector sh (Complex a) -> Vector sh (Complex a) -> Complex a +dotComplex trans (Array shX x) (Array shY y) = unsafePerformIO $ do Call.assert "dot: shapes mismatch" (shX == shY) evalContT $ do - transPtr <- Call.char 'N' - mPtr <- Call.cint 1 - nPtr <- Call.cint $ Shape.size shX + let m = Shape.size shX + transPtr <- Call.char trans + mPtr <- Call.cint m + nPtr <- Call.cint 1 alphaPtr <- Call.number one xPtr <- ContT $ withForeignPtr x - ldxPtr <- Call.cint 1 + ldxPtr <- Call.leadingDim m yPtr <- ContT $ withForeignPtr y incyPtr <- Call.cint 1 betaPtr <- Call.number zero zPtr <- Call.alloca inczPtr <- Call.cint 1 liftIO $ - BlasGen.gemv + Private.gemv transPtr mPtr nPtr alphaPtr xPtr ldxPtr yPtr incyPtr betaPtr zPtr inczPtr liftIO $ peek zPtr @@ -127,12 +220,8 @@ withForeignPtr x $ \xPtr -> Private.sum (Shape.size sh) xPtr 1 norm1 :: (Shape.C sh, Class.Floating a) => Vector sh a -> RealOf a -norm1 (Array sh x) = unsafePerformIO $ - evalContT $ do - nPtr <- Call.cint $ Shape.size sh - sxPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 - liftIO $ csum1 nPtr sxPtr incxPtr +norm1 arr = unsafePerformIO $ + evalContT $ liftIO . uncurry3 csum1 =<< vectorArgs arr csum1 :: Class.Floating a => Ptr CInt -> Ptr a -> Ptr CInt -> IO (RealOf a) csum1 = @@ -149,12 +238,8 @@ For real numbers it is equivalent to 'norm1'. -} absSum :: (Shape.C sh, Class.Floating a) => Vector sh a -> RealOf a -absSum (Array sh x) = unsafePerformIO $ - evalContT $ do - nPtr <- Call.cint $ Shape.size sh - sxPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 - liftIO $ asum nPtr sxPtr incxPtr +absSum arr = unsafePerformIO $ + evalContT $ liftIO . uncurry3 asum =<< vectorArgs arr asum :: Class.Floating a => Ptr CInt -> Ptr a -> Ptr CInt -> IO (RealOf a) asum = @@ -168,12 +253,8 @@ Euclidean norm of a vector or Frobenius norm of a matrix. -} norm2 :: (Shape.C sh, Class.Floating a) => Vector sh a -> RealOf a -norm2 (Array sh x) = unsafePerformIO $ - evalContT $ do - nPtr <- Call.cint $ Shape.size sh - sxPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 - liftIO $ nrm2 nPtr sxPtr incxPtr +norm2 arr = unsafePerformIO $ + evalContT $ liftIO . uncurry3 nrm2 =<< vectorArgs arr nrm2 :: Class.Floating a => Ptr CInt -> Ptr a -> Ptr CInt -> IO (RealOf a) nrm2 = @@ -185,22 +266,45 @@ newtype Norm a = Norm {getNorm :: Ptr CInt -> Ptr a -> Ptr CInt -> IO (RealOf a)} + +normInf :: (Shape.C sh, Class.Floating a) => Vector sh a -> RealOf a +normInf arr = unsafePerformIO $ + evalContT $ do + (nPtr, sxPtr, incxPtr) <- vectorArgs arr + liftIO $ + fmap (absolute . maybe zero snd) $ + peekElemOff1 sxPtr =<< absMax nPtr sxPtr incxPtr + {- | +Computes (almost) the infinity norm of the vector. +For complex numbers every element is replaced +by the sum of the absolute component values first. +-} +normInf1 :: (Shape.C sh, Class.Floating a) => Vector sh a -> RealOf a +normInf1 arr = unsafePerformIO $ + evalContT $ do + (nPtr, sxPtr, incxPtr) <- vectorArgs arr + liftIO $ + fmap (Scalar.norm1 . maybe zero snd) $ + peekElemOff1 sxPtr =<< BlasGen.iamax nPtr sxPtr incxPtr + + +{- | Returns the index and value of the element with the maximal absolute value. Caution: It actually returns the value of the element, not its absolute value! -} argAbsMaximum :: - (Shape.C sh, Class.Floating a) => + (Shape.InvIndexed sh, Class.Floating a) => Vector sh a -> (Shape.Index sh, a) -argAbsMaximum (Array sh x) = unsafePerformIO $ +argAbsMaximum arr = unsafePerformIO $ evalContT $ do - nPtr <- Call.cint $ Shape.size sh - sxPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 - liftIO $ do - k <- fromIntegral . subtract 1 <$> absMax nPtr sxPtr incxPtr - xmax <- peekElemOff sxPtr k - return (Shape.indices sh !! k, xmax) + (nPtr, sxPtr, incxPtr) <- vectorArgs arr + liftIO $ + fmap + (maybe + (error "Vector.argAbsMaximum: empty vector") + (mapFst (Shape.uncheckedIndexFromOffset $ Array.shape arr))) $ + peekElemOff1 sxPtr =<< absMax nPtr sxPtr incxPtr newtype ArgMaximum a = ArgMaximum {runArgMaximum :: Ptr CInt -> Ptr a -> Ptr CInt -> IO CInt} @@ -222,19 +326,35 @@ Caution: It actually returns the value of the element, not its absolute value! -} argAbs1Maximum :: - (Shape.C sh, Class.Floating a) => + (Shape.InvIndexed sh, Class.Floating a) => Vector sh a -> (Shape.Index sh, a) -argAbs1Maximum (Array sh x) = unsafePerformIO $ +argAbs1Maximum arr = unsafePerformIO $ evalContT $ do - nPtr <- Call.cint $ Shape.size sh - sxPtr <- ContT $ withForeignPtr x - incxPtr <- Call.cint 1 - liftIO $ do - k <- fromIntegral . subtract 1 <$> BlasGen.iamax nPtr sxPtr incxPtr - xmax <- peekElemOff sxPtr k - return (Shape.indices sh !! k, xmax) + (nPtr, sxPtr, incxPtr) <- vectorArgs arr + liftIO $ + fmap + (maybe + (error "Vector.argAbs1Maximum: empty vector") + (mapFst (Shape.uncheckedIndexFromOffset $ Array.shape arr))) $ + peekElemOff1 sxPtr =<< BlasGen.iamax nPtr sxPtr incxPtr +vectorArgs :: + (Shape.C sh) => Array sh a -> ContT r IO (Ptr CInt, Ptr a, Ptr CInt) +vectorArgs (Array sh x) = + liftA3 (,,) + (Call.cint $ Shape.size sh) + (ContT $ withForeignPtr x) + (Call.cint 1) +peekElemOff1 :: (Storable a) => Ptr a -> CInt -> IO (Maybe (Int, a)) +peekElemOff1 ptr k1 = + let k1i = fromIntegral k1 + ki = k1i-1 + in if k1i == 0 + then return Nothing + else Just . (,) ki <$> peekElemOff ptr ki + + product :: (Shape.C sh, Class.Floating a) => Vector sh a -> a product (Array sh x) = unsafePerformIO $ withForeignPtr x $ \xPtr -> Private.product (Shape.size sh) xPtr 1 @@ -264,16 +384,48 @@ nPtr <- Call.cint n alphaPtr <- Call.number one aPtr <- Call.number a - ldaPtr <- Call.cint m + ldaPtr <- Call.leadingDim m bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.cint k + ldbPtr <- Call.leadingDim k betaPtr <- Call.number zero - ldcPtr <- Call.cint m + ldcPtr <- Call.leadingDim m liftIO $ BlasGen.gemm transaPtr transbPtr mPtr nPtr kPtr alphaPtr aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldcPtr + +scaleReal :: + (Shape.C sh, Class.Floating a) => + RealOf a -> Vector sh a -> Vector sh a +scaleReal = + getScaleReal $ + Class.switchFloating + (ScaleReal scale) + (ScaleReal scale) + (ScaleReal scaleRealComplex) + (ScaleReal scaleRealComplex) + +newtype ScaleReal f a = ScaleReal {getScaleReal :: RealOf a -> f a -> f a} + +scaleRealComplex :: + (Shape.C sh, Class.Real a) => + a -> Vector sh (Complex a) -> Vector sh (Complex a) +scaleRealComplex alpha (Array sh x) = + Array.unsafeCreateWithSize sh $ \n cyPtr -> + evalContT $ do + alphaPtr <- Call.number alpha + n2Ptr <- Call.cint (2*n) + cxPtr <- ContT $ withForeignPtr x + let sxPtr = castPtr cxPtr + let syPtr = castPtr cyPtr + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 1 + liftIO $ do + BlasReal.copy n2Ptr sxPtr incxPtr syPtr incyPtr + BlasReal.scal n2Ptr alphaPtr syPtr incyPtr + + add, sub :: (Shape.C sh, Eq sh, Class.Floating a) => Vector sh a -> Vector sh a -> Vector sh a @@ -305,50 +457,22 @@ Call.assert "mul: shapes mismatch" (shA == shX) evalContT $ do transPtr <- Call.char 'N' - mPtr <- Call.cint n nPtr <- Call.cint n klPtr <- Call.cint 0 kuPtr <- Call.cint 0 alphaPtr <- Call.number one aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.cint 1 + ldaPtr <- Call.leadingDim 1 xPtr <- ContT $ withForeignPtr x incxPtr <- Call.cint 1 betaPtr <- Call.number zero incyPtr <- Call.cint 1 liftIO $ BlasGen.gbmv transPtr - mPtr nPtr klPtr kuPtr alphaPtr aPtr ldaPtr + nPtr nPtr klPtr kuPtr alphaPtr aPtr ldaPtr xPtr incxPtr betaPtr yPtr incyPtr -outer :: - (Shape.C shx, Eq shx, Shape.C shy, Eq shy, Class.Floating a) => - Vector shx a -> Vector shy a -> Matrix.General shx shy a -outer (Array shX x) (Array shY y) = - Array.unsafeCreate (MatrixShape.General MatrixShape.ColumnMajor shX shY) $ - \cPtr -> do - let m = Shape.size shX - let n = Shape.size shY - evalContT $ do - transaPtr <- Call.char 'N' - transbPtr <- Call.char 'N' - mPtr <- Call.cint m - nPtr <- Call.cint n - kPtr <- Call.cint 1 - alphaPtr <- Call.number one - aPtr <- ContT $ withForeignPtr x - ldaPtr <- Call.cint m - bPtr <- ContT $ withForeignPtr y - ldbPtr <- Call.cint 1 - betaPtr <- Call.number zero - ldcPtr <- Call.cint m - liftIO $ - BlasGen.gemm - transaPtr transbPtr mPtr nPtr kPtr alphaPtr - aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldcPtr - - newtype Conjugate sh a = Conjugate {getConjugate :: Vector sh a -> Vector sh a} conjugate :: @@ -371,9 +495,101 @@ sxPtr <- ContT $ withForeignPtr x incxPtr <- Call.cint 1 incyPtr <- Call.cint 1 + liftIO $ copyConjugate nPtr sxPtr incxPtr syPtr incyPtr + + +fromReal :: + (Shape.C sh, Class.Floating a) => Vector sh (RealOf a) -> Vector sh a +fromReal = + getFromReal $ + Class.switchFloating + (FromReal id) + (FromReal id) + (FromReal complexFromReal) + (FromReal complexFromReal) + +newtype FromReal f a = FromReal {getFromReal :: f (RealOf a) -> f a} + +toComplex :: + (Shape.C sh, Class.Floating a) => Vector sh a -> Vector sh (ComplexOf a) +toComplex = + getToComplex $ + Class.switchFloating + (ToComplex complexFromReal) + (ToComplex complexFromReal) + (ToComplex id) + (ToComplex id) + +newtype ToComplex f a = ToComplex {getToComplex :: f a -> f (ComplexOf a)} + +complexFromReal :: + (Shape.C sh, Class.Real a) => Vector sh a -> Vector sh (Complex a) +complexFromReal (Array sh x) = + Array.unsafeCreateWithSize sh $ \n yPtr -> + case castPtr yPtr of + yrPtr -> evalContT $ do + nPtr <- Call.cint n + xPtr <- ContT $ withForeignPtr x + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 2 + inczPtr <- Call.cint 0 + zPtr <- Call.number zero + liftIO $ do + BlasGen.copy nPtr xPtr incxPtr yrPtr incyPtr + BlasGen.copy nPtr zPtr inczPtr (advancePtr yrPtr 1) incyPtr + + +realPart :: + (Shape.C sh, Class.Floating a) => Vector sh a -> Vector sh (RealOf a) +realPart = + getToReal $ + Class.switchFloating + (ToReal id) + (ToReal id) + (ToReal complexToRealPart) + (ToReal complexToRealPart) + +newtype ToReal f a = ToReal {getToReal :: f a -> f (RealOf a)} + + +zipComplex :: + (Shape.C sh, Eq sh, Class.Real a) => + Vector sh a -> Vector sh a -> Vector sh (Complex a) +zipComplex (Array shr xr) (Array shi xi) = + Array.unsafeCreateWithSize shr $ \n yPtr -> evalContT $ do + liftIO $ Call.assert "zipComplex: shapes mismatch" (shr==shi) + nPtr <- Call.cint n + xrPtr <- ContT $ withForeignPtr xr + xiPtr <- ContT $ withForeignPtr xi + let yrPtr = castPtr yPtr + incxPtr <- Call.cint 1 + incyPtr <- Call.cint 2 liftIO $ do - BlasGen.copy nPtr sxPtr incxPtr syPtr incyPtr - LapackComplex.lacgv nPtr syPtr incyPtr + BlasGen.copy nPtr xrPtr incxPtr yrPtr incyPtr + BlasGen.copy nPtr xiPtr incxPtr (advancePtr yrPtr 1) incyPtr + + +complexToRealPart, complexToImaginaryPart :: + (Shape.C sh, Class.Real a) => Vector sh (Complex a) -> Vector sh a +complexToRealPart = complexToPart 0 +complexToImaginaryPart = complexToPart 1 + +complexToPart :: + (Shape.C sh, Class.Real a) => Int -> Vector sh (Complex a) -> Vector sh a +complexToPart offset (Array sh x) = + Array.unsafeCreateWithSize sh $ \n yPtr -> evalContT $ do + nPtr <- Call.cint n + xPtr <- ContT $ withForeignPtr x + incxPtr <- Call.cint 2 + incyPtr <- Call.cint 1 + liftIO $ + BlasGen.copy nPtr + (advancePtr (castPtr xPtr) offset) incxPtr yPtr incyPtr + +unzipComplex :: + (Shape.C sh, Class.Real a) => + Vector sh (Complex a) -> (Vector sh a, Vector sh a) +unzipComplex x = (complexToRealPart x, complexToImaginaryPart x) data RandomDistribution = diff --git a/src/Numeric/LAPACK/Wrapper.hs b/src/Numeric/LAPACK/Wrapper.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Wrapper.hs @@ -0,0 +1,4 @@ +module Numeric.LAPACK.Wrapper where + +-- cf. Data.Bifunctor.Flip +newtype Flip f b a = Flip {getFlip :: f a b} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TypeFamilies #-} +module Main where + +import qualified Test.Vector as Vector +import qualified Test.Matrix as Matrix +import qualified Test.Square as Square +import qualified Test.Triangular as Triangular +import qualified Test.Hermitian as Hermitian +import qualified Test.Banded as Banded +import qualified Test.BandedHermitian as BandedHermitian +import qualified Test.Orthogonal as Orthogonal +import qualified Test.Singular as Singular +import qualified Test.Shape as Shape +import qualified Test.Permutation as Permutation +import Test.Format () +import Test.Utility (Tagged(Tagged), prefix) + +import qualified Test.QuickCheck as QC + +import Numeric.LAPACK.Scalar (RealOf) + +import qualified Numeric.Netlib.Class as Class + +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.List as List +import Data.Complex (Complex) +import Data.Tuple.HT (mapSnd) + + +testsVar :: + (Show a, Show ar, + Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar, RealOf ar ~ ar) => + [(String, Tagged a QC.Property)] +testsVar = + prefix "Vector" Vector.testsVar ++ + prefix "Matrix" Matrix.testsVar ++ + prefix "Square" Square.testsVar ++ + prefix "Triangular" Triangular.testsVar ++ + prefix "Hermitian" Hermitian.testsVar ++ + prefix "Banded" Banded.testsVar ++ + prefix "BandedHermitian" BandedHermitian.testsVar ++ + prefix "Orthogonal" Orthogonal.testsVar ++ + prefix "Singular" Singular.testsVar ++ + [] + +tagTests :: + String -> Proxy tag -> + [(String, Tagged tag QC.Property)] -> [(String, QC.Property)] +tagTests typeName Proxy = + map (\(name, Tagged prop) -> (name++"."++typeName, prop)) + +tests :: [(String, QC.Property)] +tests = + concat $ List.transpose $ + (tagTests "Float" (Proxy :: Proxy Float) testsVar) : + (tagTests "Double" (Proxy :: Proxy Double) testsVar) : + (tagTests "ComplexFloat" (Proxy :: Proxy (Complex Float)) testsVar) : + (tagTests "ComplexDouble" (Proxy :: Proxy (Complex Double)) testsVar) : + [] + +simpleTests :: [(String, QC.Property)] +simpleTests = + prefix "Shape" Shape.tests ++ + prefix "Permutation" Permutation.tests ++ + [] + +main :: IO () +main = + mapM_ (\(name,act) -> putStr (name ++ ": ") >> act) $ + + map (mapSnd (QC.quickCheckWith (QC.stdArgs {QC.maxSuccess=200}))) tests + ++ + map (mapSnd QC.quickCheck) simpleTests diff --git a/test/Test/Banded.hs b/test/Test/Banded.hs new file mode 100644 --- /dev/null +++ b/test/Test/Banded.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +module Test.Banded (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Banded.Utility + (Square(Square), genSquare, genSquareCond, + offDiagonals, offDiagonalNats) +import Test.Generator ((<.*|>), (<|*.>), (<.*.>), (<|*|>), (<|\|>)) +import Test.Utility + (approx, approxArray, approxMatrix, + genOrder, genArray, Tagged, equalListWith) + +import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix (ZeroInt, (<#>), (<#), (#>)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, absolute) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary (unary, (:+:)) + +import qualified Data.Array.Comfort.Shape as Shape + +import Foreign.Storable (Storable) + +import Control.Applicative ((<$>)) + +import qualified Test.QuickCheck as QC + + +data Banded height width a = + forall sub super. + (Unary.Natural sub, Unary.Natural super) => + Banded (Banded.General sub super height width a) + +instance + (Show width, Show height, Show a, + Shape.C width, Shape.C height, Storable a) => + Show (Banded height width a) where + showsPrec p (Banded a) = showsPrec p a + + +genBanded :: + (Class.Floating a) => Gen.Matrix a Int Int (Banded ZeroInt ZeroInt a) +genBanded = + flip Gen.mapGenDim Gen.matrixDims $ \maxElem maxDim (height,width) -> do + order <- genOrder + kl <- QC.choose (0, toInteger maxDim) + ku <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural kl $ \sub -> + Unary.reifyNatural ku $ \super -> + fmap Banded $ genArray maxElem $ + MatrixShape.bandedGeneral (unary sub, unary super) order height width + +multiplyFullIdentity :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Banded ZeroInt ZeroInt a -> Bool +multiplyFullIdentity (Banded m) = + let a = Banded.toFull m + in approxArray a $ + Banded.multiplyFull m $ Square.toGeneral $ Square.identityFromWidth a + + +multiplyVectorDot :: + (Class.Floating a, Eq a) => + (Vector ZeroInt a, + Banded ZeroInt ZeroInt a, + Vector ZeroInt a) -> + Bool +multiplyVectorDot (x, Banded m, y) = + Vector.dot x (m#>y) == Vector.dot (x<#m) y + + +multiplyFullAny :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Banded ZeroInt ZeroInt a, + Matrix.General ZeroInt ZeroInt a) -> + Bool +multiplyFullAny (Banded a, b) = + approxArray + (Banded.multiplyFull a b) + (Matrix.multiply (Banded.toFull a) b) + +multiplyFullColumns :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Banded ZeroInt ZeroInt a, + Matrix.General ZeroInt ZeroInt a) -> + Bool +multiplyFullColumns (Banded a, b) = + equalListWith approxArray + (Matrix.toColumns (Banded.multiplyFull a b)) + (map (Banded.multiplyVector a) (Matrix.toColumns b)) + + +multiplyFullAssoc :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Banded ZeroInt ZeroInt a, + Matrix.General ZeroInt ZeroInt a, + Matrix.General ZeroInt ZeroInt a) -> + Bool +multiplyFullAssoc (Banded a, b, c) = + approxArray + (Matrix.multiply (Banded.multiplyFull a b) c) + (Banded.multiplyFull a (Matrix.multiply b c)) + + +addOffDiagonals :: + (Unary.Natural subA, Unary.Natural superA, + Unary.Natural subB, Unary.Natural superB) => + Banded.General subA superA heightA widthA a -> + Banded.General subB superB heightB widthB a -> + (Proof.Nat (subA :+: subB), Proof.Nat (superA :+: superB)) +addOffDiagonals a b = + fst $ MatrixShape.addOffDiagonals (offDiagonals a) (offDiagonals b) + +multiplyBanded :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Banded ZeroInt ZeroInt a, + Banded ZeroInt ZeroInt a) -> + Bool +multiplyBanded (Banded a, Banded b) = + case addOffDiagonals a b of + (Proof.Nat, Proof.Nat) -> + approxArray + (Banded.toFull (Banded.multiply a b)) + (Banded.multiplyFull a (Banded.toFull b)) + +multiplyBandedVectorAssoc :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Banded ZeroInt ZeroInt a, + Banded ZeroInt ZeroInt a, + Vector ZeroInt a) -> + Bool +multiplyBandedVectorAssoc (Banded a, Banded b, x) = + case addOffDiagonals a b of + (Proof.Nat, Proof.Nat) -> + approxArray (a #> b #> x) (Banded.multiply a b #> x) + + +multiplyBandedAssoc :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Banded ZeroInt ZeroInt a, + Banded ZeroInt ZeroInt a, + Banded ZeroInt ZeroInt a) -> + Bool +multiplyBandedAssoc (Banded a, Banded b, Banded c) = + let ab = Banded.multiply a b + bc = Banded.multiply b c + (subA,superA) = offDiagonalNats a + (subB,superB) = offDiagonalNats b + (subC,superC) = offDiagonalNats c + in case (addOffDiagonals a b, addOffDiagonals b c) of + ((Proof.Nat, Proof.Nat), (Proof.Nat, Proof.Nat)) -> + case ((addOffDiagonals ab c, addOffDiagonals a bc), + (Proof.addAssoc subA subB subC, + Proof.addAssoc superA superB superC)) of + (((Proof.Nat, Proof.Nat), (Proof.Nat, Proof.Nat)), + (Proof.AddAssoc, Proof.AddAssoc)) -> + approxArray (Banded.multiply a bc) (Banded.multiply ab c) + + +data Upper size a = + forall super. (Unary.Natural super) => Upper (Banded.Upper super size a) + +instance + (Show size, Show a, Shape.C size, Storable a) => + Show (Upper size a) where + showsPrec p (Upper a) = showsPrec p a + +genUpper :: (Class.Floating a) => Gen.Matrix a Int Int (Upper ZeroInt a) +genUpper = flip Gen.mapGenDim Gen.squareDim $ \maxElem maxDim size -> do + order <- genOrder + ku <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural ku $ \super -> + fmap Upper $ genArray maxElem $ + MatrixShape.bandedSquare (unary TypeNum.u0, unary super) order size + +multiplyUpperVector :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Upper ZeroInt a, Vector ZeroInt a) -> Bool +multiplyUpperVector (Upper m, x) = + approxArray (m#>x) (Banded.toUpperTriangular m #> x) + +multiplyLowerVector :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Upper ZeroInt a, Vector ZeroInt a) -> Bool +multiplyLowerVector (Upper up, x) = + let lo = Banded.transpose up + in approxArray (lo#>x) (Banded.toLowerTriangular lo #> x) + + +determinant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +determinant (Square a) = + approx 0.5 (Banded.determinant a) (Square.determinant $ Banded.toFull a) + + +invertible :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +invertible (Square a) = absolute (Banded.determinant a) > 0.1 + +multiplySolve :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Square ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +multiplySolve (Square a, b) = + approxMatrix 1e-2 (a <#> Banded.solve a b) b + + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 10 5) + + +testsVar :: + (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("multiplyFullIdentity", + checkForAll genBanded multiplyFullIdentity) : + ("multiplyFullAny", + checkForAll ((,) <$> genBanded <|*|> Gen.matrix) multiplyFullAny) : + ("multiplyVectorDot", + checkForAll + ((,,) <$> Gen.vector <.*|> genBanded <.*.> Gen.vector) + multiplyVectorDot) : + ("multiplyFullColumns", + checkForAll ((,) <$> genBanded <|*|> Gen.matrix) multiplyFullColumns) : + ("multiplyFullAssoc", + checkForAll + ((,,) <$> genBanded <|*|> Gen.matrix <|*|> Gen.matrix) + multiplyFullAssoc) : + ("multiplyBanded", + checkForAll ((,) <$> genBanded <|*|> genBanded) multiplyBanded) : + ("multiplyBandedVectorAssoc", + checkForAll + ((,,) <$> genBanded <|*|> genBanded <|*.> Gen.vector) + multiplyBandedVectorAssoc) : + ("multiplyBandedAssoc", + checkForAll + ((,,) <$> genBanded <|*|> genBanded <|*|> genBanded) + multiplyBandedAssoc) : + ("multiplyUpperVector", + checkForAll ((,) <$> genUpper <|*.> Gen.vector) multiplyUpperVector) : + ("multiplyLowerVector", + checkForAll ((,) <$> genUpper <|*.> Gen.vector) multiplyLowerVector) : + ("determinant", + checkForAll genSquare determinant) : + ("multiplySolve", + checkForAll + ((,) <$> genSquareCond invertible <|\|> Gen.matrix) multiplySolve) : + [] diff --git a/test/Test/Banded/Utility.hs b/test/Test/Banded/Utility.hs new file mode 100644 --- /dev/null +++ b/test/Test/Banded/Utility.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Test.Banded.Utility where + +import qualified Test.Generator as Gen +import Test.Utility (genOrder, genArray) + +import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import Numeric.LAPACK.Matrix.Shape (UnaryProxy) +import Numeric.LAPACK.Matrix (ZeroInt) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary (unary) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape + +import Foreign.Storable (Storable) + +import Data.Tuple.HT (mapPair) + +import qualified Test.QuickCheck as QC + + +-- cf. MatrixShape.Private +natFromProxy :: (Unary.Natural n) => UnaryProxy n -> Proof.Nat n +natFromProxy Proxy = Proof.Nat + +offDiagonals :: + Banded.Banded sub super vert horiz height width a -> + (UnaryProxy sub, UnaryProxy super) +offDiagonals = MatrixShape.bandedOffDiagonals . Array.shape + +offDiagonalNats :: + (Unary.Natural sub, Unary.Natural super) => + Banded.Banded sub super vert horiz height width a -> + (Proof.Nat sub, Proof.Nat super) +offDiagonalNats = mapPair (natFromProxy, natFromProxy) . offDiagonals + + +data Square size a = + forall sub super. + (Unary.Natural sub, Unary.Natural super) => + Square (Banded.Square sub super size a) + +instance + (Show size, Show a, Shape.C size, Storable a) => + Show (Square size a) where + showsPrec p (Square a) = showsPrec p a + +genSquare :: (Class.Floating a) => Gen.Matrix a Int Int (Square ZeroInt a) +genSquare = genSquareCond (const True) + +genSquareCond :: + (Class.Floating a) => + (Square ZeroInt a -> Bool) -> + Gen.Matrix a Int Int (Square ZeroInt a) +genSquareCond cond = + flip Gen.mapGenDim Gen.squareDim $ \maxElem maxDim size -> do + order <- genOrder + kl <- QC.choose (0, toInteger maxDim) + ku <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural kl $ \sub -> + Unary.reifyNatural ku $ \super -> + (fmap Square $ + genArray maxElem $ + MatrixShape.bandedSquare (unary sub, unary super) order size) + `QC.suchThat` + cond diff --git a/test/Test/BandedHermitian.hs b/test/Test/BandedHermitian.hs new file mode 100644 --- /dev/null +++ b/test/Test/BandedHermitian.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +module Test.BandedHermitian (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Banded.Utility + (Square(Square), genSquare, natFromProxy, offDiagonalNats) +import Test.Generator ((<.*|>), (<|*.>), (<.*.>), (<|*|>), (<|\|>)) +import Test.Utility + (approxReal, approxArray, approxRealArrayTol, approxMatrix, + genOrder, genArray, Tagged, equalListWith) + +import qualified Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite + as BandedHermitianPD +import qualified Numeric.LAPACK.Matrix.BandedHermitian as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.ShapeStatic as ShapeStatic +import Numeric.LAPACK.Matrix (ZeroInt, zeroInt, (<#>), (<#), (#>)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, fromReal, absolute, selectReal) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary (unary) + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape + +import Foreign.Storable (Storable) + +import Control.Applicative (liftA2, (<$>)) + +import qualified Data.List.HT as ListHT +import Data.Traversable (for) +import Data.Tuple.HT (mapSnd) + +import qualified Test.QuickCheck as QC + + +data BandedHermitian size a = + forall offDiag. + (Unary.Natural offDiag) => + BandedHermitian (BandedHermitian.BandedHermitian offDiag size a) + +instance + (Show size, Show a, Shape.C size, Storable a) => + Show (BandedHermitian size a) where + showsPrec p (BandedHermitian a) = showsPrec p a + + +{- +Non-real elements on the diagonal. +-} +_genBandedHermitian :: + (Class.Floating a) => Gen.Matrix a Int Int (BandedHermitian ZeroInt a) +_genBandedHermitian = + flip Gen.mapGenDim Gen.squareDim $ \maxElem maxDim size -> do + order <- genOrder + k <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural k $ \numOff -> + fmap BandedHermitian $ genArray maxElem $ + MatrixShape.bandedHermitian (unary numOff) order size + +genBandedHermitian :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Matrix a Int Int (BandedHermitian ZeroInt a) +genBandedHermitian = + flip Gen.mapGenDim Gen.squareDim $ \maxElem maxDim size -> do + order <- genOrder + k <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural k $ \numOff -> do + let shape = MatrixShape.bandedHermitian (unary numOff) order size + BandedHermitian . Array.fromList shape <$> + (for (Shape.indices shape) $ \ix -> + let real = + case ix of + MatrixShape.InsideBox r c -> r==c + MatrixShape.VertOutsideBox _ _ -> False + MatrixShape.HorizOutsideBox _ _ -> False + in if real + then fromReal <$> Util.genReal maxElem + else Util.genElement maxElem) + + + +convertToFull :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> Bool +convertToFull (BandedHermitian a) = + approxArray + (Hermitian.toSquare $ BandedHermitian.toHermitian a) + (Banded.toFull $ BandedHermitian.toBanded a) + +takeDiagonal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> Bool +takeDiagonal (BandedHermitian a) = + approxRealArrayTol 1e-5 + (Hermitian.takeDiagonal $ BandedHermitian.toHermitian a) + (BandedHermitian.takeDiagonal a) + +covariance :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +covariance (Square a) = + let (sub,super) = offDiagonalNats a + in case (Proof.addNat sub super, Proof.addComm sub super) of + (Proof.Nat, Proof.AddComm) -> + approxArray + (BandedHermitian.toBanded $ BandedHermitian.covariance a) + (Banded.adjoint a <#> a) + + + +type StaticVector1 n = Vector (ShapeStatic.ZeroBased (Unary.Succ n)) + +data SumRank1 size a = + forall offDiag. + (Unary.Natural offDiag) => + SumRank1 size [(RealOf a, (Shape.Index size, StaticVector1 offDiag a))] + +instance + (Show size, Show (Shape.Index size), Show a, Show (RealOf a), + Shape.C size, Storable a) => + Show (SumRank1 size a) where + showsPrec p (SumRank1 sh a) = showsPrec p (sh,a) + +genScaledVectors :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Vector a Int (SumRank1 ZeroInt a) +genScaledVectors = + flip Gen.mapGen Gen.vectorDim $ \maxElem size@(Shape.ZeroBased n) -> do + k <- QC.choose (0, n-1) + Unary.reifyNatural (toInteger k) $ \numOff -> + fmap (SumRank1 size) $ + if n==0 + then return [] + else + QC.listOf $ + liftA2 (,) (Util.genReal maxElem) $ + liftA2 (,) (QC.choose (0,n-k-1)) + (Util.genArray maxElem + (ShapeStatic.ZeroBased $ unary $ Unary.succ numOff)) + +sumRank1 :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> SumRank1 ZeroInt a -> Bool +sumRank1 order (SumRank1 sh xs) = + approxArray + (BandedHermitian.toHermitian $ BandedHermitian.sumRank1 order sh xs) + (Hermitian.sumRank1 order sh $ + map (mapSnd (uncurry $ displace sh)) xs) + +displace :: + (Shape.C sh, Class.Floating a) => + ZeroInt -> Int -> Vector sh a -> Vector ZeroInt a +displace (Shape.ZeroBased n) k a = + Array.mapShape (zeroInt . Shape.size) $ + Vector.constant (zeroInt k) 0 + `Vector.append` + a + `Vector.append` + Vector.constant (zeroInt $ max 0 $ n - k - Shape.size (Array.shape a)) 0 + + +multiplyIdentity :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian.Transposition -> Matrix.General ZeroInt ZeroInt a -> Bool +multiplyIdentity trans m = + approxArray m + (BandedHermitian.multiplyFull trans + (BandedHermitian.identity (Matrix.height m)) m) + +multiplyDiagonal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian.Transposition -> + (Vector ZeroInt ar, Matrix.General ZeroInt ZeroInt a) -> Bool +multiplyDiagonal trans (d,m) = + approxArray + (Matrix.scaleRowsReal d m) + (BandedHermitian.multiplyFull trans (BandedHermitian.diagonal d) m) + +multiplyFullIdentity :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> Bool +multiplyFullIdentity (BandedHermitian m) = + let a = Banded.toFull $ BandedHermitian.toBanded m + in approxArray a $ + BandedHermitian.multiplyFull BandedHermitian.NonTransposed m $ + Square.identityFrom a + + +multiplyHermitianVector :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian.Transposition -> + (BandedHermitian ZeroInt a, Vector ZeroInt a) -> + Bool +multiplyHermitianVector trans (BandedHermitian m, x) = + approxArray + (BandedHermitian.multiplyVector trans m x) + (Hermitian.multiplyVector trans (BandedHermitian.toHermitian m) x) + +multiplyVectorDot :: + (Class.Floating a, Eq a) => + (Vector ZeroInt a, BandedHermitian ZeroInt a, Vector ZeroInt a) -> Bool +multiplyVectorDot (x, BandedHermitian m, y) = + Vector.dot x (m#>y) == Vector.dot (x<#m) y + + +multiplyFullAny :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian.Transposition -> + (BandedHermitian ZeroInt a, + Matrix.General ZeroInt ZeroInt a) -> + Bool +multiplyFullAny trans (BandedHermitian a, b) = + approxArray + (BandedHermitian.multiplyFull trans a b) + (Hermitian.multiplyFull trans (BandedHermitian.toHermitian a) b) + +multiplyFullColumns :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian.Transposition -> + (BandedHermitian ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +multiplyFullColumns trans (BandedHermitian a, b) = + equalListWith approxArray + (Matrix.toColumns (BandedHermitian.multiplyFull trans a b)) + (map (BandedHermitian.multiplyVector trans a) (Matrix.toColumns b)) + + +multiplyFullAssoc :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian.Transposition -> + (BandedHermitian ZeroInt a, + Matrix.General ZeroInt ZeroInt a, + Matrix.General ZeroInt ZeroInt a) -> + Bool +multiplyFullAssoc trans (BandedHermitian a, b, c) = + approxArray + (Matrix.multiply (BandedHermitian.multiplyFull trans a b) c) + (BandedHermitian.multiplyFull trans a (Matrix.multiply b c)) + + + +genBandedHPD :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Matrix a Int Int (BandedHermitian ZeroInt a) +genBandedHPD = flip Gen.mapGenDim Gen.squareDim $ \maxElem maxDim size -> do + order <- genOrder + kl <- QC.choose (0, toInteger maxDim) + ku <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural kl $ \subU -> + Unary.reifyNatural ku $ \superU -> + let sub = unary subU; subP = natFromProxy sub + super = unary superU; superP = natFromProxy super + in case (Proof.addNat subP superP, Proof.addComm subP superP) of + (Proof.Nat, Proof.AddComm) -> + fmap (BandedHermitian . BandedHermitian.covariance) $ + (genArray maxElem $ + MatrixShape.bandedSquare (sub, super) order size) + `QC.suchThat` + (\a -> absolute (Banded.determinant a) > 0.1) + + +determinant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> Bool +determinant (BandedHermitian a) = + let detB = BandedHermitianPD.determinant a + detS = Hermitian.determinant $ BandedHermitian.toHermitian a + in approxReal (selectReal 1 1e-3 * max 1 (abs detB + abs detS)) detB detS + + +multiplySolve :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (BandedHermitian ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +multiplySolve (BandedHermitian a, b) = + approxMatrix (selectReal 10 1e-3) (a <#> BandedHermitianPD.solve a b) b + +solveDecomposed :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (BandedHermitian ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +solveDecomposed (BandedHermitian a, b) = + approxMatrix (selectReal 1e-3 1e-7) + (BandedHermitianPD.solve a b) + (BandedHermitianPD.solveDecomposed (BandedHermitianPD.decompose a) b) + + + +eigenvaluesDeterminant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> Bool +eigenvaluesDeterminant (BandedHermitian a) = + let det = BandedHermitianPD.determinant a + prod = Vector.product $ BandedHermitian.eigenvalues a + in approxReal ((det+prod) * selectReal 0.5 1e-6) det prod + +eigensystem :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> Bool +eigensystem (BandedHermitian a) = + let (q,d) = BandedHermitian.eigensystem a + in approxMatrix 1e-4 + (Banded.toFull $ BandedHermitian.toBanded a) + (q <#> Matrix.scaleRowsReal d (Square.adjoint q)) + +eigenvaluesHermitian :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> Bool +eigenvaluesHermitian (BandedHermitian a) = + approxRealArrayTol (selectReal 1e-3 1e-5) + (BandedHermitian.eigenvalues a) + (Hermitian.eigenvalues $ BandedHermitian.toHermitian a) + +eigensystemHermitian :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ZeroInt a -> QC.Property +eigensystemHermitian (BandedHermitian a) = + let (q0,d0) = BandedHermitian.eigensystem a + (q1,d1) = Hermitian.eigensystem $ BandedHermitian.toHermitian a + unit = Matrix.adjoint q0 <#> q1 + tol = selectReal 1e-4 1e-7 + in not (or (ListHT.mapAdjacent (approxReal 0.1) (Array.toList d0))) + QC.==> + approxRealArrayTol tol d0 d1 + && + and + (zipWith + (\(r,c) x -> approxReal tol (absolute x) $ if r==c then 1 else 0) + (Shape.indices $ Array.shape unit) (Array.toList unit)) + + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 6 5) + +checkForAllExtra :: + (Show a, Show b, QC.Testable test, Gen.Required required) => + QC.Gen a -> Gen.T tag required actual b -> + (a -> b -> test) -> Tagged tag QC.Property +checkForAllExtra = Gen.withExtra checkForAll + + +testsVar :: + (Show a, Show ar, + Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("convertToFull", + checkForAll genBandedHermitian convertToFull) : + ("takeDiagonal", + checkForAll genBandedHermitian takeDiagonal) : + ("sumRank1", + checkForAllExtra genOrder genScaledVectors sumRank1) : + ("covariance", + checkForAll genSquare covariance) : + ("multiplyIdentity", + checkForAllExtra QC.arbitraryBoundedEnum Gen.matrix multiplyIdentity) : + ("multiplyDiagonal", + checkForAllExtra QC.arbitraryBoundedEnum + ((,) <$> Gen.vectorReal <.*|> Gen.matrix) multiplyDiagonal) : + ("multiplyFullIdentity", + checkForAll genBandedHermitian multiplyFullIdentity) : + ("multiplyFullAny", + checkForAllExtra QC.arbitraryBoundedEnum + ((,) <$> genBandedHermitian <|*|> Gen.matrix) multiplyFullAny) : + ("multiplyHermitianVector", + checkForAllExtra QC.arbitraryBoundedEnum + ((,) <$> genBandedHermitian <|*.> Gen.vector) + multiplyHermitianVector) : + ("multiplyVectorDot", + checkForAll + ((,,) <$> Gen.vector <.*|> genBandedHermitian <.*.> Gen.vector) + multiplyVectorDot) : + ("multiplyFullColumns", + checkForAllExtra QC.arbitraryBoundedEnum + ((,) <$> genBandedHermitian <|*|> Gen.matrix) multiplyFullColumns) : + ("multiplyFullAssoc", + checkForAllExtra QC.arbitraryBoundedEnum + ((,,) <$> genBandedHermitian <|*|> Gen.matrix <|*|> Gen.matrix) + multiplyFullAssoc) : + + ("determinant", + checkForAll genBandedHPD determinant) : + ("multiplySolve", + checkForAll ((,) <$> genBandedHPD <|\|> Gen.matrix) multiplySolve) : + ("solveDecomposed", + checkForAll ((,) <$> genBandedHPD <|\|> Gen.matrix) solveDecomposed) : + + ("eigenvaluesDeterminant", + checkForAll genBandedHPD eigenvaluesDeterminant) : + ("eigensystem", + checkForAll genBandedHermitian eigensystem) : + ("eigenvaluesHermitian", + checkForAll genBandedHermitian eigenvaluesHermitian) : + ("eigensystemHermitian", + checkForAll genBandedHermitian eigensystemHermitian) : + [] diff --git a/test/Test/Format.hs b/test/Test/Format.hs new file mode 100644 --- /dev/null +++ b/test/Test/Format.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE Rank2Types #-} +module Test.Format where + +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.BandedHermitian as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Permutation as Perm +import Numeric.LAPACK.Matrix.Shape (Order(RowMajor, ColumnMajor), UnaryProxy) +import Numeric.LAPACK.Matrix (ZeroInt, zeroInt) +import Numeric.LAPACK.Format (Format, (##)) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary (unary) + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) + +import Data.Complex as Cplx (Complex((:+))) + + +vector :: (Class.Floating a) => Vector.Vector ZeroInt a +vector = Vector.random Vector.UniformBoxPM1 (zeroInt 4) 419 + +general :: (Class.Floating a) => Order -> Matrix.General ZeroInt ZeroInt a +general order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.general order (zeroInt 3) (zeroInt 4)) 420 + +split :: + (Eq lower, Shape.C height, Shape.C width, Class.Floating a) => + lower -> height -> width -> Order -> + Array (MatrixShape.SplitGeneral lower height width) a +split lowerPart height width order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.splitGeneral lowerPart order height width) 420 + +hermitian :: (Class.Floating a) => Order -> Hermitian.Hermitian ZeroInt a +hermitian order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.hermitian order (zeroInt 4)) 421 + +diagonal :: (Class.Floating a) => Order -> Triangular.Diagonal ZeroInt a +diagonal order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.diagonal order (zeroInt 4)) 422 + +lowerTriangular :: + (Class.Floating a) => Order -> Triangular.Lower ZeroInt a +lowerTriangular order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.lowerTriangular order (zeroInt 4)) 423 + +upperTriangular :: + (Class.Floating a) => Order -> Triangular.Upper ZeroInt a +upperTriangular order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.upperTriangular order (zeroInt 4)) 424 + +symmetric :: (Class.Floating a) => Order -> Triangular.Symmetric ZeroInt a +symmetric order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.symmetric order (zeroInt 4)) 425 + + +bandedHermitian :: + (Unary.Natural offDiag, Class.Floating a) => + UnaryProxy offDiag -> Order -> + BandedHermitian.BandedHermitian offDiag ZeroInt a +bandedHermitian numOff order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.bandedHermitian numOff order (zeroInt 4)) 426 + +banded :: + (Unary.Natural sub, Unary.Natural super, + Shape.C height, Shape.C width, Class.Floating a) => + (UnaryProxy sub, UnaryProxy super) -> height -> width -> Order -> + Banded.General sub super height width a +banded offDiag height width order = + Vector.random Vector.UniformBoxPM1 + (MatrixShape.bandedGeneral offDiag order height width) 427 + + +permutation :: Perm.Permutation ZeroInt +permutation = + Perm.fromPivots Perm.NonInverted (zeroInt 5) $ + Vector.fromList (zeroInt 5) [3,2,4,5,5] + + +fmt :: String +fmt = "%.4g" + +printFormatted :: Format a => a -> IO () +printFormatted x = putStrLn "" >> (x ## fmt) + +printVectorFloat :: (Format (f Float)) => f Float -> IO () +printVectorFloat = printFormatted + +printVectorComplex :: + (Format (f (Complex Float))) => f (Complex Float) -> IO () +printVectorComplex = printFormatted + +printVectorWithOrder :: + Format (f Float) => + Format (f (Complex Float)) => + (forall a. (Class.Floating a) => Order -> f a) -> IO () +printVectorWithOrder f = do + printFormatted $ floatVector $ f RowMajor + printFormatted $ floatVector $ f ColumnMajor + printFormatted $ complexVector $ f RowMajor + printFormatted $ complexVector $ f ColumnMajor + +floatVector :: f Float -> f Float +floatVector = id + +complexVector :: f (Complex Float) -> f (Complex Float) +complexVector = id + +main :: IO () +main = do + printFormatted (pi :: Float) + printFormatted permutation + printVectorFloat $ sin (1:+1) + printVectorFloat vector + printVectorComplex vector + printVectorWithOrder general + printVectorWithOrder $ split MatrixShape.Reflector (zeroInt 4) (zeroInt 3) + printVectorWithOrder $ split MatrixShape.Reflector (zeroInt 3) (zeroInt 4) + printVectorWithOrder $ split MatrixShape.Triangle (zeroInt 4) (zeroInt 3) + printVectorWithOrder hermitian + printVectorWithOrder diagonal + printVectorWithOrder lowerTriangular + printVectorWithOrder upperTriangular + printVectorWithOrder symmetric + printVectorWithOrder $ bandedHermitian $ unary TypeNum.u0 + printVectorWithOrder $ bandedHermitian $ unary TypeNum.u1 + printVectorWithOrder $ bandedHermitian $ unary TypeNum.u2 + printVectorWithOrder $ + banded (unary TypeNum.u0, unary TypeNum.u0) (zeroInt 4) (zeroInt 3) + printVectorWithOrder $ + banded (unary TypeNum.u0, unary TypeNum.u2) (zeroInt 4) (zeroInt 3) + printVectorWithOrder $ + banded (unary TypeNum.u2, unary TypeNum.u0) (zeroInt 4) (zeroInt 3) + printVectorWithOrder $ + banded (unary TypeNum.u1, unary TypeNum.u2) (zeroInt 4) (zeroInt 3) + printVectorWithOrder $ + banded (unary TypeNum.u1, unary TypeNum.u2) (zeroInt 3) (zeroInt 4) diff --git a/test/Test/Generator.hs b/test/Test/Generator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Generator.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Test.Generator where + +import qualified Test.Utility as Util +import Test.Utility (Match(Match,Mismatch)) + +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Hermitian (Hermitian) +import Numeric.LAPACK.Matrix (ZeroInt, zeroInt) +import Numeric.LAPACK.Scalar (RealOf, fromReal, one) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) +import Data.Array.Comfort.Shape ((:+:)((:+:))) + +import qualified Control.Monad.Trans.RWS as MRWS +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Functor.HT as FuncHT +import Control.Applicative (liftA2, (<$>)) + +import Data.Traversable (for) +import Data.Tuple.HT (mapFst, mapSnd, mapPair, swap) + +import qualified Test.QuickCheck as QC + + + +{- | +@Cons generator@ with @generator maxElem maxDim fixedDims@. +@generator@ constructs an array with possibly fixed height or width +and returns its actual dimensions. +Non-fixed dimensions will be choosen arbitrarily from the range @(0,maxDim)@. +Elements are choosen from the range @(-maxElem,maxElem)@. +-} +newtype T tag required actual array = Cons (required -> ExtGen (array,actual)) + +instance Functor (T tag required actual) where + fmap f (Cons gen) = Cons $ \fixed -> mapFst f <$> gen fixed + +type ExtGen = MRWS.RWST (Integer,Int,MatchMode) Match () QC.Gen + +data MatchMode = DontForceMatch | ForceMatch + deriving (Eq, Show) + +class Required required where nothingRequired :: required +instance Required () where nothingRequired = () +instance Required (Maybe a) where nothingRequired = Nothing +instance (Required a, Required b) => Required (a,b) where + nothingRequired = (nothingRequired,nothingRequired) + +run :: + (Required required) => + T tag required actual array -> Integer -> Int -> + Util.TaggedGen tag (array, Match) +run (Cons gen) maxElem maxDim = + Util.Tagged $ do + forceMatch <- QC.elements [DontForceMatch, ForceMatch] + ((array, _actualDim), match) <- + MRWS.evalRWST (gen nothingRequired) (maxElem, maxDim, forceMatch) () + return (array, match) + +withExtra :: + (T tag required actual (a,b) -> ((a,b) -> c) -> io) -> + QC.Gen a -> T tag required actual b -> (a -> b -> c) -> io +withExtra checkForAll genA genB test = + checkForAll (mapGen (\_ b -> flip (,) b <$> genA) genB) (uncurry test) + + +mapGen :: + (Integer -> a -> QC.Gen b) -> + T tag required actual a -> T tag required actual b +mapGen f (Cons gen) = + Cons $ \fixed -> do + (maxElem, _maxDim, _match) <- MRWS.ask + MT.lift . FuncHT.mapFst (f maxElem) =<< gen fixed + +mapGenDim :: + (Integer -> Int -> a -> QC.Gen b) -> + T tag required actual a -> T tag required actual b +mapGenDim f (Cons gen) = + Cons $ \fixed -> do + (maxElem, maxDim, _match) <- MRWS.ask + MT.lift . FuncHT.mapFst (f maxElem maxDim) =<< gen fixed + + +chooseDimMin :: Int -> ExtGen Int +chooseDimMin k = do + (_maxElem, maxDim, _match) <- MRWS.ask + MT.lift $ QC.choose (k,maxDim) + + +class Dim dim where chooseDim :: ExtGen dim +instance Dim Int where chooseDim = chooseDimMin 0 +instance (Dim dimA, Dim dimB) => Dim (dimA:+:dimB) where + chooseDim = liftA2 (:+:) chooseDim chooseDim + + +matchDim :: (Dim i, Eq i) => i -> ExtGen i +matchDim size = do + (_maxElem, _maxDim, match) <- MRWS.ask + case match of + ForceMatch -> return size + DontForceMatch -> do + newSize <- chooseDim + MRWS.tell $ if newSize==size then Match else Mismatch + return newSize + + +type Scalar tag = T tag () () + +scalar :: (Class.Floating a) => Scalar a a +scalar = + Cons $ \ _fixed -> do + (maxElem, _maxDim, _match) <- MRWS.ask + MT.lift $ flip (,) () <$> Util.genElement maxElem + +(<.*.>) :: + Vector tag size (a -> b) -> + Vector tag size a -> + Scalar tag b +(<.*.>) (Cons genA) (Cons genB) = + Cons $ \() -> do + (f,size) <- genA Nothing + (a,_) <- genB $ Just size + return (f a, ()) + + +type Vector tag size = T tag (Maybe size) size + +vectorDim :: (Class.Floating a) => Vector a Int ZeroInt +vectorDim = + Cons $ \ fixed -> do + dims <- maybe chooseDim return fixed + return (zeroInt dims, dims) + +vector :: (Class.Floating a) => Vector a Int (Vector.Vector ZeroInt a) +vector = mapGen Util.genArray vectorDim + +vectorReal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Vector a Int (Vector.Vector ZeroInt ar) +vectorReal = mapGen Util.genArray vectorDim + +(<.*|>) :: + (Dim height, Eq height) => + Vector tag height (a -> b) -> + Matrix tag height width a -> + Vector tag width b +(<.*|>) (Cons genA) (Cons genB) = + Cons $ \fixed -> do + (a,(height,width)) <- genB $ Right <$> fixed + (f,_) <- genA . Just =<< matchDim height + return (f a, width) + +(<|*.>) :: + (Dim width, Eq width) => + Matrix tag height width (a -> b) -> + Vector tag width a -> + Vector tag height b +(<|*.>) (Cons genA) (Cons genB) = + Cons $ \fixed -> do + (f,(height,width)) <- genA $ Left <$> fixed + (a,_) <- genB . Just =<< matchDim width + return (f a, height) + +(<.=.>) :: + (Dim size, Eq size) => + Vector tag size (a -> b) -> + Vector tag size a -> + Vector tag size b +(<.=.>) (Cons genA) (Cons genB) = + Cons $ \fixed -> do + (f,size) <- genA fixed + (a,_) <- genB . Just =<< matchDim size + return (f a, size) + + +type Matrix tag height width = + T tag (Maybe (Either height width)) (height,width) + +matrixDims :: + (Class.Floating a) => Matrix a Int Int (ZeroInt, ZeroInt) +matrixDims = + Cons $ \ fixed -> do + dims <- + case fixed of + Nothing -> liftA2 (,) chooseDim chooseDim + Just (Left h) -> (,) h <$> chooseDim + Just (Right w) -> flip (,) w <$> chooseDim + return (mapPair (zeroInt,zeroInt) dims, dims) + +matrix :: + (Class.Floating a) => Matrix a Int Int (Matrix.General ZeroInt ZeroInt a) +matrix = + flip mapGen matrixDims $ \maxElem dims -> do + order <- Util.genOrder + Util.genArray maxElem $ uncurry (MatrixShape.general order) dims + + +squareDim :: (Class.Floating a) => Matrix a Int Int ZeroInt +squareDim = + Cons $ \ fixed -> do + size <- + case fixed of + Nothing -> chooseDim + Just (Left h) -> return h + Just (Right w) -> return w + return (zeroInt size, (size,size)) + +squareShaped :: + (Shape.C sh, Class.Floating a) => + (MatrixShape.Order -> ZeroInt -> sh) -> Matrix a Int Int (Array sh a) +squareShaped shape = + flip mapGen squareDim $ \maxElem size -> do + order <- Util.genOrder + Util.genArray maxElem $ shape order size + +square :: (Class.Floating a) => Matrix a Int Int (Square.Square ZeroInt a) +square = squareShaped MatrixShape.square + +squareCond :: + (Class.Floating a) => + (Square.Square ZeroInt a -> Bool) -> + Matrix a Int Int (Square.Square ZeroInt a) +squareCond cond = + flip mapGen squareDim $ \maxElem size -> do + order <- Util.genOrder + Util.genArray maxElem (MatrixShape.square order size) + `QC.suchThat` + cond + +invertible :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix a Int Int (Square.Square ZeroInt a) +invertible = squareCond Util.invertible + +diagonal :: + (Class.Floating a) => Matrix a Int Int (Triangular.Diagonal ZeroInt a) +diagonal = squareShaped MatrixShape.diagonal + +identity :: + (MatrixShape.Content lo, MatrixShape.Content up, Class.Floating a) => + Matrix a Int Int (Triangular.Triangular lo MatrixShape.Unit up ZeroInt a) +identity = + flip mapGen squareDim $ \ _maxElem size -> do + order <- Util.genOrder + return $ Triangular.identity order size + +triangularCond :: + (MatrixShape.Content up, MatrixShape.Content lo, MatrixShape.TriDiag diag, + Class.Floating a) => + (Triangular.Triangular lo diag up ZeroInt a -> Bool) -> + Matrix a Int Int (Triangular.Triangular lo diag up ZeroInt a) +triangularCond cond = + flip mapGen squareDim $ \maxElem size -> do + order <- Util.genOrder + genTriangularArray maxElem + (MatrixShape.Triangular + MatrixShape.autoDiag MatrixShape.autoUplo order size) + `QC.suchThat` + cond + +triangular :: + (MatrixShape.Content up, MatrixShape.Content lo, MatrixShape.TriDiag diag, + Class.Floating a) => + Matrix a Int Int (Triangular.Triangular lo diag up ZeroInt a) +triangular = triangularCond (const True) + + +newtype GenTriangularDiag lo up a diag = + GenTriangularDiag { + runGenTriangularDiag :: + MatrixShape.Triangular lo diag up ZeroInt -> + QC.Gen (Triangular.Triangular lo diag up ZeroInt a) + } + +genTriangularArray :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a) => + Integer -> + MatrixShape.Triangular lo diag up ZeroInt -> + QC.Gen (Triangular.Triangular lo diag up ZeroInt a) +genTriangularArray maxElem = + runGenTriangularDiag $ + MatrixShape.switchTriDiag + (GenTriangularDiag $ \shape -> + Array.fromList shape <$> + (for (Shape.indices shape) $ \(r,c) -> + if r==c + then return one + else Util.genElement maxElem)) + (GenTriangularDiag $ Util.genArray maxElem) + + +tallDims :: (Class.Floating a) => Matrix a Int Int (ZeroInt, ZeroInt) +tallDims = + Cons $ \ fixed -> do + dims <- + case fixed of + Nothing -> do + h <- chooseDim + w <- MT.lift $ QC.choose (0,h) + return (h,w) + Just (Left h) -> do + w <- MT.lift $ QC.choose (0,h) + return (h,w) + Just (Right w) -> do + h <- chooseDimMin w + return (h,w) + return (mapPair (zeroInt,zeroInt) dims, dims) + +tall :: + (Class.Floating a) => + Matrix a Int Int (Matrix.Tall ZeroInt ZeroInt a) +tall = + flip mapGen tallDims $ \maxElem dims -> do + order <- Util.genOrder + Util.genArray maxElem $ uncurry (MatrixShape.tall order) dims + +fullRankTall :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix a Int Int (Matrix.Tall ZeroInt ZeroInt a) +fullRankTall = + flip mapGen tallDims $ \maxElem dims -> do + order <- Util.genOrder + Util.genArray maxElem (uncurry (MatrixShape.tall order) dims) + `QC.suchThat` Util.fullRankTall + + +wideDims :: (Class.Floating a) => Matrix a Int Int (ZeroInt, ZeroInt) +wideDims = + Cons $ \ fixed -> do + dims <- + case fixed of + Nothing -> do + w <- chooseDim + h <- MT.lift $ QC.choose (0,w) + return (h,w) + Just (Left h) -> do + w <- chooseDimMin h + return (h,w) + Just (Right w) -> do + h <- MT.lift $ QC.choose (0,w) + return (h,w) + return (mapPair (zeroInt,zeroInt) dims, dims) + +wide :: + (Class.Floating a) => + Matrix a Int Int (Matrix.Wide ZeroInt ZeroInt a) +wide = + flip mapGen wideDims $ \maxElem dims -> do + order <- Util.genOrder + Util.genArray maxElem $ uncurry (MatrixShape.wide order) dims + +fullRankWide :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix a Int Int (Matrix.Wide ZeroInt ZeroInt a) +fullRankWide = + flip mapGen wideDims $ \maxElem dims -> do + order <- Util.genOrder + fmap Matrix.transpose $ + Util.genArray maxElem (uncurry (MatrixShape.tall order) (swap dims)) + `QC.suchThat` Util.fullRankTall + + +hermitian :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix a Int Int (Hermitian ZeroInt a) +hermitian = hermitianCond (const True) + +hermitianCond :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Hermitian ZeroInt a -> Bool) -> + Matrix a Int Int (Hermitian ZeroInt a) +hermitianCond cond = + flip mapGen squareDim $ \maxElem size -> do + order <- Util.genOrder + let shape = MatrixShape.hermitian order size + (Array.fromList shape <$> + (for (Shape.indices shape) $ \(r,c) -> + if r==c + then fromReal <$> Util.genReal maxElem + else Util.genElement maxElem)) + `QC.suchThat` cond + + +{- +There cannot be a pure/point function. +-} +(<|*|>) :: + (Dim fuse, Eq fuse) => + Matrix tag height fuse (a -> b) -> + Matrix tag fuse width a -> + Matrix tag height width b +(<|*|>) (Cons genA) (Cons genB) = + Cons $ \fixed -> + case fixed of + Just (Right width) -> do + (a,(fuse,_)) <- genB $ Just $ Right width + (f,(height,_)) <- genA . Just . Right =<< matchDim fuse + return (f a, (height,width)) + Just (Left height) -> do + (f,(_,fuse)) <- genA $ Just $ Left height + (a,(_,width)) <- genB . Just . Left =<< matchDim fuse + return (f a, (height,width)) + Nothing -> do + (f,(height,fuse)) <- genA Nothing + (a,(_,width)) <- genB . Just . Left =<< matchDim fuse + return (f a, (height,width)) + +transpose :: + Matrix tag height width a -> + Matrix tag width height a +transpose (Cons gen) = + Cons $ fmap (mapSnd swap) . gen . fmap (either Right Left) + +(<|\|>) :: + (Dim height, Eq height) => + Matrix tag height width (a -> b) -> + Matrix tag height nrhs a -> + Matrix tag width nrhs b +(<|\|>) a b = transpose a <|*|> b + +(<***>) :: + Vector tag height (a -> b) -> + Vector tag width a -> + Matrix tag height width b +(<***>) (Cons genA) (Cons genB) = + Cons $ \fixed -> do + (f,height) <- genA $ either Just (const Nothing) =<< fixed + (a,width) <- genB $ either (const Nothing) Just =<< fixed + return (f a, (height,width)) + + +{- +We need this type because the test stackRowsColumnsCommutative +requires to fix both height and width of the bottom right matrix. + +Conversely, we cannot use the type e.g. for Square matrices, +because Square does not allow independent choice of height and width. +-} +type Matrix2 tag height width = + T tag (Maybe height, Maybe width) (height,width) + +matrix2Dims :: (Class.Floating a) => Matrix2 a Int Int (ZeroInt, ZeroInt) +matrix2Dims = + Cons $ \ (fixedHeight,fixedWidth) -> do + let maybeChooseDim = maybe chooseDim return + dims <- + liftA2 (,) (maybeChooseDim fixedHeight) (maybeChooseDim fixedWidth) + return (mapPair (zeroInt,zeroInt) dims, dims) + +matrix2 :: + (Class.Floating a) => Matrix2 a Int Int (Matrix.General ZeroInt ZeroInt a) +matrix2 = + flip mapGen matrix2Dims $ \maxElem dims -> do + order <- Util.genOrder + Util.genArray maxElem $ uncurry (MatrixShape.general order) dims + +(<===>) :: + (Dim width, Eq width) => + Matrix2 tag heightA width (a -> b) -> + Matrix2 tag heightB width a -> + Matrix2 tag (heightA:+:heightB) width b +(<===>) (Cons genA) (Cons genB) = + Cons $ \(fixedHeight,fixedWidth) -> do + (f,(heightA,width)) <- + genA ((\(heightA:+:_) -> heightA) <$> fixedHeight, fixedWidth) + matchingWidth <- matchDim width + (a,(heightB,_)) <- + genB ((\(_:+:heightB) -> heightB) <$> fixedHeight, Just matchingWidth) + return (f a, (heightA:+:heightB, width)) + +(<|||>) :: + (Dim height, Eq height) => + Matrix2 tag height widthA (a -> b) -> + Matrix2 tag height widthB a -> + Matrix2 tag height (widthA:+:widthB) b +(<|||>) (Cons genA) (Cons genB) = + Cons $ \(fixedHeight,fixedWidth) -> do + (f,(height,widthA)) <- + genA (fixedHeight, (\(widthA:+:_) -> widthA) <$> fixedWidth) + matchingHeight <- matchDim height + (a,(_,widthB)) <- + genB (Just matchingHeight, (\(_:+:widthB) -> widthB) <$> fixedWidth) + return (f a, (height, widthA:+:widthB)) + + +infixl 4 <.*.>, <.*|>, <|*.>, <|*|>, <|\|>, <***>, <.=.>, <===>, <|||> diff --git a/test/Test/Hermitian.hs b/test/Test/Hermitian.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hermitian.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE TypeFamilies #-} +module Test.Hermitian (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Generator ((<.*|>), (<|*.>), (<|*|>), (<|\|>)) +import Test.Utility + (approx, approxReal, approxArray, approxArrayTol, approxMatrix, + Tagged, genOrder) + +import qualified Numeric.LAPACK.Orthogonal.Householder as HH +import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite as HermitianPD +import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Hermitian (Hermitian) +import Numeric.LAPACK.Matrix.Square (Square) +import Numeric.LAPACK.Matrix.Shape (Order) +import Numeric.LAPACK.Matrix (General, ZeroInt, zeroInt, (<#), (<#>), (#>)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, fromReal, selectReal) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape + +import Control.Applicative (liftA2, (<$>)) + +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty + +import qualified Test.QuickCheck as QC + + +covariance :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +covariance x = + approxArray + (Matrix.fromFull $ Hermitian.toSquare $ Hermitian.covariance x) + (Matrix.adjoint x <#> x) + + +outer :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Order -> Vector ZeroInt a -> Bool +outer order x = + approxArray + (Matrix.fromFull $ Hermitian.toSquare $ Hermitian.outer order x) + (Matrix.outer order x x) + + +genScaledVectors :: + (NonEmptyC.Gen f, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Vector a Int (ZeroInt, f (ar, Vector ZeroInt a)) +genScaledVectors = + flip Gen.mapGen Gen.vectorDim $ \maxElem size -> + fmap ((,) size) $ + NonEmptyC.genOf $ + liftA2 (,) (Util.genReal maxElem) (Util.genArray maxElem size) + +sumRank1 :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Order -> (ZeroInt, [(ar, Vector ZeroInt a)]) -> Bool +sumRank1 order (sh,xs) = + approxArray + (Matrix.fromFull $ Hermitian.toSquare $ Hermitian.sumRank1 order sh xs) + (foldl Vector.add (Vector.constant (MatrixShape.general order sh sh) 0) $ + fmap (rank1 order) xs) + +sumRank1NonEmpty :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Order -> NonEmpty.T [] (ar, Vector ZeroInt a) -> Bool +sumRank1NonEmpty order xs = + approxArray + (Matrix.fromFull $ Hermitian.toSquare $ + Hermitian.sumRank1NonEmpty order xs) + (NonEmpty.foldl1 Vector.add $ fmap (rank1 order) xs) + +rank1 :: + (Eq size, Shape.C size, Class.Floating a) => + Order -> (RealOf a, Vector size a) -> Matrix.General size size a +rank1 order (r,x) = Vector.scaleReal r $ Matrix.outer order x x + + +genScaledVectorPairs :: + (NonEmptyC.Gen f, Class.Floating a) => + Gen.Vector a Int (ZeroInt, f (a, (Vector ZeroInt a, Vector ZeroInt a))) +genScaledVectorPairs = + flip Gen.mapGen Gen.vectorDim $ \maxElem size -> + fmap ((,) size) $ + NonEmptyC.genOf $ + liftA2 (,) (Util.genElement maxElem) $ + liftA2 (,) (Util.genArray maxElem size) (Util.genArray maxElem size) + +sumRank2 :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Order -> (ZeroInt, [(a, (Vector ZeroInt a, Vector ZeroInt a))]) -> Bool +sumRank2 order (sh,xys) = + approxArray + (Matrix.fromFull $ Hermitian.toSquare $ Hermitian.sumRank2 order sh xys) + (foldl Vector.add (Vector.constant (MatrixShape.general order sh sh) 0) $ + fmap (rank2 order) xys) + +sumRank2NonEmpty :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Order -> NonEmpty.T [] (a, (Vector ZeroInt a, Vector ZeroInt a)) -> Bool +sumRank2NonEmpty order xys = + approxArray + (Matrix.fromFull $ Hermitian.toSquare $ + Hermitian.sumRank2NonEmpty order xys) + (NonEmpty.foldl1 Vector.add $ fmap (rank2 order) xys) + +rank2 :: + (Eq size, Shape.C size, Class.Floating a) => + Order -> (a, (Vector size a, Vector size a)) -> Matrix.General size size a +rank2 order (a,(x,y)) = + let ax = Vector.scale a x + in Vector.add + (Matrix.outer order ax y) + (Matrix.outer order y ax) + + +addAdjoint :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +addAdjoint x = + approxArray + (Hermitian.toSquare $ Hermitian.addAdjoint x) + (Matrix.add (Matrix.adjoint x) x) + + +multiplySquare :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +multiplySquare a = + approxArray (Hermitian.toSquare $ Hermitian.square a) (a <#> a) + +squareSquare :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +squareSquare a = + approxArray + (Hermitian.toSquare $ Hermitian.square a) + (Square.square $ Hermitian.toSquare a) + +{- +multiplyPower :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Int, Hermitian ZeroInt a) -> Bool +multiplyPower (n,a) = + let b = Hermitian.power (fromIntegral n) a + c = nest n (Hermitian.multiply a) $ Hermitian.identityFrom a + in approxArrayTol (1e-6 * (Vector.normInf1 b + Vector.normInf1 c)) b c +-} + + +multiplyVectorLeft :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Vector ZeroInt a, Hermitian ZeroInt a) -> Bool +multiplyVectorLeft (x,a) = + approxArray (x <# Hermitian.toSquare a) (x <# a) + +multiplyVectorRight :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Hermitian ZeroInt a, Vector ZeroInt a) -> Bool +multiplyVectorRight (a,x) = + approxArray (Hermitian.toSquare a #> x) (a #> x) + + +multiplyLeft :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (General ZeroInt ZeroInt a, Hermitian ZeroInt a) -> Bool +multiplyLeft (a,b) = + approxMatrix 1e-5 (a <#> Hermitian.toSquare b) (a <#> b) + +multiplyRight :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Hermitian ZeroInt a, General ZeroInt ZeroInt a) -> Bool +multiplyRight (a,b) = + approxArray (Hermitian.toSquare a <#> b) (a <#> b) + + +determinant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +determinant a = + approx + (selectReal 1e-1 1e-5) + (fromReal $ Hermitian.determinant a) + (Square.determinant $ Hermitian.toSquare a) + +choleskyQR :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Tall ZeroInt ZeroInt a -> QC.Property +choleskyQR a = + let qr = HH.fromMatrix a + r = HH.tallExtractR qr + in HH.determinantAbsolute qr > 0.1 + QC.==> + approxArrayTol 1e-1 + (Matrix.scaleRows (Array.map signum $ Triangular.takeDiagonal r) $ + Triangular.toSquare r) + (Triangular.toSquare $ + HermitianPD.decompose $ Hermitian.covariance $ Matrix.fromFull a) + + +invertible :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian sh a -> Bool +invertible a = abs (Hermitian.determinant a) > 0.1 + +inverse :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +inverse a = + approxArrayTol + (selectReal 1 1e-5) + (Hermitian.toSquare $ Hermitian.inverse a) + (Square.inverse $ Hermitian.toSquare a) + + +solve :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Hermitian ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +solve (a, b) = + approxMatrix (selectReal 1 1e-5) + (Hermitian.solve a b) + (Square.solve (Hermitian.toSquare a) b) + + + +genPositiveDefinite :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Matrix a Int Int (Hermitian ZeroInt a) +genPositiveDefinite = + flip Gen.mapGenDim Gen.squareDim $ + \maxElem maxDim width@(Shape.ZeroBased w) -> do + height <- zeroInt <$> QC.choose (w,maxDim) + order <- Util.genOrder + Hermitian.covariance . Matrix.fromFull <$> + Util.genArray maxElem (MatrixShape.tall order height width) + `QC.suchThat` Util.fullRankTall + +determinantPD :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +determinantPD a = + approxReal (selectReal 100 1e-4) + (Hermitian.determinant a) + (HermitianPD.determinant a) + +inversePD :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +inversePD a = + approxArrayTol (selectReal 1000 1e-4) + (Hermitian.inverse a) + (HermitianPD.inverse a) + +solvePD :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Hermitian ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +solvePD (a,b) = + approxArrayTol (selectReal 1000 1e-4) + (Hermitian.solve a b) + (HermitianPD.solve a b) + +solveDecomposedPD :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Hermitian ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +solveDecomposedPD (a,b) = + approxArrayTol (selectReal 1e-1 1e-6) + (HermitianPD.solve a b) + (HermitianPD.solveDecomposed (HermitianPD.decompose a) b) + + + +eigenvaluesDeterminant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +eigenvaluesDeterminant a = + approxReal + (selectReal 1e-1 1e-5) + (Hermitian.determinant a) + (Vector.product $ Hermitian.eigenvalues a) + +eigensystem :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Hermitian ZeroInt a -> Bool +eigensystem a = + let (q,d) = Hermitian.eigensystem a + in approxMatrix 1e-4 + (Hermitian.toSquare a) + (q <#> Matrix.scaleRowsReal d (Square.adjoint q)) + + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 3 5) + +checkForAllExtra :: + (Show a, Show b, QC.Testable test, Gen.Required required) => + QC.Gen a -> Gen.T tag required actual b -> + (a -> b -> test) -> Tagged tag QC.Property +checkForAllExtra = Gen.withExtra checkForAll + + +testsVar :: + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("covariance", + checkForAll Gen.matrix covariance) : + ("outer", + checkForAllExtra genOrder Gen.vector outer) : + ("sumRank1", + checkForAllExtra genOrder genScaledVectors sumRank1) : + ("sumRank1NonEmpty", + checkForAllExtra genOrder (snd <$> genScaledVectors) sumRank1NonEmpty) : + ("sumRank2", + checkForAllExtra genOrder genScaledVectorPairs sumRank2) : + ("sumRank2NonEmpty", + checkForAllExtra genOrder + (snd <$> genScaledVectorPairs) sumRank2NonEmpty) : + ("addAdjoint", + checkForAll Gen.square addAdjoint) : + ("multiplySquare", + checkForAll Gen.hermitian multiplySquare) : + ("squareSquare", + checkForAll Gen.hermitian squareSquare) : + + ("multiplyVectorLeft", + checkForAll ((,) <$> Gen.vector <.*|> Gen.hermitian) multiplyVectorLeft) : + ("multiplyVectorRight", + checkForAll ((,) <$> Gen.hermitian <|*.> Gen.vector) multiplyVectorRight) : + ("multiplyLeft", + checkForAll ((,) <$> Gen.matrix <|*|> Gen.hermitian) multiplyLeft) : + ("multiplyRight", + checkForAll ((,) <$> Gen.hermitian <|*|> Gen.matrix) multiplyRight) : + + ("determinant", + checkForAll Gen.hermitian determinant) : + ("choleskyQR", + checkForAll Gen.tall choleskyQR) : + + ("inverse", + checkForAll (Gen.hermitianCond invertible) inverse) : + ("solve", + checkForAll + ((,) <$> Gen.hermitianCond invertible <|\|> Gen.matrix) solve) : + + ("determinantPD", + checkForAll genPositiveDefinite determinantPD) : + ("inversePD", + checkForAll genPositiveDefinite inversePD) : + ("solvePD", + checkForAll ((,) <$> genPositiveDefinite <|\|> Gen.matrix) solvePD) : + ("solveDecomposedPD", + checkForAll + ((,) <$> genPositiveDefinite <|\|> Gen.matrix) solveDecomposedPD) : + + ("eigenvaluesDeterminant", + checkForAll Gen.hermitian eigenvaluesDeterminant) : + ("eigensystem", + checkForAll Gen.hermitian eigensystem) : + [] diff --git a/test/Test/Matrix.hs b/test/Test/Matrix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Matrix.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Test.Matrix (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Generator ((<|*|>), (<|*.>), (<.*.>), (<***>), (<|||>), (<===>)) +import Test.Utility + (approx, approxArray, approxMatrix, + genOrder, Tagged(Tagged), TaggedGen) + +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix + (General, ZeroInt, zeroInt, (#>), (<#>), (|||), (===)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, conjugate) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) +import Data.Array.Comfort.Shape ((:+:)) + +import Control.Applicative (liftA2, (<$>)) + +import Data.Tuple.HT (mapPair, swap) +import Data.Eq.HT (equating) + +import qualified Test.QuickCheck as QC + + +genArray :: + (Shape.C shape, Class.Floating a) => shape -> QC.Gen (Array shape a) +genArray = Util.genArray 10 + +equalArray :: + (Shape.C shape, Eq shape, Class.Floating a) => + Array shape a -> Array shape a -> Bool +equalArray x y = + if Array.shape x == Array.shape y + then equalArrayBody x y + else error "equalArray: shapes mismatch" + +equalArrayBody :: + (Shape.C shape, Class.Floating a) => + Array shape a -> Array shape a -> Bool +equalArrayBody = + getEqualArray $ + Class.switchFloating + (EqualArray $ equating Array.toList) + (EqualArray $ equating Array.toList) + (EqualArray $ equating Array.toList) + (EqualArray $ equating Array.toList) + +newtype EqualArray f a = EqualArray {getEqualArray :: f a -> f a -> Bool} + + +dotProduct :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Vector ZeroInt a, Vector ZeroInt a) -> Bool +dotProduct (x,y) = + approx 1e-5 + (Vector.dot x y) + (Matrix.toScalar $ + Matrix.singleRow MatrixShape.RowMajor x <#> + Matrix.singleColumn MatrixShape.ColumnMajor y) + +innerDot :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Vector ZeroInt a, Vector ZeroInt a) -> Bool +innerDot (x,y) = + approx 1e-5 (Vector.inner x y) (Vector.dot (Vector.conjugate x) y) + +tensorProductTranspose :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> (Vector ZeroInt a, Vector ZeroInt a) -> Bool +tensorProductTranspose order (x,y) = + approxArray + (Matrix.transpose (Matrix.tensorProduct order x y)) + (Matrix.tensorProduct (MatrixShape.flipOrder order) y x) + +outerTranspose :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> (Vector ZeroInt a, Vector ZeroInt a) -> Bool +outerTranspose order (x,y) = + approxArray + (Matrix.transpose (Matrix.outer order x y)) + (Matrix.outer (MatrixShape.flipOrder order) + (Vector.conjugate y) (Vector.conjugate x)) + +tensorProduct :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> (Vector ZeroInt a, Vector ZeroInt a) -> Bool +tensorProduct order (x,y) = + approxArray + (Matrix.tensorProduct order x y) + (Matrix.singleColumn order x <#> Matrix.singleRow order y) + +tensorProductMul :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular.Diagonal ZeroInt a, + Matrix.General ZeroInt ZeroInt a, + Triangular.Diagonal ZeroInt a) -> + Bool +tensorProductMul (x,m,y) = + let xmy = x <#> m <#> y + in approxArray xmy + (Vector.mul m + (Matrix.tensorProduct (MatrixShape.fullOrder $ Array.shape xmy) + (Triangular.takeDiagonal x) (Triangular.takeDiagonal y))) + +outerTensorProduct :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> (Vector ZeroInt a, Vector ZeroInt a) -> Bool +outerTensorProduct order (x,y) = + approxArray + (Matrix.outer order x y) + (Matrix.tensorProduct order x $ Vector.conjugate y) + +genScaledVectorPairs :: + (Class.Floating a) => + Gen.Matrix a Int Int + ((ZeroInt, ZeroInt), [(a, (Vector ZeroInt a, Vector ZeroInt a))]) +genScaledVectorPairs = + flip Gen.mapGen Gen.matrixDims $ \maxElem size@(height,width) -> + fmap ((,) size) $ + QC.listOf $ + liftA2 (,) (Util.genElement maxElem) $ + liftA2 (,) (Util.genArray maxElem height) (Util.genArray maxElem width) + +sumRank1 :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> + ((ZeroInt,ZeroInt), [(a, (Vector ZeroInt a, Vector ZeroInt a))]) -> Bool +sumRank1 order (size,xys) = + approxArray + (case order of + MatrixShape.ColumnMajor -> Matrix.sumRank1 size xys + MatrixShape.RowMajor -> + Matrix.adjoint $ + Matrix.sumRank1 (swap size) $ map (mapPair (conjugate, swap)) xys) + (foldl Vector.add + (Vector.constant (uncurry (MatrixShape.general order) size) 0) + (map (\(a,(x,y)) -> Matrix.outer order (Vector.scale a x) y) xys)) + + +outerTrace :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> (Vector ZeroInt a, Vector ZeroInt a) -> Bool +outerTrace order (x,y) = + approx 1e-5 + (Vector.inner y x) + (Square.trace $ Square.fromGeneral $ Matrix.outer order x y) + +outerInner :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> (Vector ZeroInt a, Vector ZeroInt a, Vector ZeroInt a) -> Bool +outerInner order (x,y,z) = + approxArray (Matrix.outer order x y #> z) (Vector.scale (Vector.inner y z) x) + + +tensorTrace :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> (Vector ZeroInt a, Vector ZeroInt a) -> Bool +tensorTrace order (x,y) = + approx 1e-5 (Vector.dot y x) + (Square.trace $ Square.fromGeneral $ Matrix.tensorProduct order x y) + +tensorDot :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> + (Vector ZeroInt a, Vector ZeroInt a, Vector ZeroInt a) -> Bool +tensorDot order (x,y,z) = + approxArray + (Matrix.tensorProduct order x y #> z) (Vector.scale (Vector.dot y z) x) + + +genZeroColumns :: + (Class.Floating a) => TaggedGen a (Matrix.Tall ZeroInt ZeroInt a) +genZeroColumns = Tagged $ do + height <- zeroInt <$> QC.choose (0,5) + order <- genOrder + genArray (MatrixShape.tall order height (zeroInt 0)) + + +reverseNoRows :: (Class.Floating a) => Matrix.Wide ZeroInt ZeroInt a -> Bool +reverseNoRows x = + equalArray x $ Matrix.reverseRows x + +reverseNoColumns :: (Class.Floating a) => Matrix.Tall ZeroInt ZeroInt a -> Bool +reverseNoColumns x = + equalArray x $ Matrix.reverseColumns x + + + +genMatrix2EqHeight :: + (Class.Floating a) => + Gen.Matrix2 a Int (Int:+:Int) + (General ZeroInt ZeroInt a, General ZeroInt ZeroInt a) +genMatrix2EqHeight = (,) <$> Gen.matrix2 <|||> Gen.matrix2 + +genMatrix2EqWidth :: + (Class.Floating a) => + Gen.Matrix2 a (Int:+:Int) Int + (General ZeroInt ZeroInt a, General ZeroInt ZeroInt a) +genMatrix2EqWidth = (,) <$> Gen.matrix2 <===> Gen.matrix2 + +reverseRows :: (Class.Floating a) => General ZeroInt ZeroInt a -> Bool +reverseRows x = + equalArray x $ Matrix.reverseRows (Matrix.reverseRows x) + +reverseColumns :: (Class.Floating a) => General ZeroInt ZeroInt a -> Bool +reverseColumns x = + equalArray x $ Matrix.reverseColumns (Matrix.reverseColumns x) + + +mapHeight :: + (heightA -> heightB) -> + MatrixShape.General heightA width -> + MatrixShape.General heightB width +mapHeight f shape = + MatrixShape.general + (MatrixShape.fullOrder shape) + (f $ MatrixShape.fullHeight shape) + (MatrixShape.fullWidth shape) + +mapWidth :: + (widthA -> widthB) -> + MatrixShape.General height widthA -> + MatrixShape.General height widthB +mapWidth f shape = + MatrixShape.general + (MatrixShape.fullOrder shape) + (MatrixShape.fullHeight shape) + (f $ MatrixShape.fullWidth shape) + +zeroIntHeight :: + (Shape.C height, Shape.C width) => + General height width a -> General ZeroInt width a +zeroIntHeight = Array.mapShape (mapHeight (zeroInt . Shape.size)) + +zeroIntWidth :: + (Shape.C height, Shape.C width) => + General height width a -> General height ZeroInt a +zeroIntWidth = Array.mapShape (mapWidth (zeroInt . Shape.size)) + +reverseRowsStack :: + (Class.Floating a) => + (General ZeroInt ZeroInt a, General ZeroInt ZeroInt a) -> Bool +reverseRowsStack (x,y) = + equalArray + (Matrix.reverseRows $ zeroIntHeight $ x===y) + (zeroIntHeight $ Matrix.reverseRows y === Matrix.reverseRows x) + +reverseColumnsStack :: + (Class.Floating a) => + (General ZeroInt ZeroInt a, General ZeroInt ZeroInt a) -> Bool +reverseColumnsStack (x,y) = + equalArray + (Matrix.reverseColumns $ zeroIntWidth $ x|||y) + (zeroIntWidth $ Matrix.reverseColumns y ||| Matrix.reverseColumns x) + + +data Cut = Take | Drop deriving (Show, Eq, Ord, Enum, Bounded) +data Slice = Row | Column deriving (Show, Eq, Ord, Enum, Bounded) + +cut :: + (Class.Floating a) => + Cut -> Slice -> Int -> + General ZeroInt ZeroInt a -> General ZeroInt ZeroInt a +cut Take Row = Matrix.takeRows +cut Take Column = Matrix.takeColumns +cut Drop Row = Matrix.dropRows +cut Drop Column = Matrix.dropColumns + +cutCommutative :: + (Class.Floating a) => + ((Cut,Slice),(Int,Int)) -> General ZeroInt ZeroInt a -> Bool +cutCommutative (kind,(k,j)) x = + let cutK = uncurry cut kind k + cutJ = uncurry cut kind j + in equalArray (cutK $ cutJ x) (cutJ $ cutK x) + +cutRowColumnCommutative :: + (Class.Floating a) => + ((Cut,Int),(Cut,Int)) -> General ZeroInt ZeroInt a -> Bool +cutRowColumnCommutative ((cutR,k),(cutC,j)) x = + let cutRows = cut cutR Row k + cutColumns = cut cutC Column j + in equalArray (cutRows $ cutColumns x) (cutColumns $ cutRows x) + + +takeEqually :: + (Class.Floating a) => Int -> General ZeroInt ZeroInt a -> Bool +takeEqually k x = + equalArray + (Matrix.takeEqually k x) + (Matrix.takeRows k (Matrix.takeColumns k x)) + +dropEqually :: + (Class.Floating a) => Int -> General ZeroInt ZeroInt a -> Bool +dropEqually k x = + equalArray + (Matrix.dropEqually k x) + (Matrix.dropRows k (Matrix.dropColumns k x)) + + +stackSplitRows :: + (Class.Floating a) => Int -> General ZeroInt ZeroInt a -> Bool +stackSplitRows k x = + equalArray x + (zeroIntHeight $ Matrix.takeRows k x === Matrix.dropRows k x) + +stackSplitColumns :: + (Class.Floating a) => Int -> General ZeroInt ZeroInt a -> Bool +stackSplitColumns k x = + equalArray x + (zeroIntWidth $ Matrix.takeColumns k x ||| Matrix.dropColumns k x) + + +takeStackRows, dropStackRows :: + (Class.Floating a) => + (General ZeroInt ZeroInt a, General ZeroInt ZeroInt a) -> Bool +takeStackRows (x,y) = + equalArray + (Matrix.toRowMajor x) + (Matrix.toRowMajor $ Matrix.takeRows (Shape.size $ Matrix.height x) $ + zeroIntHeight $ x===y) +dropStackRows (x,y) = + equalArray + (Matrix.toRowMajor y) + (Matrix.toRowMajor $ Matrix.dropRows (Shape.size $ Matrix.height x) $ + zeroIntHeight $ x===y) + +takeStackColumns, dropStackColumns :: + (Class.Floating a) => + (General ZeroInt ZeroInt a, General ZeroInt ZeroInt a) -> Bool +takeStackColumns (x,y) = + equalArray + (Matrix.toRowMajor x) + (Matrix.toRowMajor $ Matrix.takeColumns (Shape.size $ Matrix.width x) $ + zeroIntWidth $ x|||y) +dropStackColumns (x,y) = + equalArray + (Matrix.toRowMajor y) + (Matrix.toRowMajor $ Matrix.dropColumns (Shape.size $ Matrix.width x) $ + zeroIntWidth $ x|||y) + +stackRowsAssociative, stackColumnsAssociative :: + (Class.Floating a) => + (General ZeroInt ZeroInt a, + General ZeroInt ZeroInt a, + General ZeroInt ZeroInt a) -> Bool +stackRowsAssociative (x,y,z) = + equalArray + (zeroIntHeight ((x===y)===z)) + (zeroIntHeight (x===(y===z))) +stackColumnsAssociative (x,y,z) = + equalArray + (zeroIntWidth ((x|||y)|||z)) + (zeroIntWidth (x|||(y|||z))) + +stackRowsColumnsCommutative :: + (Class.Floating a) => + ((General ZeroInt ZeroInt a, General ZeroInt ZeroInt a), + (General ZeroInt ZeroInt a, General ZeroInt ZeroInt a)) -> Bool +stackRowsColumnsCommutative ((x,y),(z,w)) = + equalArray + (Matrix.toRowMajor $ (x|||y)===(z|||w)) + (Matrix.toRowMajor $ (x===z)|||(y===w)) + + +multiplyDiagonalMatrix :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular.Diagonal ZeroInt a, General ZeroInt ZeroInt a) -> Bool +multiplyDiagonalMatrix (x,y) = + approxArray (x <#> y) (Triangular.toSquare x <#> y) + +multiplyMatrixDiagonal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (General ZeroInt ZeroInt a, Triangular.Diagonal ZeroInt a) -> Bool +multiplyMatrixDiagonal (x,y) = + approxMatrix 1e-5 (x <#> y) (x <#> Triangular.toSquare y) + + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 10 5) + +checkForAllExtra :: + (Show a, Show b, QC.Testable test, Gen.Required required) => + QC.Gen a -> Gen.T tag required actual b -> + (a -> b -> test) -> Tagged tag QC.Property +checkForAllExtra = Gen.withExtra checkForAll + + +testsVar :: + (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("dotProduct", + checkForAll ((,) <$> Gen.vector <.*.> Gen.vector) dotProduct) : + ("innerDot", + checkForAll ((,) <$> Gen.vector <.*.> Gen.vector) innerDot) : + ("tensorProductTranspose", + checkForAllExtra genOrder + ((,) <$> Gen.vector <***> Gen.vector) tensorProductTranspose) : + ("outerTranspose", + checkForAllExtra genOrder + ((,) <$> Gen.vector <***> Gen.vector) outerTranspose) : + ("tensorProduct", + checkForAllExtra genOrder + ((,) <$> Gen.vector <***> Gen.vector) tensorProduct) : + ("tensorProductMul", + checkForAll ((,,) <$> Gen.diagonal <|*|> Gen.matrix <|*|> Gen.diagonal) + tensorProductMul) : + ("outerTensorProduct", + checkForAllExtra genOrder + ((,) <$> Gen.vector <***> Gen.vector) outerTensorProduct) : + ("sumRank1", + checkForAllExtra genOrder genScaledVectorPairs sumRank1) : + + ("outerTrace", + checkForAllExtra genOrder + ((,) <$> Gen.vector <.*.> Gen.vector) outerTrace) : + ("outerInner", + checkForAllExtra genOrder + ((,,) <$> Gen.vector <***> Gen.vector <|*.> Gen.vector) outerInner) : + ("tensorTrace", + checkForAllExtra genOrder + ((,) <$> Gen.vector <.*.> Gen.vector) tensorTrace) : + ("tensorDot", + checkForAllExtra genOrder + ((,,) <$> Gen.vector <***> Gen.vector <|*.> Gen.vector) tensorDot) : + + ("reverseNoRows", + Util.checkForAllPlain + (fmap Matrix.transpose <$> genZeroColumns) reverseNoRows) : + ("reverseNoColumns", + Util.checkForAllPlain genZeroColumns reverseNoColumns) : + ("reverseRows", + checkForAll Gen.matrix reverseRows) : + ("reverseColumns", + checkForAll Gen.matrix reverseColumns) : + ("reverseRowsStack", + checkForAll genMatrix2EqWidth reverseRowsStack) : + ("reverseColumnsStack", + checkForAll genMatrix2EqHeight reverseColumnsStack) : + ("cutCommutative", + checkForAllExtra + (liftA2 (,) + (liftA2 (,) QC.arbitraryBoundedEnum QC.arbitraryBoundedEnum) + (liftA2 (,) (QC.choose (0,5)) (QC.choose (0,5)))) + Gen.matrix cutCommutative) : + ("cutRowColumnCommutative", + checkForAllExtra + (liftA2 (,) + (liftA2 (,) QC.arbitraryBoundedEnum (QC.choose (0,5))) + (liftA2 (,) QC.arbitraryBoundedEnum (QC.choose (0,5)))) + Gen.matrix cutRowColumnCommutative) : + ("takeEqually", + checkForAllExtra (QC.choose (0,5)) Gen.matrix takeEqually) : + ("dropEqually", + checkForAllExtra (QC.choose (0,5)) Gen.matrix dropEqually) : + ("stackSplitRows", + checkForAllExtra (QC.choose (0,5)) Gen.matrix stackSplitRows) : + ("stackSplitColumns", + checkForAllExtra (QC.choose (0,5)) Gen.matrix stackSplitColumns) : + ("takeStackRows", + checkForAll genMatrix2EqWidth takeStackRows) : + ("dropStackRows", + checkForAll genMatrix2EqWidth dropStackRows) : + ("takeStackColumns", + checkForAll genMatrix2EqHeight takeStackColumns) : + ("dropStackColumns", + checkForAll genMatrix2EqHeight dropStackColumns) : + ("stackRowsAssociative", + checkForAll + ((,,) <$> Gen.matrix2 <===> Gen.matrix2 <===> Gen.matrix2) + stackRowsAssociative) : + ("stackColumnsAssociative", + checkForAll + ((,,) <$> Gen.matrix2 <|||> Gen.matrix2 <|||> Gen.matrix2) + stackColumnsAssociative) : + ("stackRowsColumnsCommutative", + checkForAll + ((,) <$> genMatrix2EqHeight <===> genMatrix2EqHeight) + stackRowsColumnsCommutative) : + + ("multiplyDiagonalMatrix", + checkForAll + ((,) <$> Gen.diagonal <|*|> Gen.matrix) multiplyDiagonalMatrix) : + ("multiplyMatrixDiagonal", + checkForAll + ((,) <$> Gen.matrix <|*|> Gen.diagonal) multiplyMatrixDiagonal) : + [] diff --git a/test/Test/Orthogonal.hs b/test/Test/Orthogonal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Orthogonal.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Test.Orthogonal (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Generator ((<|*|>), (<|\|>)) +import Test.Utility + (approx, approxReal, approxArrayTol, approxMatrix, isIdentity, Tagged) + +import qualified Numeric.LAPACK.Orthogonal.Householder as HH +import qualified Numeric.LAPACK.Orthogonal as Ortho +import qualified Numeric.LAPACK.Matrix.Hermitian as Herm +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Square (Square) +import Numeric.LAPACK.Matrix (General, ZeroInt, (<#>)) +import Numeric.LAPACK.Scalar (RealOf, absolute, selectReal) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) + +import Control.Applicative (liftA2, (<$>)) + +import qualified Test.QuickCheck as QC + + +pseudoInverseProjection :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +pseudoInverseProjection a = + let ainv = snd $ Ortho.pseudoInverseRCond 1e-5 a + tol = selectReal 1e-1 1e-5 + in approxArrayTol tol a (a <#> ainv <#> a) && + approxArrayTol tol ainv (ainv <#> a <#> ainv) + +pseudoInverseHermitian :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +pseudoInverseHermitian a = + let ainv = snd $ Ortho.pseudoInverseRCond 1e-5 a + tol = selectReal 1e-2 1e-5 + aainv = a <#> ainv + ainva = ainv <#> a + in approxMatrix tol aainv (Matrix.adjoint aainv) && + approxMatrix tol ainva (Matrix.adjoint ainva) + +pseudoInverseFactored :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Tall ZeroInt ZeroInt a, + Matrix.Wide ZeroInt ZeroInt a) -> Bool +pseudoInverseFactored (a,b) = + let pinv x = snd $ Ortho.pseudoInverseRCond 1e-5 x + in approxMatrix (selectReal 1e-1 1e-5) + (pinv (a <#> b)) (pinv b <#> pinv a) + +pseudoInverseInverse :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +pseudoInverseInverse a = + approxMatrix (selectReal 1e-1 1e-5) + (Matrix.inverse a) + (snd $ Ortho.pseudoInverseRCond 1e-5 a) + + +determinant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +determinant a = + let detSquare = Square.determinant a + detOrtho = Ortho.determinant a + in approx + (1e-3 * max 1 (max (absolute detSquare) (absolute detOrtho))) + detSquare detOrtho + +determinantAbsolute :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +determinantAbsolute a = + let det = absolute $ Ortho.determinant a + detAbs = Ortho.determinantAbsolute a + in approxReal (1e-5 * max 1 (max det detAbs)) det detAbs + +gramianDeterminant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +gramianDeterminant a = + let cov = Herm.covariance a + Shape.ZeroBased n = Matrix.width a + estimate = (Vector.sum (Herm.takeDiagonal cov) / fromIntegral n) ^ n + in approxReal (1e-5 * max 1 estimate) + (Herm.determinant cov) + (Ortho.determinantAbsolute a ^ (2::Int)) + + +multiplyDeterminantRight :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (General ZeroInt ZeroInt a, Square ZeroInt a) -> Bool +multiplyDeterminantRight (a,b) = + let detA = Ortho.determinantAbsolute a + detB = absolute $ Ortho.determinant b + in approxReal + (selectReal 1e-1 1e-5 * max 1 detA * max 1 detB) + (Ortho.determinantAbsolute (a<#>b)) + (detA * detB) + +multiplyDeterminantLeft :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Square ZeroInt a, General ZeroInt ZeroInt a) -> Bool +multiplyDeterminantLeft (a,b) = + let detA = absolute $ Ortho.determinant a + detB = Ortho.determinantAbsolute b + in approxReal + (selectReal 1e-1 1e-5 * max 1 detA * max 1 detB) + (Ortho.determinantAbsolute (a<#>b)) + (detA * detB) + + +genFullRankTallRHS :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Matrix a Int Int + (Matrix.Tall ZeroInt ZeroInt a, + Matrix.General ZeroInt ZeroInt a) +genFullRankTallRHS = (,) <$> Gen.fullRankTall <|\|> Gen.matrix + + +normalEquationLeastSquares :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Tall ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +normalEquationLeastSquares (a, b) = + approxArrayTol + (selectReal 10 1e-3) + (Ortho.leastSquares a b) + (Herm.solve (Herm.covariance $ Matrix.fromFull a) $ + Matrix.adjoint a <#> b) + +specializedLeastSquares :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Tall ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +specializedLeastSquares (a, b) = + approxArrayTol + (selectReal 1e-1 1e-5) + (Ortho.leastSquares a b) + (snd $ Ortho.leastSquaresMinimumNormRCond 1e-5 (Matrix.fromFull a) b) + +householderLeastSquares :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Tall ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +householderLeastSquares (a, b) = + approxArrayTol + (selectReal 1e-1 1e-5) + (Ortho.leastSquares a b) + (HH.leastSquares (HH.fromMatrix a) b) + + + +genFullRankWideRHS :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Matrix a Int Int + (Matrix.Wide ZeroInt ZeroInt a, + Matrix.General ZeroInt ZeroInt a) +genFullRankWideRHS = (,) <$> Gen.fullRankWide <|\|> Gen.matrix + + +normalEquationMinimumNorm :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Wide ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +normalEquationMinimumNorm (a, b) = + approxArrayTol + (selectReal 10 1e-3) + (Ortho.minimumNorm a b) + (Matrix.adjoint a <#> + Herm.solve (Herm.covariance $ Matrix.fromFull $ Matrix.adjoint a) b) + +specializedMinimumNorm :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Wide ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +specializedMinimumNorm (a, b) = + approxArrayTol + (selectReal 1e-1 1e-5) + (Ortho.minimumNorm a b) + (snd $ Ortho.leastSquaresMinimumNormRCond 1e-5 (Matrix.fromFull a) b) + +householderMinimumNorm :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Wide ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +householderMinimumNorm (a, b) = + approxArrayTol + (selectReal 1e-1 1e-5) + (Ortho.minimumNorm a b) + (HH.minimumNorm (HH.fromMatrix $ Matrix.adjoint a) b) + + +complementDimension :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Tall ZeroInt ZeroInt a -> Bool +complementDimension a = + let b = Matrix.fromFull a Matrix.||| Matrix.fromFull (Ortho.complement a) + in Shape.size (Matrix.height b) == Shape.size (Matrix.width b) + +complementBiorthogonal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Tall ZeroInt ZeroInt a -> Bool +complementBiorthogonal a = + all (approx 1e-3 0) $ + Array.toList $ Matrix.adjoint a <#> Ortho.complement a + +complementOrthogonal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Tall ZeroInt ZeroInt a -> Bool +complementOrthogonal = + isIdentity (selectReal 1e-3 1e-7) . + Herm.toSquare . Herm.covariance . Matrix.fromFull . Ortho.complement + + +householderReconstruction :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.General ZeroInt ZeroInt a -> Bool +householderReconstruction a = + approxArrayTol (selectReal 1e-3 1e-7) + a (uncurry (<#>) (Ortho.householder a)) + +householderDeterminant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +householderDeterminant a = + let detOrtho = Ortho.determinant a + detHH = HH.determinant $ HH.fromMatrix a + in approx 1e-5 detOrtho detHH + + +maybeConjugate :: + (Shape.C sh, Class.Floating a) => + HH.Conjugation -> Array sh a -> Array sh a +maybeConjugate HH.NonConjugated = id +maybeConjugate HH.Conjugated = Vector.conjugate + +maybeTranspose :: + (Shape.C size, Class.Floating a, MatrixShape.TriDiag diag, + MatrixShape.Content lo, MatrixShape.Content up) => + Herm.Transposition -> + Triangular.Triangular up diag lo size a -> Square size a +maybeTranspose HH.NonTransposed = Triangular.toSquare +maybeTranspose HH.Transposed = Triangular.toSquare . Triangular.transpose + +maybeAdjoint :: + (Shape.C size, Class.Floating a) => + HH.Inversion -> Square size a -> Square size a +maybeAdjoint HH.NonInverted = id +maybeAdjoint HH.Inverted = Matrix.adjoint + +householderSolveRR :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (HH.Transposition, HH.Conjugation) -> + Matrix.Tall ZeroInt ZeroInt a -> Bool +householderSolveRR (trans,conj) a = + let qr = HH.fromMatrix a + in isIdentity (selectReal 1e-3 1e-7) $ + HH.tallSolveR trans conj qr $ + maybeTranspose trans $ maybeConjugate conj $ HH.tallExtractR qr + + +householderMultiplyR :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + HH.Transposition -> + (Matrix.Tall ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> + Bool +householderMultiplyR trans (a,b) = + let qr = HH.fromMatrix a + r = HH.tallExtractR qr + in approxArrayTol + (selectReal 1e-3 1e-7) + (HH.tallMultiplyR trans qr b) + (case trans of + HH.NonTransposed -> r <#> b + HH.Transposed -> Triangular.transpose r <#> b) + + +householderQOrthogonal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.General ZeroInt ZeroInt a -> Bool +householderQOrthogonal a = + let q = HH.extractQ $ HH.fromMatrix a + in isIdentity (selectReal 1e-3 1e-7) $ Matrix.adjoint q <#> q + + +householderMultiplyQ :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + HH.Inversion -> + (Matrix.General ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> + Bool +householderMultiplyQ inv (a,b) = + let qr = HH.fromMatrix a + in approxArrayTol + (selectReal 1e-3 1e-7) + (maybeAdjoint inv (HH.extractQ qr) <#> b) + (HH.multiplyQ inv qr b) + + +householderTallQOrthogonal :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Tall ZeroInt ZeroInt a -> Bool +householderTallQOrthogonal = + isIdentity (selectReal 1e-3 1e-7) . + Herm.toSquare . Herm.covariance . Matrix.fromFull . + HH.tallExtractQ . HH.fromMatrix + +householderTallMultiplyQ :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Tall ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +householderTallMultiplyQ (a,b) = + let qr = HH.fromMatrix a + in approxArrayTol + (selectReal 1e-3 1e-7) + (HH.tallExtractQ qr <#> b) + (HH.tallMultiplyQ qr b) + +householderTallMultiplyQAdjoint :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.Tall ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +householderTallMultiplyQAdjoint (a,b) = + let qr = HH.fromMatrix a + in approxArrayTol + (selectReal 1e-3 1e-7) + (Matrix.adjoint (HH.tallExtractQ qr) <#> b) + (HH.tallMultiplyQAdjoint qr b) + + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 3 5) + + +testsVar :: + (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("pseudoInverseProjection", + checkForAll Gen.matrix pseudoInverseProjection) : + ("pseudoInverseHermitian", + checkForAll Gen.matrix pseudoInverseHermitian) : + ("pseudoInverseFactored", + checkForAll + ((,) <$> Gen.fullRankTall <|*|> Gen.fullRankWide) + pseudoInverseFactored) : + ("pseudoInverseInverse", + checkForAll Gen.invertible pseudoInverseInverse) : + + ("determinant", + checkForAll Gen.square determinant) : + ("determinantAbsolute", + checkForAll Gen.square determinantAbsolute) : + ("gramianDeterminant", + checkForAll Gen.matrix gramianDeterminant) : + ("multiplyDeterminantRight", + checkForAll + ((,) <$> Gen.matrix <|*|> Gen.square) multiplyDeterminantRight) : + ("multiplyDeterminantLeft", + checkForAll + ((,) <$> (fst . Ortho.householder <$> Gen.square) <|*|> Gen.matrix) + multiplyDeterminantLeft) : + ("normalEquationLeastSquares", + checkForAll genFullRankTallRHS normalEquationLeastSquares) : + ("normalEquationMinimumNorm", + checkForAll genFullRankWideRHS normalEquationMinimumNorm) : + ("specializedLeastSquares", + checkForAll genFullRankTallRHS specializedLeastSquares) : + ("specializedMinimumNorm", + checkForAll genFullRankWideRHS specializedMinimumNorm) : + + ("complementDimension", + checkForAll Gen.tall complementDimension) : + ("complementBiorthogonal", + checkForAll Gen.tall complementBiorthogonal) : + ("complementOrthogonal", + checkForAll Gen.tall complementOrthogonal) : + + ("householderReconstruction", + checkForAll Gen.matrix householderReconstruction) : + ("householderDeterminant", + checkForAll Gen.square householderDeterminant) : + ("householderLeastSquares", + checkForAll genFullRankTallRHS householderLeastSquares) : + ("householderMinimumNorm", + checkForAll genFullRankWideRHS householderMinimumNorm) : + ("householderSolveRR", + Gen.withExtra checkForAll + (liftA2 (,) QC.arbitraryBoundedEnum QC.arbitraryBoundedEnum) + Gen.fullRankTall householderSolveRR) : + ("householderMultiplyR", + Gen.withExtra checkForAll + QC.arbitraryBoundedEnum ((,) <$> Gen.tall <|*|> Gen.matrix) + householderMultiplyR) : + ("householderQOrthogonal", + checkForAll Gen.matrix householderQOrthogonal) : + ("householderMultiplyQ", + Gen.withExtra checkForAll + QC.arbitraryBoundedEnum ((,) <$> Gen.matrix <|\|> Gen.matrix) + householderMultiplyQ) : + ("householderTallQOrthogonal", + checkForAll Gen.tall householderTallQOrthogonal) : + ("householderTallMultiplyQ", + checkForAll ((,) <$> Gen.tall <|*|> Gen.matrix) householderTallMultiplyQ) : + ("householderTallMultiplyQAdjoint", + checkForAll + ((,) <$> Gen.tall <|\|> Gen.matrix) householderTallMultiplyQAdjoint) : + [] diff --git a/test/Test/Permutation.hs b/test/Test/Permutation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Permutation.hs @@ -0,0 +1,40 @@ +module Test.Permutation where + +import qualified Numeric.LAPACK.Permutation as Perm +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Permutation (Inversion(Inverted, NonInverted)) +import Numeric.LAPACK.Matrix (ZeroInt, zeroInt) +import Numeric.LAPACK.Vector (Vector) + +import qualified Data.Array.Comfort.Storable as Array +import Data.Array.Comfort.Storable (Array) + +import Foreign.C.Types (CInt) + +import Control.Monad (forM) + +import qualified Test.QuickCheck as QC + + +genPivots :: QC.Gen (Vector ZeroInt CInt) +genPivots = do + nat <- QC.arbitrary + let n = length nat + let nc = fromIntegral n + fmap (Vector.fromList (zeroInt n)) $ + forM (zip [1..] nat) $ \(i,()) -> QC.choose (i,nc) + + +permutationPivots :: Bool -> Array ZeroInt CInt -> Bool +permutationPivots dir xs = + let inv = if dir then Inverted else NonInverted + in Array.toList (Perm.toPivots inv (Perm.fromPivots inv (Array.shape xs) xs)) + == + Array.toList xs + + +tests :: [(String, QC.Property)] +tests = + ("permutationPivots", + QC.property $ QC.forAll genPivots . permutationPivots) : + [] diff --git a/test/Test/Shape.hs b/test/Test/Shape.hs new file mode 100644 --- /dev/null +++ b/test/Test/Shape.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +module Test.Shape where + +import Test.Utility (genOrder, prefix) + +import qualified Data.Array.Comfort.Shape.Test as ShapeTest +import qualified Data.Array.Comfort.Shape as Shape + +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import Numeric.LAPACK.Matrix (ZeroInt, zeroInt) + +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary (unary) + +import Control.Applicative ((<$>)) + +import qualified Test.QuickCheck as QC + + +genGeneral :: QC.Gen (MatrixShape.General ZeroInt ZeroInt) +genGeneral = do + order <- genOrder + m <- QC.choose (0,10) + n <- QC.choose (0,10) + return $ MatrixShape.general order (zeroInt m) (zeroInt n) + +genTall :: QC.Gen (MatrixShape.Tall ZeroInt ZeroInt) +genTall = do + order <- genOrder + m <- QC.choose (0,10) + n <- QC.choose (0,m) + return $ MatrixShape.tall order (zeroInt m) (zeroInt n) + +genWide :: QC.Gen (MatrixShape.Wide ZeroInt ZeroInt) +genWide = do + order <- genOrder + m <- QC.choose (0,10) + n <- QC.choose (m,10) + return $ MatrixShape.wide order (zeroInt m) (zeroInt n) + +genSquare :: QC.Gen (MatrixShape.Square ZeroInt) +genSquare = do + order <- genOrder + n <- QC.choose (0,10) + return $ MatrixShape.square order (zeroInt n) + + +genHermitian :: QC.Gen (MatrixShape.Hermitian ZeroInt) +genHermitian = do + order <- genOrder + n <- QC.choose (0,10) + return $ MatrixShape.hermitian order (zeroInt n) + +genDiagonal :: QC.Gen (MatrixShape.Diagonal ZeroInt) +genDiagonal = do + order <- genOrder + n <- QC.choose (0,10) + return $ MatrixShape.diagonal order (zeroInt n) + +genLowerTriangular :: + QC.Gen (MatrixShape.LowerTriangular MatrixShape.NonUnit ZeroInt) +genLowerTriangular = do + order <- genOrder + n <- QC.choose (0,10) + return $ MatrixShape.lowerTriangular order (zeroInt n) + +genUpperTriangular :: + QC.Gen (MatrixShape.UpperTriangular MatrixShape.NonUnit ZeroInt) +genUpperTriangular = do + order <- genOrder + n <- QC.choose (0,10) + return $ MatrixShape.upperTriangular order (zeroInt n) + +genSymmetric :: QC.Gen (MatrixShape.Symmetric ZeroInt) +genSymmetric = do + order <- genOrder + n <- QC.choose (0,10) + return $ MatrixShape.symmetric order (zeroInt n) + + +data Banded vert horiz height width = + forall sub super. + (Unary.Natural sub, Unary.Natural super) => + Banded (MatrixShape.Banded sub super vert horiz height width) + +instance + (Extent.C horiz, Extent.C vert, + Show height, Show width, Shape.C height, Shape.C width) => + Show (Banded vert horiz height width) where + showsPrec p (Banded sh) = showsPrec p sh + +instance + (Extent.C horiz, Extent.C vert, Shape.C height, Shape.C width) => + Shape.C (Banded vert horiz height width) where + size (Banded sh) = Shape.size sh + uncheckedSize (Banded sh) = Shape.uncheckedSize sh + +instance + (Extent.C horiz, Extent.C vert, + Shape.Indexed height, Shape.Indexed width) => + Shape.Indexed (Banded vert horiz height width) where + type Index (Banded vert horiz height width) = + MatrixShape.BandedIndex (Shape.Index height) (Shape.Index width) + indices (Banded sh) = Shape.indices sh + offset (Banded sh) = Shape.offset sh + uncheckedOffset (Banded sh) = Shape.uncheckedOffset sh + inBounds (Banded sh) = Shape.inBounds sh + + sizeOffset (Banded sh) = Shape.sizeOffset sh + uncheckedSizeOffset (Banded sh) = Shape.uncheckedSizeOffset sh + +instance + (Extent.C horiz, Extent.C vert, + Shape.InvIndexed height, Shape.InvIndexed width) => + Shape.InvIndexed (Banded vert horiz height width) where + + indexFromOffset (Banded sh) = Shape.indexFromOffset sh + uncheckedIndexFromOffset (Banded sh) = Shape.uncheckedIndexFromOffset sh + + +genBanded :: + MatrixShape.Full vert horiz height width -> + QC.Gen (Banded vert horiz height width) +genBanded sh = do + kl <- QC.choose (0,10) + ku <- QC.choose (0,10) + Unary.reifyNatural kl $ \sub -> + Unary.reifyNatural ku $ \super -> + return $ Banded $ MatrixShape.bandedFromFull (unary sub, unary super) sh + + +data BandedHermitian size = + forall offDiag. + (Unary.Natural offDiag) => + BandedHermitian (MatrixShape.BandedHermitian offDiag size) + +instance (Show size, Shape.C size) => Show (BandedHermitian size) where + showsPrec p (BandedHermitian sh) = showsPrec p sh + +instance (Shape.C size) => Shape.C (BandedHermitian size) where + size (BandedHermitian sh) = Shape.size sh + uncheckedSize (BandedHermitian sh) = Shape.uncheckedSize sh + +instance (Shape.Indexed size) => Shape.Indexed (BandedHermitian size) where + type Index (BandedHermitian size) = + MatrixShape.BandedIndex (Shape.Index size) (Shape.Index size) + indices (BandedHermitian sh) = Shape.indices sh + offset (BandedHermitian sh) = Shape.offset sh + uncheckedOffset (BandedHermitian sh) = Shape.uncheckedOffset sh + inBounds (BandedHermitian sh) = Shape.inBounds sh + + sizeOffset (BandedHermitian sh) = Shape.sizeOffset sh + uncheckedSizeOffset (BandedHermitian sh) = Shape.uncheckedSizeOffset sh + +instance + (Shape.InvIndexed size) => Shape.InvIndexed (BandedHermitian size) where + + indexFromOffset (BandedHermitian sh) = + Shape.indexFromOffset sh + uncheckedIndexFromOffset (BandedHermitian sh) = + Shape.uncheckedIndexFromOffset sh + + +genBandedHermitian :: QC.Gen (BandedHermitian ZeroInt) +genBandedHermitian = do + order <- genOrder + n <- QC.choose (0,10) + k <- QC.choose (0,10) + Unary.reifyNatural k $ \numOff -> + return $ BandedHermitian $ + MatrixShape.bandedHermitian (unary numOff) order (zeroInt n) + + +tests :: [(String, QC.Property)] +tests = + prefix "General" (ShapeTest.tests genGeneral) ++ + prefix "Tall" (ShapeTest.tests genTall) ++ + prefix "Wide" (ShapeTest.tests genWide) ++ + prefix "Square" (ShapeTest.tests genSquare) ++ + + prefix "Split.Reflector.General" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Reflector <$> genGeneral) ++ + prefix "Split.Reflector.Tall" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Reflector <$> genTall) ++ + prefix "Split.Reflector.Wide" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Reflector <$> genWide) ++ + prefix "Split.Reflector.Square" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Reflector <$> genSquare) ++ + prefix "Split.Triangle.General" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Triangle <$> genGeneral) ++ + prefix "Split.Triangle.Tall" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Triangle <$> genTall) ++ + prefix "Split.Triangle.Wide" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Triangle <$> genWide) ++ + prefix "Split.Triangle.Square" + (ShapeTest.tests $ + MatrixShape.splitFromFull MatrixShape.Triangle <$> genSquare) ++ + + prefix "Hermitian" (ShapeTest.tests genHermitian) ++ + prefix "Diagonal" (ShapeTest.tests genDiagonal) ++ + prefix "LowerTriangular" (ShapeTest.tests genLowerTriangular) ++ + prefix "UpperTriangular" (ShapeTest.tests genUpperTriangular) ++ + prefix "Symmetric" (ShapeTest.tests genSymmetric) ++ + + prefix "Banded.General" (ShapeTest.tests $ genBanded =<< genGeneral) ++ + prefix "Banded.Tall" (ShapeTest.tests $ genBanded =<< genTall) ++ + prefix "Banded.Wide" (ShapeTest.tests $ genBanded =<< genWide) ++ + prefix "Banded.Square" (ShapeTest.tests $ genBanded =<< genSquare) ++ + prefix "BandedHermitian" (ShapeTest.tests genBandedHermitian) ++ + [] diff --git a/test/Test/Singular.hs b/test/Test/Singular.hs new file mode 100644 --- /dev/null +++ b/test/Test/Singular.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TypeFamilies #-} +module Test.Singular (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Generator ((<|\|>)) +import Test.Utility + (approxReal, approxArrayTol, approxMatrix, isIdentity, Tagged) + +import qualified Numeric.LAPACK.Singular as Singular +import qualified Numeric.LAPACK.Orthogonal as Ortho +import qualified Numeric.LAPACK.Matrix.Hermitian as Herm +import qualified Numeric.LAPACK.Matrix as Matrix +import Numeric.LAPACK.Matrix (General, ZeroInt, (<#>)) +import Numeric.LAPACK.Scalar (RealOf, selectReal) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape + +import Control.Applicative ((<$>)) + +import qualified Test.QuickCheck as QC + + +pseudoInverseOrtho :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +pseudoInverseOrtho a = + let (no,invo) = Ortho.pseudoInverseRCond 1e-5 a + (ns,invs) = Singular.pseudoInverseRCond 1e-5 a + tol = selectReal 1e-2 1e-5 + in no==ns && approxMatrix tol invo invs + +pseudoInverseProjection :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +pseudoInverseProjection a = + let ainv = snd $ Singular.pseudoInverseRCond 1e-5 a + tol = selectReal 1e-1 1e-5 + in approxArrayTol tol a (a <#> ainv <#> a) && + approxArrayTol tol ainv (ainv <#> a <#> ainv) + +pseudoInverseHermitian :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +pseudoInverseHermitian a = + let ainv = snd $ Singular.pseudoInverseRCond 1e-5 a + tol = selectReal 1e-2 1e-5 + aainv = a <#> ainv + ainva = ainv <#> a + in approxMatrix tol aainv (Matrix.adjoint aainv) && + approxMatrix tol ainva (Matrix.adjoint ainva) + + +determinantAbsolute :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + General ZeroInt ZeroInt a -> Bool +determinantAbsolute a = + let detOrtho = Ortho.determinantAbsolute a + detSing = Singular.determinantAbsolute a + in approxReal + (selectReal 1e-3 1e-5 * max 1 (max detOrtho detSing)) + detOrtho detSing + + +leastSquaresMinimumNorm :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.General ZeroInt ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +leastSquaresMinimumNorm (a,b) = + let (no,xo) = Ortho.leastSquaresMinimumNormRCond 1e-5 a b + (ns,xs) = Singular.leastSquaresMinimumNormRCond 1e-5 a b + in no==ns && + approxMatrix (selectReal 10 1e-3) xo xs + + +decompose :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.General ZeroInt ZeroInt a -> Bool +decompose a = + let (u,s,vt) = Singular.decompose a + mn = Shape.size $ Array.shape s + in approxArrayTol 1e-3 a + (Matrix.takeColumns mn (Matrix.generalizeWide u) <#> + Matrix.scaleRowsReal s (Matrix.takeRows mn (Matrix.generalizeTall vt))) + && + isIdentity 1e-3 (Matrix.adjoint u <#> u) + && + isIdentity 1e-3 (Matrix.adjoint vt <#> vt) + +decomposeTall :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Tall ZeroInt ZeroInt a -> Bool +decomposeTall a = + let (u,s,vt) = Singular.decomposeTall a + in approxArrayTol 1e-3 a (u <#> Matrix.scaleRowsReal s vt) + && + isIdentity 1e-3 (Herm.toSquare $ Herm.covariance $ Matrix.fromFull u) + && + isIdentity 1e-3 (Matrix.adjoint vt <#> vt) + +decomposeWide :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Wide ZeroInt ZeroInt a -> Bool +decomposeWide a = + let (u,s,vt) = Singular.decomposeWide a + in approxArrayTol 1e-3 a (u <#> Matrix.scaleRowsReal s vt) + && + isIdentity 1e-3 (Matrix.adjoint u <#> u) + && + isIdentity 1e-3 + (Herm.toSquare $ Herm.covariance $ + Matrix.fromFull $ Matrix.transpose vt) + + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 3 5) + +testsVar :: + (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("pseudoInverseOrtho", + checkForAll Gen.matrix pseudoInverseOrtho) : + ("pseudoInverseProjection", + checkForAll Gen.matrix pseudoInverseProjection) : + ("pseudoInverseHermitian", + checkForAll Gen.matrix pseudoInverseHermitian) : + ("determinantAbsolute", + checkForAll Gen.matrix determinantAbsolute) : + ("leastSquaresMinimumNorm", + checkForAll ((,) <$> Gen.matrix <|\|> Gen.matrix) leastSquaresMinimumNorm) : + ("decompose", + checkForAll Gen.matrix decompose) : + ("decomposeTall", + checkForAll Gen.tall decomposeTall) : + ("decomposeWide", + checkForAll Gen.wide decomposeWide) : + [] diff --git a/test/Test/Square.hs b/test/Test/Square.hs new file mode 100644 --- /dev/null +++ b/test/Test/Square.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TypeFamilies #-} +module Test.Square (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Generator ((<|*|>), (<|\|>)) +import Test.Utility (approx, approxArray, approxArrayTol, approxMatrix, Tagged) + +import qualified Numeric.LAPACK.Matrix.Triangular as Tri +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Square (Square) +import Numeric.LAPACK.Matrix (ZeroInt, (<#>)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, absolute, selectReal) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array + +import Control.Applicative ((<$>)) + +import Data.Function.HT (nest) + +import qualified Test.QuickCheck as QC + + +multiplySquare :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +multiplySquare a = + approxArray (Square.square a) (Square.multiply a a) + +multiplyPower :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Int -> Square ZeroInt a -> Bool +multiplyPower n a = + let b = Square.power (fromIntegral n) a + c = nest n (Square.multiply a) $ Square.identityFrom a + in approxArrayTol (1e-6 * (Vector.normInf1 b + Vector.normInf1 c)) b c + + +determinantSingleton :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + a -> Bool +determinantSingleton a = + approx 1e-5 a (Square.determinant $ Square.autoFromList [a]) + +determinantTranspose :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +determinantTranspose a = + approx 1e-5 + (Square.determinant a) (Square.determinant $ Square.transpose a) + + +multiplyDeterminant :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Square ZeroInt a, Square ZeroInt a) -> Bool +multiplyDeterminant (a,b) = + let detA = Square.determinant a + detB = Square.determinant b + in approx + (1e-2 * max 1 (absolute detA) * max 1 (absolute detB)) + (Square.determinant (a<#>b)) + (detA * detB) + +multiplyInverse :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +multiplyInverse a = + let eye = Square.inverse a <#> a + in approxArrayTol 1e-4 eye (Square.identityFrom eye) + + +multiplySolve :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Square ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +multiplySolve (a, b) = + approxMatrix 1e-2 (a <#> Square.solve a b) b + +schur :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +schur a = + let (q,r) = Square.schur a + in approxMatrix 1e-4 a (q <#> r <#> Square.adjoint q) + + +diagonal :: (Class.Floating a) => Vector ZeroInt a -> Tri.Diagonal ZeroInt a +diagonal = Tri.diagonal MatrixShape.ColumnMajor + +genDiagonalizable :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Matrix a Int Int (Square ZeroInt a) +genDiagonalizable = flip Gen.mapGen Gen.invertible $ \ _maxElem a -> do + d <- Util.genDistinct 3 10 (Square.size a) + return $ Square.solve a $ diagonal d <#> a + + +eigensystem :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +eigensystem a = + let (vr,d,vl) = Square.eigensystem a + scal = Array.map recip $ Square.takeDiagonal $ Square.adjoint vl <#> vr + in approxMatrix (selectReal 1e-1 1e-5) + (Vector.toComplex a) + (vr <#> diagonal d <#> diagonal scal <#> Square.adjoint vl) + +eigensystemLeft :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +eigensystemLeft a = + let (_vr,d,vl) = Square.eigensystem a + vlAdj = Square.adjoint vl + in approxMatrix (selectReal 1e-1 1e-5) + (Vector.toComplex a) + (Square.solve vlAdj $ diagonal d <#> vlAdj) + +eigensystemRight :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square ZeroInt a -> Bool +eigensystemRight a = + let (vr,d,_vl) = Square.eigensystem a + solveLeft b m = + Matrix.transpose $ + Square.solve (Matrix.transpose m) (Matrix.transpose b) + in approxMatrix (selectReal 1e-1 1e-5) + (Vector.toComplex a) + (solveLeft (vr <#> diagonal d) vr) + + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 3 5) + + +testsVar :: + (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("multiplySquare", + checkForAll Gen.square multiplySquare) : + ("multiplyPower", + Gen.withExtra checkForAll (QC.choose (0,10)) Gen.square multiplyPower) : + ("multiplyInverse", + checkForAll Gen.invertible multiplyInverse) : + ("determinantSingleton", + checkForAll Gen.scalar determinantSingleton) : + ("determinantTranspose", + checkForAll Gen.square determinantTranspose) : + ("multiplyDeterminant", + checkForAll ((,) <$> Gen.square <|*|> Gen.square) multiplyDeterminant) : + ("multiplySolve", + checkForAll ((,) <$> Gen.invertible <|\|> Gen.matrix) multiplySolve) : + + ("schur", + checkForAll Gen.square schur) : + ("eigensystem", + checkForAll genDiagonalizable eigensystem) : + ("eigensystemLeft", + checkForAll genDiagonalizable eigensystemLeft) : + ("eigensystemRight", + checkForAll genDiagonalizable eigensystemRight) : + [] diff --git a/test/Test/Triangular.hs b/test/Test/Triangular.hs new file mode 100644 --- /dev/null +++ b/test/Test/Triangular.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Rank2Types #-} +module Test.Triangular (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Generator ((<.*|>), (<|*.>), (<|*|>), (<|\|>)) +import Test.Utility (approx, approxArray, approxArrayTol, approxMatrix, Tagged) + +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Triangular (Triangular) +import Numeric.LAPACK.Matrix (General, ZeroInt, (<#), (<#>), (#>)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, selectReal, absolute) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable ((!)) + +import Control.Applicative ((<$>)) + +import Data.Traversable (for) +import Data.Tuple.HT (mapFst) + +import qualified Test.QuickCheck as QC + + +multiplyIdentityVector :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, Vector ZeroInt a) -> Bool +multiplyIdentityVector (eye,a) = + approxArray a (Triangular.multiplyVector eye a) + +multiplyIdentityFull :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, General ZeroInt ZeroInt a) -> + Bool +multiplyIdentityFull (eye,a) = + approxArray a (Triangular.multiplyFull eye a) + +multiplyIdentity :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Eq lo, Eq diag, Eq up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, Triangular lo diag up ZeroInt a) -> + Bool +multiplyIdentity (eye,a) = + approxArray a (Triangular.multiply eye a) + +multiplyVector :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, Vector ZeroInt a) -> Bool +multiplyVector (a,x) = + approxArray + (Triangular.toSquare a #> x) + (Triangular.multiplyVector a x) + +multiply :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, Triangular lo diag up ZeroInt a) -> + Bool +multiply (a,b) = + approxArray + (Triangular.toSquare a <#> Triangular.toSquare b) + (Triangular.toSquare $ Triangular.multiply a b) + +multiplyFull :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, General ZeroInt ZeroInt a) -> + Bool +multiplyFull (a,b) = + approxArray + (Triangular.toSquare a <#> b) + (Triangular.multiplyFull a b) + +multiplySquare :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Triangular lo diag up ZeroInt a -> Bool +multiplySquare a = + approxArray + (Triangular.toSquare $ Triangular.square a) + (Triangular.multiplyFull a $ Triangular.toSquare a) + +squareSquare :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Triangular lo diag up ZeroInt a -> Bool +squareSquare a = + approxArray + (Triangular.toSquare $ Triangular.square a) + (Square.square $ Triangular.toSquare a) + + +multiplyVectorLeft :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Vector ZeroInt a, Triangular lo diag up ZeroInt a) -> Bool +multiplyVectorLeft (x,a) = + approxArray (x <# Triangular.toSquare a) (x <# a) + +multiplyVectorRight :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, Vector ZeroInt a) -> Bool +multiplyVectorRight (a,x) = + approxArray (Triangular.toSquare a #> x) (a #> x) + + +multiplyLeft :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (General ZeroInt ZeroInt a, Triangular lo diag up ZeroInt a) -> Bool +multiplyLeft (a,b) = + approxMatrix 1e-5 (a <#> Triangular.toSquare b) (a <#> b) + +multiplyRight :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, General ZeroInt ZeroInt a) -> Bool +multiplyRight (a,b) = + approxArray (Triangular.toSquare a <#> b) (a <#> b) + + + +determinant :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Triangular lo diag up ZeroInt a -> Bool +determinant a = + approx + (selectReal 1e-1 1e-5) + (Triangular.determinant a) + (Square.determinant $ Triangular.toSquare a) + + +invertible :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Triangular lo diag up sh a -> Bool +invertible a = absolute (Triangular.determinant a) > 0.1 + +genInvertible :: + (MatrixShape.Content up, MatrixShape.Content lo, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + GenTriangular lo diag up a +genInvertible = Gen.triangularCond invertible + +inverse :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Triangular lo diag up ZeroInt a -> Bool +inverse a = + approxArrayTol + (selectReal 1 1e-5) + (Triangular.toSquare $ Triangular.inverse a) + (Square.inverse $ Triangular.toSquare a) + +inverseGeneric :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Triangular lo diag up ZeroInt a -> Bool +inverseGeneric a = + approxArrayTol + (selectReal 1 1e-5) + (Triangular.toSquare $ Triangular.inverseGeneric a) + (Square.inverse $ Triangular.toSquare a) + + +solve :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +solve (a, b) = + approxMatrix (selectReal 1 1e-5) + (Triangular.solve a b) + (Square.solve (Triangular.toSquare a) b) + +solveIdentity :: + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Triangular lo diag up ZeroInt a, Matrix.General ZeroInt ZeroInt a) -> Bool +solveIdentity (eye, a) = + approxMatrix (selectReal 1e-3 1e-5) + a (Triangular.solve eye a) + + + +eigenvaluesDeterminant :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Triangular lo diag up ZeroInt a -> Bool +eigenvaluesDeterminant a = + approx + (selectReal 1e-1 1e-5) + (Triangular.determinant a) + (Vector.product $ Triangular.eigenvalues a) + + +genDiagonalizable :: + (MatrixShape.Content lo, MatrixShape.Content up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + GenTriangular lo MatrixShape.NonUnit up a +genDiagonalizable = + flip Gen.mapGen Gen.squareDim $ \maxElem size -> do + order <- Util.genOrder + d <- Util.genDistinct 3 10 size + let shape = + MatrixShape.Triangular + MatrixShape.NonUnit MatrixShape.autoUplo order size + Array.fromList shape <$> + (for (Shape.indices shape) $ \(r,c) -> + if r==c + then return (d!r) + else Util.genElement maxElem) + +eigensystem :: + (MatrixShape.DiagUpLo lo up, Eq lo, Eq up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + MatrixShape.Order -> Triangular lo MatrixShape.NonUnit up ZeroInt a -> Bool +eigensystem order a = + let (vr,d,vl) = Triangular.eigensystem a + scal = Triangular.takeDiagonal $ Triangular.multiply vl vr + in approxMatrix + (selectReal 1e-3 1e-5) + (Triangular.toSquare a) + (Triangular.toSquare $ + vr + `Triangular.multiply` + Triangular.diagonal order (Vector.mul d $ Array.map recip scal) + `Triangular.multiply` + vl) + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 3 5) + +checkForAllExtra :: + (Show a, Show b, QC.Testable test, Gen.Required required) => + QC.Gen a -> Gen.T tag required actual b -> + (a -> b -> test) -> Tagged tag QC.Property +checkForAllExtra = Gen.withExtra checkForAll + + +type GenTriangular lo diag up a = + Gen.Matrix a Int Int (Triangular lo diag up ZeroInt a) + + +addSuperName :: String -> [(String, a)] -> [(String, a)] +addSuperName superName = map (mapFst ((superName++) . ("."++))) + +checkAnyFlexDiag :: + (MatrixShape.TriDiag diag) => + String -> + (forall lo up. + (MatrixShape.Content lo, MatrixShape.Content up, + Eq lo, Eq up, Show lo, Show up) => + GenTriangular lo diag up a -> + Tagged a QC.Property) -> + (forall lo up. + (MatrixShape.Content lo, MatrixShape.Content up, + Eq lo, Eq up, Show lo, Show up) => + GenTriangular lo diag up a) -> + [(String, Tagged a QC.Property)] +checkAnyFlexDiag name checker gen = + (checkDiagUpLoFlexDiag name checker gen ++) $ + addSuperName name $ + ("Symmetric", checker (Triangular.asSymmetric <$> gen)) : + [] + +checkAny :: + String -> + (forall lo up diag. + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Eq lo, Eq up, Show lo, Show up, Show diag) => + GenTriangular lo diag up a -> + Tagged a QC.Property) -> + (forall lo up diag. + (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + Eq lo, Eq up, Show lo, Show up, Show diag) => + GenTriangular lo diag up a) -> + [(String, Tagged a QC.Property)] +checkAny name checker gen = + checkAnyFlexDiag (name++".Unit") checker + (Triangular.forceUnitDiagonal <$> gen) ++ + checkAnyFlexDiag (name++".NonUnit") checker + (Triangular.forceNonUnitDiagonal <$> gen) + + +checkDiagUpLoFlexDiag :: + (MatrixShape.TriDiag diag) => + String -> + (forall lo up. + (MatrixShape.DiagUpLo lo up, Eq lo, Eq up, Show lo, Show up) => + GenTriangular lo diag up a -> + Tagged a QC.Property) -> + (forall lo up. + (MatrixShape.DiagUpLo lo up, Eq lo, Eq up, Show lo, Show up) => + GenTriangular lo diag up a) -> + [(String, Tagged a QC.Property)] +checkDiagUpLoFlexDiag name checker gen = + addSuperName name $ + ("Diagonal", checker (Triangular.asDiagonal <$> gen)) : + ("Lower", checker (Triangular.asLower <$> gen)) : + ("Upper", checker (Triangular.asUpper <$> gen)) : + [] + +checkDiagUpLo :: + String -> + (forall lo up diag. + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Eq lo, Eq diag, Eq up, Show lo, Show diag, Show up) => + GenTriangular lo diag up a -> Tagged a QC.Property) -> + (forall lo up diag. + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Eq lo, Eq diag, Eq up, Show lo, Show diag, Show up) => + GenTriangular lo diag up a) -> + [(String, Tagged a QC.Property)] +checkDiagUpLo name checker gen = + checkDiagUpLoFlexDiag (name++".Unit") checker + (Triangular.forceUnitDiagonal <$> gen) ++ + checkDiagUpLoFlexDiag (name++".NonUnit") checker + (Triangular.forceNonUnitDiagonal <$> gen) + + +testsVar :: + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + checkAny "multiplyIdentityVector" + (\gen -> checkForAll ((,) <$> gen <|*.> Gen.vector) multiplyIdentityVector) + (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ + checkAny "multiplyIdentityFull" + (\gen -> checkForAll ((,) <$> gen <|*|> Gen.matrix) multiplyIdentityFull) + (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ + checkDiagUpLo "multiplyIdentity" + (\gen -> checkForAll ((,) <$> gen <|*|> Gen.triangular) multiplyIdentity) + (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ + checkAny "multiplyVector" + (\gen -> checkForAll ((,) <$> gen <|*.> Gen.vector) multiplyVector) + Gen.triangular ++ + checkAny "multiplyFull" + (\gen -> checkForAll ((,) <$> gen <|*|> Gen.matrix) multiplyFull) + Gen.triangular ++ + checkAny "multiplyVectorLeft" + (\gen -> checkForAll ((,) <$> Gen.vector <.*|> gen) multiplyVectorLeft) + Gen.triangular ++ + checkAny "multiplyVectorRight" + (\gen -> checkForAll ((,) <$> gen <|*.> Gen.vector) multiplyVectorRight) + Gen.triangular ++ + checkAny "multiplyLeft" + (\gen -> checkForAll ((,) <$> Gen.matrix <|*|> gen) multiplyLeft) + Gen.triangular ++ + checkAny "multiplyRight" + (\gen -> checkForAll ((,) <$> gen <|*|> Gen.matrix) multiplyRight) + Gen.triangular ++ + + checkDiagUpLo "multiply" + (\gen -> checkForAll ((,) <$> gen <|*|> gen) multiply) + Gen.triangular ++ + checkDiagUpLo "multiplySquare" + (\gen -> checkForAll gen multiplySquare) + Gen.triangular ++ + checkDiagUpLo "squareSquare" + (\gen -> checkForAll gen squareSquare) + Gen.triangular ++ + + checkAny "determinant" + (\gen -> checkForAll gen determinant) + Gen.triangular ++ + checkAny "solve" + (\gen -> checkForAll ((,) <$> gen <|\|> Gen.matrix) solve) + genInvertible ++ + checkAny "solveIdentity" + (\gen -> checkForAll ((,) <$> gen <|\|> Gen.matrix) solveIdentity) + (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ + checkDiagUpLo "inverse" + (\gen -> checkForAll gen inverse) + genInvertible ++ + checkAny "inverseGeneric" + (\gen -> checkForAll gen inverseGeneric) + genInvertible ++ + + checkDiagUpLo "eigenvaluesDeterminant" + (\gen -> checkForAll gen eigenvaluesDeterminant) + Gen.triangular ++ + checkDiagUpLoFlexDiag "eigensystem" + (\gen -> checkForAllExtra Util.genOrder gen eigensystem) + genDiagonalizable ++ + [] diff --git a/test/Test/Utility.hs b/test/Test/Utility.hs new file mode 100644 --- /dev/null +++ b/test/Test/Utility.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE TypeFamilies #-} +module Test.Utility where + +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Orthogonal as Ortho +import Numeric.LAPACK.Matrix.Square (Square) +import Numeric.LAPACK.Matrix.Shape (Order(RowMajor,ColumnMajor)) +import Numeric.LAPACK.Matrix (ZeroInt) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, absolute) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) + +import qualified Control.Monad.Trans.State as MS +import Control.Monad (replicateM) +import Control.Applicative (Applicative, liftA2, pure, (<*>), (<$>)) + +import qualified Data.List.HT as ListHT +import qualified Data.Complex as Complex +import Data.Complex (Complex((:+))) +import Data.Monoid (Monoid(mempty,mappend)) +import Data.Semigroup (Semigroup((<>))) + +import qualified Test.QuickCheck as QC +import Test.ChasingBottoms.IsBottom (isBottom) + + +equalListWith :: (a -> a -> Bool) -> [a] -> [a] -> Bool +equalListWith eq xs ys = + and $ ListHT.takeWhileJust $ + zipWith + (\mx my -> + case (mx,my) of + (Nothing,Nothing) -> Nothing + (Just x, Just y) -> Just $ eq x y + _ -> Just False) + (map Just xs ++ repeat Nothing) + (map Just ys ++ repeat Nothing) + + +approx :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => ar -> a -> a -> Bool +approx tol x y = absolute (x-y) <= tol + +approxReal :: (Class.Real a) => a -> a -> a -> Bool +approxReal tol x y = abs (x-y) <= tol + + +approxArrayTol :: + (Shape.C shape, Eq shape, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ar -> Array shape a -> Array shape a -> Bool +approxArrayTol tol x y = + if Array.shape x == Array.shape y + then and $ zipWith (approx tol) (Array.toList x) (Array.toList y) + else error "approxArray: shapes mismatch" + +approxArray :: + (Shape.C shape, Eq shape, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Array shape a -> Array shape a -> Bool +approxArray = approxArrayTol 1e-5 + +approxRealArrayTol :: + (Shape.C shape, Eq shape, Class.Real a) => + a -> Array shape a -> Array shape a -> Bool +approxRealArrayTol tol x y = + if Array.shape x == Array.shape y + then and $ zipWith (approxReal tol) (Array.toList x) (Array.toList y) + else error "approxRealArray: shapes mismatch" + +approxMatrix :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ar -> + Matrix.Full vert horiz height width a -> + Matrix.Full vert horiz height width a -> Bool +approxMatrix tol x y = + approxArrayTol tol + (Matrix.toRowMajor $ Matrix.fromFull x) + (Matrix.toRowMajor $ Matrix.fromFull y) + + +genReal :: (Class.Real a) => Integer -> QC.Gen a +genReal n = fromInteger <$> QC.choose (-n,n) + +genComplex :: (Class.Real a) => Integer -> QC.Gen (Complex a) +genComplex n = liftA2 (Complex.:+) (genReal n) (genReal n) + +genElement :: (Class.Floating a) => Integer -> QC.Gen a +genElement n = + Class.switchFloating (genReal n) (genReal n) (genComplex n) (genComplex n) + +genArray :: + (Shape.C shape, Class.Floating a) => + Integer -> shape -> QC.Gen (Array shape a) +genArray n shape = + Array.fromList shape <$> replicateM (Shape.size shape) (genElement n) + + +select :: [a] -> QC.Gen (a, [a]) +select = QC.elements . ListHT.removeEach + +genDistinct :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Integer -> Integer -> ZeroInt -> QC.Gen (Vector ZeroInt a) +genDistinct maxElemS maxElemD size@(Shape.ZeroBased n) = do + let range k = map fromInteger [(-k)..k] + xs <- + MS.evalStateT (replicateM n $ MS.StateT select) $ + Class.switchFloating + (range maxElemS) + (range maxElemD) + (liftA2 (:+) (range maxElemS) (range maxElemS)) + (liftA2 (:+) (range maxElemD) (range maxElemD)) + return $ Vector.fromList size xs + + +genOrder :: QC.Gen Order +genOrder = QC.elements [RowMajor, ColumnMajor] + + + +invertible :: + (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square sh a -> Bool +invertible a = absolute (Square.determinant a) > 0.1 + +fullRankTall :: + (Shape.C height, Shape.C width, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Tall height width a -> Bool +fullRankTall a = Ortho.determinantAbsolute a > 0.1 + + +isIdentity :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ar -> Square ZeroInt a -> Bool +isIdentity tol eye = + approxArrayTol tol eye (Square.identityFrom eye) + + + +newtype Tagged tag a = Tagged a +type TaggedGen tag a = Tagged tag (QC.Gen a) + +instance Functor (Tagged tag) where + fmap f (Tagged a) = Tagged (f a) + +instance Applicative (Tagged tag) where + pure = Tagged + Tagged f <*> Tagged a = Tagged (f a) + + + +checkForAllPlain :: + (Show a, QC.Testable test) => + TaggedGen tag a -> (a -> test) -> Tagged tag QC.Property +checkForAllPlain (Tagged gen) test = Tagged $ QC.forAll gen test + +checkForAll :: + (Show a, QC.Testable test) => + TaggedGen tag (a, Match) -> (a -> test) -> Tagged tag QC.Property +checkForAll taggedGen test = + checkForAllPlain taggedGen $ \(a,match) -> + case match of + Match -> QC.property $ test a + Mismatch -> QC.property $ isBottom $ test a + +{- | +In @DontForceMatch@ mode the test generators +may ignore generating matching dimensions. +If dimensions actually mismatch, a @Mismatch@ value is returned. +In this case the test driver asserts that +the test routine is aborted with an error. +However, a typical test type might be +\"generic implementation = specialized implementation\". +If the generic implementation correctly checks the sizes, +then the tester cannot detect a missing check in the specialized implementation. +So far the proposed way to avoid this problem +is to add a test that relies solely on the function to be tested. +If you have no better idea, compare an implementation with itself. +-} +data Match = Mismatch | Match + deriving (Eq, Show) + +instance Semigroup Match where + (<>) = mappend + +instance Monoid Match where + mempty = Match + mappend Match Match = Match + mappend _ _ = Mismatch + + + +prefix :: String -> [(String, test)] -> [(String, test)] +prefix msg = + map (\(str,test) -> (msg ++ "." ++ str, test)) diff --git a/test/Test/Vector.hs b/test/Test/Vector.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vector.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TypeFamilies #-} +module Test.Vector (testsVar) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Utility (Tagged(Tagged), TaggedGen) + +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix (ZeroInt, zeroInt) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf) + +import qualified Numeric.Netlib.Class as Class + +import Control.Applicative (liftA2, (<$>)) + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable ((!)) + +import qualified Data.NonEmpty as NonEmpty +import Data.NonEmpty ((!:)) + +import qualified Test.QuickCheck as QC +import Test.ChasingBottoms.IsBottom (isBottom) + + +appendTakeDrop :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Int -> Vector ZeroInt a -> Bool +appendTakeDrop n x = + Util.approxArray x $ + Array.mapShape (zeroInt . Shape.size) + (Vector.append (Vector.take n x) (Vector.drop n x)) + +takeLeftRightAppend :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Vector ZeroInt a, Vector ZeroInt a) -> Bool +takeLeftRightAppend (x,y) = + let xy = Vector.append x y + in Util.approxArray x (Vector.takeLeft xy) + && + Util.approxArray y (Vector.takeRight xy) + + +normInf :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Vector ZeroInt a -> Bool +normInf x = + Vector.normInf x + == + (NonEmpty.maximum $ 0 !: map Scalar.absolute (Array.toList x)) + +normInf1 :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Vector ZeroInt a -> Bool +normInf1 x = + Vector.normInf1 x + == + (NonEmpty.maximum $ 0 !: map Scalar.norm1 (Array.toList x)) + + +genVector :: (Class.Floating a) => TaggedGen a (Vector ZeroInt a) +genVector = Tagged $ Util.genArray 10 . zeroInt =<< QC.choose (0,5) + +normInfAppend :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar, RealOf ar ~ ar) => + (Vector ZeroInt a, Vector ZeroInt a) -> Bool +normInfAppend (x,y) = + Vector.normInf (Vector.append x y) + == + Vector.normInf (Vector.autoFromList [Vector.normInf x, Vector.normInf y]) + +normInf1Append :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar, RealOf ar ~ ar) => + (Vector ZeroInt a, Vector ZeroInt a) -> Bool +normInf1Append (x,y) = + Vector.normInf1 (Vector.append x y) + == + Vector.normInf1 (Vector.autoFromList [Vector.normInf1 x, Vector.normInf1 y]) + + +argAbsMaximum :: + (Eq a, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Vector ZeroInt a -> Bool +argAbsMaximum xs = + let kx@(k,x) = Vector.argAbsMaximum xs + in if Array.shape xs == zeroInt 0 + then isBottom kx + else xs!k == x && Scalar.absolute x == Vector.normInf xs + +argAbs1Maximum :: + (Eq a, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Vector ZeroInt a -> Bool +argAbs1Maximum xs = + let kx@(k,x) = Vector.argAbs1Maximum xs + in if Array.shape xs == zeroInt 0 + then isBottom kx + else xs!k == x && Scalar.norm1 x == Vector.normInf1 xs + + +checkForAll :: + (Show a, QC.Testable test, Gen.Required required) => + Gen.T tag required actual a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 10 5) + + +testsVar :: + (Show a, + Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar, RealOf ar ~ ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("appendTakeDrop", + Gen.withExtra checkForAll + (QC.getNonNegative <$> QC.arbitrary) Gen.vector appendTakeDrop) : + ("takeLeftRightAppend", + Util.checkForAllPlain + (liftA2 (liftA2 (,)) genVector genVector) takeLeftRightAppend) : + ("normInf", + checkForAll Gen.vector normInf) : + ("normInf1", + checkForAll Gen.vector normInf1) : + ("normInfAppend", + Util.checkForAllPlain + (liftA2 (liftA2 (,)) genVector genVector) normInfAppend) : + ("normInf1Append", + Util.checkForAllPlain + (liftA2 (liftA2 (,)) genVector genVector) normInf1Append) : + ("argAbsMaximum", + checkForAll Gen.vector argAbsMaximum) : + ("argAbs1Maximum", + checkForAll Gen.vector argAbs1Maximum) : + []