packages feed

lapack 0.1 → 0.2

raw patch · 76 files changed

+14092/−3413 lines, 76 filesdep +ChasingBottomsdep +QuickCheckdep +boxesdep ~basedep ~blas-ffidep ~comfort-arraynew-component:exe:lapack-economic

Dependencies added: ChasingBottoms, QuickCheck, boxes, deepseq, fixed-length, guarded-allocation, lapack, lazyio, semigroups, tfp

Dependency ranges changed: base, blas-ffi, comfort-array, netlib-ffi, non-empty, transformers, utility-ht

Files

+ Makefile view
@@ -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
+ example/EconomicAllocation.hs view
@@ -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"
lapack.cabal view
@@ -1,5 +1,5 @@ Name:             lapack-Version:          0.1+Version:          0.2 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -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
− src/Numeric/LAPACK/Eigen/General.hs 
@@ -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
− src/Numeric/LAPACK/Eigen/Hermitian.hs 
@@ -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
− src/Numeric/LAPACK/Eigen/Triangular.hs 
@@ -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
src/Numeric/LAPACK/Format.hs view
@@ -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]
− src/Numeric/LAPACK/Linear/General.hs 
@@ -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
− src/Numeric/LAPACK/Linear/Hermitian.hs 
@@ -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
− src/Numeric/LAPACK/Linear/HermitianPositiveDefinite.hs 
@@ -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
+ src/Numeric/LAPACK/Linear/LowerUpper.hs view
@@ -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
+ src/Numeric/LAPACK/Linear/Private.hs view
@@ -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"
− src/Numeric/LAPACK/Linear/Triangular.hs 
@@ -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
src/Numeric/LAPACK/Matrix.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Banded.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Banded/Basic.hs view
@@ -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)
+ src/Numeric/LAPACK/Matrix/Banded/Linear.hs view
@@ -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)
+ src/Numeric/LAPACK/Matrix/BandedHermitian.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs view
@@ -0,0 +1,5 @@+module Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite (+   module Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear,+   ) where++import Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear
+ src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Basic.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Divide.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Extent.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Extent/Kind.hs view
@@ -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)
+ src/Numeric/LAPACK/Matrix/Extent/Private.hs view
@@ -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+-}
src/Numeric/LAPACK/Matrix/Hermitian.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs view
@@ -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)
+ src/Numeric/LAPACK/Matrix/Hermitian/Private.hs view
@@ -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}
+ src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs view
@@ -0,0 +1,5 @@+module Numeric.LAPACK.Matrix.HermitianPositiveDefinite (+   module Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear,+   ) where++import Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear
+ src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs view
@@ -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
src/Numeric/LAPACK/Matrix/Multiply.hs view
@@ -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)
src/Numeric/LAPACK/Matrix/Private.hs view
@@ -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
src/Numeric/LAPACK/Matrix/Shape.hs view
@@ -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
src/Numeric/LAPACK/Matrix/Shape/Private.hs view
@@ -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<n+               then InsideBox r (columnFromOffset size ci)+               else HorizOutsideBox r (ci-n)+      ColumnMajor ->+         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
src/Numeric/LAPACK/Matrix/Square.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Square/Basic.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Square/Eigen.hs view
@@ -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"
+ src/Numeric/LAPACK/Matrix/Square/Linear.hs view
@@ -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)
+ src/Numeric/LAPACK/Matrix/Symmetric/Private.hs view
@@ -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)))
src/Numeric/LAPACK/Matrix/Triangular.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Triangular/Basic.hs view
@@ -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)
+ src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs view
@@ -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
+ src/Numeric/LAPACK/Matrix/Triangular/Linear.hs view
@@ -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)
src/Numeric/LAPACK/Matrix/Triangular/Private.hs view
@@ -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
src/Numeric/LAPACK/Orthogonal.hs view
@@ -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)))
+ src/Numeric/LAPACK/Orthogonal/Householder.hs view
@@ -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
+ src/Numeric/LAPACK/Orthogonal/Private.hs view
@@ -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_
+ src/Numeric/LAPACK/Permutation.hs view
@@ -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
+ src/Numeric/LAPACK/Permutation/Private.hs view
@@ -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
src/Numeric/LAPACK/Private.hs view
@@ -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)
+ src/Numeric/LAPACK/Scalar.hs view
@@ -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)
+ src/Numeric/LAPACK/ShapeStatic.hs view
@@ -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
src/Numeric/LAPACK/Singular.hs view
@@ -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"
+ src/Numeric/LAPACK/Split.hs view
@@ -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
src/Numeric/LAPACK/Vector.hs view
@@ -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 =
+ src/Numeric/LAPACK/Wrapper.hs view
@@ -0,0 +1,4 @@+module Numeric.LAPACK.Wrapper where++-- cf. Data.Bifunctor.Flip+newtype Flip f b a = Flip {getFlip :: f a b}
+ test/Main.hs view
@@ -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
+ test/Test/Banded.hs view
@@ -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) :+   []
+ test/Test/Banded/Utility.hs view
@@ -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
+ test/Test/BandedHermitian.hs view
@@ -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) :+   []
+ test/Test/Format.hs view
@@ -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)
+ test/Test/Generator.hs view
@@ -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 <.*.>, <.*|>, <|*.>, <|*|>, <|\|>, <***>, <.=.>, <===>, <|||>
+ test/Test/Hermitian.hs view
@@ -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) :+   []
+ test/Test/Matrix.hs view
@@ -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) :+   []
+ test/Test/Orthogonal.hs view
@@ -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) :+   []
+ test/Test/Permutation.hs view
@@ -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) :+   []
+ test/Test/Shape.hs view
@@ -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) +++   []
+ test/Test/Singular.hs view
@@ -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) :+   []
+ test/Test/Square.hs view
@@ -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) :+   []
+ test/Test/Triangular.hs view
@@ -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 +++   []
+ test/Test/Utility.hs view
@@ -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))
+ test/Test/Vector.hs view
@@ -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) :+   []